1 /*- 2 * Copyright (c) 2005-2019 Michael Scholz <mi-scholz@users.sourceforge.net> 3 * All rights reserved. 4 * 5 * Redistribution and use in source and binary forms, with or without 6 * modification, are permitted provided that the following conditions 7 * are met: 8 * 1. Redistributions of source code must retain the above copyright 9 * notice, this list of conditions and the following disclaimer. 10 * 2. Redistributions in binary form must reproduce the above copyright 11 * notice, this list of conditions and the following disclaimer in the 12 * documentation and/or other materials provided with the distribution. 13 * 14 * THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND 15 * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 16 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 17 * ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE 18 * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 19 * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 20 * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 21 * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 22 * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 23 * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 24 * SUCH DAMAGE. 25 * 26 * @(#)fth-lib.h 2.5 11/25/19 27 */ 28 29 #if !defined(_FTH_LIB_H_) 30 #define _FTH_LIB_H_ 31 32 #define FTH_VERSION fth_short_version() 33 34 #define DEFAULT_SEQ_LENGTH 128 35 #define NEW_SEQ_LENGTH(Len) \ 36 ((((Len) / DEFAULT_SEQ_LENGTH) + 1) * DEFAULT_SEQ_LENGTH) 37 /*- 38 * 1 cells 20 lshift 39 * 1 cells 8 = (64bit addr): 0x800000 40 * 1 cells 4 = (32bit addr): 0x400000 41 */ 42 #define MAX_SEQ_LENGTH ((ficlInteger)(FTH_SIZEOF_VOID_P << 20)) 43 44 /* non-object names */ 45 #define FTH_STR_EXCEPTION "exception" 46 #define FTH_STR_KEYWORD "keyword" 47 #define FTH_STR_OBJECT "object" 48 #define FTH_STR_PORT "port" 49 #define FTH_STR_PROC "proc" 50 #define FTH_STR_SOCKET "socket" 51 #define FTH_STR_SYMBOL "symbol" 52 #define FTH_STR_WORD "word" 53 54 /* C object-type names */ 55 #define FTH_STR_ACELL "acell" 56 #define FTH_STR_ARRAY "array" 57 #define FTH_STR_BIGNUM "bignum" 58 #define FTH_STR_BOOLEAN "boolean" 59 #define FTH_STR_COMPLEX "complex" 60 #define FTH_STR_FLOAT "float" 61 #define FTH_STR_HASH "hash" 62 #define FTH_STR_HOOK "hook" 63 #define FTH_STR_IO "io" 64 #define FTH_STR_LIST "list" 65 #define FTH_STR_LLONG "llong" 66 #define FTH_STR_NIL "nil" 67 #define FTH_STR_RATIO "ratio" 68 #define FTH_STR_REGEXP "regexp" 69 #define FTH_STR_STRING "string" 70 71 /* Predefined symbols. */ 72 #define FTH_SYMBOL_DOCUMENTATION fth_symbol("documentation") 73 #define FTH_SYMBOL_LAST_MESSAGE fth_symbol("last-message") 74 #define FTH_SYMBOL_MESSAGE fth_symbol("message") 75 #define FTH_SYMBOL_SOURCE fth_symbol("source") 76 #define FTH_SYMBOL_TRACE_VAR fth_symbol("trace-var-hook") 77 78 /* Predefined keywords. */ 79 #define FTH_KEYWORD_CLOSE fth_keyword("close") 80 #define FTH_KEYWORD_COMMAND fth_keyword("command") 81 #define FTH_KEYWORD_COUNT fth_keyword("count") 82 #define FTH_KEYWORD_DOMAIN fth_keyword("domain") 83 #define FTH_KEYWORD_FAM fth_keyword("fam") 84 #define FTH_KEYWORD_FILENAME fth_keyword("filename") 85 #define FTH_KEYWORD_FLUSH fth_keyword("flush") 86 #define FTH_KEYWORD_IF_EXISTS fth_keyword("if-exists") 87 #define FTH_KEYWORD_INIT fth_keyword("initial-element") 88 #define FTH_KEYWORD_N fth_keyword("n") 89 #define FTH_KEYWORD_PORT fth_keyword("port") 90 #define FTH_KEYWORD_PORT_NAME fth_keyword("port-name") 91 #define FTH_KEYWORD_RANGE fth_keyword("range") 92 #define FTH_KEYWORD_READ_CHAR fth_keyword("read-char") 93 #define FTH_KEYWORD_READ_LINE fth_keyword("read-line") 94 #define FTH_KEYWORD_REPS fth_keyword("reps") 95 #define FTH_KEYWORD_SOCKET fth_keyword("socket") 96 #define FTH_KEYWORD_SOFT_PORT fth_keyword("soft-port") 97 #define FTH_KEYWORD_START fth_keyword("start") 98 #define FTH_KEYWORD_STRING fth_keyword("string") 99 #define FTH_KEYWORD_WHENCE fth_keyword("whence") 100 #define FTH_KEYWORD_WRITE_CHAR fth_keyword("write-char") 101 #define FTH_KEYWORD_WRITE_LINE fth_keyword("write-line") 102 103 /* Predefined exceptions. */ 104 #define STR_BAD_ARITY "bad-arity" 105 #define STR_BAD_SYNTAX "bad-syntax" 106 #define STR_BIGNUM_ERROR "bignum-error" 107 #define STR_CATCH_ERROR "catch-error" 108 #define STR_EVAL_ERROR "eval-error" 109 #define STR_FICL_ERROR "ficl-error" 110 #define STR_FORTH_ERROR "forth-error" 111 #define STR_LOAD_ERROR "load-error" 112 #define STR_MATH_ERROR "math-error" 113 #define STR_NO_MEMORY_ERROR "no-memory-error" 114 #define STR_NULL_STRING "null-string" 115 #define STR_OPTKEY_ERROR "optkey-error" 116 #define STR_OUT_OF_RANGE "out-of-range" 117 #define STR_REGEXP_ERROR "regexp-error" 118 #define STR_SIGNAL_CAUGHT "signal-caught" 119 #define STR_SOCKET_ERROR "socket-error" 120 #define STR_SO_FILE_ERROR "so-file-error" 121 #define STR_SYSTEM_ERROR "system-error" 122 #define STR_WRONG_NUMBER_OF_ARGS "wrong-number-of-args" 123 #define STR_WRONG_TYPE_ARG "wrong-type-arg" 124 125 #define FTH_BAD_ARITY fth_exception(STR_BAD_ARITY) 126 #define FTH_BAD_SYNTAX fth_exception(STR_BAD_SYNTAX) 127 #define FTH_BIGNUM_ERROR fth_exception(STR_BIGNUM_ERROR) 128 #define FTH_CATCH_ERROR fth_exception(STR_CATCH_ERROR) 129 #define FTH_EVAL_ERROR fth_exception(STR_EVAL_ERROR) 130 #define FTH_FICL_ERROR fth_exception(STR_FICL_ERROR) 131 #define FTH_FORTH_ERROR fth_exception(STR_FORTH_ERROR) 132 #define FTH_LOAD_ERROR fth_exception(STR_LOAD_ERROR) 133 #define FTH_MATH_ERROR fth_exception(STR_MATH_ERROR) 134 #define FTH_NO_MEMORY_ERROR fth_exception(STR_NO_MEMORY_ERROR) 135 #define FTH_NULL_STRING fth_exception(STR_NULL_STRING) 136 #define FTH_OPTKEY_ERROR fth_exception(STR_OPTKEY_ERROR) 137 #define FTH_OUT_OF_RANGE fth_exception(STR_OUT_OF_RANGE) 138 #define FTH_REGEXP_ERROR fth_exception(STR_REGEXP_ERROR) 139 #define FTH_SIGNAL_CAUGHT fth_exception(STR_SIGNAL_CAUGHT) 140 #define FTH_SOCKET_ERROR fth_exception(STR_SOCKET_ERROR) 141 #define FTH_SO_FILE_ERROR fth_exception(STR_SO_FILE_ERROR) 142 #define FTH_SYSTEM_ERROR fth_exception(STR_SYSTEM_ERROR) 143 #define FTH_WRONG_NUMBER_OF_ARGS fth_exception(STR_WRONG_NUMBER_OF_ARGS) 144 #define FTH_WRONG_TYPE_ARG fth_exception(STR_WRONG_TYPE_ARG) 145 146 /* ANS Exception. */ 147 #define __ANS_EXC(Exc) \ 148 fth_exception(ficl_ans_exc_name(FICL_VM_STATUS_ ## Exc)) 149 #define FTH_ABORT __ANS_EXC(ABORT) 150 #define FTH_ABORTQ __ANS_EXC(ABORTQ) 151 #define FTH_ALIGNMENT_ERROR __ANS_EXC(ALIGNMENT_ERROR) 152 #define FTH_ARGUMENT_ERROR __ANS_EXC(ARGUMENT_ERROR) 153 #define FTH_BNUMBER_ERROR __ANS_EXC(BNUMBER_ERROR) 154 #define FTH_BRANCH_ERROR __ANS_EXC(BRANCH_ERROR) 155 #define FTH_BREAD_ERROR __ANS_EXC(BREAD_ERROR) 156 #define FTH_BWRITE_ERROR __ANS_EXC(BWRITE_ERROR) 157 #define FTH_CHAR_ERROR __ANS_EXC(CHAR_ERROR) 158 #define FTH_COMPILER_NESTING __ANS_EXC(COMPILER_NESTING) 159 #define FTH_COMPILE_ONLY __ANS_EXC(COMPILE_ONLY) 160 #define FTH_CONTROL_MISMATCH __ANS_EXC(CONTROL_MISMATCH) 161 #define FTH_CS_OVERFLOW __ANS_EXC(CS_OVERFLOW) 162 #define FTH_DICT_OVERFLOW __ANS_EXC(DICT_OVERFLOW) 163 #define FTH_DIVISION_BY_ZERO __ANS_EXC(DIVISION_BY_ZERO) 164 #define FTH_EOF_ERROR __ANS_EXC(EOF_ERROR) 165 #define FTH_ES_OVERFLOW __ANS_EXC(ES_OVERFLOW) 166 #define FTH_FBASE_ERROR __ANS_EXC(FBASE_ERROR) 167 #define FTH_FDIVIDE_BY_ZERO __ANS_EXC(FDIVIDE_BY_ZERO) 168 #define FTH_FILE_IO_ERROR __ANS_EXC(FILE_IO_ERROR) 169 #define FTH_FNUMBER_ERROR __ANS_EXC(FNUMBER_ERROR) 170 #define FTH_FPOSITION_ERROR __ANS_EXC(FPOSITION_ERROR) 171 #define FTH_FP_ERROR __ANS_EXC(FP_ERROR) 172 #define FTH_FP_UNDERFLOW __ANS_EXC(FP_UNDERFLOW) 173 #define FTH_FRANGE_ERROR __ANS_EXC(FRANGE_ERROR) 174 #define FTH_FSTACK_OVERFLOW __ANS_EXC(FSTACK_OVERFLOW) 175 #define FTH_FSTACK_UNDERFLOW __ANS_EXC(FSTACK_UNDERFLOW) 176 #define FTH_INTERRUPT __ANS_EXC(INTERRUPT) 177 #define FTH_INVALID_FORGET __ANS_EXC(INVALID_FORGET) 178 #define FTH_MEMORY_ACCESS __ANS_EXC(MEMORY_ACCESS) 179 #define FTH_MEMORY_WRITE_ERROR __ANS_EXC(MEMORY_WRITE_ERROR) 180 #define FTH_MISSING_LPARAMETER __ANS_EXC(MISSING_LPARAMETER) 181 #define FTH_NAME_ARG_ERROR __ANS_EXC(NAME_ARG_ERROR) 182 #define FTH_NAME_TOO_LONG __ANS_EXC(NAME_TOO_LONG) 183 #define FTH_NOT_IMPLEMENTED __ANS_EXC(NOT_IMPLEMENTED) 184 #define FTH_NO_SUCH_FILE __ANS_EXC(NO_SUCH_FILE) 185 #define FTH_NUMERIC_ARG_ERROR __ANS_EXC(NUMERIC_ARG_ERROR) 186 #define FTH_OBSOLETE __ANS_EXC(OBSOLETE) 187 #define FTH_PARSE_OVERFLOW __ANS_EXC(PARSE_OVERFLOW) 188 #define FTH_PNO_OVERFLOW __ANS_EXC(PNO_OVERFLOW) 189 #define FTH_POSTPONE_ERROR __ANS_EXC(POSTPONE_ERROR) 190 #define FTH_PRECISION_ERROR __ANS_EXC(PRECISION_ERROR) 191 #define FTH_QUIT __ANS_EXC(QUIT) 192 #define FTH_RANGE_ERROR __ANS_EXC(RANGE_ERROR) 193 #define FTH_RECURSION_ERROR __ANS_EXC(RECURSION_ERROR) 194 #define FTH_RSTACK_IMBALANCE __ANS_EXC(RSTACK_IMBALANCE) 195 #define FTH_RSTACK_OVERFLOW __ANS_EXC(RSTACK_OVERFLOW) 196 #define FTH_RSTACK_UNDERFLOW __ANS_EXC(RSTACK_UNDERFLOW) 197 #define FTH_SEARCH_OVERFLOW __ANS_EXC(SEARCH_OVERFLOW) 198 #define FTH_SEARCH_UNDERFLOW __ANS_EXC(SEARCH_UNDERFLOW) 199 #define FTH_STACK_OVERFLOW __ANS_EXC(STACK_OVERFLOW) 200 #define FTH_STACK_UNDERFLOW __ANS_EXC(STACK_UNDERFLOW) 201 #define FTH_TOO_DEEP __ANS_EXC(TOO_DEEP) 202 #define FTH_TO_BODY_ERROR __ANS_EXC(TO_BODY_ERROR) 203 #define FTH_UNDEFINED __ANS_EXC(UNDEFINED) 204 #define FTH_WORD_LIST_CHANGED __ANS_EXC(WORD_LIST_CHANGED) 205 #define FTH_WORD_LIST_ERROR __ANS_EXC(WORD_LIST_ERROR) 206 #define FTH_ZERO_STRING __ANS_EXC(ZERO_STRING) 207 208 /* Soft port prcs array indexes, globally required. */ 209 enum { 210 PORT_READ_CHAR, 211 PORT_WRITE_CHAR, 212 PORT_READ_LINE, 213 PORT_WRITE_LINE, 214 PORT_FLUSH, 215 PORT_CLOSE, 216 PORT_TYPE_LAST 217 }; 218 219 #if !defined(EXIT_SUCCESS) 220 #define EXIT_SUCCESS 0 221 #endif 222 #if !defined(EXIT_FAILURE) 223 #define EXIT_FAILURE 1 224 #endif 225 #if !defined(BUFSIZ) 226 #define BUFSIZ 1024 227 #endif 228 #if !defined(MAXPATHLEN) 229 #define MAXPATHLEN 1024 230 #endif 231 232 #define EXIT_ABORT 2 233 234 #define FTH_MALLOC(N) fth_malloc((size_t)(N)) 235 #define FTH_REALLOC(P, N) fth_realloc(P, N) 236 #define FTH_CALLOC(M, N) fth_calloc((size_t)(M), (size_t)(N)) 237 #define FTH_FREE(P) fth_free(P) 238 #define FTH_STRDUP(S) fth_strdup(S) 239 240 /* from ruby/defines.h */ 241 #if defined(__cplusplus) 242 #define ANYARGS ... 243 #else 244 #define ANYARGS 245 #endif 246 247 #if defined(lint) 248 /* misc.c */ 249 #define FTH_PROG_NAME "fth" 250 #define FTH_PREFIX_PATH "/usr/local" 251 #define FTH_LOCALEDIR FTH_PREFIX_PATH "/share/locale" 252 #endif 253 254 #if defined(HAVE_FLOAT_H) 255 #include <float.h> 256 #endif 257 #if !defined(DBL_MANT_DIG) 258 #define DBL_MANT_DIG 53 259 #endif 260 261 #if HAVE_COMPLEX 262 #if defined(HAVE_MISSING_COMPLEX_H) 263 #include <missing_complex.h> 264 #endif 265 #if defined(HAVE_MISSING_MATH_H) 266 #include <missing_math.h> 267 #endif 268 /* 269 * While NetBSD/OpenBSD/GNU libc do provide complex trigonometric 270 * functions, others like FreeBSD/Minix don't (but FBSD's 271 * ports/math/libmissing fills the gap). 272 */ 273 274 /* Trigonometric functions. */ 275 276 #if !defined(HAVE_CSIN) 277 ficlComplex csin(ficlComplex); 278 #endif 279 #if !defined(HAVE_CCOS) 280 ficlComplex ccos(ficlComplex); 281 #endif 282 #if !defined(HAVE_CTAN) 283 ficlComplex ctan(ficlComplex); 284 #endif 285 #if !defined(HAVE_CASIN) 286 ficlComplex casin(ficlComplex); 287 #endif 288 #if !defined(HAVE_CACOS) 289 ficlComplex cacos(ficlComplex); 290 #endif 291 #if !defined(HAVE_CATAN) 292 ficlComplex catan(ficlComplex); 293 #endif 294 #if !defined(HAVE_CATAN2) 295 ficlComplex catan2(ficlComplex, ficlComplex); 296 #endif 297 298 /* Hyperbolic functions. */ 299 300 #if !defined(HAVE_CSINH) 301 ficlComplex csinh(ficlComplex); 302 #endif 303 #if !defined(HAVE_CCOSH) 304 ficlComplex ccosh(ficlComplex); 305 #endif 306 #if !defined(HAVE_CTANH) 307 ficlComplex ctanh(ficlComplex); 308 #endif 309 #if !defined(HAVE_CASINH) 310 ficlComplex casinh(ficlComplex); 311 #endif 312 #if !defined(HAVE_CACOSH) 313 ficlComplex cacosh(ficlComplex); 314 #endif 315 #if !defined(HAVE_CATANH) 316 ficlComplex catanh(ficlComplex); 317 #endif 318 319 /* Exponential and logarithmic functions. */ 320 321 #if !defined(HAVE_CEXP) 322 ficlComplex cexp(ficlComplex); 323 #endif 324 #if !defined(HAVE_CLOG) 325 ficlComplex clog(ficlComplex); 326 #endif 327 #if !defined(HAVE_CLOG10) 328 ficlComplex clog10(ficlComplex); 329 #endif 330 331 /* Power functions. */ 332 333 #if !defined(HAVE_CPOW) 334 ficlComplex cpow(ficlComplex, ficlComplex); 335 #endif 336 #if !defined(HAVE_CSQRT) 337 ficlComplex csqrt(ficlComplex); 338 #endif 339 340 /* Absolute value and conjugates. */ 341 342 #if !defined(HAVE_CABS) 343 ficlFloat cabs (ficlComplex); 344 #endif 345 #if !defined(HAVE_CABS2) 346 ficlFloat cabs2 (ficlComplex); 347 #endif 348 #if !defined(HAVE_CARG) 349 ficlFloat carg (ficlComplex); 350 #endif 351 #if !defined(HAVE_CONJ) 352 ficlComplex conj(ficlComplex); 353 #endif 354 #endif /* HAVE_COMPLEX */ 355 356 /* === Object === */ 357 358 /* C object-type numbers */ 359 typedef enum { 360 FTH_ARRAY_T, 361 FTH_BOOLEAN_T, 362 FTH_HASH_T, 363 FTH_HOOK_T, 364 FTH_IO_T, 365 FTH_NIL_T, 366 FTH_REGEXP_T, 367 FTH_STRING_T, 368 /* number types */ 369 FTH_LLONG_T, 370 FTH_FLOAT_T, 371 FTH_COMPLEX_T, 372 FTH_BIGNUM_T, 373 FTH_RATIO_T, 374 FTH_LAST_ENTRY_T 375 } fobj_t; 376 377 typedef struct { 378 fobj_t type; /* uniq object-type number (0, 1, ...) */ 379 int flag; /* number types */ 380 char name[32]; /* object-type name */ 381 /* methods for C object-types */ 382 FTH (*inspect)(FTH self); 383 FTH (*to_string)(FTH self); 384 FTH (*dump)(FTH self); 385 FTH (*to_array)(FTH self); 386 FTH (*copy)(FTH self); 387 FTH (*value_ref)(FTH self, FTH index); 388 FTH (*value_set)(FTH self, FTH index, FTH value); 389 FTH (*equal_p)(FTH self, FTH obj); 390 FTH (*length)(FTH self); 391 void (*mark)(FTH self); 392 void (*free)(FTH self); 393 /* procs for Forth object-types */ 394 FTH inspect_proc; 395 FTH to_string_proc; 396 FTH dump_proc; 397 FTH to_array_proc; 398 FTH copy_proc; 399 FTH value_ref_proc; 400 FTH value_set_proc; 401 FTH equal_p_proc; 402 FTH length_proc; 403 FTH mark_proc; 404 FTH free_proc; 405 FTH apply; /* proc object */ 406 } FObject; 407 408 #define FTH_OBJECT_REF(Obj) ((FObject *)(Obj)) 409 #define FTH_OBJECT_NAME(Obj) ((char *)(FTH_OBJECT_REF(Obj)->name)) 410 #define FTH_OBJECT_TYPE(Obj) FTH_OBJECT_REF(Obj)->type 411 #define FTH_OBJECT_FLAG(Obj) FTH_OBJECT_REF(Obj)->flag 412 413 /* === Instance === */ 414 typedef enum { 415 INT_T, 416 UINT_T, 417 LONG_T, 418 ULONG_T, 419 FLOAT_T, 420 COMPLEX_T, 421 BIGNUM_T, 422 RATIO_T, 423 FTH_T, 424 VOIDP_T 425 } instance_t; 426 427 typedef struct FInstance { 428 instance_t type; 429 int gc_mark; 430 struct FInstance *next; 431 void *gen; 432 FObject *obj; 433 FTH properties; 434 FTH values; 435 FTH debug_hook; /* ( inspect-string obj -- str ) */ 436 ficlInteger cycle; 437 int changed_p; 438 int extern_p; 439 union { 440 ficlInteger i; 441 ficlUnsigned u; 442 ficl2Integer di; 443 ficl2Unsigned ud; 444 ficlFloat f; 445 #if HAVE_COMPLEX 446 ficlComplex cp; 447 #endif 448 ficlBignum bi; 449 ficlRatio rt; 450 FTH fp; 451 void *p; 452 } fcell; 453 } FInstance; 454 455 #define FTH_INSTANCE_REF(Obj) ((FInstance *)(Obj)) 456 457 #define FTH_INSTANCE_CELL_TYPE(Obj) FTH_INSTANCE_REF(Obj)->type 458 #define FTH_INSTANCE_CELL_TYPE_SET(Obj, Type) \ 459 (FTH_INSTANCE_CELL_TYPE(Obj) = (instance_t)(Type)) 460 461 #define FTH_INT_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.i 462 #define FTH_UINT_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.u 463 #define FTH_LONG_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.di 464 #define FTH_ULONG_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.ud 465 #define FTH_FLOAT_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.f 466 #if HAVE_COMPLEX 467 #define FTH_COMPLEX_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.cp 468 #endif 469 #define FTH_BIGNUM_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.bi 470 #define FTH_RATIO_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.rt 471 #define FTH_FTH_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.fp 472 #define FTH_VOIDP_OBJECT(Obj) FTH_INSTANCE_REF(Obj)->fcell.p 473 474 #define FTH_INT_OBJECT_SET(Obj, Val) \ 475 FTH_INSTANCE_CELL_TYPE_SET(Obj, INT_T); \ 476 (FTH_INT_OBJECT(Obj) = (ficlInteger)(Val)) 477 #define FTH_UINT_OBJECT_SET(Obj, Val) \ 478 FTH_INSTANCE_CELL_TYPE_SET(Obj, UINT_T); \ 479 (FTH_UINT_OBJECT(Obj) = (ficlUnsigned)(Val)) 480 #define FTH_LONG_OBJECT_SET(Obj, Val) \ 481 FTH_INSTANCE_CELL_TYPE_SET(Obj, LONG_T); \ 482 (FTH_LONG_OBJECT(Obj) = (ficl2Integer)(Val)) 483 #define FTH_ULONG_OBJECT_SET(Obj, Val) \ 484 FTH_INSTANCE_CELL_TYPE_SET(Obj, ULONG_T); \ 485 (FTH_ULONG_OBJECT(Obj) = (ficl2Unsigned)(Val)) 486 #define FTH_FLOAT_OBJECT_SET(Obj, Val) \ 487 FTH_INSTANCE_CELL_TYPE_SET(Obj, FLOAT_T); \ 488 (FTH_FLOAT_OBJECT(Obj) = (ficlFloat)(Val)) 489 #if HAVE_COMPLEX 490 #define FTH_COMPLEX_OBJECT_SET(Obj, Val) \ 491 FTH_INSTANCE_CELL_TYPE_SET(Obj, COMPLEX_T); \ 492 (FTH_COMPLEX_OBJECT(Obj) = (ficlComplex)(Val)) 493 #endif 494 #define FTH_BIGNUM_OBJECT_SET(Obj, Val) \ 495 FTH_INSTANCE_CELL_TYPE_SET(Obj, BIGNUM_T); \ 496 (FTH_BIGNUM_OBJECT(Obj) = (ficlBignum)(Val)) 497 #define FTH_RATIO_OBJECT_SET(Obj, Val) \ 498 FTH_INSTANCE_CELL_TYPE_SET(Obj, RATIO_T); \ 499 (FTH_RATIO_OBJECT(Obj) = (ficlRatio)(Val)) 500 #define FTH_FTH_OBJECT_SET(Obj, Val) \ 501 FTH_INSTANCE_CELL_TYPE_SET(Obj, FTH_T); \ 502 (FTH_FTH_OBJECT(Obj) = (FTH)(Val)) 503 #define FTH_VOIDP_OBJECT_SET(Obj, Val) \ 504 FTH_INSTANCE_CELL_TYPE_SET(Obj, VOIDP_T); \ 505 (FTH_VOIDP_OBJECT(Obj) = (void *)(Val)) 506 507 #define FTH_INSTANCE_REF_GEN(Obj, Type) ((Type *)(FTH_INSTANCE_REF(Obj)->gen)) 508 #define FTH_INSTANCE_REF_OBJ(Obj) \ 509 FTH_OBJECT_REF(FTH_INSTANCE_REF(Obj)->obj) 510 #define FTH_INSTANCE_TYPE(Obj) \ 511 FTH_OBJECT_TYPE(FTH_INSTANCE_REF_OBJ(Obj)) 512 #define FTH_INSTANCE_NAME(Obj) \ 513 FTH_OBJECT_NAME(FTH_INSTANCE_REF_OBJ(Obj)) 514 #define FTH_INSTANCE_FLAG(Obj) \ 515 FTH_OBJECT_FLAG(FTH_INSTANCE_REF_OBJ(Obj)) 516 #define FTH_INSTANCE_PROPERTIES(Obj) FTH_INSTANCE_REF(Obj)->properties 517 #define FTH_INSTANCE_DEBUG_HOOK(Obj) FTH_INSTANCE_REF(Obj)->debug_hook 518 #define FTH_INSTANCE_CHANGED_P(Obj) FTH_INSTANCE_REF(Obj)->changed_p 519 #define FTH_INSTANCE_CHANGED(Obj) (FTH_INSTANCE_REF(Obj)->changed_p = 1) 520 #define FTH_INSTANCE_CHANGED_CLR(Obj) (FTH_INSTANCE_REF(Obj)->changed_p = 0) 521 522 /* === Word === */ 523 #define FICL_WORD_NAME_REF(Name) \ 524 ficlSystemLookup(FTH_FICL_SYSTEM(), (char *)(Name)) 525 #define FICL_NAME_DEFINED_P(Name) (FICL_WORD_NAME_REF(Name) != NULL) 526 #define FICL_WORD_REF(Obj) ((ficlWord *)(Obj)) 527 #define FICL_WORD_TYPE(Obj) FICL_WORD_REF(Obj)->kind 528 #define FICL_WORD_PRIMITIVE_P(Obj) FICL_WORD_REF(Obj)->primitive_p 529 #define FICL_WORD_NAME(Obj) FICL_WORD_REF(Obj)->name 530 #define FICL_WORD_LENGTH(Obj) FICL_WORD_REF(Obj)->argc 531 #define FICL_WORD_PROPERTIES(Obj) FICL_WORD_REF(Obj)->properties 532 #define FICL_WORD_REQ(Obj) FICL_WORD_REF(Obj)->req 533 #define FICL_WORD_OPT(Obj) FICL_WORD_REF(Obj)->opt 534 #define FICL_WORD_REST(Obj) FICL_WORD_REF(Obj)->rest 535 #define FICL_WORD_FUNC(Obj) FICL_WORD_REF(Obj)->func 536 #define FICL_WORD_VFUNC(Obj) FICL_WORD_REF(Obj)->vfunc 537 #define FICL_WORD_CODE(Obj) FICL_WORD_REF(Obj)->code 538 #define FICL_WORD_PARAM(Obj) CELL_FTH_REF(FICL_WORD_REF(Obj)->param) 539 540 /* return FTH string and FTH int */ 541 #define FTH_WORD_NAME(Obj) fth_make_string_or_false(FICL_WORD_NAME(Obj)) 542 543 #define FTH_WORD_PARAM(Obj) ficl_to_fth(FICL_WORD_PARAM(Obj)) 544 545 #define FTH_STACK_CHECK(Vm, Pop, Push) do { \ 546 ficlInteger _depth; \ 547 ficlInteger _req; \ 548 ficlStack *_stack; \ 549 \ 550 _stack = (Vm)->dataStack; \ 551 _req = (ficlInteger)(Pop); \ 552 _depth = (_stack->top - _stack->base) + 1; \ 553 if (_req > _depth) \ 554 fth_throw(FTH_WRONG_NUMBER_OF_ARGS, \ 555 "%s: not enough arguments, %ld instead of %ld", \ 556 RUNNING_WORD_VM(Vm), \ 557 _depth, \ 558 _req); \ 559 } while (0) 560 561 #define FTH_STACK_DEPTH(Vm) \ 562 (((Vm)->dataStack->top - (Vm)->dataStack->base) + 1) 563 564 #define RUNNING_WORD_VM(Vm) \ 565 (((Vm)->runningWord && (Vm)->runningWord->length > 0) ? \ 566 (Vm)->runningWord->name : "noname") 567 #define RUNNING_WORD() RUNNING_WORD_VM(FTH_FICL_VM()) 568 569 #define FTH_ADD_FEATURE_AND_INFO(Name, Docs) \ 570 fth_add_feature(Name); \ 571 fth_word_doc_set((ficlWord *)fth_symbol(Name), Docs "\n\ 572 Other topics include:\n\ 573 array list file\n\ 574 hash hook io\n\ 575 off-t float complex\n\ 576 ratio bignum object\n\ 577 port proc regexp\n\ 578 string symbol keyword\n\ 579 exception") 580 581 #define FTH_CONSTANT_SET(Name, Value) \ 582 ficlDictionaryAppendConstant(FTH_FICL_DICT(), \ 583 (char *)(Name), (ficlInteger)(Value)) 584 585 #define FTH_CONSTANT_SET_WITH_DOC(Name, Value, Docs) \ 586 fth_word_doc_set(FTH_CONSTANT_SET(Name, Value), Docs) 587 588 #define FTH_PRIMITIVE_SET(Name, Code, Type, Docs) \ 589 fth_word_doc_set(ficlDictionaryAppendPrimitive(FTH_FICL_DICT(), \ 590 (char *)(Name), Code, (ficlUnsigned)(Type)), Docs) 591 592 #define FTH_PRI1(Name, Code, Docs) \ 593 FTH_PRIMITIVE_SET(Name, Code, FICL_WORD_DEFAULT, Docs) 594 595 #define FTH_PRIM_IM(Name, Code, Docs) \ 596 FTH_PRIMITIVE_SET(Name, Code, FICL_WORD_IMMEDIATE, Docs) 597 598 #define FTH_PRIM_CO(Name, Code, Docs) \ 599 FTH_PRIMITIVE_SET(Name, Code, FICL_WORD_COMPILE_ONLY, Docs) 600 601 #define FTH_PRIM_CO_IM(Name, Code, Docs) \ 602 FTH_PRIMITIVE_SET(Name, Code, FICL_WORD_COMPILE_ONLY_IMMEDIATE, Docs) 603 604 #define FTH_PROC(Name, Code, Req, Opt, Rest, Docs) \ 605 fth_define_procedure(Name, Code, Req, Opt, Rest, Docs) 606 607 #define FTH_VOID_PROC(Name, Code, Req, Opt, Rest, Docs) \ 608 fth_define_void_procedure(Name, Code, Req, Opt, Rest, Docs) 609 610 #define fth_show(Obj) \ 611 fprintf(stderr, "#<SHOW %s[%d]: %s>\n", __FILE__, __LINE__, \ 612 fth_to_c_inspect(Obj)) 613 614 /* 615 * Old names partly required elsewhere. 616 */ 617 618 #define FTH_DOCUMENTATION_SYMBOL FTH_SYMBOL_DOCUMENTATION 619 #define FTH_LAST_MESSAGE_SYMBOL FTH_SYMBOL_LAST_MESSAGE 620 #define FTH_MESSAGE_SYMBOL FTH_SYMBOL_MESSAGE 621 #define FTH_SOURCE_SYMBOL FTH_SYMBOL_SOURCE 622 #define FTH_TRACE_VAR_SYMBOL FTH_SYMBOL_TRACE_VAR 623 624 #define FTH_PRIM(Dict, Name, Code, Docs) \ 625 fth_word_doc_set(ficlDictionaryAppendPrimitive(Dict, \ 626 Name, \ 627 Code, \ 628 FICL_WORD_DEFAULT), Docs) 629 630 #define ficlStackPop2Float(Stack) ficlStackPopFloat(Stack) 631 #define fth_false() FTH_FALSE 632 #define fth_hook_procedure_list(Obj) fth_hook_to_array(Obj) 633 #define fth_make_off_t(Obj) fth_make_llong(Obj) 634 #define fth_make_uoff_t(Obj) fth_make_ullong(Obj) 635 #define fth_obj_id(Obj) fth_object_id(Obj) 636 #define fth_off_t_copy(Obj) fth_llong_copy(Obj) 637 #define fth_set_object_equal(Obj, Func) fth_set_object_equal_p(Obj, Func) 638 #define fth_uoff_t_p(Obj) fth_ullong_p(Obj) 639 640 #endif /* _FTH_LIB_H_ */ 641 642 /* 643 * fth-lib.h ends here 644 */ 645