1 /* 2 * gauche.h - Gauche scheme system header 3 * 4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org> 5 * 6 * Redistribution and use in source and binary forms, with or without 7 * modification, are permitted provided that the following conditions 8 * are met: 9 * 10 * 1. Redistributions of source code must retain the above copyright 11 * notice, this list of conditions and the following disclaimer. 12 * 13 * 2. Redistributions in binary form must reproduce the above copyright 14 * notice, this list of conditions and the following disclaimer in the 15 * documentation and/or other materials provided with the distribution. 16 * 17 * 3. Neither the name of the authors nor the names of its contributors 18 * may be used to endorse or promote products derived from this 19 * software without specific prior written permission. 20 * 21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 */ 33 34 #ifndef GAUCHE_H 35 #define GAUCHE_H 36 37 /* GAUCHE_API_VERSION is GAUCHE_MAJOR_VERSION*1000 + revision. 38 The revision is only incremented when we change API, which we expect 39 rare during the same major revision. */ 40 #ifndef GAUCHE_API_VERSION 41 #define GAUCHE_API_VERSION 97 42 //#define GAUCHE_API_VERSION 1000 43 #endif 44 45 /* Read config.h _before_ other headers, for it may affect the behavior 46 of system header files. Currently the only known instance of it is 47 sigwait() on Solaris---we need to define _POSIX_PTHREAD_SEMANTICS to 48 get pthread-compatible sigwait()---but we may encounter more of such 49 instances. */ 50 #include <gauche/config.h> 51 #include <gauche/config_threads.h> 52 53 #include <stdio.h> 54 #include <stdlib.h> 55 #include <sys/types.h> 56 #include <sys/stat.h> 57 #include <stdarg.h> 58 #include <setjmp.h> 59 #include <limits.h> 60 #include <signal.h> 61 #include <string.h> 62 #include <errno.h> 63 #include <stdint.h> 64 #include <inttypes.h> 65 #include <gauche/int64.h> 66 67 #ifdef TIME_WITH_SYS_TIME 68 # include <sys/time.h> 69 # include <time.h> 70 #else 71 # ifdef HAVE_SYS_TIME_H 72 # include <sys/time.h> 73 # else 74 # include <time.h> 75 # endif 76 #endif 77 78 typedef ssize_t ScmSize; 79 80 /* For Windows platforms, we need some compatibility tricks. 81 This defines GAUCHE_WINDOWS preprocessor symbol. 82 (This should come before including gc.h) */ 83 #if defined(__MINGW32__) || defined(MSVC) 84 #include <gauche/win-compat.h> 85 #endif /* MINGW32 || WINDOWS */ 86 87 /* Defines SCM_EXTERN magic. */ 88 #include <gauche/extern.h> 89 90 #if defined(LIBGAUCHE_BODY) 91 #if !defined(GC_DLL) 92 #define GC_DLL /* for gc.h to handle Win32 crazyness */ 93 #endif 94 #if !defined(GC_BUILD) 95 #define GC_BUILD /* ditto */ 96 #endif 97 #endif /* LIBGAUCHE_BODY */ 98 #include <gc.h> 99 100 #ifndef SCM_DECL_BEGIN 101 #ifdef __cplusplus 102 #define SCM_DECL_BEGIN extern "C" { 103 #define SCM_DECL_END } 104 #else /*! __cplusplus */ 105 #define SCM_DECL_BEGIN 106 #define SCM_DECL_END 107 #endif /*! __cplusplus */ 108 #endif /*!defined(SCM_DECL_BEGIN)*/ 109 110 SCM_DECL_BEGIN 111 112 #ifdef HAVE_UNISTD_H 113 #include <unistd.h> 114 #endif /*HAVE_UNISTD_H*/ 115 116 /* This must come after gauche/extern.h */ 117 #include <gauche/float.h> 118 119 /* Some useful macros */ 120 #ifndef FALSE 121 #define FALSE 0 122 #endif 123 #ifndef TRUE 124 #define TRUE (!FALSE) 125 #endif 126 127 128 129 /* Define this to 0 to turn off fast flonum extension. See the comment in 130 gauche/number.h for the details. */ 131 #define GAUCHE_FFX 1 132 133 /* Temporary - to test alignment of pairs */ 134 #define GAUCHE_CHECK_PAIR_ALIGNMENT 0 135 136 /* TRANSIENT: Define this to 1 to include (obsoleted) string pointer functions. 137 It will be completely gone soon. */ 138 #define GAUCHE_STRING_POINTER 0 139 140 /* Enable an option to make keywords and symbols disjoint. 141 (Transient: Will be gone once we completely migrate to 142 unified keyword-symbol system */ 143 #define GAUCHE_KEEP_DISJOINT_KEYWORD_OPTION 1 144 145 /* Experimental: Enable lightweight continuation capturing in exception 146 handling. */ 147 #define GAUCHE_SPLIT_STACK 0 148 149 /* Include appropriate threading interface. Threading primitives are 150 abstracted with SCM_INTERNAL_* macros and ScmInternal* typedefs. 151 See gauche/uthread.h for the semantics of these primitives. */ 152 #ifdef GAUCHE_USE_PTHREADS 153 # include <gauche/pthread.h> 154 #elif GAUCHE_USE_WTHREADS 155 # include <gauche/wthread.h> 156 #else /* !GAUCHE_USE_PTHREADS */ 157 # include <gauche/uthread.h> 158 #endif /* !GAUCHE_USE_PTHREADS */ 159 160 #define SCM_WORD_BITS (SIZEOF_LONG*8) 161 162 /* Newer gcc/glibc adds lots of __attribute__((warn_unused_result)) that 163 causes excessive warnings for the code that intentionally ignores the 164 return value. Casting the result to void won't silence it. 165 Hence this macro. */ 166 #define SCM_IGNORE_RESULT(expr) do { if(expr) {} } while(0) 167 168 /* ScmFlonum and ScmClass must always be aligned in 8-byte boundaries. 169 Some platform doesn't align static double in 8-byte boundaries, so 170 we try this as well. */ 171 #ifdef __GNUC__ 172 #define SCM_ALIGN8 __attribute__ ((aligned (8))) 173 #else /* !__GNUC__ */ 174 #define SCM_ALIGN8 /*empty*/ 175 #endif /* !__GNUC__ */ 176 177 /* Statically allocated ScmPair must be aligned in two ScmWords boundary.*/ 178 #ifdef __GNUC__ 179 #define SCM_PAIR_ALWAYS_ALIGNED_EVEN_WORDS 1 180 #define SCM_ALIGN_PAIR __attribute__ ((aligned(sizeof(ScmWord)*2))) 181 #else /* !__GNUC__ */ 182 #define SCM_PAIR_ALWAYS_ALIGNED_EVEN_WORDS 0 183 #define SCM_ALIGN_PAIR /*empty*/ 184 #endif /* !__GNUC__ */ 185 186 /* 'No return' attribute */ 187 #ifdef __GNUC__ 188 #define SCM_NORETURN __attribute__((__noreturn__)) 189 #else /*__GNUC__*/ 190 #define SCM_NORETURN /*empty*/ 191 #endif /*__GNUC__*/ 192 193 /* 'unused' attribute */ 194 #ifdef __GNUC__ 195 #define SCM_UNUSED __attribute__((__unused__)) 196 #else /*__GNUC__*/ 197 #define SCM_UNUSED /*empty*/ 198 #endif /*__GNUC__*/ 199 200 /* 'noinline' attribute */ 201 #ifdef __GNUC__ 202 #define SCM_NOINLINE __attribute__((__noinline__)) 203 #else /*__GNUC__*/ 204 #define SCM_NOINLINE /*empty*/ 205 #endif /*__GNUC__*/ 206 207 208 /*------------------------------------------------------------- 209 * BASIC TYPES 210 */ 211 212 /* 213 * A word large enough to hold a pointer 214 */ 215 typedef intptr_t ScmWord; 216 217 /* 218 * A byte 219 */ 220 typedef unsigned char ScmByte; 221 222 /* 223 * A character. 224 */ 225 typedef long ScmChar; 226 227 /* 228 * An opaque pointer. All Scheme objects are represented by 229 * this type. 230 */ 231 typedef struct ScmHeaderRec *ScmObj; 232 233 /* 234 * The class structure. ScmClass is actually a subclass of ScmObj. 235 */ 236 typedef struct ScmClassRec ScmClass; 237 238 /* TAG STRUCTURE 239 * 240 * [Pointer] 241 * -------- -------- -------- ------00 242 * Points to a pair or other heap-allocated objects. 243 * If the lower 3 bits of the pointed word are '111', 244 * it's a heap object (see below). Otherwise, it's 245 * a pair. 246 * 247 * [Fixnum] 248 * -------- -------- -------- ------01 249 * 30 or 62-bit signed integer 250 * 251 * [Flonum] 252 * -------- -------- -------- -----M10 253 * Points to C double. M=0 if the double is in the VM 254 * register, M=1 if it is on the heap. See the comment in 255 * gauche/number.h for the details. 256 * 257 * [Character] 258 * -------- -------- -------- 00000011 259 * 24-bit. 20bits are enough to cover all UCS, but we 260 * reserve a few extra bits for possible future extension. 261 * 262 * [Miscellaneous] 263 * -------- -------- -------- 00001011 264 * #f, #t, '(), eof-object, undefined, uninitialized 265 * 266 * [Pattern variable] 267 * -------- -------- -------- 00010011 268 * Used in macro expander. 269 * 270 * [String cursor] 271 * -------- -------- -------- 00011011 272 * Represent short string cursors. 273 * 274 * [Heap object] 275 * -------- -------- -------- -----111 276 * Only appears at the first word of heap-allocated 277 * objects except pairs and flonums. Masking lower 278 * 3bits gives a pointer to ScmClass. 279 */ 280 281 /* Type coercer */ 282 283 #define SCM_OBJ(obj) ((ScmObj)(obj)) 284 #define SCM_WORD(obj) ((ScmWord)(obj)) 285 286 /* 287 * PRIMARY TAG IDENTIFICATION 288 */ 289 290 #define SCM_TAG1(obj) (SCM_WORD(obj) & 0x01) 291 #define SCM_TAG2(obj) (SCM_WORD(obj) & 0x03) 292 #define SCM_TAG3(obj) (SCM_WORD(obj) & 0x07) 293 #define SCM_TAG8(obj) (SCM_WORD(obj) & 0xff) 294 295 /* Check if the ScmObj is a 'pointer'---either to a pair, 296 a heap object, or a ScmFlonum. */ 297 #define SCM_PTRP(obj) (SCM_TAG1(obj) == 0) 298 299 /* Check if the ScmObj is a pointer to either a pair or a heap 300 (That is, we can safely take SCM_OBJ(obj)->tag) */ 301 #define SCM_HPTRP(obj) (SCM_TAG2(obj) == 0) 302 303 /* This macro further takes the lower three bits of the word pointed 304 by OBJ, to distinguish whether it's a pair or a heap object. */ 305 #define SCM_HTAG(obj) (SCM_WORD(SCM_OBJ(obj)->tag)&7) 306 307 /* 308 * IMMEDIATE OBJECTS 309 */ 310 311 #define SCM_IMMEDIATEP(obj) (SCM_TAG8(obj) == 0x0b) 312 #define SCM_ITAG(obj) (SCM_WORD(obj)>>8) 313 314 #define SCM__MAKE_ITAG(num) (((num)<<8) + 0x0b) 315 #define SCM_FALSE SCM_OBJ(SCM__MAKE_ITAG(0)) /* #f */ 316 #define SCM_TRUE SCM_OBJ(SCM__MAKE_ITAG(1)) /* #t */ 317 #define SCM_NIL SCM_OBJ(SCM__MAKE_ITAG(2)) /* '() */ 318 #define SCM_EOF SCM_OBJ(SCM__MAKE_ITAG(3)) /* eof-object */ 319 #define SCM_UNDEFINED SCM_OBJ(SCM__MAKE_ITAG(4)) /* #undefined */ 320 #define SCM_UNBOUND SCM_OBJ(SCM__MAKE_ITAG(5)) /* unbound value */ 321 #define SCM_UNINITIALIZED SCM_OBJ(SCM__MAKE_ITAG(6)) /* uninitialized */ 322 323 #define SCM_FALSEP(obj) ((obj) == SCM_FALSE) 324 #define SCM_TRUEP(obj) ((obj) == SCM_TRUE) 325 #define SCM_NULLP(obj) ((obj) == SCM_NIL) 326 #define SCM_EOFP(obj) ((obj) == SCM_EOF) 327 #define SCM_UNDEFINEDP(obj) ((obj) == SCM_UNDEFINED) 328 #define SCM_UNBOUNDP(obj) ((obj) == SCM_UNBOUND) 329 #define SCM_UNINITIALIZEDP(obj) ((obj) == SCM_UNINITIALIZED) 330 331 /* 332 * BOOLEAN 333 */ 334 #define SCM_BOOLP(obj) ((obj) == SCM_TRUE || (obj) == SCM_FALSE) 335 #define SCM_BOOL_VALUE(obj) (!SCM_FALSEP(obj)) 336 #define SCM_MAKE_BOOL(obj) ((obj)? SCM_TRUE:SCM_FALSE) 337 338 #define SCM_EQ(x, y) ((x) == (y)) 339 340 SCM_EXTERN int Scm_EqP(ScmObj x, ScmObj y); 341 SCM_EXTERN int Scm_EqvP(ScmObj x, ScmObj y); 342 SCM_EXTERN int Scm_EqualP(ScmObj x, ScmObj y); 343 344 /* comparison mode */ 345 enum { 346 SCM_CMP_EQ, 347 SCM_CMP_EQV, 348 SCM_CMP_EQUAL 349 }; 350 351 SCM_EXTERN int Scm_EqualM(ScmObj x, ScmObj y, int mode); 352 353 /* 354 * FIXNUM 355 */ 356 357 #define SCM_INTP(obj) (SCM_TAG2(obj) == 1) 358 #define SCM_INT_VALUE(obj) (((signed long int)SCM_WORD(obj)) >> 2) 359 #define SCM_MAKE_INT(obj) SCM_OBJ(((uintptr_t)(obj) << 2) + 1) 360 361 #define SCM_UINTP(obj) (SCM_INTP(obj)&&((signed long int)SCM_WORD(obj)>=0)) 362 typedef long ScmSmallInt; /* C integer type corresponds to Scheme fixnum 363 See SCM_SMALL_* macros in gauche/number.h */ 364 365 /* 366 * FLONUM 367 */ 368 369 typedef struct ScmFlonumRec { 370 double val; 371 } ScmFlonum SCM_ALIGN8; 372 373 #define SCM_FLONUM(obj) ((ScmFlonum*)(SCM_WORD(obj)&~0x07)) 374 #define SCM_FLONUMP(obj) (SCM_TAG2(obj) == 2) 375 #define SCM_FLONUM_VALUE(obj) (SCM_FLONUM(obj)->val) 376 377 /* 378 * CHARACTERS 379 * 380 * A character is represented by (up to) 29-bit integer. The actual 381 * encoding depends on compile-time flags. 382 * 383 * For character cases, I only care about ASCII chars (at least for now) 384 */ 385 386 #define SCM_CHAR(obj) ((ScmChar)(obj)) 387 #define SCM_CHARP(obj) ((SCM_WORD(obj)&0xff) == 3) 388 #define SCM_CHAR_VALUE(obj) SCM_CHAR(((unsigned long)SCM_WORD(obj)) >> 8) 389 #define SCM_MAKE_CHAR(ch) SCM_OBJ((intptr_t)(((unsigned long)(ch))<<8) + 3) 390 391 #define SCM_CHAR_INVALID ((ScmChar)(-1)) /* indicate invalid char */ 392 #define SCM_CHAR_MAX (0xffffff) 393 394 #define SCM_CHAR_ASCII_P(ch) ((ch) < 0x80) 395 396 /* The following four macros are obsoleted; use API version instead.*/ 397 #define SCM_CHAR_UPPER_P(ch) Scm_CharUppercaseP(ch) 398 #define SCM_CHAR_LOWER_P(ch) Scm_CharLowercaseP(ch) 399 #define SCM_CHAR_UPCASE(ch) Scm_CharUpcase(ch) 400 #define SCM_CHAR_DOWNCASE(ch) Scm_CharDowncase(ch) 401 402 SCM_EXTERN int Scm_DigitToInt(ScmChar ch, int radix, int extended); 403 SCM_EXTERN ScmChar Scm_IntToDigit(int n, int radix, int basechar1, int basechar2); 404 SCM_EXTERN int Scm_CharToUcs(ScmChar ch); 405 SCM_EXTERN ScmChar Scm_UcsToChar(int ucs); 406 SCM_EXTERN ScmObj Scm_CharEncodingName(void); 407 SCM_EXTERN const char **Scm_SupportedCharacterEncodings(void); 408 SCM_EXTERN int Scm_SupportedCharacterEncodingP(const char *encoding); 409 410 SCM_EXTERN int Scm_CharGeneralCategory(ScmChar ch); 411 SCM_EXTERN int Scm_CharAlphabeticP(ScmChar ch); 412 SCM_EXTERN int Scm_CharUppercaseP(ScmChar ch); 413 SCM_EXTERN int Scm_CharLowercaseP(ScmChar ch); 414 SCM_EXTERN int Scm_CharTitlecaseP(ScmChar ch); 415 SCM_EXTERN int Scm_CharNumericP(ScmChar ch); 416 417 SCM_EXTERN ScmChar Scm_CharUpcase(ScmChar ch); 418 SCM_EXTERN ScmChar Scm_CharDowncase(ScmChar ch); 419 SCM_EXTERN ScmChar Scm_CharTitlecase(ScmChar ch); 420 SCM_EXTERN ScmChar Scm_CharFoldcase(ScmChar ch); 421 422 #if defined(GAUCHE_CHAR_ENCODING_EUC_JP) 423 #include "gauche/char_euc_jp.h" 424 #elif defined(GAUCHE_CHAR_ENCODING_UTF_8) 425 #include "gauche/char_utf_8.h" 426 #elif defined(GAUCHE_CHAR_ENCODING_SJIS) 427 #include "gauche/char_sjis.h" 428 #else 429 #include "gauche/char_none.h" 430 #endif 431 432 /* Character lexer category. See 7.1.1 of R7RS */ 433 typedef enum { 434 SCM_CHAR_INITIAL, 435 SCM_CHAR_SUBSEQUENT, 436 SCM_CHAR_SIGN_SUBSEQUENT, 437 } ScmCharLexerCategory; 438 439 SCM_EXTERN int Scm_CharLexerCategoryP(ScmChar c, ScmCharLexerCategory cat); 440 441 /* 442 * HEAP ALLOCATED OBJECTS 443 * 444 * A heap allocated object has its class tag in the first word 445 * (except pairs). Masking the lower three bits of class tag 446 * gives a pointer to the class object. 447 */ 448 449 #define SCM_HOBJP(obj) (SCM_HPTRP(obj)&&(SCM_HTAG(obj)==7)) 450 451 #define SCM_CPP_CAT(a, b) a##b 452 #define SCM_CPP_CAT3(a, b, c) a ## b ## c 453 454 /* We use a pointer to the class structure (with low-bit tag) as 455 the generic type tag. NB: The ScmClass structure is always 456 aligned on 8-byte boundary, so +7 makes the tag's lower 457 3 bits '111'. Such pattern never appears in tagged pointer, 458 so we can distinguish heap allocated objects from ScmPair. */ 459 #define SCM_CLASS2TAG(klass) ((ScmByte*)(klass) + 7) 460 461 /* A common header for heap-allocated objects */ 462 typedef struct ScmHeaderRec { 463 ScmByte *tag; /* private. should be accessed 464 only via SCM_CLASS_OF and SCM_SET_CLASS 465 macros. */ 466 } ScmHeader; 467 468 #define SCM_HEADER ScmHeader hdr /* for declaration */ 469 470 /* Here comes the ugly part. To understand the general idea, just ignore 471 GAUCHE_BROKEN_LINKER_WORKAROUND part; except that, it's pretty simple. 472 Every heap allocated object contains (pointer to its class + 7) in its 473 tag field. */ 474 #if !defined(GAUCHE_BROKEN_LINKER_WORKAROUND) 475 476 # define SCM_CLASS_DECL(klass) extern ScmClass klass 477 # define SCM_CLASS_STATIC_PTR(klass) (&klass) 478 # define SCM_CLASS_STATIC_TAG(klass) SCM_CLASS2TAG(&klass) 479 480 /* Extract the class pointer from the tag. 481 You can use these only if SCM_HOBJP(obj) != FALSE */ 482 # define SCM_CLASS_OF(obj) SCM_CLASS((SCM_OBJ(obj)->tag - 7)) 483 # define SCM_SET_CLASS(obj, k) (SCM_OBJ(obj)->tag = (ScmByte*)(k) + 7) 484 485 /* Check if classof(OBJ) equals to an extended class KLASS. 486 We can check SCM_HPTRP instead of SCM_HOBJP here, since a pair never 487 satisfies the second test. */ 488 # define SCM_XTYPEP(obj, klass) \ 489 (SCM_HPTRP(obj)&&(SCM_OBJ(obj)->tag == SCM_CLASS2TAG(klass))) 490 491 #else /*GAUCHE_BROKEN_LINKER_WORKAROUND*/ 492 493 /* You don't want to understand these. */ 494 # define SCM_CLASS_DECL(klass) \ 495 SCM_EXTERN ScmClass klass; \ 496 extern ScmClass *SCM_CPP_CAT(_imp__, klass) 497 # define SCM_CLASS_STATIC_PTR(klass) ((ScmClass*)(&SCM_CPP_CAT(_imp__,klass))) 498 # define SCM_CLASS_STATIC_TAG(klass) SCM_CLASS2TAG(SCM_CLASS_STATIC_PTR(klass)) 499 500 # define SCM_CLASS_OF(obj) (*(ScmClass**)((SCM_OBJ(obj)->tag - 7))) 501 # define SCM_SET_CLASS(obj, k) (SCM_OBJ(obj)->tag = (ScmByte*)((k)->classPtr) + 7) 502 503 # define SCM_XTYPEP(obj, klass) \ 504 (SCM_HOBJP(obj)&&(SCM_CLASS_OF(obj) == klass)) 505 #endif /*GAUCHE_BROKEN_LINKER_WORKAROUND*/ 506 507 508 509 /* Check if classof(OBJ) is a subtype of an extended class KLASS */ 510 #define SCM_ISA(obj, klass) (SCM_XTYPEP(obj,klass)||Scm_TypeP(SCM_OBJ(obj),klass)) 511 512 /* A common header for objects whose class is defined in Scheme */ 513 typedef struct ScmInstanceRec { 514 ScmByte *tag; /* private */ 515 ScmObj *slots; /* private */ 516 } ScmInstance; 517 518 #define SCM_INSTANCE_HEADER ScmInstance hdr /* for declaration */ 519 520 #define SCM_INSTANCE(obj) ((ScmInstance*)(obj)) 521 #define SCM_INSTANCE_SLOTS(obj) (SCM_INSTANCE(obj)->slots) 522 523 /* Fundamental allocators */ 524 #define SCM_MALLOC(size) GC_MALLOC(size) 525 #define SCM_MALLOC_ATOMIC(size) GC_MALLOC_ATOMIC(size) 526 #define SCM_STRDUP(s) GC_STRDUP(s) 527 #define SCM_STRDUP_PARTIAL(s, n) Scm_StrdupPartial(s, n) 528 529 #define SCM_NEW(type) ((type*)(SCM_MALLOC(sizeof(type)))) 530 #define SCM_NEW_ARRAY(type, nelts) ((type*)(SCM_MALLOC(sizeof(type)*(nelts)))) 531 #define SCM_NEW2(type, size) ((type)(SCM_MALLOC(size))) 532 #define SCM_NEW_ATOMIC(type) ((type*)(SCM_MALLOC_ATOMIC(sizeof(type)))) 533 #define SCM_NEW_ATOMIC_ARRAY(type, nelts) ((type*)(SCM_MALLOC_ATOMIC(sizeof(type)*(nelts)))) 534 #define SCM_NEW_ATOMIC2(type, size) ((type)(SCM_MALLOC_ATOMIC(size))) 535 536 typedef void (*ScmFinalizerProc)(ScmObj z, void *data); 537 SCM_EXTERN void Scm_RegisterFinalizer(ScmObj z, ScmFinalizerProc finalizer, 538 void *data); 539 SCM_EXTERN void Scm_UnregisterFinalizer(ScmObj z); 540 541 /* Safe coercer */ 542 #define SCM_OBJ_SAFE(obj) ((obj)?SCM_OBJ(obj):SCM_UNDEFINED) 543 544 typedef struct ScmVMRec ScmVM; 545 typedef struct ScmPairRec ScmPair; 546 typedef struct ScmExtendedPairRec ScmExtendedPair; 547 typedef struct ScmLazyPairRec ScmLazyPair; 548 typedef struct ScmCharSetRec ScmCharSet; 549 typedef struct ScmStringRec ScmString; 550 typedef struct ScmDStringRec ScmDString; 551 typedef struct ScmVectorRec ScmVector; 552 typedef struct ScmBignumRec ScmBignum; 553 typedef struct ScmRatnumRec ScmRatnum; 554 typedef struct ScmCompnumRec ScmCompnum; 555 typedef struct ScmPortRec ScmPort; 556 typedef struct ScmHashTableRec ScmHashTable; 557 typedef struct ScmTreeMapRec ScmTreeMap; 558 typedef struct ScmModuleRec ScmModule; 559 typedef struct ScmSymbolRec ScmSymbol; 560 typedef struct ScmGlocRec ScmGloc; 561 typedef struct ScmProcedureRec ScmProcedure; 562 typedef struct ScmClosureRec ScmClosure; 563 typedef struct ScmSubrRec ScmSubr; 564 typedef struct ScmGenericRec ScmGeneric; 565 typedef struct ScmMethodRec ScmMethod; 566 typedef struct ScmNextMethodRec ScmNextMethod; 567 typedef struct ScmSyntaxRec ScmSyntax; 568 typedef struct ScmMacroRec ScmMacro; 569 typedef struct ScmPromiseRec ScmPromise; 570 typedef struct ScmRegexpRec ScmRegexp; 571 typedef struct ScmRegMatchRec ScmRegMatch; 572 typedef struct ScmWriteControlsRec ScmWriteControls; /* see writerP.h */ 573 typedef struct ScmWriteContextRec ScmWriteContext; /* see writerP.h */ 574 typedef struct ScmWriteStateRec ScmWriteState; /* see wrtierP.h */ 575 typedef struct ScmAutoloadRec ScmAutoload; 576 typedef struct ScmComparatorRec ScmComparator; 577 typedef struct ScmDLObjRec ScmDLObj; /* see load.c */ 578 typedef struct ScmReadContextRec ScmReadContext; /* see read.c */ 579 580 typedef ScmObj ScmSubrProc(ScmObj *, int, void*); 581 582 #include <gauche/bits.h> 583 584 /*--------------------------------------------------------- 585 * VM STUFF 586 */ 587 588 /* Detailed definitions are in vm.h. Here I expose external interface */ 589 590 #include <gauche/parameter.h> 591 #include <gauche/vm.h> 592 593 #define SCM_VM(obj) ((ScmVM *)(obj)) 594 #define SCM_VMP(obj) SCM_XTYPEP(obj, SCM_CLASS_VM) 595 596 #define SCM_VM_CURRENT_INPUT_PORT(vm) (SCM_VM(vm)->curin) 597 #define SCM_VM_CURRENT_OUTPUT_PORT(vm) (SCM_VM(vm)->curout) 598 #define SCM_VM_CURRENT_ERROR_PORT(vm) (SCM_VM(vm)->curerr) 599 600 SCM_EXTERN ScmVM *Scm_VM(void); /* Returns the current VM */ 601 602 /* The new APIs to run Scheme code from C. 603 Returns # of results (>=0) if operation is successful, 604 -1 if an error is occurred and captured. 605 All result values are available in ScmEvalPacket. 606 Exceptions are captured and returned in the ScmEvalPacket. */ 607 typedef struct ScmEvalPacketRec { 608 ScmObj results[SCM_VM_MAX_VALUES]; 609 int numResults; 610 ScmObj exception; 611 ScmModule *module; /* 'Current module' after evaluation */ 612 } ScmEvalPacket; 613 614 SCM_EXTERN int Scm_Eval(ScmObj form, ScmObj env, ScmEvalPacket *packet); 615 SCM_EXTERN int Scm_EvalCString(const char *form, ScmObj env, 616 ScmEvalPacket *packet); 617 SCM_EXTERN int Scm_Apply(ScmObj proc, ScmObj args, 618 ScmEvalPacket *packet); 619 620 /* Calls VM recursively to evaluate the Scheme code. These 621 ones does not capture exceptions. */ 622 SCM_EXTERN ScmObj Scm_EvalRec(ScmObj form, ScmObj env); 623 SCM_EXTERN ScmObj Scm_ApplyRec(ScmObj proc, ScmObj args); 624 SCM_EXTERN ScmObj Scm_ApplyRec0(ScmObj proc); 625 SCM_EXTERN ScmObj Scm_ApplyRec1(ScmObj proc, ScmObj arg0); 626 SCM_EXTERN ScmObj Scm_ApplyRec2(ScmObj proc, ScmObj arg0, ScmObj arg1); 627 SCM_EXTERN ScmObj Scm_ApplyRec3(ScmObj proc, ScmObj arg0, ScmObj arg1, 628 ScmObj arg2); 629 SCM_EXTERN ScmObj Scm_ApplyRec4(ScmObj proc, ScmObj arg0, ScmObj arg1, 630 ScmObj arg2, ScmObj arg3); 631 SCM_EXTERN ScmObj Scm_ApplyRec5(ScmObj proc, ScmObj arg0, ScmObj arg1, 632 ScmObj arg2, ScmObj arg3, ScmObj arg4); 633 634 /* for compatibility */ 635 #define Scm_EvalCStringRec(f, e) Scm_EvalRec(Scm_ReadFromCString(f), e) 636 637 /* Returns multiple values. Actually these functions just sets 638 extra values in VM and returns the primary value. */ 639 SCM_EXTERN ScmObj Scm_Values(ScmObj args); 640 SCM_EXTERN ScmObj Scm_Values2(ScmObj val0, ScmObj val1); 641 SCM_EXTERN ScmObj Scm_Values3(ScmObj val0, ScmObj val1, ScmObj val2); 642 SCM_EXTERN ScmObj Scm_Values4(ScmObj val0, ScmObj val1, ScmObj val2, 643 ScmObj val3); 644 SCM_EXTERN ScmObj Scm_Values5(ScmObj val0, ScmObj val1, ScmObj val2, 645 ScmObj val3, ScmObj val4); 646 SCM_EXTERN ScmObj Scm_ValuesFromArray(ScmObj *argv, ScmSmallInt argc); 647 648 /* CPS API for evaluating Scheme fragments on VM. */ 649 SCM_EXTERN ScmObj Scm_VMApply(ScmObj proc, ScmObj args); 650 SCM_EXTERN ScmObj Scm_VMApply0(ScmObj proc); 651 SCM_EXTERN ScmObj Scm_VMApply1(ScmObj proc, ScmObj arg); 652 SCM_EXTERN ScmObj Scm_VMApply2(ScmObj proc, ScmObj arg1, ScmObj arg2); 653 SCM_EXTERN ScmObj Scm_VMApply3(ScmObj proc, ScmObj arg1, ScmObj arg2, 654 ScmObj arg3); 655 SCM_EXTERN ScmObj Scm_VMApply4(ScmObj proc, ScmObj arg1, ScmObj arg2, 656 ScmObj arg3, ScmObj arg4); 657 SCM_EXTERN ScmObj Scm_VMEval(ScmObj expr, ScmObj env); 658 SCM_EXTERN ScmObj Scm_VMCall(ScmObj *args, int argcnt, void *data); 659 660 SCM_EXTERN ScmObj Scm_VMCallCC(ScmObj proc); 661 SCM_EXTERN ScmObj Scm_VMCallPC(ScmObj proc); 662 SCM_EXTERN ScmObj Scm_VMReset(ScmObj proc); 663 SCM_EXTERN ScmObj Scm_VMDynamicWind(ScmObj pre, ScmObj body, ScmObj post); 664 SCM_EXTERN ScmObj Scm_VMDynamicWindC(ScmSubrProc *before, 665 ScmSubrProc *body, 666 ScmSubrProc *after, 667 void *data); 668 669 SCM_EXTERN ScmObj Scm_VMWithErrorHandler(ScmObj handler, ScmObj thunk); 670 SCM_EXTERN ScmObj Scm_VMWithGuardHandler(ScmObj handler, ScmObj thunk); 671 SCM_EXTERN ScmObj Scm_VMWithExceptionHandler(ScmObj handler, ScmObj thunk); 672 SCM_EXTERN ScmObj Scm_VMReraise(); 673 674 /* Miscellaneous stuff */ 675 SCM_EXTERN int Scm_VMGetNumResults(ScmVM *vm); 676 SCM_EXTERN ScmObj Scm_VMGetResult(ScmVM *vm); 677 SCM_EXTERN ScmObj Scm_VMGetStackLite(ScmVM *vm); 678 SCM_EXTERN ScmObj Scm_VMGetCallTraceLite(ScmVM *vm); 679 SCM_EXTERN ScmObj Scm_VMGetStack(ScmVM *vm); 680 681 /* A box is to keep a reference. Internally, it is used for mutable 682 local variables. srfi-111 defines Scheme interface. */ 683 typedef struct ScmBoxRec { 684 SCM_HEADER; 685 ScmObj value; 686 } ScmBox; 687 688 SCM_CLASS_DECL(Scm_BoxClass); 689 #define SCM_CLASS_BOX (&Scm_BoxClass) 690 #define SCM_BOX(obj) ((ScmBox*)(obj)) 691 #define SCM_BOXP(obj) (SCM_XTYPEP(obj, SCM_CLASS_BOX)) 692 #define SCM_BOX_VALUE(obj) (SCM_BOX(obj)->value) 693 #define SCM_BOX_SET(obj, val) (SCM_BOX(obj)->value = (val)) 694 695 SCM_EXTERN ScmBox *Scm_MakeBox(ScmObj value); 696 697 /* An mv-box is multi-valued box. Srfi-195 extends srfi-111 to support 698 arbitrary number of values in a box. We use a different type <mv-box>, 699 in order to keep the one-value box lightweight. */ 700 typedef struct ScmMVBoxRec { 701 SCM_HEADER; 702 ScmSmallInt size; 703 ScmObj values[1]; /* variable length */ 704 } ScmMVBox; 705 706 SCM_CLASS_DECL(Scm_MVBoxClass); 707 #define SCM_CLASS_MVBOX (&Scm_MVBoxClass) 708 #define SCM_MVBOX(obj) ((ScmMVBox*)(obj)) 709 #define SCM_MVBOXP(obj) (SCM_XTYPEP(obj, SCM_CLASS_MVBOX)) 710 #define SCM_MVBOX_SIZE(obj) (SCM_MVBOX(obj)->size) 711 #define SCM_MVBOX_VALUES(obj) (SCM_MVBOX(obj)->values) 712 #define SCM_MVBOX_SET(obj, k, val) (SCM_MVBOX(obj)->values[k] = (val)) 713 714 SCM_EXTERN ScmMVBox *Scm_MakeMVBox(ScmSmallInt size, ScmObj init); 715 SCM_EXTERN ScmMVBox *Scm_ListToMVBox(ScmObj elts); 716 717 /*--------------------------------------------------------- 718 * CLASS 719 */ 720 721 typedef void (*ScmClassPrintProc)(ScmObj obj, 722 ScmPort *sink, 723 ScmWriteContext *mode); 724 typedef int (*ScmClassCompareProc)(ScmObj x, ScmObj y, int equalp); 725 typedef ScmSmallInt (*ScmClassHashProc)(ScmObj obj, ScmSmallInt salt, 726 u_long flags); 727 typedef ScmObj (*ScmClassAllocateProc)(ScmClass *klass, ScmObj initargs); 728 729 /* Flags value for ScmClassHashProc */ 730 enum { 731 SCM_HASH_PORTABLE = 1L<<0 /* must calculate a portable hash value, 732 can be used for portable-hash. */ 733 }; 734 735 736 /* See class.c for the description of function pointer members. 737 There's a lot of voodoo magic in class structure, so don't touch 738 those fields casually. Also, the order of these fields must be 739 reflected to the class definition macros below. */ 740 struct ScmClassRec { 741 /* A trick to align statically allocated class structure on 8-byte 742 boundary. This doesn't guarantee, though, so we use __alignment__ 743 attribute as well, whenever possible (see SCM_ALIGN8 macro). */ 744 union { 745 SCM_INSTANCE_HEADER; 746 double align_dummy; 747 } classHdr; 748 #if defined(GAUCHE_BROKEN_LINKER_WORKAROUND) 749 ScmClass **classPtr; 750 #endif 751 /* Some type-specific primitive methods. Note that these take precedence 752 than the generic function verison (write-object, object-compare etc.) 753 */ 754 ScmClassPrintProc print; 755 ScmClassCompareProc compare; 756 ScmClassHashProc hash; 757 ScmClassAllocateProc allocate; 758 ScmClass **cpa; /* class precedence array, NULL terminated */ 759 int numInstanceSlots; /* # of instance slots */ 760 int coreSize; /* size of core structure; 0 == unknown */ 761 unsigned int flags; 762 ScmObj name; /* scheme name */ 763 ScmObj directSupers; /* list of classes */ 764 ScmObj cpl; /* list of classes */ 765 ScmObj accessors; /* alist of slot-name & slot-accessor */ 766 ScmObj directSlots; /* alist of slot-name & slot-definition */ 767 ScmObj slots; /* alist of slot-name & slot-definition */ 768 ScmObj directSubclasses; /* list of direct subclasses */ 769 ScmObj directMethods; /* list of methods that has this class in 770 its specializer */ 771 ScmObj initargs; /* saved key-value list for redefinition */ 772 ScmObj modules; /* modules where this class is defined */ 773 ScmObj redefined; /* if this class is obsoleted by class 774 redefinition, points to the new class. 775 if this class is being redefined, points 776 to a thread that is handling the 777 redefinition. (it won't be seen by 778 Scheme; see class.c) 779 otherwise #f */ 780 ScmInternalMutex mutex; /* to protect from MT hazard */ 781 ScmInternalCond cv; /* wait on this while a class being updated */ 782 void *data; /* extra data to do nasty trick. See the note 783 in class.c */ 784 } SCM_ALIGN8; 785 786 typedef struct ScmClassStaticSlotSpecRec ScmClassStaticSlotSpec; 787 788 #define SCM_CLASS(obj) ((ScmClass*)(obj)) 789 #define SCM_CLASSP(obj) SCM_ISA(obj, SCM_CLASS_CLASS) 790 791 #define SCM_CLASS_NUM_INSTANCE_SLOTS(obj) SCM_CLASS(obj)->numInstanceSlots 792 793 /* Class categories 794 795 In C level, there are four categories of classes. The category of 796 class can be obtained by masking the lower two bits of flags field. 797 798 SCM_CLASS_BUILTIN 799 An instance of this class doesn't have "slots" member (thus 800 cannot be cast to ScmInstance*). From Scheme level, this 801 class cannot be redefined. It cannot be inherited in Scheme 802 code with the standard inheritance mechanism; though it can have 803 subclasses, provided a special allocator and initializer. 804 805 SCM_CLASS_ABSTRACT 806 This class is defined in C, but doesn't allowed to create an 807 instance by its own. It is intended to be used as a mixin from 808 both C and Scheme-defined class. An instance of this class 809 shouldn't have C members other than SCM_HEADER. 810 This class cannot be redefined. 811 812 SCM_CLASS_BASE 813 This class is defined in C, and can be subclassed in Scheme. 814 An instance of this class must have "slots" member and be 815 able to be cast to ScmInstance. The instance may have other 816 C members. This class cannot be redefined. 817 818 SCM_CLASS_SCHEME 819 A Scheme-defined class. This class will have one or more 820 SCM_CLASS_BASE classes in its CPL. Specifically, <object> 821 class is always included in its CPL. This class can be 822 redefined. 823 824 This classification and its rules are to integrate C structures 825 and Scheme classes. C structure level inheritance has to be 826 single-inheritance, with the subclass structure including its 827 parent structure. Scheme level inheritance is more flexible, 828 but for that flexibility it has to have "slots" member in its 829 instance (i.e. it has to be castable to ScmInstance*). 830 831 Here's the basic inheritance rules: 832 833 - First, ABSTRACT class can be inserted at any place in the 834 inheritance chain. It doesn't affect C-level operation. It is 835 only to add the type information in Scheme-level. 836 In the following rules we ignore ABSTRACT classes. 837 838 - BASE class can be inherited from BASE classes, and its 839 inheritance chain must form a single inheritance. 840 841 - BUILTIN class can be inherited from BUILTIN classes, and 842 its inheritance chain must form a single inheritance 843 844 - SCHEME class can be inherited from SCHEME or BASE classes. 845 It can inherite from multiple SCHEME and/or BASE classes. 846 */ 847 848 enum { 849 SCM_CLASS_BUILTIN = 0, 850 SCM_CLASS_ABSTRACT = 1, 851 SCM_CLASS_BASE = 2, 852 SCM_CLASS_SCHEME = 3, 853 854 /* A special flag that only be used for "natively applicable" 855 objects, which basically inherits ScmProcedure. */ 856 SCM_CLASS_APPLICABLE = 0x04, 857 858 /* If this flag is set, important slots such as class-precedence-list 859 or class-slots becomes settable. 860 We reset this flag at the end of class initialization, so that 861 we can avoid the behavior of a class from being accidentally 862 changed. The flag may be set during updating a class metaobject 863 triggered by metaclass change (see lib/gauche/redefutil.scm). 864 */ 865 SCM_CLASS_MALLEABLE = 0x08, 866 867 /* This flag indicates the class is for the aggregate data type. 868 Currently the writer uses this info to determine when to stop 869 recursing (see print-level). We may use this later for generic 870 data structure walker. */ 871 SCM_CLASS_AGGREGATE = 0x10 872 }; 873 874 #define SCM_CLASS_FLAGS(obj) (SCM_CLASS(obj)->flags) 875 #define SCM_CLASS_APPLICABLE_P(obj) (SCM_CLASS_FLAGS(obj)&SCM_CLASS_APPLICABLE) 876 877 #define SCM_CLASS_CATEGORY(obj) (SCM_CLASS_FLAGS(obj)&3) 878 #define SCM_CLASS_MALLEABLE_P(obj) (SCM_CLASS_FLAGS(obj)&SCM_CLASS_MALLEABLE) 879 880 SCM_EXTERN void Scm_InitStaticClass(ScmClass *klass, const char *name, 881 ScmModule *mod, 882 ScmClassStaticSlotSpec *slots, 883 int flags); 884 SCM_EXTERN void Scm_InitStaticClassWithSupers(ScmClass *klass, 885 const char *name, 886 ScmModule *mod, 887 ScmObj supers, 888 ScmClassStaticSlotSpec *slots, 889 int flags); 890 SCM_EXTERN void Scm_InitStaticClassWithMeta(ScmClass *klass, 891 const char *name, 892 ScmModule *mod, 893 ScmClass *meta, 894 ScmObj supers, 895 ScmClassStaticSlotSpec *slots, 896 int flags); 897 SCM_EXTERN ScmObj Scm_ShortClassName(ScmClass *klass); /* strip '<' and '>' */ 898 899 /* Use this in 'compare' slot to allow Scheme method to define 900 compare/equal? behavior thru object-compare/object-equal? */ 901 SCM_EXTERN int Scm_ObjectCompare(ScmObj x, ScmObj y, int equalp); 902 903 /* OBSOLETE */ 904 SCM_EXTERN void Scm_InitBuiltinClass(ScmClass *c, const char *name, 905 ScmClassStaticSlotSpec *slots, 906 int withMeta, 907 ScmModule *m); 908 909 SCM_EXTERN ScmClass *Scm_ClassOf(ScmObj obj); 910 SCM_EXTERN int Scm_SubtypeP(ScmClass *sub, ScmClass *type); 911 SCM_EXTERN int Scm_TypeP(ScmObj obj, ScmClass *type); 912 SCM_EXTERN ScmClass *Scm_BaseClassOf(ScmClass *klass); 913 914 SCM_EXTERN void Scm_ClassMalleableSet(ScmClass *klass, int flag); 915 916 SCM_EXTERN ScmObj Scm_VMSlotRef(ScmObj obj, ScmObj slot, int boundp); 917 SCM_EXTERN ScmObj Scm_VMSlotSet(ScmObj obj, ScmObj slot, ScmObj value); 918 SCM_EXTERN ScmObj Scm_VMSlotBoundP(ScmObj obj, ScmObj slot); 919 920 921 /* built-in classes */ 922 SCM_CLASS_DECL(Scm_TopClass); 923 SCM_CLASS_DECL(Scm_BottomClass); 924 SCM_CLASS_DECL(Scm_BoolClass); 925 SCM_CLASS_DECL(Scm_CharClass); 926 SCM_CLASS_DECL(Scm_ClassClass); 927 SCM_CLASS_DECL(Scm_EOFObjectClass); 928 SCM_CLASS_DECL(Scm_UndefinedObjectClass); 929 SCM_CLASS_DECL(Scm_UnknownClass); 930 SCM_CLASS_DECL(Scm_ObjectClass); /* base of Scheme-defined objects */ 931 SCM_CLASS_DECL(Scm_ForeignPointerClass); 932 933 934 #define SCM_CLASS_TOP (&Scm_TopClass) 935 #define SCM_CLASS_BOTTOM (&Scm_BottomClass) 936 #define SCM_CLASS_BOOL (&Scm_BoolClass) 937 #define SCM_CLASS_CHAR (&Scm_CharClass) 938 #define SCM_CLASS_CLASS (&Scm_ClassClass) 939 #define SCM_CLASS_EOF_OBJECT (&Scm_EOFObjectClass) 940 #define SCM_CLASS_UNDEFINED_OBJECT (&Scm_UndefinedObjectClass) 941 #define SCM_CLASS_UNKNOWN (&Scm_UnknownClass) 942 #define SCM_CLASS_OBJECT (&Scm_ObjectClass) 943 #define SCM_CLASS_FOREIGN_POINTER (&Scm_ForeignPointerClass) 944 945 /* NB: we can't use SCM_EXTERN because Windows DLL can't use the address of 946 dllimport-ed variables as constants. */ 947 extern ScmClass *Scm_DefaultCPL[]; 948 extern ScmClass *Scm_ObjectCPL[]; 949 950 #define SCM_CLASS_DEFAULT_CPL (Scm_DefaultCPL) 951 #define SCM_CLASS_OBJECT_CPL (Scm_ObjectCPL) 952 953 /* Static definition of classes 954 * SCM_DEFINE_BUILTIN_CLASS 955 * SCM_DEFINE_BUILTIN_CLASS_FLAGS 956 * SCM_DEFINE_BUILTIN_CLASS_SIMPLE 957 * SCM_DEFINE_ABSTRACT_CLASS 958 * SCM_DEFINE_BASE_CLASS 959 */ 960 961 /* internal macro. do not use directly */ 962 #if defined(GAUCHE_BROKEN_LINKER_WORKAROUND) 963 #define SCM__CLASS_PTR_SLOT(cname) (&SCM_CPP_CAT(_imp__, cname)), 964 #define SCM__CLASS_PTR_BODY(cname) \ 965 ; ScmClass *SCM_CPP_CAT(_imp__, cname) = &cname 966 #else /*!GAUCHE_BROKEN_LINKER_WORKAROUND*/ 967 #define SCM__CLASS_PTR_SLOT(cname) /* none */ 968 #define SCM__CLASS_PTR_BODY(cname) /* none */ 969 #endif /*!GAUCHE_BROKEN_LINKER_WORKAROUND*/ 970 971 #define SCM__DEFINE_CLASS_COMMON(cname, coreSize, flag, printer, compare, serialize, allocate, cpa) \ 972 ScmClass cname = { \ 973 {{ SCM_CLASS_STATIC_TAG(Scm_ClassClass), NULL }}, \ 974 SCM__CLASS_PTR_SLOT(cname) \ 975 printer, \ 976 compare, \ 977 serialize, \ 978 allocate, \ 979 cpa, \ 980 0, /*numInstanceSlots*/ \ 981 coreSize, /*coreSize*/ \ 982 flag, /*flags*/ \ 983 SCM_FALSE,/*name*/ \ 984 SCM_NIL, /*directSupers*/ \ 985 SCM_NIL, /*cpl*/ \ 986 SCM_NIL, /*accessors*/ \ 987 SCM_NIL, /*directSlots*/ \ 988 SCM_NIL, /*slots*/ \ 989 SCM_NIL, /*directSubclasses*/ \ 990 SCM_NIL, /*directMethods*/ \ 991 SCM_NIL, /*initargs*/ \ 992 SCM_NIL, /*modules*/ \ 993 SCM_FALSE, /*redefined*/ \ 994 SCM_INTERNAL_MUTEX_INITIALIZER, \ 995 SCM_INTERNAL_COND_INITIALIZER, \ 996 NULL /* data */ \ 997 } SCM__CLASS_PTR_BODY(cname) 998 999 /* Define built-in class statically -- full-featured version */ 1000 #define SCM_DEFINE_BUILTIN_CLASS(cname, printer, compare, serialize, allocate, cpa) \ 1001 SCM__DEFINE_CLASS_COMMON(cname, 0, \ 1002 SCM_CLASS_BUILTIN, \ 1003 printer, compare, serialize, allocate, cpa) 1004 1005 #define SCM_DEFINE_BUILTIN_CLASS_FLAGS(cname, printer, compare, serialize, allocate, cpa, flags) \ 1006 SCM__DEFINE_CLASS_COMMON(cname, 0, \ 1007 SCM_CLASS_BUILTIN|(flags), \ 1008 printer, compare, serialize, allocate, cpa) 1009 1010 /* Define built-in class statically -- simpler version */ 1011 #define SCM_DEFINE_BUILTIN_CLASS_SIMPLE(cname, printer) \ 1012 SCM_DEFINE_BUILTIN_CLASS(cname, printer, NULL, NULL, NULL, NULL) 1013 1014 /* define an abstract class */ 1015 #define SCM_DEFINE_ABSTRACT_CLASS(cname, cpa) \ 1016 SCM__DEFINE_CLASS_COMMON(cname, 0, \ 1017 SCM_CLASS_ABSTRACT, \ 1018 NULL, NULL, NULL, NULL, cpa) 1019 1020 /* define a class that can be subclassed by Scheme */ 1021 #define SCM_DEFINE_BASE_CLASS(cname, ctype, printer, compare, serialize, allocate, cpa) \ 1022 SCM__DEFINE_CLASS_COMMON(cname, sizeof(ctype), \ 1023 SCM_CLASS_BASE, \ 1024 printer, compare, serialize, allocate, cpa) 1025 1026 /* 1027 * A simple class and instance API to wrap C pointer. 1028 * This is for C programs that want to define a visible class from Scheme 1029 * but don't want to go through full-fledged class mechanism. 1030 */ 1031 typedef struct ScmForeignPointerRec { 1032 SCM_HEADER; 1033 void *ptr; /* foreign object. this pointer shouldn't 1034 be modified once <foreign-pointer> is 1035 constructed by Scm_MakeForeignPointer. */ 1036 ScmObj attributes; /* alist. useful to store e.g. callbacks. 1037 use accessor procedures. */ 1038 ScmWord flags; /* used internally. We use ScmWord to keep 1039 ScmForeignPointer fit in 4 words. */ 1040 } ScmForeignPointer; 1041 1042 #define SCM_FOREIGN_POINTER_P(obj) SCM_ISA(obj, SCM_CLASS_FOREIGN_POINTER) 1043 #define SCM_FOREIGN_POINTER(obj) ((ScmForeignPointer*)(obj)) 1044 #define SCM_FOREIGN_POINTER_REF(type, obj) \ 1045 ((type)(Scm_ForeignPointerRef(SCM_FOREIGN_POINTER(obj)))) 1046 1047 typedef void (*ScmForeignCleanupProc)(ScmObj); 1048 1049 SCM_EXTERN ScmClass *Scm_MakeForeignPointerClass(ScmModule *module, 1050 const char *name, 1051 ScmClassPrintProc print, 1052 ScmForeignCleanupProc cleanup, 1053 int flags); 1054 SCM_EXTERN ScmObj Scm_MakeForeignPointer(ScmClass *klass, void *ptr); 1055 SCM_EXTERN ScmObj Scm_MakeForeignPointerWithAttr(ScmClass *klass, void *ptr, 1056 ScmObj attr); 1057 SCM_EXTERN void *Scm_ForeignPointerRef(ScmForeignPointer *fp); 1058 SCM_EXTERN int Scm_ForeignPointerInvalidP(ScmForeignPointer *fp); 1059 SCM_EXTERN void Scm_ForeignPointerInvalidate(ScmForeignPointer *fp); 1060 1061 /* foreign pointer class flags */ 1062 enum { 1063 SCM_FOREIGN_POINTER_KEEP_IDENTITY = (1L<<0), 1064 /* If set, a foreign pointer class keeps a weak hash table that maps 1065 PTR to the wrapping ScmObj, so Scm_MakeForeignPointer returns 1066 eq? object if the same PTR is given. This incurs some overhead, 1067 but cleanup procedure can safely free the foreign object without 1068 worring if there's other ScmObj that's pointing to PTR. 1069 Do not use this flag if PTR is also allocated by GC_malloc. The 1070 used hash table is only weak for its value, so PTR wouldn't be 1071 GCed. */ 1072 SCM_FOREIGN_POINTER_MAP_NULL = (1L<<1) 1073 /* If set, Scm_MakeForeignPointer returns SCM_FALSE whenever the 1074 given PTR is NULL. It is the only case that 1075 Scm_MakeForeignPointer returns non-ForeignPointer object. */ 1076 }; 1077 1078 /* foreign pointer attributes. you can attach info to each foreign pointer. 1079 possible applications: 1080 - Keep Scheme objects that are set in the foreign object, preventing 1081 them from begin GCed. 1082 - Keep mutex to use the foreign object from multiple threads */ 1083 1084 SCM_EXTERN ScmObj Scm_ForeignPointerAttr(ScmForeignPointer *fp); 1085 SCM_EXTERN ScmObj Scm_ForeignPointerAttrGet(ScmForeignPointer *fp, 1086 ScmObj key, ScmObj fallback); 1087 SCM_EXTERN ScmObj Scm_ForeignPointerAttrSet(ScmForeignPointer *fp, 1088 ScmObj key, ScmObj value); 1089 1090 /*-------------------------------------------------------- 1091 * COLLECTION INTERFACE 1092 */ 1093 1094 #include <gauche/collection.h> 1095 1096 /*-------------------------------------------------------- 1097 * CONNECTION INTERFACE 1098 */ 1099 1100 SCM_CLASS_DECL(Scm_ConnectionClass); 1101 #define SCM_CLASS_CONNECTION (&Scm_ConnectionClass) 1102 1103 /*-------------------------------------------------------- 1104 * PAIR AND LIST 1105 */ 1106 1107 /* An ordinary pair uses two words. It can be distinguished from 1108 * other heap allocated objects by checking the first word doesn't 1109 * have "111" in the lower bits. 1110 */ 1111 struct ScmPairRec { 1112 ScmObj car; /* should be accessed via macros */ 1113 ScmObj cdr; /* ditto */ 1114 }; 1115 1116 /* An extended pair behaves like an ordinary pair for read operations, 1117 * but can keep extra information in attributes. It also has 1118 * hidden field, and can behave differently on mutating operations. 1119 * Immutable pairs are implemented on that mechanism. 1120 * See priv/pairP.h for the real structure of an extended pair. 1121 */ 1122 struct ScmExtendedPairRec { 1123 ScmObj car; /* should be accessed via macros */ 1124 ScmObj cdr; /* ditto */ 1125 ScmObj attributes; /* should be accessed via API func. */ 1126 }; 1127 1128 #if GAUCHE_CHECK_PAIR_ALIGNMENT 1129 # define SCM_PAIRP(obj) (Scm_CheckingPairP(SCM_OBJ(obj))) 1130 SCM_EXTERN int Scm_CheckingPairP(ScmObj); 1131 #else 1132 # define SCM_PAIRP(obj) \ 1133 (SCM_HPTRP(obj)&&(SCM_HTAG(obj)!=7||Scm_PairP(SCM_OBJ(obj)))) 1134 #endif 1135 1136 #define SCM_PAIR(obj) ((ScmPair*)(obj)) 1137 #define SCM_CAR(obj) (SCM_PAIR(obj)->car) 1138 #define SCM_CDR(obj) (SCM_PAIR(obj)->cdr) 1139 #define SCM_CAAR(obj) (SCM_CAR(SCM_CAR(obj))) 1140 #define SCM_CADR(obj) (SCM_CAR(SCM_CDR(obj))) 1141 #define SCM_CDAR(obj) (SCM_CDR(SCM_CAR(obj))) 1142 #define SCM_CDDR(obj) (SCM_CDR(SCM_CDR(obj))) 1143 1144 #define SCM_SET_CAR(obj, value) Scm_SetCar(obj, value) 1145 #define SCM_SET_CDR(obj, value) Scm_SetCdr(obj, value) 1146 1147 /* Use these only if you know OBJ is a mutable pair */ 1148 #define SCM_SET_CAR_UNCHECKED(obj, value) (SCM_CAR(obj) = (value)) 1149 #define SCM_SET_CDR_UNCHECKED(obj, value) (SCM_CDR(obj) = (value)) 1150 1151 #if SIZEOF_INTPTR_T == 4 1152 #define SCM_ODD_WORD_POINTER_P(p) (SCM_WORD(p) & 0x4) 1153 #else /*SIZEOF_INTPTR_T == 8*/ 1154 #define SCM_ODD_WORD_POINTER_P(p) (SCM_WORD(p) & 0x8) 1155 #endif 1156 1157 #if SCM_PAIR_ALWAYS_ALIGNED_EVEN_WORDS 1158 #define SCM_EXTENDED_PAIR_P(obj) \ 1159 (SCM_ODD_WORD_POINTER_P(obj)&&SCM_PAIRP(obj)) 1160 #else /*!SCM_PAIR_ALWAYS_ALIGNED_EVEN_WORDS*/ 1161 #define SCM_EXTENDED_PAIR_P(obj) \ 1162 (SCM_ODD_WORD_POINTER_P(obj)&&SCM_PAIRP(obj)&&SCM_HOBJP(((ScmObj*)(obj))-1)) 1163 #endif /*!SCM_PAIR_ALWAYS_ALIGNED_EVEN_WORDS*/ 1164 #define SCM_EXTENDED_PAIR(obj) ((ScmExtendedPair*)(obj)) 1165 1166 1167 SCM_CLASS_DECL(Scm_ListClass); 1168 SCM_CLASS_DECL(Scm_PairClass); 1169 SCM_CLASS_DECL(Scm_NullClass); 1170 #define SCM_CLASS_LIST (&Scm_ListClass) 1171 #define SCM_CLASS_PAIR (&Scm_PairClass) 1172 #define SCM_CLASS_NULL (&Scm_NullClass) 1173 1174 #define SCM_LISTP(obj) (SCM_NULLP(obj) || SCM_PAIRP(obj)) 1175 1176 /* Useful macros to manipulate lists. */ 1177 1178 #define SCM_FOR_EACH(p, list) \ 1179 for((p) = (list); SCM_PAIRP(p); (p) = SCM_CDR(p)) 1180 1181 #define SCM_APPEND1(start, last, obj) \ 1182 do { \ 1183 if (SCM_NULLP(start)) { \ 1184 (start) = (last) = Scm_Cons((obj), SCM_NIL); \ 1185 } else { \ 1186 SCM_SET_CDR((last), Scm_Cons((obj), SCM_NIL)); \ 1187 (last) = SCM_CDR(last); \ 1188 } \ 1189 } while (0) 1190 1191 #define SCM_APPEND(start, last, obj) \ 1192 do { \ 1193 ScmObj list_SCM_GLS = (obj); \ 1194 if (SCM_NULLP(start)) { \ 1195 (start) = (list_SCM_GLS); \ 1196 if (!SCM_NULLP(list_SCM_GLS)) { \ 1197 (last) = Scm_LastPair(list_SCM_GLS); \ 1198 } \ 1199 } else { \ 1200 SCM_SET_CDR((last), (list_SCM_GLS)); \ 1201 (last) = Scm_LastPair(last); \ 1202 } \ 1203 } while (0) 1204 1205 #define SCM_LIST1(a) Scm_Cons(a, SCM_NIL) 1206 #define SCM_LIST2(a,b) Scm_Cons(a, SCM_LIST1(b)) 1207 #define SCM_LIST3(a,b,c) Scm_Cons(a, SCM_LIST2(b, c)) 1208 #define SCM_LIST4(a,b,c,d) Scm_Cons(a, SCM_LIST3(b, c, d)) 1209 #define SCM_LIST5(a,b,c,d,e) Scm_Cons(a, SCM_LIST4(b, c, d, e)) 1210 1211 /* special return value of Scm_Length */ 1212 enum { 1213 SCM_LIST_DOTTED = -1, /* dotted list */ 1214 SCM_LIST_CIRCULAR = -2 /* circular list */ 1215 }; 1216 1217 #define SCM_PROPER_LIST_P(obj) (Scm_Length(obj) >= 0) 1218 #define SCM_DOTTED_LIST_P(obj) (Scm_Length(obj) == SCM_LIST_DOTTED) 1219 #define SCM_CIRCULAR_LIST_P(obj) (Scm_Length(obj) == SCM_LIST_CIRCULAR) 1220 1221 SCM_EXTERN ScmObj Scm_Cons(ScmObj car, ScmObj cdr); 1222 SCM_EXTERN ScmObj Scm_Acons(ScmObj caar, ScmObj cdar, ScmObj cdr); 1223 SCM_EXTERN ScmObj Scm_MakeImmutablePair(ScmObj car, ScmObj cdr); 1224 SCM_EXTERN ScmObj Scm_List(ScmObj elt, ...); 1225 SCM_EXTERN ScmObj Scm_Conses(ScmObj elt, ...); 1226 SCM_EXTERN ScmObj Scm_VaList(va_list elts); 1227 SCM_EXTERN ScmObj Scm_VaCons(va_list elts); 1228 SCM_EXTERN ScmObj Scm_ArrayToList(ScmObj *elts, ScmSize nelts); 1229 SCM_EXTERN ScmObj Scm_ArrayToListWithTail(ScmObj *elts, ScmSize nelts, 1230 ScmObj tail); 1231 SCM_EXTERN ScmObj *Scm_ListToArray(ScmObj list, ScmSize *nelts, ScmObj *store, 1232 int alloc); 1233 1234 SCM_EXTERN ScmObj Scm_Car(ScmObj obj); 1235 SCM_EXTERN ScmObj Scm_Cdr(ScmObj obj); 1236 SCM_EXTERN ScmObj Scm_Caar(ScmObj obj); 1237 SCM_EXTERN ScmObj Scm_Cadr(ScmObj obj); 1238 SCM_EXTERN ScmObj Scm_Cdar(ScmObj obj); 1239 SCM_EXTERN ScmObj Scm_Cddr(ScmObj obj); 1240 1241 SCM_EXTERN int Scm_ImmutablePairP(ScmObj obj); 1242 SCM_EXTERN void Scm_SetCar(ScmObj pair, ScmObj value); 1243 SCM_EXTERN void Scm_SetCdr(ScmObj pair, ScmObj value); 1244 1245 SCM_EXTERN ScmSize Scm_Length(ScmObj obj); 1246 SCM_EXTERN ScmObj Scm_CopyList(ScmObj list); 1247 SCM_EXTERN ScmObj Scm_MakeList(ScmSmallInt len, ScmObj fill); 1248 SCM_EXTERN ScmObj Scm_Append2X(ScmObj list, ScmObj obj); 1249 SCM_EXTERN ScmObj Scm_Append2(ScmObj list, ScmObj obj); 1250 SCM_EXTERN ScmObj Scm_Append(ScmObj args); 1251 SCM_EXTERN ScmObj Scm_ReverseX(ScmObj list); 1252 SCM_EXTERN ScmObj Scm_Reverse(ScmObj list); 1253 SCM_EXTERN ScmObj Scm_Reverse2X(ScmObj list, ScmObj tail); 1254 SCM_EXTERN ScmObj Scm_Reverse2(ScmObj list, ScmObj tail); 1255 SCM_EXTERN ScmObj Scm_ListTail(ScmObj list, ScmSmallInt i, ScmObj fallback); 1256 SCM_EXTERN ScmObj Scm_ListRef(ScmObj list, ScmSmallInt i, ScmObj fallback); 1257 SCM_EXTERN ScmObj Scm_LastPair(ScmObj list); 1258 1259 SCM_EXTERN ScmObj Scm_Memq(ScmObj obj, ScmObj list); 1260 SCM_EXTERN ScmObj Scm_Memv(ScmObj obj, ScmObj list); 1261 SCM_EXTERN ScmObj Scm_Member(ScmObj obj, ScmObj list, int cmpmode); 1262 SCM_EXTERN ScmObj Scm_Assq(ScmObj obj, ScmObj alist); 1263 SCM_EXTERN ScmObj Scm_Assv(ScmObj obj, ScmObj alist); 1264 SCM_EXTERN ScmObj Scm_Assoc(ScmObj obj, ScmObj alist, int cmpmode); 1265 1266 SCM_EXTERN ScmObj Scm_Delete(ScmObj obj, ScmObj list, int cmpmode); 1267 SCM_EXTERN ScmObj Scm_DeleteX(ScmObj obj, ScmObj list, int cmpmode); 1268 SCM_EXTERN ScmObj Scm_AssocDelete(ScmObj elt, ScmObj alist, int cmpmode); 1269 SCM_EXTERN ScmObj Scm_AssocDeleteX(ScmObj elt, ScmObj alist, int cmpmode); 1270 1271 SCM_EXTERN ScmObj Scm_DeleteDuplicates(ScmObj list, int cmpmode); 1272 SCM_EXTERN ScmObj Scm_DeleteDuplicatesX(ScmObj list, int cmpmode); 1273 1274 SCM_EXTERN ScmObj Scm_MakeExtendedPair(ScmObj car, ScmObj cdr, ScmObj attrs); 1275 SCM_EXTERN ScmObj Scm_ExtendedCons(ScmObj car, ScmObj cdr); 1276 SCM_EXTERN ScmObj Scm_PairAttr(ScmPair *pair); 1277 SCM_EXTERN ScmObj Scm_PairAttrGet(ScmPair *pair, ScmObj key, ScmObj fallback); 1278 SCM_EXTERN ScmObj Scm_PairAttrSet(ScmPair *pair, ScmObj key, ScmObj value); 1279 1280 #if GAUCHE_API_VERSION >= 1000 1281 SCM_EXTERN ScmObj Scm_MonotonicMerge(ScmObj sequences); 1282 #define Scm_MonotonicMerge1(x) Scm_MonotonicMerge(x) 1283 #else /* GAUCHE_API_VERSION < 1000 */ 1284 SCM_EXTERN ScmObj Scm_MonotonicMerge(ScmObj start, ScmObj sequences); 1285 SCM_EXTERN ScmObj Scm_MonotonicMerge1(ScmObj sequences); 1286 #endif /* GAUCHE_API_VERSION < 1000 */ 1287 1288 /*-------------------------------------------------------- 1289 * CHARACTERS 1290 */ 1291 1292 /* OBSOLETED */ 1293 /* This kind of thing is now handled by string-incomplete->complete 1294 in libstr.scm. */ 1295 typedef enum { 1296 SCM_ILLEGAL_CHAR_REJECT, /* Refuse to handle illegal chars. For ports 1297 this means raising an error. For string 1298 conversion procedure, this makes it to 1299 return #f. */ 1300 SCM_ILLEGAL_CHAR_OMIT, /* Silently discard the illegal chars. */ 1301 SCM_ILLEGAL_CHAR_REPLACE /* Replace an illegal char to a substitute 1302 char, specified elsewhere. */ 1303 } ScmIllegalCharHandling; 1304 1305 1306 /*-------------------------------------------------------- 1307 * STRING 1308 */ 1309 1310 #include <gauche/string.h> 1311 1312 /*-------------------------------------------------------- 1313 * VECTOR 1314 */ 1315 1316 #include <gauche/vector.h> 1317 1318 /*-------------------------------------------------------- 1319 * PORT 1320 */ 1321 1322 #include <gauche/port.h> 1323 1324 1325 /*-------------------------------------------------------- 1326 * WRITE 1327 */ 1328 1329 #include <gauche/writer.h> 1330 1331 /*--------------------------------------------------------- 1332 * READ 1333 */ 1334 1335 #include <gauche/reader.h> 1336 1337 /*-------------------------------------------------------- 1338 * HASHTABLE 1339 */ 1340 1341 #include <gauche/hash.h> 1342 1343 /*-------------------------------------------------------- 1344 * TREEMAP 1345 */ 1346 1347 #include <gauche/treemap.h> 1348 1349 /*-------------------------------------------------------- 1350 * WEAK VECTOR, WEAK BOX & WEAK HASH TABLES 1351 */ 1352 1353 #include <gauche/weak.h> 1354 1355 /*-------------------------------------------------------- 1356 * CHAR-SET 1357 */ 1358 1359 #include <gauche/charset.h> 1360 1361 /*-------------------------------------------------------- 1362 * MODULE 1363 */ 1364 1365 #include <gauche/module.h> 1366 1367 /*-------------------------------------------------------- 1368 * SYMBOL 1369 */ 1370 1371 #include <gauche/symbol.h> 1372 1373 /*-------------------------------------------------------- 1374 * GLOC 1375 */ 1376 1377 #include <gauche/gloc.h> 1378 1379 /*-------------------------------------------------------- 1380 * NUMBER 1381 */ 1382 1383 #include <gauche/number.h> 1384 1385 /*-------------------------------------------------------- 1386 * PROCEDURE (APPLICABLE OBJECT) 1387 */ 1388 1389 1390 typedef ScmObj (*ScmTransformerProc)(ScmObj self, ScmObj form, ScmObj env, 1391 void *data); 1392 1393 /* Base structure */ 1394 struct ScmProcedureRec { 1395 SCM_INSTANCE_HEADER; 1396 unsigned int required : 16; /* # of required args */ 1397 unsigned int optional : 8; /* >=1 if it takes opt args. see below.*/ 1398 unsigned int type : 3; /* ScmProcedureType */ 1399 unsigned int locked : 1; /* setter locked? (see below) */ 1400 unsigned int currying : 1; /* autocurrying */ 1401 unsigned int constant : 1; /* constant procedure. see below. */ 1402 unsigned int leaf : 1; /* leaf procedure/method */ 1403 unsigned int reserved : 1; /* unused yet. */ 1404 ScmObj info; /* source code info (see below) */ 1405 ScmObj setter; /* setter, if exists. */ 1406 ScmObj inliner; /* inliner information (see below) */ 1407 }; 1408 1409 /* About locked slot: 1410 For <procedure> and <generic>, it shows whether the setter is locked. 1411 For <method>, it shows whether the alteration of the method is disallowed, 1412 i.e. one can't redefine a method with matching signature. 1413 (These two roles are reflected to the two macors, 1414 SCM_PROCEDURE_SETTER_LOCKED and SCM_PROCEDURE_METHOD_LOCKED) 1415 TODO: When we change ABI, maybe split these roles to different flags. 1416 */ 1417 1418 /* About optional slot: 1419 If this slot is non-zero, the procedure takes optional arguments. 1420 For Standard Scheme procedures with 'rest' arguments, this slot is 1 1421 and all excessive arguments are 'folded' in a list. 1422 1423 This slot may have a value more than 1. If it is N (>1), then up to N-1 1424 optional arguments are passed without being folded (that is, passed 1425 'on the stack'. Only when the given argument is more than or equal to 1426 N + reqargs, the excessive arguments are folded and passed in a list. 1427 Thus, such procedure may get between reqargs values and N+reqargs values 1428 after folding (NB: Fixed argument procedure always get regargs values, 1429 and standard Scheme variable argument procedure always get reqargs+1 values 1430 after argument folding). 1431 1432 This special treatment is to avoid unnecessary consing of argumets; 1433 if we know the callee immediately unfolds the rest argument, it's no 1434 use to fold excessive arguments anyway. 1435 */ 1436 1437 /* About 'constant' flag: 1438 1439 For a <procedure> and <method>, this flag being TRUE means it returns 1440 the same constant value if given same constant arguments, and it does 1441 not have any other external effects. The compiler may use this info 1442 to replace a call of this proc with the resulting value, 1443 if all the arguments are known at compile-time. 1444 The resulting value must be serializable to the 1445 precompiled file. The result shouldn't be affected 1446 by the timing of the compile, architecture on which the compiler runs, 1447 or the compiler configuration (e.g. internal encoding). 1448 1449 If <generic> has this flag, it tells the compiler that it can calculate 1450 applicable method at the compile time. It is independent from method's 1451 constantness---the selected method may or may not be used as a compile-time 1452 calculation; but it is safe to pre-select that method, given that 1453 enough information is available at the compile time. 1454 We warn if a new method is added to a 'constant' generic. 1455 */ 1456 1457 /* About 'leaf' flag: 1458 For METHOD, this flag indicates the method doesn't refer to next-method 1459 argument at all, so we can skip creating next-method instance when 1460 making a call. 1461 For CLOSURE, we *plan* to use this to indicate the closure body doesn't 1462 make a call to another procedures, to allow certain optimizations. 1463 */ 1464 1465 /* About 'info' slot: 1466 This is a sort of the kitchen sink slot, keeping whatever miscellaneous 1467 information as our implementation evolves. Since this can be a part of 1468 statically allocated structure, we can't change its format in a way 1469 that breaks the backward compatibility. 1470 1471 SUBR, CLOSURE: 1472 This slot may contain one of this: 1473 - Signature: For example, the subr `cons' has (cons obj1 obj2) 1474 in it. The first pair may have the following pair attributes. 1475 1476 `source-info' (<filename> <lineno>) 1477 The source location the procedure is defined, if known. 1478 This info can be retrieved with (source-location PROC). 1479 `bind-info' (<module-name> <var-name>) 1480 The proc is bound to <var-name> in a module named 1481 <module-name>, and it's inlinable binding. When the 1482 compiler can pre-calculate the proc to be called in a 1483 code, it can replace the original code with a global 1484 variable reference to <var-name>. (We can't directly 1485 insert reference to the proc, for it may not be 1486 serializable for AOT compilation). 1487 1488 - A <primitive-parameter> or <parameter> object. R7RS requires 1489 parameters to be a procedure, responding #t to procedure?. 1490 We need to adapt Gauche parameter into that, saving the 1491 actual parameter instance here. 1492 1493 - Subr's name, as a string or a symbol. This is the old format. 1494 It may also the case that subr is created from C function 1495 Scm_MakeSubr(), for it's cumbersome in C routine to construct 1496 the signature list. Accept it, but not recommended to use 1497 this format in the new code. 1498 - #f. Indicates there's no useful info. 1499 1500 GENERIC: 1501 This slot contains the "name" of the gf, which is a symbol. 1502 A kludge: For setter gf, which can be created indirectly 1503 via (define-method (setter GF) ...), we use a weird name 1504 |setter of GF|. This is a quick hack to make it work, but ideally 1505 we should accept a list (setter GF) as the name. Anticipate 1506 this change in future. 1507 Furthermore, in order to hold source-info, we might just make 1508 it a pair, e.g. (NAME) or ((setter NAME)). 1509 1510 METHOD: 1511 This slot contains (<name> <specializer> ...), 1512 where <name> is the name of the generic function, and 1513 <specializer>s are the name of classes. 1514 1515 NEXT_METHOD: 1516 This slot isn't used. 1517 */ 1518 1519 /* About procedure inliner: 1520 This slot holds information to inline procedures. The value of this slot 1521 can be one of the following kinds: 1522 1523 #f: No inliner associated to this procedure. (For historical 1524 reasons, the code that access to this slot expects this slot can be 1525 NULL and treats it as SCM_FALSE in that case) 1526 1527 <integer>: Only appears in some built-in procedures, and specifies 1528 the VM instruction number. This should be considered as a special 1529 hack. The set of procedures that can have this type of inliner 1530 is tied to the VM definition. 1531 1532 <vector>: Procedures defined with define-inline have this. The vector 1533 encodes intermediate form (IForm) of the procedure code, which will be 1534 expanded into the caller. 1535 1536 <macro>: A compiler macro. The macro expander is invoked with the 1537 original source and macro-use environment, just like the ordinary macro 1538 call. The expander must return an Sexpr. If the expander returns 1539 the input as is, it indicates expansion is not possible and the form 1540 is compiled as the ordinary procedure call. 1541 1542 <procedure>: A procedural inliner. It has signature Sexpr,[IForm] -> IForm, 1543 where Sexpr is the original source of call size (just for debug info) and 1544 input [IForm] is the IForm for list of arguments. See compiler-1.scm. 1545 It returns the modified IForm. It can return #<undef>, to indicate 1546 inlining isn't possible. 1547 */ 1548 1549 /* procedure type */ 1550 enum ScmProcedureType { 1551 SCM_PROC_SUBR, 1552 SCM_PROC_CLOSURE, 1553 SCM_PROC_GENERIC, 1554 SCM_PROC_METHOD, 1555 SCM_PROC_NEXT_METHOD 1556 }; 1557 1558 #define SCM_PROCEDURE(obj) ((ScmProcedure*)(obj)) 1559 #define SCM_PROCEDURE_REQUIRED(obj) SCM_PROCEDURE(obj)->required 1560 #define SCM_PROCEDURE_OPTIONAL(obj) SCM_PROCEDURE(obj)->optional 1561 #define SCM_PROCEDURE_TYPE(obj) SCM_PROCEDURE(obj)->type 1562 #define SCM_PROCEDURE_CONSTANT(obj) SCM_PROCEDURE(obj)->constant 1563 #define SCM_PROCEDURE_CURRYING(obj) SCM_PROCEDURE(obj)->currying 1564 #define SCM_PROCEDURE_INFO(obj) SCM_PROCEDURE(obj)->info 1565 #define SCM_PROCEDURE_SETTER(obj) SCM_PROCEDURE(obj)->setter 1566 #define SCM_PROCEDURE_INLINER(obj) SCM_PROCEDURE(obj)->inliner 1567 #define SCM_PROCEDURE_SETTER_LOCKED(obj) SCM_PROCEDURE(obj)->locked 1568 #define SCM_PROCEDURE_LEAF(obj) SCM_PROCEDURE(obj)->leaf 1569 1570 SCM_CLASS_DECL(Scm_ProcedureClass); 1571 #define SCM_CLASS_PROCEDURE (&Scm_ProcedureClass) 1572 #define SCM_PROCEDUREP(obj) \ 1573 (SCM_HOBJP(obj) && SCM_CLASS_APPLICABLE_P(SCM_CLASS_OF(obj))) 1574 #define SCM_PROCEDURE_TAKE_NARG_P(obj, narg) \ 1575 (SCM_PROCEDUREP(obj)&& \ 1576 ( (!SCM_PROCEDURE_OPTIONAL(obj)&&SCM_PROCEDURE_REQUIRED(obj)==(narg)) \ 1577 ||(SCM_PROCEDURE_OPTIONAL(obj)&&SCM_PROCEDURE_REQUIRED(obj)<=(narg)))) 1578 #define SCM_PROCEDURE_THUNK_P(obj) \ 1579 (SCM_PROCEDUREP(obj)&& \ 1580 ( (!SCM_PROCEDURE_OPTIONAL(obj)&&SCM_PROCEDURE_REQUIRED(obj)==0) \ 1581 ||(SCM_PROCEDURE_OPTIONAL(obj)))) 1582 #define SCM_PROCEDURE_INIT(obj, req, opt, typ, inf) \ 1583 SCM_PROCEDURE(obj)->required = req, \ 1584 SCM_PROCEDURE(obj)->optional = opt, \ 1585 SCM_PROCEDURE(obj)->type = typ, \ 1586 SCM_PROCEDURE(obj)->locked = FALSE, \ 1587 SCM_PROCEDURE(obj)->currying = FALSE, \ 1588 SCM_PROCEDURE(obj)->constant = FALSE, \ 1589 SCM_PROCEDURE(obj)->leaf = FALSE, \ 1590 SCM_PROCEDURE(obj)->reserved = 0, \ 1591 SCM_PROCEDURE(obj)->info = inf, \ 1592 SCM_PROCEDURE(obj)->setter = SCM_FALSE, \ 1593 SCM_PROCEDURE(obj)->inliner = SCM_FALSE 1594 1595 /* This is internal - should never be used directly */ 1596 #define SCM__PROCEDURE_INITIALIZER(klass, req, opt, typ, cst, lef, inf, inl) \ 1597 { { klass, NULL }, (req), (opt), (typ), FALSE, FALSE, cst, lef, 0, \ 1598 (inf), SCM_FALSE, (inl) } 1599 1600 SCM_EXTERN ScmObj Scm_CopyProcedure(ScmProcedure *proc); 1601 SCM_EXTERN ScmObj Scm_CurryProcedure(ScmObj proc, ScmObj *given, 1602 int ngiven, int foldlen); 1603 1604 /* Closure - Scheme defined procedure */ 1605 struct ScmClosureRec { 1606 ScmProcedure common; 1607 ScmObj code; /* compiled code */ 1608 ScmEnvFrame *env; /* environment */ 1609 }; 1610 1611 #define SCM_CLOSUREP(obj) \ 1612 (SCM_PROCEDUREP(obj)&&(SCM_PROCEDURE_TYPE(obj)==SCM_PROC_CLOSURE)) 1613 #define SCM_CLOSURE(obj) ((ScmClosure*)(obj)) 1614 #define SCM_CLOSURE_CODE(obj) SCM_CLOSURE(obj)->code 1615 #define SCM_CLOSURE_ENV(obj) SCM_CLOSURE(obj)->env 1616 1617 SCM_EXTERN ScmObj Scm_MakeClosure(ScmObj code, ScmEnvFrame *env); 1618 1619 /* Subr - C defined procedure */ 1620 struct ScmSubrRec { 1621 ScmProcedure common; 1622 int flags; 1623 ScmSubrProc *func; 1624 void *data; 1625 }; 1626 1627 #define SCM_SUBRP(obj) \ 1628 (SCM_PROCEDUREP(obj)&&(SCM_PROCEDURE_TYPE(obj)==SCM_PROC_SUBR)) 1629 #define SCM_SUBR(obj) ((ScmSubr*)(obj)) 1630 #define SCM_SUBR_FLAGS(obj) SCM_SUBR(obj)->flags 1631 #define SCM_SUBR_FUNC(obj) SCM_SUBR(obj)->func 1632 #define SCM_SUBR_DATA(obj) SCM_SUBR(obj)->data 1633 1634 /* flags */ 1635 #define SCM_SUBR_IMMEDIATE_ARG (1L<<0) /* This subr will not retain a reference 1636 to the flonums given to args. VM 1637 can safely pass the register flonums 1638 to the subr. This is added when 1639 the :fast-flonum flag is given to 1640 define-cproc. */ 1641 1642 #define SCM__DEFINE_SUBR_INT(cvar, req, opt, cst, inf, flags, func, inliner, data) \ 1643 ScmSubr cvar = { \ 1644 SCM__PROCEDURE_INITIALIZER(SCM_CLASS_STATIC_TAG(Scm_ProcedureClass),\ 1645 req, opt, SCM_PROC_SUBR, cst, 0, inf, inliner), \ 1646 flags, (func), (data) \ 1647 } 1648 1649 #define SCM_DEFINE_SUBR(cvar, req, opt, inf, func, inliner, data) \ 1650 SCM__DEFINE_SUBR_INT(cvar, req, opt, 0, inf, 0, func, inliner, data) 1651 #define SCM_DEFINE_SUBRX(cvar, req, opt, cst, inf, flags, func, inliner, data) \ 1652 SCM__DEFINE_SUBR_INT(cvar, req, opt, cst, inf, flags, func, inliner, data) 1653 1654 SCM_EXTERN ScmObj Scm_MakeSubr(ScmSubrProc *func, 1655 void *data, 1656 int required, int optional, 1657 ScmObj info); 1658 SCM_EXTERN ScmObj Scm_NullProc(void); 1659 1660 SCM_EXTERN ScmObj Scm_SetterSet(ScmProcedure *proc, ScmProcedure *setter, 1661 int lock); 1662 SCM_EXTERN ScmObj Scm_Setter(ScmObj proc); 1663 SCM_EXTERN int Scm_HasSetter(ScmObj proc); 1664 1665 /* Generic - Generic function */ 1666 struct ScmGenericRec { 1667 ScmProcedure common; 1668 ScmObj methods; /* list of methods */ 1669 int maxReqargs; /* maximum # of args required to select 1670 applicable methods */ 1671 ScmObj (*fallback)(ScmObj *argv, int argc, ScmGeneric *gf); 1672 void *dispatcher; 1673 void *data; 1674 ScmInternalMutex lock; 1675 }; 1676 1677 SCM_CLASS_DECL(Scm_GenericClass); 1678 #define SCM_CLASS_GENERIC (&Scm_GenericClass) 1679 #define SCM_GENERICP(obj) SCM_XTYPEP(obj, SCM_CLASS_GENERIC) 1680 #define SCM_GENERIC(obj) ((ScmGeneric*)obj) 1681 #define SCM_GENERIC_DATA(obj) (SCM_GENERIC(obj)->data) 1682 1683 /* we share 'constant' flag for sealed generic */ 1684 #define SCM_GENERIC_SEALED_P(obj) SCM_PROCEDURE_CONSTANT(obj) 1685 1686 #define SCM_DEFINE_GENERIC(cvar, cfunc, data) \ 1687 ScmGeneric cvar = { \ 1688 SCM__PROCEDURE_INITIALIZER(SCM_CLASS_STATIC_TAG(Scm_GenericClass),\ 1689 0, 0, SCM_PROC_GENERIC, 0, 0, \ 1690 SCM_FALSE, NULL), \ 1691 SCM_NIL, 0, cfunc, NULL, data, \ 1692 SCM_INTERNAL_MUTEX_INITIALIZER \ 1693 } 1694 1695 SCM_EXTERN void Scm_InitBuiltinGeneric(ScmGeneric *gf, const char *name, 1696 ScmModule *mod); 1697 SCM_EXTERN ScmObj Scm_MakeBaseGeneric(ScmObj name, 1698 ScmObj (*fallback)(ScmObj *, int, ScmGeneric*), 1699 void *data); 1700 SCM_EXTERN ScmObj Scm_NoNextMethod(ScmObj *argv, int argc, ScmGeneric *gf); 1701 SCM_EXTERN ScmObj Scm_NoOperation(ScmObj *argv, int argc, ScmGeneric *gf); 1702 SCM_EXTERN ScmObj Scm_InvalidApply(ScmObj *argv, int argc, ScmGeneric *gf); 1703 1704 /* Method - method 1705 A method can be defined either by C or by Scheme. C-defined method 1706 have func ptr, with optional data. Scheme-define method has NULL 1707 in func, code in data, and optional environment in env. */ 1708 struct ScmMethodRec { 1709 ScmProcedure common; 1710 ScmGeneric *generic; 1711 ScmClass **specializers; /* array of specializers, size==required */ 1712 ScmObj (*func)(ScmNextMethod *nm, ScmObj *argv, int argc, void * data); 1713 void *data; /* closure, or code */ 1714 ScmEnvFrame *env; /* environment (for Scheme created method) */ 1715 }; 1716 1717 SCM_CLASS_DECL(Scm_MethodClass); 1718 #define SCM_CLASS_METHOD (&Scm_MethodClass) 1719 #define SCM_METHODP(obj) SCM_ISA(obj, SCM_CLASS_METHOD) 1720 #define SCM_METHOD(obj) ((ScmMethod*)obj) 1721 #define SCM_METHOD_LOCKED(obj) SCM_METHOD(obj)->common.locked 1722 #define SCM_METHOD_LEAF_P(obj) SCM_METHOD(obj)->common.leaf 1723 1724 #define SCM_DEFINE_METHOD(cvar, gf, req, opt, specs, func, data) \ 1725 ScmMethod cvar = { \ 1726 SCM__PROCEDURE_INITIALIZER(SCM_CLASS_STATIC_TAG(Scm_MethodClass),\ 1727 req, opt, SCM_PROC_METHOD, 0, 0, \ 1728 SCM_FALSE, NULL), \ 1729 gf, specs, func, data, NULL \ 1730 } 1731 1732 SCM_EXTERN void Scm_InitBuiltinMethod(ScmMethod *m); 1733 1734 /* Next method object 1735 Next method is just another callable entity, with memoizing 1736 the arguments. */ 1737 struct ScmNextMethodRec { 1738 ScmProcedure common; 1739 ScmGeneric *generic; 1740 ScmObj methods; /* list of applicable methods */ 1741 ScmObj *argv; /* original arguments */ 1742 int argc; /* # of original arguments */ 1743 int applyargs; /* if TRUE, argv[argc-1] has a list of rest args */ 1744 }; 1745 1746 SCM_CLASS_DECL(Scm_NextMethodClass); 1747 #define SCM_CLASS_NEXT_METHOD (&Scm_NextMethodClass) 1748 #define SCM_NEXT_METHODP(obj) SCM_XTYPEP(obj, SCM_CLASS_NEXT_METHOD) 1749 #define SCM_NEXT_METHOD(obj) ((ScmNextMethod*)obj) 1750 1751 /* Calling a Scheme function from C 1752 * 1753 * static ScmObj proc = SCM_UNDEFINED; 1754 * 1755 * SCM_BIND_PROC(proc, "scheme-proc-name", module); 1756 * 1757 * Scm_ApplyRec(proc, args); 1758 * or 1759 * Scm_Apply(proc, args, &result); 1760 * 1761 * SCM_BIND_PROC macro initializes the C variable proc to the value of 1762 * the global Scheme variable scheme-proc-name in the module. 1763 * It is idempotent operation, so it's MT-safe. 1764 */ 1765 #define SCM_BIND_PROC(var, name, module) \ 1766 do { \ 1767 if (SCM_UNDEFINEDP(var)) { \ 1768 ScmObj v__ = \ 1769 Scm_GlobalVariableRef(module, \ 1770 SCM_SYMBOL(SCM_INTERN(name)), \ 1771 0); \ 1772 if (SCM_UNBOUNDP(v__)) { \ 1773 Scm_Error("Procedure %s is unbound", name); \ 1774 } \ 1775 var = v__; \ 1776 } \ 1777 } while (0) 1778 1779 1780 /* OBSOLETED - These are defined in Scheme now. */ 1781 SCM_EXTERN ScmObj Scm_ForEach1(ScmObj proc, ScmObj args); 1782 SCM_EXTERN ScmObj Scm_ForEach(ScmObj proc, ScmObj arg1, ScmObj args); 1783 SCM_EXTERN ScmObj Scm_Map1(ScmObj proc, ScmObj args); 1784 SCM_EXTERN ScmObj Scm_Map(ScmObj proc, ScmObj arg1, ScmObj args); 1785 1786 /*-------------------------------------------------------- 1787 * MACROS AND SYNTAX 1788 */ 1789 1790 /* The actual definitions of ScmSyntax and ScmMacro are private.*/ 1791 1792 #define SCM_SYNTAX(obj) ((ScmSyntax*)(obj)) 1793 #define SCM_SYNTAXP(obj) SCM_XTYPEP(obj, SCM_CLASS_SYNTAX) 1794 SCM_CLASS_DECL(Scm_SyntaxClass); 1795 #define SCM_CLASS_SYNTAX (&Scm_SyntaxClass) 1796 1797 #define SCM_MACRO(obj) ((ScmMacro*)(obj)) 1798 #define SCM_MACROP(obj) SCM_XTYPEP(obj, SCM_CLASS_MACRO) 1799 SCM_CLASS_DECL(Scm_MacroClass); 1800 #define SCM_CLASS_MACRO (&Scm_MacroClass) 1801 1802 SCM_EXTERN ScmObj Scm_MakeMacro(ScmObj name, ScmObj transformer, 1803 ScmObj src, ScmObj describer); 1804 SCM_EXTERN ScmObj Scm_MacroTransformer(ScmMacro *mac); 1805 SCM_EXTERN ScmObj Scm_MacroName(ScmMacro *mac); 1806 1807 SCM_EXTERN ScmObj Scm_MakeMacroTransformer(ScmSymbol *name, 1808 ScmObj proc); 1809 SCM_EXTERN ScmObj Scm_MakeMacroAutoload(ScmSymbol *name, 1810 ScmAutoload *al); 1811 1812 #if GAUCHE_API_VERSION >= 1000 1813 SCM_EXTERN ScmObj Scm_UnwrapSyntax(ScmObj form, int immutablep); 1814 #define Scm_UnwrapSyntax2(form, imm) Scm_UnwrapSyntax(form, imm) 1815 #else /* GAUCHE_API_VERSION < 1000 */ 1816 SCM_EXTERN ScmObj Scm_UnwrapSyntax(ScmObj form); 1817 SCM_EXTERN ScmObj Scm_UnwrapSyntax2(ScmObj form, int immutablep); 1818 #endif /* GAUCHE_API_VERSION < 1000 */ 1819 1820 /*-------------------------------------------------------- 1821 * PROMISE 1822 */ 1823 1824 struct ScmPromiseRec { 1825 SCM_HEADER; 1826 ScmObj kind; /* promise kind */ 1827 struct ScmPromiseContentRec *content; /* opaque */ 1828 }; 1829 1830 SCM_CLASS_DECL(Scm_PromiseClass); 1831 #define SCM_CLASS_PROMISE (&Scm_PromiseClass) 1832 #define SCM_PROMISE(obj) ((ScmPromise*)(obj)) 1833 #define SCM_PROMISEP(obj) SCM_XTYPEP(obj, SCM_CLASS_PROMISE) 1834 1835 SCM_EXTERN ScmObj Scm_MakePromise(int forced, ScmObj code); 1836 SCM_EXTERN ScmObj Scm_VMForce(ScmObj p); /* CPS, lightweight */ 1837 SCM_EXTERN ScmObj Scm_Force(ScmObj p); 1838 1839 /* Lazy pair structure is opaque to public. Whenever you apply to an 1840 ScmObj SCM_PAIRP, a lazy pair morphs itself to a pair, so the normal 1841 code never see lazy pairs. */ 1842 1843 SCM_CLASS_DECL(Scm_LazyPairClass); 1844 #define SCM_CLASS_LAZY_PAIR (&Scm_LazyPairClass) 1845 #define SCM_LAZY_PAIR(obj) ((ScmLazyPair*)(obj)) 1846 #define SCM_LAZY_PAIR_P(obj) SCM_XTYPEP(obj, SCM_CLASS_LAZY_PAIR) 1847 1848 SCM_EXTERN ScmObj Scm_MakeLazyPair(ScmObj item, ScmObj generator); 1849 SCM_EXTERN int Scm_DecomposeLazyPair(ScmObj obj, ScmObj *item, ScmObj *generator); 1850 SCM_EXTERN ScmObj Scm_ForceLazyPair(volatile ScmLazyPair *lp); 1851 SCM_EXTERN int Scm_PairP(ScmObj x); 1852 1853 /*-------------------------------------------------------- 1854 * condition 1855 */ 1856 1857 /* Condition classes are defined in a separate file */ 1858 #include <gauche/exception.h> 1859 1860 /* 'reason' flag for Scm_PortError */ 1861 enum { 1862 SCM_PORT_ERROR_INPUT, 1863 SCM_PORT_ERROR_OUTPUT, 1864 SCM_PORT_ERROR_CLOSED, 1865 SCM_PORT_ERROR_UNIT, 1866 SCM_PORT_ERROR_DECODING, 1867 SCM_PORT_ERROR_ENCODING, 1868 SCM_PORT_ERROR_SEEK, 1869 SCM_PORT_ERROR_INVALID_POSITION, 1870 SCM_PORT_ERROR_OTHER 1871 }; 1872 1873 /* Throwing error */ 1874 SCM_EXTERN void Scm_Error(const char *msg, ...) SCM_NORETURN; 1875 SCM_EXTERN void Scm_SysError(const char *msg, ...) SCM_NORETURN; 1876 SCM_EXTERN void Scm_TypeError(const char *what, 1877 const char *expected, ScmObj got) SCM_NORETURN; 1878 SCM_EXTERN void Scm_PortError(ScmPort *port, int reason, 1879 const char *msg, ...) SCM_NORETURN; 1880 SCM_EXTERN void Scm_PortErrorWithAux(ScmPort *port, int reason, 1881 ScmObj auxinfo, 1882 const char *msg, ...) SCM_NORETURN; 1883 1884 /* common pattern */ 1885 #define SCM_TYPE_ERROR(arg, expected) Scm_TypeError(#arg, expected, arg) 1886 1887 SCM_EXTERN void Scm_Warn(const char *msg, ...); 1888 SCM_EXTERN void Scm_FWarn(ScmString *fmt, ScmObj args); 1889 1890 SCM_EXTERN ScmObj Scm_Raise(ScmObj exception, u_long flags); 1891 1892 /* flags for Scm_Raise */ 1893 enum { 1894 SCM_RAISE_NON_CONTINUABLE = (1L<<0) 1895 }; 1896 1897 SCM_EXTERN ScmObj Scm_RaiseCondition(ScmObj conditionType, ...); 1898 1899 /* A marker to insert between key-value pair and formatting string 1900 in Scm_RaiseCondition. */ 1901 #define SCM_RAISE_CONDITION_MESSAGE ((const char *)1) 1902 1903 SCM_EXTERN int Scm_ConditionHasType(ScmObj c, ScmObj k); 1904 SCM_EXTERN ScmObj Scm_ConditionMessage(ScmObj c); 1905 SCM_EXTERN ScmObj Scm_ConditionTypeName(ScmObj c); 1906 1907 enum { 1908 /* predefined stack trace formats. EXPERIMENTAL. */ 1909 SCM_STACK_TRACE_FORMAT_ORIGINAL, /* original format */ 1910 SCM_STACK_TRACE_FORMAT_CC /* compiler-message-like format */ 1911 }; 1912 1913 SCM_EXTERN void Scm_ShowStackTrace(ScmPort *out, ScmObj stacklite, 1914 int maxdepth, int skip, int offset, 1915 int format); 1916 1917 SCM_EXTERN void Scm_SetCallTraceSize(u_long size); 1918 1919 SCM_EXTERN ScmObj Scm_ReportError(ScmObj e, ScmObj out); 1920 1921 /*-------------------------------------------------------- 1922 * REGEXP 1923 */ 1924 1925 /* The definition of Scm_RegexpRec and Scm_RegeMatchRec is hidden 1926 in gauche/regexp.h */ 1927 1928 SCM_CLASS_DECL(Scm_RegexpClass); 1929 #define SCM_CLASS_REGEXP (&Scm_RegexpClass) 1930 #define SCM_REGEXP(obj) ((ScmRegexp*)obj) 1931 #define SCM_REGEXPP(obj) SCM_XTYPEP(obj, SCM_CLASS_REGEXP) 1932 1933 /* flags */ 1934 #define SCM_REGEXP_CASE_FOLD (1L<<0) 1935 #define SCM_REGEXP_PARSE_ONLY (1L<<1) 1936 /* bits 2 and 3 are used internally */ 1937 #define SCM_REGEXP_MULTI_LINE (1L<<4) 1938 1939 SCM_EXTERN ScmObj Scm_RegComp(ScmString *pattern, int flags); 1940 #if GAUCHE_API_VERSION >= 1000 1941 SCM_EXTERN ScmObj Scm_RegCompFromAST(ScmObj ast, int flags); 1942 #define Scm_RegCompFromAST2(a,b) Scm_RegCompFromAST(a,b) 1943 #else /* GAUCHE_API_VERSION < 1000 */ 1944 SCM_EXTERN ScmObj Scm_RegCompFromAST(ScmObj ast); 1945 SCM_EXTERN ScmObj Scm_RegCompFromAST2(ScmObj ast, int flags); 1946 #endif /* GAUCHE_API_VERSION < 1000 */ 1947 SCM_EXTERN ScmObj Scm_RegOptimizeAST(ScmObj ast); 1948 SCM_EXTERN ScmObj Scm_RegExec(ScmRegexp *rx, ScmString *input, ScmObj start, ScmObj end); 1949 SCM_EXTERN void Scm_RegDump(ScmRegexp *rx); 1950 1951 SCM_CLASS_DECL(Scm_RegMatchClass); 1952 #define SCM_CLASS_REGMATCH (&Scm_RegMatchClass) 1953 #define SCM_REGMATCH(obj) ((ScmRegMatch*)obj) 1954 #define SCM_REGMATCHP(obj) SCM_XTYPEP(obj, SCM_CLASS_REGMATCH) 1955 1956 SCM_EXTERN ScmObj Scm_RegMatchSubstr(ScmRegMatch *rm, ScmObj obj); 1957 SCM_EXTERN ScmObj Scm_RegMatchStart(ScmRegMatch *rm, ScmObj obj); 1958 SCM_EXTERN ScmObj Scm_RegMatchEnd(ScmRegMatch *rm, ScmObj obj); 1959 SCM_EXTERN ScmObj Scm_RegMatchAfter(ScmRegMatch *rm, ScmObj obj); 1960 SCM_EXTERN ScmObj Scm_RegMatchBefore(ScmRegMatch *rm, ScmObj obj); 1961 SCM_EXTERN void Scm_RegMatchDump(ScmRegMatch *match); 1962 1963 /*------------------------------------------------------- 1964 * STUB MACROS 1965 */ 1966 #define SCM_ENTER_SUBR(name) 1967 1968 #define SCM_ARGREF(count) (SCM_FP[count]) 1969 #define SCM_RETURN(value) return value 1970 #define SCM_CURRENT_MODULE() (Scm_VM()->module) 1971 #define SCM_VOID_RETURN_VALUE(expr) ((void)(expr), SCM_UNDEFINED) 1972 1973 #define SCM_MAYBE_P(pred, obj) (SCM_FALSEP(obj)||(pred(obj))) 1974 #define SCM_MAYBE(unboxer, obj) (SCM_FALSEP(obj)?NULL:(unboxer(obj))) 1975 #define SCM_MAKE_MAYBE(boxer, obj) ((obj)?(boxer(obj)):SCM_FALSE) 1976 1977 /*--------------------------------------------------- 1978 * SIGNAL 1979 */ 1980 1981 typedef struct ScmSysSigsetRec { 1982 SCM_HEADER; 1983 sigset_t set; 1984 } ScmSysSigset; 1985 1986 SCM_CLASS_DECL(Scm_SysSigsetClass); 1987 #define SCM_CLASS_SYS_SIGSET (&Scm_SysSigsetClass) 1988 #define SCM_SYS_SIGSET(obj) ((ScmSysSigset*)(obj)) 1989 #define SCM_SYS_SIGSET_P(obj) SCM_XTYPEP(obj, SCM_CLASS_SYS_SIGSET) 1990 1991 SCM_EXTERN ScmObj Scm_SysSigsetOp(ScmSysSigset*, ScmObj, int); 1992 SCM_EXTERN ScmObj Scm_SysSigsetFill(ScmSysSigset*, int); 1993 SCM_EXTERN void Scm_SigFillSetMostly(sigset_t *set); 1994 SCM_EXTERN ScmObj Scm_GetSignalHandler(int); 1995 SCM_EXTERN ScmObj Scm_GetSignalHandlerMask(int); 1996 SCM_EXTERN ScmObj Scm_GetSignalHandlers(void); 1997 SCM_EXTERN ScmObj Scm_SetSignalHandler(ScmObj, ScmObj, ScmSysSigset*); 1998 SCM_EXTERN ScmObj Scm_SysSigmask(int how, ScmSysSigset *newmask); 1999 SCM_EXTERN ScmObj Scm_Pause(void); 2000 SCM_EXTERN ScmObj Scm_SigSuspend(ScmSysSigset *mask); 2001 SCM_EXTERN int Scm_SigWait(ScmSysSigset *mask); 2002 SCM_EXTERN sigset_t Scm_GetMasterSigmask(void); 2003 SCM_EXTERN void Scm_SetMasterSigmask(sigset_t *set); 2004 SCM_EXTERN ScmObj Scm_SignalName(int signum); 2005 SCM_EXTERN void Scm_ResetSignalHandlers(sigset_t *mask); 2006 2007 #if GAUCHE_API_VERSION < 1000 2008 SCM_EXTERN void Scm_GetSigmask(sigset_t *mask); 2009 SCM_EXTERN void Scm_SetSigmask(sigset_t *mask); 2010 #endif /*GAUCHE_API_VERSION < 1000*/ 2011 2012 /*--------------------------------------------------- 2013 * SYSTEM 2014 */ 2015 2016 #include <gauche/system.h> 2017 2018 /*--------------------------------------------------- 2019 * LOAD AND DYNAMIC LINK 2020 */ 2021 2022 #include <gauche/load.h> 2023 2024 /*--------------------------------------------------- 2025 * PROFILER INTERFACE 2026 */ 2027 2028 SCM_EXTERN void Scm_ProfilerStart(void); 2029 SCM_EXTERN int Scm_ProfilerStop(void); 2030 SCM_EXTERN void Scm_ProfilerReset(void); 2031 2032 /*--------------------------------------------------- 2033 * UTILITY STUFF 2034 */ 2035 2036 /* Program start and termination */ 2037 2038 SCM_EXTERN void Scm_Init(const char *signature); 2039 SCM_EXTERN int Scm_InitializedP(void); 2040 SCM_EXTERN void Scm_Cleanup(void); 2041 SCM_EXTERN void Scm_Exit(int code) SCM_NORETURN; 2042 SCM_EXTERN void Scm_Abort(const char *msg) SCM_NORETURN; 2043 SCM_EXTERN void Scm_Panic(const char *msg, ...) SCM_NORETURN; 2044 2045 /* 'kind' argument of Scm_InitCommandLine */ 2046 enum { 2047 SCM_COMMAND_LINE_SCRIPT = 1, /* for (command-line) */ 2048 SCM_COMMAND_LINE_OS = 2, /* for (os-command-line) */ 2049 SCM_COMMAND_LINE_BOTH = (SCM_COMMAND_LINE_SCRIPT|SCM_COMMAND_LINE_OS) 2050 }; 2051 2052 #if GAUCHE_API_VERSION >= 1000 2053 SCM_EXTERN ScmObj Scm_InitCommandLine(int argc, const char *argv[], 2054 int kind); 2055 #define Scm_InitCommandLine2(ac, av, kind) Scm_InitCommandLine(ac, av, kind) 2056 #else /* GAUCHE_API_VERSION < 1000 */ 2057 SCM_EXTERN ScmObj Scm_InitCommandLine(int argc, const char *argv[]); 2058 SCM_EXTERN ScmObj Scm_InitCommandLine2(int argc, const char *argv[], int kind); 2059 #endif /* GAUCHE_API_VERSION < 1000 */ 2060 2061 SCM_EXTERN void Scm_SimpleMain(int argc, const char *argv[], 2062 const char *script, u_long flags); 2063 2064 SCM_EXTERN void Scm_GC(void); 2065 SCM_EXTERN void Scm_PrintStaticRoots(void); 2066 SCM_EXTERN void Scm_RegisterDL(void *data_start, void *data_end, 2067 void *bss_start, void *bss_end); 2068 SCM_EXTERN void Scm_GCSentinel(void *obj, const char *name); 2069 2070 SCM_EXTERN ScmObj Scm_GetFeatures(void); 2071 SCM_EXTERN void Scm_AddFeature(const char *feature, const char *mod); 2072 SCM_EXTERN void Scm_DisableFeature(const char *feature); 2073 2074 SCM_EXTERN void *Scm_AddCleanupHandler(void (*proc)(void *data), void *data); 2075 SCM_EXTERN void Scm_DeleteCleanupHandler(void *handle); 2076 2077 /* repl */ 2078 SCM_EXTERN void Scm_Repl(ScmObj reader, ScmObj evaluator, ScmObj printer, 2079 ScmObj prompter); 2080 2081 /* Inspect the configuration */ 2082 SCM_EXTERN const char *Scm_HostArchitecture(void); 2083 2084 SCM_EXTERN ScmObj Scm_LibraryDirectory(void); 2085 SCM_EXTERN ScmObj Scm_ArchitectureDirectory(void); 2086 SCM_EXTERN ScmObj Scm_SiteLibraryDirectory(void); 2087 SCM_EXTERN ScmObj Scm_SiteArchitectureDirectory(void); 2088 SCM_EXTERN ScmObj Scm_RuntimeDirectory(void); /* may return SCM_FALSE */ 2089 SCM_EXTERN ScmObj Scm_LibgauchePath(void); /* may return SCM_FALSE */ 2090 SCM_EXTERN ScmObj Scm_ExecutablePath(void); /* may return SCM_FALSE */ 2091 2092 /* Compare and Sort */ 2093 2094 #include <gauche/compare.h> 2095 2096 /* Assertion */ 2097 2098 #ifdef GAUCHE_RECKLESS 2099 #define SCM_ASSERT(expr) /* nothing */ 2100 #else 2101 2102 #ifdef __GNUC__ 2103 2104 #define SCM_ASSERT(expr) \ 2105 do { \ 2106 if (!(expr)) \ 2107 Scm_Panic("\"%s\", line %d (%s): Assertion failed: %s", \ 2108 __FILE__, __LINE__, __PRETTY_FUNCTION__, #expr); \ 2109 } while (0) 2110 2111 #else 2112 2113 #define SCM_ASSERT(expr) \ 2114 do { \ 2115 if (!(expr)) \ 2116 Scm_Panic("\"%s\", line %d: Assertion failed: %s", \ 2117 __FILE__, __LINE__, #expr); \ 2118 } while (0) 2119 2120 #endif /* !__GNUC__ */ 2121 2122 #endif /* !GAUCHE_RECKLESS */ 2123 2124 #include <gauche/scmconst.h> 2125 #include <gauche/endian.h> 2126 2127 SCM_DECL_END 2128 2129 #endif /* GAUCHE_H */ 2130