#define USE_STDIO_H #include "run-time.h" #include #include #include #include #include #include #ifdef macintosh #include #include #endif #if defined(__alpha) || defined(__mips64) #define NO_LONGLONG 1 #define LONG_BIT 64 #define WORD_BIT 32 #define LOHALF(x) (x & 0x00000000FFFFFFFFL) #define HIHALF(x) (((unsigned long)x & 0xFFFFFFFF00000000L) >> 32) #else #define LONG_BIT 32 #endif #define ignore(x) x /* stack allocation relies on inlining calls to error handlers pointer_element_at (base, byte_offset) at and at_setter's for base and byte_offset int8, int16, int32, int64, uint8, uint16, uint32, uint64, single_float, double_float signal handling break, error and errno file date and file date setter */ /* PLATFORM SPECIFIC HAX */ #ifdef macintosh #define rint(x) floor(x) #define strncasecmp(s1,s2,n) strncmp(s1, s2, n) #define putenv(X) #endif #ifdef WIN32 #define rint(x) floor(x) #define strncasecmp _strnicmp #endif /* DYLAN CONSTANTS */ extern OBJECT KPfalseVKi; extern OBJECT KPtrueVKi; extern OBJECT KPunboundVKi; #define UNBOUND_P(x) ((x) == &KPunboundVKi) #if defined(WIN32) #define INLINE __inline #elif defined(macintosh) #define INLINE #else #define INLINE inline #endif /* stubbed primitives */ D primitive_runtime_module_handle() { return(I(0)); } /* SUPPORT */ void primitive_break() { #if defined(macintosh) Debugger(); #elif defined(WIN32) extern void __stdcall DebugBreak(void); DebugBreak(); #else int *ptr = (int*)0; *ptr = 0; /* generate a memory fault */ #endif } /* MEMORY */ INLINE D instance_header_setter (D header, D* instance) { instance[0] = header; return(header); } void primitive_mps_collect (DBOOL ignored) { ignore(ignored); GC_gcollect(); } DBOOL primitive_mps_collection_stats (D x) { ignore(x); return(0); } DSINT primitive_mps_committed (void) { return(GC_get_heap_size()); } D allocate (unsigned long size) { if (size > 100000000) primitive_break(); return((D)GC_malloc((size_t)size)); } D primitive_allocate (DSINT size) { return((D)allocate(size * sizeof(D))); } D primitive_byte_allocate (DSINT number_words, DSINT number_bytes) { return((D)allocate(number_words * sizeof(D) + number_bytes)); } D primitive_untraced_allocate (DSINT size) { return(allocate(size * sizeof(D))); } D primitive_manual_allocate (D sizeObject) { size_t size = (size_t)R(sizeObject); void* p = malloc(size); return(primitive_wrap_machine_word((DMINT)p)); } void primitive_manual_free (D object) { free((void*)primitive_unwrap_c_pointer(object)); } void primitive_fillX(D dst, int base_offset, int offset, int size, D value) { register int i; D* target = ((D*)dst) + base_offset + offset; for (i = 0; i < size; i++) target[i] = value; } void primitive_fill_bytesX (D dst, int base_offset, int offset, int size, DSINT value) { if (size > 0) memset(((unsigned char*)((D*)dst + base_offset)) + offset, value, (size_t)size); } DSINT primitive_repeated_slot_offset(D x) { D* instance = (D*)x; Wrapper* wrapper = (Wrapper*)instance[0]; DSINT fixed_part = wrapper->fixed_part; DSINT n_slots = fixed_part >> 2; DSINT offset = 1 + n_slots + 1; return(offset); } D primitive_repeated_slot_as_raw(D x, DSINT offset) { return((D)((D*)x + offset)); } void primitive_replace_bytesX (D dst, DSINT dst_base_offset, DSINT dst_offset, D src, DSINT src_base_offset, DSINT src_offset, DSINT size) { if (size > 0) memcpy(&(((char*)(&(((D*)dst)[dst_base_offset])))[dst_offset]), &(((char*)(&(((D*)src)[src_base_offset])))[src_offset]), (size_t)size); } #define COPY_WORDS(dst, src, size) memcpy((dst), (src), (size) * sizeof(D)) void primitive_replaceX (D dst, DSINT dst_base_offset, DSINT dst_offset, D src, DSINT src_base_offset, DSINT src_offset, DSINT size) { ignore(src_base_offset); if (size > 0) COPY_WORDS(&(((D*)dst)[dst_base_offset + dst_offset]), &(((D*)src)[dst_base_offset + src_offset]), size); } D primitive_compare_bytes(D base1, DSINT offset1, D base2, DSINT offset2, DSINT size) { return (RAWASBOOL(memcmp(&((((BS*)base1)->data)[offset1]), &((((BS*)base2)->data)[offset2]), (size_t)size))); } D primitive_compare_words(D base1, DSINT offset1, D base2, DSINT offset2, DSINT size) { return (RAWASBOOL(memcmp(&((((BS*)base1)->data)[offset1]), &((((BS*)base2)->data)[offset2]), size * sizeof(D)))); } D primitive_byte_allocate_filled_terminated (DSINT size, DSINT number_bytes, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset) { D* object = primitive_byte_allocate(size, number_bytes); instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); primitive_fill_bytesX (object, repeated_size_offset + 1, 0, repeated_size, (unsigned char)R(fill_value)); ((char*)(&object[repeated_size_offset + 1]))[repeated_size] = (char)0; if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); return((D)object); } /* This one still zero-terminates. TODO: turn that off */ D primitive_byte_allocate_filled (DSINT size, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset, DBYTE repeated_fill_value) { D* object = primitive_byte_allocate(size, repeated_size + 1); instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); primitive_fill_bytesX (object, repeated_size_offset + 1, 0, repeated_size, (unsigned char)R(repeated_fill_value)); ((char*)(&object[repeated_size_offset + 1]))[repeated_size] = (char)0; if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); return((D)object); } #define define_repeated_allocator(name, type) \ D primitive_ ## name ## _allocate_filled \ (DSINT size, D class_wrapper, DSINT number_slots, D fill_value, \ DSINT repeated_size, DSINT repeated_size_offset, \ type repeated_fill_value) \ { \ int i; \ D* object = primitive_byte_allocate(size, (DSINT)(repeated_size * sizeof(type))); \ instance_header_setter(class_wrapper, object); \ primitive_fillX(object, 1, 0, number_slots, fill_value); \ for (i = 0; i < repeated_size; i++) \ ((type*)(&object[repeated_size_offset + 1]))[i] = (type)repeated_fill_value; \ if (repeated_size_offset > 0) \ object[repeated_size_offset] = I(repeated_size); \ return((D)object); \ } define_repeated_allocator(object, D) define_repeated_allocator(double_byte, DDBYTE) define_repeated_allocator(word, DWORD) define_repeated_allocator(double_word, DDWORD) define_repeated_allocator(single_float, DSFLT) define_repeated_allocator(double_float, DDFLT) D primitive_allocate_filled (DSINT size, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset) { D* object = primitive_allocate(size); instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); primitive_fillX(object, repeated_size_offset + 1, 0, repeated_size, fill_value); if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); return((D)object); } D primitive_allocate_in_awl_pool (DSINT size, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset, D assoc) { D* object = primitive_allocate(size); instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); primitive_fillX(object, repeated_size_offset + 1, 0, repeated_size, fill_value); if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); object[1] = assoc; return((D)object); } D primitive_allocate_weak_in_awl_pool (DSINT size, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset, D assoc) { D* object = primitive_allocate(size); instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); primitive_fillX(object, repeated_size_offset + 1, 0, repeated_size, fill_value); if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); object[1] = assoc; return((D)object); } D primitive_allocate_wrapper (DSINT size, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset) { D* object = primitive_allocate(size); instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); primitive_fillX(object, repeated_size_offset + 1, 0, repeated_size, fill_value); if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); return((D)object); } /* STACK ALLOCATION */ /* This one still zero-terminates. TODO: turn that off */ INLINE D initialize_byte_stack_allocate_filled (D ptr, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset, DBYTE repeated_fill_value) { D* object = ptr; instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); primitive_fill_bytesX (object, repeated_size_offset + 1, 0, repeated_size, (unsigned char)R(repeated_fill_value)); ((char*)(&object[repeated_size_offset + 1]))[repeated_size] = (char)0; if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); return((D)object); } INLINE D initialize_object_stack_allocate_filled (D ptr, D class_wrapper, DSINT number_slots, D fill_value, DSINT repeated_size, DSINT repeated_size_offset, D repeated_fill_value) { int i; D* object = ptr; instance_header_setter(class_wrapper, object); primitive_fillX(object, 1, 0, number_slots, fill_value); for (i = 0; i < repeated_size; i++) ((D*)(&object[repeated_size_offset + 1]))[i] = (D)repeated_fill_value; if (repeated_size_offset > 0) object[repeated_size_offset] = I(repeated_size); return((D)object); } /* PINNING PRIMITIVES */ void primitive_unpin_object(D object) { ignore(object); } /* C-FFI PRIMITIVES */ D primitive_wrap_c_pointer(D wrapper, DMINT x) { return(primitive_allocate_filled (2, wrapper, 1, (D)x, 0, 0)); } /* NUMBERS */ extern D MV2_(D, D); extern D MV3_(D, D, D); #define MV2(x,y) return((DMINT)MV2_((D)(x), (D)(y))) #define MV2U(x,y) return((DUMINT)MV2_((D)(x), (D)(y))) #define MV3(x,y,z) return((DMINT)MV3_((D)(x), (D)(y), (D)(z))) extern Wrapper KLmachine_wordGVKeW; extern Wrapper KLdouble_integerGVKeW; extern Wrapper KLsingle_floatGVKdW; extern Wrapper KLdouble_floatGVKdW; typedef union { UINT32 i; FLT f; } INTFLT; D primitive_raw_as_single_float(DSFLT x) { return(primitive_allocate_filled (2, &KLsingle_floatGVKdW, 1, (D)primitive_cast_single_float_as_machine_word(x), 0, 0)); } DMINT primitive_single_float_as_double_integer(DSFLT f) { #ifdef NO_LONGLONG DMINT i = (DMINT)f; MV2((DMINT)i, (i < 0) ? (DMINT)-1 : (DMINT)0); #else DLMINT i = (DLMINT)f; MV2((DMINT)i, (DMINT)(i >> LONG_BIT)); #endif } DSFLT primitive_double_integer_as_single_float(DMINT low, DMINT high) { #ifdef NO_LONGLONG DSFLT fl = (DSFLT)(DUMINT)low; DSFLT fh = (DSFLT)((high < 0) ? 0 - high : high); DSFLT f = fl + fh * pow(2.0, (DDFLT)LONG_BIT); return((high < 0) ? 0.0 - f : f); #else DLMINT i = ((DLMINT)high << LONG_BIT) | (DLMINT)low; return((DSFLT)i); #endif } DUMINT primitive_cast_single_float_as_machine_word(DSFLT x) { INTFLT intflt; intflt.f = x; return(intflt.i); } DSFLT primitive_cast_machine_word_as_single_float(DUMINT x) { INTFLT intflt; intflt.i = x; return(intflt.f); } typedef union { UINT64 i; DFLT f; } INTDFLT; D primitive_raw_as_double_float(DDFLT x) { D f = primitive_allocate_filled(3, &KLdouble_floatGVKdW, 0, (D)0, 0, 0); ((DDF)f)->data = x; return(f); } DMINT primitive_double_float_as_double_integer(DDFLT f) { #ifdef NO_LONGLONG DMINT i = (DMINT)f; MV2((DMINT)i, (i < 0) ? (DMINT)-1 : (DMINT)0); #else DLMINT i = (DLMINT)f; MV2((DMINT)i, (DMINT)(i >> LONG_BIT)); #endif } DDFLT primitive_double_integer_as_double_float(DMINT low, DMINT high) { #ifdef NO_LONGLONG DDFLT fl = (DDFLT)(DUMINT)low; DDFLT fh = (DDFLT)((high < 0) ? 0 - high : high); DDFLT f = fl + fh * pow(2.0, (DDFLT)LONG_BIT); return((high < 0) ? 0.0 - f : f); #else DLMINT i = ((DLMINT)high << LONG_BIT) | (DLMINT)low; return((DDFLT)i); #endif } DUMINT primitive_cast_double_float_as_machine_words(DDFLT x) { INTDFLT intflt; intflt.f = x; #ifdef NO_LONGLONG MV2U((DUMINT)intflt.i, 0); #else MV2U((DUMINT)intflt.i, (DUMINT)(intflt.i >> LONG_BIT)); #endif } DDFLT primitive_cast_machine_words_as_double_float(DUMINT low, DUMINT high) { INTDFLT intflt; #ifdef NO_LONGLONG intflt.i = (DULMINT)low; #else intflt.i = ((DULMINT)high << LONG_BIT) | (DULMINT)low; #endif return(intflt.f); } /* MACHINE-WORD primitives */ D primitive_wrap_machine_word(DMINT x) { return(primitive_allocate_filled (2, &KLmachine_wordGVKeW, 1, (D)x, 0, 0)); } /*---*** NOTE: This is wrong! It should make a */ D primitive_wrap_abstract_integer(DMINT x) { if (R(I(x)) != x) return(primitive_wrap_machine_word(x)); else return(primitive_box_integer(x)); } /*---*** NOTE: This is wrong! It should make a */ D primitive_wrap_unsigned_abstract_integer(DMINT x) { if (R(I(x)) != x) return(primitive_wrap_machine_word(x)); else return(primitive_box_integer(x)); } /*---*** NOTE: This is wrong! It should unwrap a */ DMINT primitive_unwrap_abstract_integer(D x) { if (BOOLASRAW(primitive_integerQ(x))) return(primitive_unbox_integer(x)); else return(primitive_unwrap_machine_word(x)); } /*---*** NOTE: Here's the correct implementation of the above three functions */ #ifdef NOTYET #if defined(__alpha) || defined(__mips64) #define HIGH_BITS 0xC000000000000000L #define HIGH_BITS_AND_SIGN 0xE000000000000000L #else #define HIGH_BITS 0xC0000000L #define HIGH_BITS_AND_SIGN 0xE0000000L #endif D primitive_wrap_abstract_integer(DMINT x) { DUMINT hs = (DUMINT)x & HIGH_BITS_AND_SIGN; if (hs != 0 && hs != HIGH_BITS_AND_SIGN) { xd = primitive_allocate_filled (3, &KLdouble_integerGVKeW, 2, (D)0, 0, 0); (DBI)xd->low = (DUMINT)x; /* Propogate the sign of x through the high word of the */ (DBI)xd->high = (x < 0) ? -1 : 0; return(xd); } else return(I(x)); } D primitive_wrap_unsigned_abstract_integer(DMINT x) { if ((DUMINT)x & HIGH_BITS != 0) { D xd = primitive_allocate_filled (3, &KLdouble_integerGVKeW, 2, (D)0, 0, 0); /* When x is treated as an unsigned value, the high word of the resulting will always be 0 */ (DBI)xd->low = (DUMINT)x; return(xd); } else return(I(x)); } DMINT primitive_unwrap_abstract_integer(D x) { if (BOOLASRAW(primitive_integerQ(x))) return(R(x)); else /* Native runtime will signal overflow if (DBI)x->high != 0 | != 1 (See page 3 of "Integer and Machine integer primitives") */ return((DBI)x->low); } #endif /* SunOS4 doesn't include ldiv and friends in (Sigh) */ #if defined(sun) && !defined(__svr4__) typedef struct ldiv_t { long quot; long rem; } ldiv_t; ldiv_t ldiv(long x, long y) { ldiv_t z; z.quot = x / y; z.rem = x % y; return(z); } #endif DMINT primitive_machine_word_divide(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); MV2((DMINT)z.quot, (DMINT)z.rem); } D IKJboole_ior_, IKJboole_xor_; DMINT primitive_machine_word_boole(D s, DMINT x, DMINT y) { if (s == IKJboole_ior_) return(x | y); else if (s == IKJboole_xor_) return(x ^ y); else /* if (s == IKJboole_and) */ return(x & y); } DMINT primitive_machine_word_floorS_quotient(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem > 0) : (z.rem < 0))) { z.quot--; z.rem += y; } return((DMINT)z.quot); } DMINT primitive_machine_word_floorS_remainder(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem > 0) : (z.rem < 0))) { z.quot--; z.rem += y; } return((DMINT)z.rem); } DMINT primitive_machine_word_floorS(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem > 0) : (z.rem < 0))) { z.quot--; z.rem += y; } MV2((DMINT)z.quot, (DMINT)z.rem); } DMINT primitive_machine_word_ceilingS_quotient(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem < 0) : (z.rem > 0))) { z.quot++; z.rem -= y; } return((DMINT)z.quot); } DMINT primitive_machine_word_ceilingS_remainder(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem < 0) : (z.rem > 0))) { z.quot++; z.rem -= y; } return((DMINT)z.rem); } DMINT primitive_machine_word_ceilingS(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem < 0) : (z.rem > 0))) { z.quot++; z.rem -= y; } MV2((DMINT)z.quot, (DMINT)z.rem); } DMINT primitive_machine_word_roundS_quotient(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); long threshold = labs(y) / 2; if ((z.rem > threshold) || ((z.rem == threshold) && (z.quot & 1))) { if (y < 0) { z.quot--; z.rem += y; } else { z.quot++; z.rem -= y; } } else if ((z.rem < -threshold) || ((z.rem == -threshold) && (z.quot & 1))) { if (y < 0) { z.quot++; z.rem -= y; } else { z.quot--; z.rem += y; } } return((DMINT)z.quot); } DMINT primitive_machine_word_roundS_remainder(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); long threshold = labs(y) / 2; if ((z.rem > threshold) || ((z.rem == threshold) && (z.quot & 1))) { if (y < 0) { z.quot--; z.rem += y; } else { z.quot++; z.rem -= y; } } else if ((z.rem < -threshold) || ((z.rem == -threshold) && (z.quot & 1))) { if (y < 0) { z.quot++; z.rem -= y; } else { z.quot--; z.rem += y; } } return((DMINT)z.rem); } DMINT primitive_machine_word_roundS(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); long threshold = labs(y) / 2; if ((z.rem > threshold) || ((z.rem == threshold) && (z.quot & 1))) { if (y < 0) { z.quot--; z.rem += y; } else { z.quot++; z.rem -= y; } } else if ((z.rem < -threshold) || ((z.rem == -threshold) && (z.quot & 1))) { if (y < 0) { z.quot++; z.rem -= y; } else { z.quot--; z.rem += y; } } MV2((DMINT)z.quot, (DMINT)z.rem); } DMINT primitive_machine_word_truncateS_quotient(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); return((DMINT)z.quot); } DMINT primitive_machine_word_truncateS_remainder(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); return((DMINT)z.rem); } DMINT primitive_machine_word_truncateS(DMINT x, DMINT y) { ldiv_t z = ldiv(x, y); MV2((DMINT)z.quot, (DMINT)z.rem); } /*---*** NOTE: This code is wrong for Alpha (NO_LONGLONG) but, as the ---*** only users of these primitives never pass a high value that's ---*** other than the sign of the low value, this implementation ---*** will work for now ... */ static void divide_double (DMINT xl, DMINT xh, DMINT y, DMINT* q, DMINT* r) { #ifdef NO_LONGLONG DMINT dividend = (xh < 0 && xl > 0) ? xl : xl; DMINT divisor = y; *q = dividend / divisor; *r = dividend % divisor; if (xh < 0 && xl > 0) { *q = -(*q); *r = -(*r); } #else DLMINT dividend = ((DLMINT)xh << LONG_BIT) | (DLMINT)(DUMINT)xl; DLMINT divisor = (DLMINT)y; *q = (DMINT)(dividend / divisor); *r = (DMINT)(dividend % divisor); #endif return; } /*---*** NOTE: This code is wrong for Alpha (NO_LONGLONG) but, as these ---*** primitives aren't used yet, we can get away with it for now ... */ static void unsigned_divide_double (DMINT xl, DMINT xh, DMINT y, DUMINT* q, DUMINT* r) { #ifdef NO_LONGLONG DUMINT dividend = (DUMINT)xl; DUMINT divisor = (DUMINT)y; *q = dividend / divisor; *r = dividend % divisor; #else DULMINT dividend = ((DULMINT)(DUMINT)xh << LONG_BIT) | (DULMINT)(DUMINT)xl; DULMINT divisor = (DULMINT)(DUMINT)y; *q = (DUMINT)(dividend / divisor); *r = (DUMINT)(dividend % divisor); #endif return; } DMINT primitive_machine_word_double_floorS_quotient(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r > 0) : (r < 0))) { q--; r += y; } return(q); } DMINT primitive_machine_word_double_floorS_remainder(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r > 0) : (r < 0))) { q--; r += y; } return(r); } DMINT primitive_machine_word_double_floorS(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r > 0) : (r < 0))) { q--; r += y; } MV2(q, r); } DMINT primitive_machine_word_double_ceilingS_quotient(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r < 0) : (r > 0))) { q++; r -= y; } return(q); } DMINT primitive_machine_word_double_ceilingS_remainder(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r < 0) : (r > 0))) { q++; r -= y; } return(r); } DMINT primitive_machine_word_double_ceilingS(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r < 0) : (r > 0))) { q++; r -= y; } MV2(q, r); } DMINT primitive_machine_word_double_roundS_quotient(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; long threshold = labs(y) / 2; divide_double(xl, xh, y, &q, &r); if ((r > threshold) || ((r == threshold) && (q & 1))) { if (y < 0) { q--; r += y; } else { q++; r -= y; } } else if ((r < -threshold) || ((r == -threshold) && (q & 1))) { if (y < 0) { q++; r -= y; } else { q--; r += y; } } return(q); } DMINT primitive_machine_word_double_roundS_remainder(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; long threshold = labs(y) / 2; divide_double(xl, xh, y, &q, &r); if ((r > threshold) || ((r == threshold) && (q & 1))) { if (y < 0) { q--; r += y; } else { q++; r -= y; } } else if ((r < -threshold) || ((r == -threshold) && (q & 1))) { if (y < 0) { q++; r -= y; } else { q--; r += y; } } return(r); } DMINT primitive_machine_word_double_roundS(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; long threshold = labs(y) / 2; divide_double(xl, xh, y, &q, &r); if ((r > threshold) || ((r == threshold) && (q & 1))) { if (y < 0) { q--; r += y; } else { q++; r -= y; } } else if ((r < -threshold) || ((r == -threshold) && (q & 1))) { if (y < 0) { q++; r -= y; } else { q--; r += y; } } MV2(q, r); } DMINT primitive_machine_word_double_truncateS_quotient(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); return(q); } DMINT primitive_machine_word_double_truncateS_remainder(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); return(r); } DMINT primitive_machine_word_double_truncateS(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); MV2(q, r); } DMINT primitive_machine_word_double_divide_quotient(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); return(q); } DMINT primitive_machine_word_double_divide_remainder(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); return(r); } DMINT primitive_machine_word_double_divide(DMINT xl, DMINT xh, DMINT y) { DMINT q, r; divide_double(xl, xh, y, &q, &r); MV2(q, r); } DMINT primitive_machine_word_count_low_zeros(DMINT x) { if (x == 0) return(DMINT)(primitive_word_size()); { DMINT mask4 = (DMINT)0xF; int index = (int)(mask4 & x); int count = 0; static int t[16] = { 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0 }; /* scan for a non-zero low nibble. */ for (; index == 0; count += 4, x >>= 4, index = (int)(mask4 & x)) {} return(DMINT)(count + t[index]); } } DMINT primitive_machine_word_count_high_zeros(DMINT x) { if (x == 0) return(DMINT)(primitive_word_size()); { DUMINT ux = (DUMINT)x; DUMINT mask4 = ((DUMINT)0xF) << (primitive_word_size() - 4); DUMINT uindex = mask4 & ux; int count = 0; static int t[16] = { 4, 3, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 }; /* scan for non-zero high nibble. */ for (; uindex == (DUMINT)0; count += 4, ux <<= 4, uindex = mask4 & ux) {} { int index = (int)(uindex >> (primitive_word_size() - 4)); return(DMINT)(count + t[index]); } } } static void multiply_double (DMINT x, DMINT y, DUMINT* zl, DUMINT* zh) { #ifdef NO_LONGLONG DUMINT xl = (DUMINT)LOHALF(x); DUMINT xh = (DUMINT)HIHALF(x); DUMINT yl = (DUMINT)LOHALF(y); DUMINT yh = (DUMINT)HIHALF(y); DUMINT zll = xl * yl; DUMINT zlh = xl * yh; DUMINT zhl = xh * yl; DUMINT zhh = xh * yh; *zl = zll + ((LOHALF(zlh) + LOHALF(zhl)) << WORD_BIT); *zh = zhh + HIHALF(zlh) + HIHALF(zhl); #else DULMINT z = (DULMINT)(DUMINT)x * (DULMINT)(DUMINT)y; *zl = (DUMINT)z; *zh = (DUMINT)(z >> LONG_BIT); #endif return; } DMINT primitive_machine_word_add_with_overflow(DMINT x, DMINT y) { DMINT r = (DMINT)((DUMINT)x + (DUMINT)y); /* Overflow if signs of inputs are the same but different from sign of result ... */ MV2(r, RAWASBOOL(((x ^ y) >= 0) && ((r ^ x) < 0))); } DMINT primitive_machine_word_subtract_with_overflow(DMINT x, DMINT y) { DMINT r = (DMINT)((DUMINT)x - (DUMINT)y); /* Overflow if signs of inputs differ and sign of result isn't sign of X ... */ MV2(r, RAWASBOOL(((x ^ y) < 0) && ((r ^ x) < 0))); } DMINT primitive_machine_word_multiply_with_overflow(DMINT x, DMINT y) { DUMINT rl, rh; multiply_double(x, y, &rl, &rh); /* Overflow if sign of result is wrong or ? ... */ MV3(rl, rh, RAWASBOOL(((x ^ y) < 0) ? ((DMINT)rh >= 0) : ((DMINT)rh < 0))); } DMINT primitive_machine_word_negative_with_overflow(DMINT x) { DMINT r = - x; /* Overflow if input was negative and result is negative or zero ... */ MV2(r, RAWASBOOL(x < 0 && r <= 0)); } DMINT primitive_machine_word_abs_with_overflow(DMINT x) { DMINT r = labs(x); /* Overflow if input was negative and result is negative or zero ... */ MV2(r, RAWASBOOL(x < 0 && r <= 0)); } DMINT primitive_machine_word_shift_left_with_overflow(DMINT x, DMINT y) { MV2(primitive_machine_word_shift_left_low(x, y), 0); } DMINT primitive_machine_word_multiply_high(DMINT x, DMINT y) { DUMINT zl, zh; multiply_double(x, y, &zl, &zh); return((DMINT)zh); } DMINT primitive_machine_word_multiply_lowShigh(DMINT x, DMINT y) { DUMINT zl, zh; multiply_double(x, y, &zl, &zh); MV2((DMINT)zl, (DMINT)zh); } DMINT primitive_machine_word_multiply_low_with_overflow(DMINT x, DMINT y) { DMINT r = x * y; /* Overflow if result has wrong sign or is smaller than inputs ... */ MV2(r, RAWASBOOL((((x ^ y) < 0) ? r >= 0 : r < 0) || (labs(r) < labs(x)) || (labs(r) < labs(y)))); } DMINT primitive_machine_word_unsigned_add_with_carry(DMINT x, DMINT y) { DUMINT ux = (DUMINT)x; DUMINT uy = (DUMINT)y; DUMINT uz = ux + uy; DUMINT bbc = ((ux & 1) && (uy & 1)) ? (DUMINT)1 : (DUMINT)0; MV2(uz, ((DMINT)((ux >> 1) + (uy >> 1) + bbc) < 0) ? (DMINT)1 : (DMINT)0); } DMINT primitive_machine_word_unsigned_subtract_with_borrow(DMINT x, DMINT y) { DUMINT ux = (DUMINT)x; DUMINT uy = (DUMINT)y; DUMINT uz = ux - uy; MV2(uz, (uy > ux) ? (DMINT)1 : (DMINT)0); } DMINT primitive_machine_word_unsigned_multiply_high(DMINT x, DMINT y) { DUMINT zl, zh; multiply_double(x, y, &zl, &zh); return((DMINT)zh); } DMINT primitive_machine_word_unsigned_multiply(DMINT x, DMINT y) { DUMINT zl, zh; multiply_double(x, y, &zl, &zh); MV2(zl, zh); } DMINT primitive_machine_word_unsigned_divide(DMINT x, DMINT y) { DUMINT q, r; unsigned_divide_double(x, (x < 0) ? -1 : 0, y, &q, &r); MV2(q, r); } DMINT primitive_machine_word_unsigned_rotate_left(DMINT x, DMINT y) { DUMINT low = (DUMINT)x >> (LONG_BIT - y); DUMINT high = (DUMINT)x << y; return((DMINT)(low | high)); } DMINT primitive_machine_word_unsigned_rotate_right(DMINT x, DMINT y) { DUMINT high = (DUMINT)x << (LONG_BIT - y); DUMINT low = (DUMINT)x >> y; return((DMINT)(low | high)); } DMINT primitive_machine_word_unsigned_double_divide_quotient(DMINT xl, DMINT xh, DMINT y) { DUMINT q, r; unsigned_divide_double(xl, xh, y, &q, &r); return((DMINT)q); } DMINT primitive_machine_word_unsigned_double_divide_remainder(DMINT xl, DMINT xh, DMINT y) { DUMINT q, r; unsigned_divide_double(xl, xh, y, &q, &r); return((DMINT)r); } DMINT primitive_machine_word_unsigned_double_divide(DMINT xl, DMINT xh, DMINT y) { DUMINT q, r; unsigned_divide_double(xl, xh, y, &q, &r); MV2(q, r); } DMINT primitive_machine_word_unsigned_shift_left_high(DMINT x, DMINT y) { return((DMINT)((DUMINT)x >> (LONG_BIT - y))); } DMINT primitive_machine_word_unsigned_double_shift_left_high(DMINT xl, DMINT xh, DMINT y) { DUMINT lowpart = (DUMINT)xl >> (LONG_BIT - y); DUMINT highpart = (DUMINT)xh << y; return((DMINT)(lowpart | highpart)); } DMINT primitive_machine_word_unsigned_double_shift_left(DMINT xl, DMINT xh, DMINT y) { DUMINT lowpart = (DUMINT)xl >> (LONG_BIT - y); DUMINT highpart = (DUMINT)xh << y; MV2((DUMINT)xl << y, lowpart | highpart); } DMINT primitive_machine_word_unsigned_double_shift_right_low(DMINT xl, DMINT xh, DMINT y) { DUMINT lowpart = (DUMINT)xl >> y; DUMINT highpart = (DUMINT)xh << (LONG_BIT - y); return((DMINT)(lowpart | highpart)); } DMINT primitive_machine_word_unsigned_double_shift_right_high(DMINT xl, DMINT xh, DMINT y) { ignore(xl); return((DMINT)((DUMINT)xh >> y)); } DMINT primitive_machine_word_unsigned_double_shift_right(DMINT xl, DMINT xh, DMINT y) { DUMINT lowpart = (DUMINT)xl >> y; DUMINT highpart = (DUMINT)xh << (LONG_BIT - y); MV2(lowpart | highpart, (DUMINT)xh >> y); } /* VECTOR */ extern Wrapper KLsimple_object_vectorGVKdW; #define VECTOR_HEADER_SIZE (2) INLINE int vector_size (SOV* vector) { return(R(vector->size)); } INLINE int vector_size_setter (int new_size, SOV* vector) { vector->size = I(new_size); return(new_size); } INLINE D* vector_data(SOV* vector) { return(vector->data); } INLINE D vector_ref (SOV* vector, int offset) { return(vector_data((SOV*)vector)[offset]); } /* gts,98apr08 */ D VECTOR_REF_OR_F(D vector, int offset) { if (offset >= vector_size(vector)) return(DFALSE); else return(vector_ref((SOV*)vector, offset)); } INLINE D vector_ref_setter (D new_value, SOV* vector, int offset) { return(vector_data(vector)[offset] = new_value); } extern SOV* Pempty_vectorVKi; SOV* allocate_vector (int size) { if (size == 0) return(Pempty_vectorVKi); else { SOV* vector = (SOV*)primitive_allocate(size + VECTOR_HEADER_SIZE); return(vector); } } SOV* make_vector (int size) { if (size == 0) return(Pempty_vectorVKi); else { SOV* vector = allocate_vector(size); instance_header_setter(&KLsimple_object_vectorGVKdW, (D*)vector); vector_size_setter(size, vector); return(vector); } } D primitive_make_vector (int size) { return((D)make_vector(size)); } SOV* initialize_vector_from_buffer_with_size (SOV* vector, int vector_size, D* buffer, int buffer_size) { instance_header_setter(&KLsimple_object_vectorGVKdW, (D*)vector); vector_size_setter(vector_size, vector); COPY_WORDS(vector_data(vector), buffer, buffer_size); return(vector); } SOV* initialize_vector_from_buffer (SOV* vector, int size, D* buffer) { return(initialize_vector_from_buffer_with_size(vector, size, buffer, size)); } SOV* make_vector_from_buffer (int size, D* buffer) { SOV* copy = allocate_vector(size); initialize_vector_from_buffer(copy, size, buffer); return(copy); } D primitive_copy_vector (D vector) { return((D)make_vector_from_buffer(vector_size((SOV*)vector), vector_data((SOV*)vector))); } D primitive_raw_as_vector (D size, D buffer) { return(make_vector_from_buffer((long)size, (D*)buffer)); } #define DEF_STACK_DATA(_name, _size) \ D _stk_##_name[STACK_DATA_SIZE]; \ D _name = ((_size) > STACK_DATA_SIZE) ? (D)primitive_allocate(_size) : (D)_stk_##_name #define DEF_STACK_DATA_FROM_BUFFER_WITH_SIZE(_name, _data_size, _buffer, _buffer_size) \ DEF_STACK_DATA(_name, _data_size); \ COPY_WORDS(_name, _buffer, _buffer_size) #define DEF_STACK_DATA_FROM_BUFFER(_name, _size, _buffer) \ DEF_STACK_DATA_FROM_BUFFER_WITH_SIZE(_name, _size, _buffer, _size) #define DEF_STACK_VECTOR(_name, _size) \ STACK_SOV _stk_##_name; \ SOV* _name = ((_size) > STACK_SOV_SIZE) ? allocate_vector(_size) : (SOV*)(&_stk_##_name) #define DEF_STACK_VECTOR_INITTED(_name, _size) \ STACK_SOV _stk_##_name; \ SOV* _name = ((_size) > STACK_SOV_SIZE) ? allocate_vector(_size) : (init_stack_vector((SOV*)(&_stk_##_name), (_size))) INLINE SOV* init_stack_vector(SOV* vector, int size) { instance_header_setter(&KLsimple_object_vectorGVKdW, (D*)vector); vector_size_setter(size, vector); return(vector); } #define DEF_STACK_VECTOR_FROM_BUFFER_WITH_SIZE(_name, _vector_size, _buffer, _buffer_size) \ DEF_STACK_VECTOR(_name, _vector_size); \ initialize_vector_from_buffer_with_size (_name, _vector_size, _buffer, _buffer_size) #define DEF_STACK_VECTOR_FROM_BUFFER(_name, _size, _buffer) \ DEF_STACK_VECTOR_FROM_BUFFER_WITH_SIZE(_name, _size, _buffer, _size) #define primitive_stack_allocate_vector(size) \ ((SOV*)primitive_stack_allocate(size + VECTOR_HEADER_SIZE)) /* STRING */ extern Wrapper KLbyte_stringGVKdW; D primitive_raw_as_string (DBSTR buffer) { size_t size = strlen(buffer); BS* string = (BS*)allocate(sizeof(BS) + size + 1); instance_header_setter(&KLbyte_stringGVKdW, (D*)string); string->size = I(size); memcpy(string->data, buffer, size); return((D)string); } /* SIGNATURES */ INLINE SOV* signature_required(SIG* sig) { return(sig->required); } INLINE SOV* signature_values(SIG* sig) { return(sig->values); } INLINE D signature_rest_value(SIG* sig) { return(sig->rest_value); } #define NUMBER_REQUIRED_MASK 0x0000ff #define NUMBER_VALUES_MASK 0x00ff00 #define NUMBER_VALUES_OFFSET 8 #define KEY_P_MASK 0x010000 #define ALL_KEYS_P_MASK 0x020000 #define REST_P_MASK 0x040000 #define OPTIONALS_P_MASK (KEY_P_MASK | REST_P_MASK) #define REST_VALUE_P_MASK 0x080000 #define NEXT_P_MASK 0x100000 INLINE int signature_number_required(SIG* sig) { return(R(sig->properties) & NUMBER_REQUIRED_MASK); } INLINE int signature_number_values(SIG* sig) { return((R(sig->properties) & NUMBER_VALUES_MASK) >> NUMBER_VALUES_OFFSET); } INLINE int signature_key_p(SIG* sig) { return((R(sig->properties) & KEY_P_MASK) > 0); } INLINE int signature_all_keys_p(SIG* sig) { return((R(sig->properties) & ALL_KEYS_P_MASK) > 0); } INLINE int signature_rest_p(SIG* sig) { return((R(sig->properties) & REST_P_MASK) > 0); } INLINE int signature_optionals_p(SIG* sig) { return((R(sig->properties) & OPTIONALS_P_MASK) > 0); } INLINE int signature_rest_value_p(SIG* sig) { return((R(sig->properties) & REST_VALUE_P_MASK) > 0); } INLINE int signature_next_p(SIG* sig) { return((R(sig->properties) & NEXT_P_MASK) > 0); } INLINE D signature_make_properties (int number_required, int number_values, int key_p, int all_keys_p, int rest_p, int rest_value_p) { return(I(number_required | (number_values << NUMBER_VALUES_OFFSET) | (key_p ? KEY_P_MASK : 0) | (all_keys_p ? ALL_KEYS_P_MASK : 0) | (rest_p ? REST_P_MASK : 0) | (rest_value_p ? REST_VALUE_P_MASK : 0))); } /* FUNCTION */ INLINE DFN function_xep(FN* function) { return(function->xep); } DFN primitive_function_xep(D function) { return(function_xep((FN*)function)); } INLINE DLFN function_mep(FN* function) { return(function->mep); } INLINE DLFN function_iep(FN* function) { return(function->mep); } INLINE DLFN keyword_function_iep(FN* function) { return(((KFN*)function)->iep); } INLINE D method_keyword_specifiers(FN* method) { return(((KFN*)method)->keyword_specifiers); } INLINE SOV* function_specializers(FN* function) { return(signature_required(function->signature)); } INLINE int function_number_required(FN* function) { return(signature_number_required(function->signature)); } INLINE int function_number_values(FN* function) { return(signature_number_values(function->signature)); } INLINE int function_key_p(FN* function) { return(signature_key_p(function->signature)); } INLINE int function_all_keys_p(FN* function) { return(signature_all_keys_p(function->signature)); } INLINE int function_rest_p(FN* function) { return(signature_rest_p(function->signature)); } INLINE int function_optionals_p(FN* function) { return(signature_optionals_p(function->signature)); } INLINE int function_rest_value_p(FN* function) { return(signature_rest_value_p(function->signature)); } INLINE int function_next_p(FN* function) { return(signature_next_p(function->signature)); } /* VARARGS SUPPORT */ INLINE void transfer_varargs(va_list ap, int n, D* arguments) { int i; for(i=0; i max_stack_size); return (overflow_p); #endif } extern D LobjectGVKd; extern D Ktype_check_errorVKiI(D argument, D specializer); extern Wrapper KLfunction_classGVKiW; #define INSTANCEP(x, y) (primitive_instanceQ((x), (y)) != DFALSE) /* int FUNCTIONP(D x) { OBJECT* object = (OBJECT*)x; Wrapper* objectwrapper = (Wrapper*)(object->class); OBJECT* objectclass = (OBJECT*)(objectwrapper->class); Wrapper* classwrapper = (Wrapper*)(objectclass->class); return(classwrapper == &KLfunction_classGVKiW); } */ /* **** This assumes the object is indirect and properly headered, so is really **** only useful in limited circumstances, like discriminating between a **** method and an engine-node in a few places where we are wedged. **** If we get instance bits up, it should use those, since depending on the **** metaclass to be something in particular is pretty fragile. */ #define FUNCTIONP(x) \ ( /* ((Wrapper*)(((OBJECT*)(((Wrapper*)(((OBJECT*)(x))->class))->class))->class)) */ \ /* OBJECT_WRAPPER(OBJECT_CLASS(x)) == &KLfunction_classGVKiW */ \ (R((((Wrapper*)OBJECT_WRAPPER(x)))->subtype_mask) & 64) \ ) INLINE D primitive_type_check (D value, D type) { if (type != LobjectGVKd && !INSTANCEP(value, type)) Ktype_check_errorVKiI(value, type); return(value); } extern D Kstack_overflow_errorVKiI(); INLINE void SIMPLE_CALL_CHECK(FN* function) { int stack_marker; ignore(function); /* if (STACK_OK(bottom_of_stack,(unsigned long)(&stack_marker))) { stack_overflowedQ = 1; Kstack_overflow_errorVKiI(); }*/ } extern D Kargument_count_overflow_errorVKiI(D function, D argc); INLINE void CALL_CHECK(FN* function, int argument_count) { SIMPLE_CALL_CHECK(function); if (argument_count > MAX_ARGUMENTS) Kargument_count_overflow_errorVKiI(function, I(argument_count)); } INLINE void TYPE_CHECK_ARG (D specializer, D argument) { primitive_type_check(argument, specializer); } INLINE void TYPE_CHECK_ARGS(D function, int argument_count, D* arguments) { SOV* specs = function_specializers((FN*)function); if (specs) { D* specializers = vector_data(specs); int i; for (i = 0; i < argument_count; i++) TYPE_CHECK_ARG(specializers[i], arguments[i]); } } INLINE void TYPE_CHECK_ARGS_1(D fn, D a1) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); } } INLINE void TYPE_CHECK_ARGS_2(D fn, D a1, D a2) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); } } INLINE void TYPE_CHECK_ARGS_3(D fn, D a1, D a2, D a3) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); TYPE_CHECK_ARG(specializers[2], a3); } } INLINE void TYPE_CHECK_ARGS_4(D fn, D a1, D a2, D a3, D a4) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); TYPE_CHECK_ARG(specializers[2], a3); TYPE_CHECK_ARG(specializers[3], a4); } } INLINE void TYPE_CHECK_ARGS_5(D fn, D a1, D a2, D a3, D a4, D a5) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); TYPE_CHECK_ARG(specializers[2], a3); TYPE_CHECK_ARG(specializers[3], a4); TYPE_CHECK_ARG(specializers[4], a5); } } INLINE void TYPE_CHECK_ARGS_6 (D fn, D a1, D a2, D a3, D a4, D a5, D a6) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); TYPE_CHECK_ARG(specializers[2], a3); TYPE_CHECK_ARG(specializers[3], a4); TYPE_CHECK_ARG(specializers[4], a5); TYPE_CHECK_ARG(specializers[5], a6); } } INLINE void TYPE_CHECK_ARGS_7 (D fn, D a1, D a2, D a3, D a4, D a5, D a6, D a7) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); TYPE_CHECK_ARG(specializers[2], a3); TYPE_CHECK_ARG(specializers[3], a4); TYPE_CHECK_ARG(specializers[4], a5); TYPE_CHECK_ARG(specializers[5], a6); TYPE_CHECK_ARG(specializers[6], a7); } } INLINE void TYPE_CHECK_ARGS_8 (D fn, D a1, D a2, D a3, D a4, D a5, D a6, D a7, D a8) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); TYPE_CHECK_ARG(specializers[2], a3); TYPE_CHECK_ARG(specializers[3], a4); TYPE_CHECK_ARG(specializers[4], a5); TYPE_CHECK_ARG(specializers[5], a6); TYPE_CHECK_ARG(specializers[6], a7); TYPE_CHECK_ARG(specializers[7], a8); } } INLINE void TYPE_CHECK_ARGS_9 (D fn, D a1, D a2, D a3, D a4, D a5, D a6, D a7, D a8, D a9) { SOV* specs = function_specializers((FN*)fn); if (specs) { D* specializers = vector_data(specs); TYPE_CHECK_ARG(specializers[0], a1); TYPE_CHECK_ARG(specializers[1], a2); TYPE_CHECK_ARG(specializers[2], a3); TYPE_CHECK_ARG(specializers[3], a4); TYPE_CHECK_ARG(specializers[4], a5); TYPE_CHECK_ARG(specializers[5], a6); TYPE_CHECK_ARG(specializers[6], a7); TYPE_CHECK_ARG(specializers[7], a8); TYPE_CHECK_ARG(specializers[8], a9); } } extern D Kargument_count_errorVKiI(D function, D argc); INLINE void BASIC_REQUIRED_CALL_CHECK (FN* function, int number_required, int argument_count) { CALL_CHECK(function, argument_count); if (argument_count != number_required) Kargument_count_errorVKiI(function, I(argument_count)); } INLINE void REQUIRED_CALL_CHECK (FN* function, int number_required, int argument_count, D* arguments) { BASIC_REQUIRED_CALL_CHECK(function, number_required, argument_count); TYPE_CHECK_ARGS(function, argument_count, arguments); } INLINE void BASIC_OPTIONAL_CALL_CHECK (FN* function, int number_required, int argument_count) { CALL_CHECK(function, argument_count); if (argument_count < number_required) Kargument_count_errorVKiI(function, I(argument_count)); } INLINE void OPTIONAL_CALL_CHECK (FN* function, int number_required, int argument_count, D* arguments) { BASIC_OPTIONAL_CALL_CHECK(function, number_required, argument_count); TYPE_CHECK_ARGS(function, number_required, arguments); } extern D Kodd_keyword_arguments_errorVKiI(D function, D argc); INLINE void KEYWORD_CALL_CHECK (FN* function, int number_required, int argument_count, D* arguments) { OPTIONAL_CALL_CHECK (function, number_required, argument_count, arguments); if ((argument_count - number_required) & 1) Kodd_keyword_arguments_errorVKiI(function, I(argument_count)); } /* CALLING CONVENTION */ D primitive_xep_apply (FN* fn, int n, D a[]) { DFN xep = fn->xep; Pfunction_ = fn; Pnext_methods_ = DFALSE; switch (n) { case 0: return(xep(fn,n)); case 1: return(xep(fn,n,a[0])); case 2: return(xep(fn,n,a[0],a[1])); case 3: return(xep(fn,n,a[0],a[1],a[2])); case 4: return(xep(fn,n,a[0],a[1],a[2],a[3])); case 5: return(xep(fn,n,a[0],a[1],a[2],a[3],a[4])); case 6: return(xep(fn,n,a[0],a[1],a[2],a[3],a[4],a[5])); case 7: return(xep(fn,n,a[0],a[1],a[2],a[3],a[4],a[5],a[6])); case 8: return(xep(fn,n,a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7])); case 9: return(xep(fn,n,a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8])); default: return(xep(fn,n, a[ 0],a[ 1],a[ 2],a[ 3],a[ 4],a[ 5],a[ 6],a[ 7],a[ 8],a[ 9], a[10],a[11],a[12],a[13],a[14],a[15],a[16],a[17],a[18],a[19], a[20],a[21],a[22],a[23],a[24],a[25],a[26],a[27],a[28],a[29], a[30],a[31],a[32],a[33],a[34],a[35],a[36],a[37],a[38],a[39], a[40],a[41],a[42],a[43],a[44],a[45],a[46],a[47],a[48],a[49], a[50],a[51],a[52],a[53],a[54],a[55],a[56],a[57],a[58],a[59], a[60],a[61],a[62],a[63])); } } /* INLINE int FUNCTION_OK(FN* function) { return(class_meta_class(function_class(function)) == dylanXinternalX_L_function_class_G_); } */ D primitive_xep_call (FN* fn, int n, ...) { int i; va_list ap; va_start(ap,n); for(i=0; imep; D* v = vector_data((SOV*)args); Pnext_methods_ = new_next_methods; Pfunction_ = fn; Pargument_count_ = vector_size((SOV*)args); switch (Pargument_count_) { case 0: return(mep()); case 1: return(mep(v[0])); case 2: return(mep(v[0],v[1])); case 3: return(mep(v[0],v[1],v[2])); case 4: return(mep(v[0],v[1],v[2],v[3])); case 5: return(mep(v[0],v[1],v[2],v[3],v[4])); case 6: return(mep(v[0],v[1],v[2],v[3],v[4],v[5])); case 7: return(mep(v[0],v[1],v[2],v[3],v[4],v[5],v[6])); case 8: return(mep(v[0],v[1],v[2],v[3],v[4],v[5],v[6],v[7])); case 9: return(mep(v[0],v[1],v[2],v[3],v[4],v[5],v[6],v[7],v[8])); default: COPY_WORDS(a, v, Pargument_count_); return(mep(a[ 0],a[ 1],a[ 2],a[ 3],a[ 4],a[ 5],a[ 6],a[ 7],a[ 8],a[ 9], a[10],a[11],a[12],a[13],a[14],a[15],a[16],a[17],a[18],a[19], a[20],a[21],a[22],a[23],a[24],a[25],a[26],a[27],a[28],a[29], a[30],a[31],a[32],a[33],a[34],a[35],a[36],a[37],a[38],a[39], a[40],a[41],a[42],a[43],a[44],a[45],a[46],a[47],a[48],a[49], a[50],a[51],a[52],a[53],a[54],a[55],a[56],a[57],a[58],a[59], a[60],a[61],a[62],a[63])); } } INLINE GFN* parent_gf (D cache_header_or_gf) { while (!FUNCTIONP(cache_header_or_gf)) { cache_header_or_gf = ((CACHEHEADERENGINE*)cache_header_or_gf)->parent; } return((GFN*)cache_header_or_gf); } extern D primitive_engine_node_apply_with_optionals (D engD, D parent, D args); D primitive_engine_node_apply_with_optionals (D engD, D parent, D args) { ENGINE* eng = (ENGINE*)engD; DLFN ep = eng->entry_point; D* a = vector_data((SOV*)args); Pnext_methods_ = parent; Pfunction_ = (D)eng; Pargument_count_ = vector_size((SOV*)args); switch (Pargument_count_) { case 0: return(ep()); case 1: return(ep(a[0])); case 2: return(ep(a[0],a[1])); case 3: return(ep(a[0],a[1],a[2])); case 4: return(ep(a[0],a[1],a[2],a[3])); case 5: return(ep(a[0],a[1],a[2],a[3],a[4])); case 6: return(ep(a[0],a[1],a[2],a[3],a[4],a[5])); case 7: return(ep(a[0],a[1],a[2],a[3],a[4],a[5],a[6])); }; /* Over 7 implementation args, the engine-node calling sequence passes the implementaiton args as a vector, but the engine-node *might* be a method, in which case they have to be spread out again! */ if (FUNCTIONP(eng)) return(primitive_mep_apply_with_optionals((FN*)eng, parent, args)); else return(ep(args)); } D inline_invoke_engine_node (ENGINE* eng, int argcount, ...) { int i; DEF_STACK_VECTOR_INITTED(argvec, Pargument_count_); va_list ap; va_start(ap,argcount); for(i=0; ientry_point)((D)argvec)); } D primitive_engine_node_apply(ENGINE* eng, D parent, D a[]) { GFN* gf = parent_gf(parent); SIG* sig = gf->signature; int number_required = signature_number_required(sig); int argument_count = vector_size((SOV*)a); if (signature_optionals_p(sig)) { /* OPTIONAL_CALL_CHECK(gfn,number_required,argument_count); */ { D* arguments = vector_data((SOV*)a); DEF_STACK_VECTOR_FROM_BUFFER_WITH_SIZE (new_arguments, number_required + 1, arguments, number_required); { int optionals_count = argument_count - number_required; DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); vector_ref_setter(rest_arguments, new_arguments, number_required); return(primitive_engine_node_apply_with_optionals((D)eng, parent, (D*)new_arguments)); }}} else { /* REQUIRED_CALL_CHECK(gfn,number_required,argument_count); */ return(primitive_engine_node_apply_with_optionals((D)eng, parent, a)); }} D primitive_mep_apply (FN* fn, D next_methods, D a[]) { int number_required = function_number_required(fn); int argument_count = vector_size((SOV*)a); if (function_optionals_p(fn)) { /* OPTIONAL_CALL_CHECK(fn,number_required,argument_count); */ { D* arguments = vector_data((SOV*)a); DEF_STACK_VECTOR_FROM_BUFFER_WITH_SIZE (new_arguments, number_required + 1, arguments, number_required); { int optionals_count = argument_count - number_required; DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); vector_ref_setter(rest_arguments, new_arguments, number_required); return(primitive_mep_apply_with_optionals (fn, next_methods, (D*)new_arguments)); }}} else { /* REQUIRED_CALL_CHECK(fn,number_required,argument_count); */ return(primitive_mep_apply_with_optionals(fn, next_methods, a)); }} D iep_apply (DLFN iep, int n, D a[]) { switch (n) { case 0: return(iep()); case 1: return(iep(a[0])); case 2: return(iep(a[0],a[1])); case 3: return(iep(a[0],a[1],a[2])); case 4: return(iep(a[0],a[1],a[2],a[3])); case 5: return(iep(a[0],a[1],a[2],a[3],a[4])); case 6: return(iep(a[0],a[1],a[2],a[3],a[4],a[5])); case 7: return(iep(a[0],a[1],a[2],a[3],a[4],a[5],a[6])); case 8: return(iep(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7])); case 9: return(iep(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8])); default: return(iep(a[ 0],a[ 1],a[ 2],a[ 3],a[ 4],a[ 5],a[ 6],a[ 7],a[ 8],a[ 9], a[10],a[11],a[12],a[13],a[14],a[15],a[16],a[17],a[18],a[19], a[20],a[21],a[22],a[23],a[24],a[25],a[26],a[27],a[28],a[29], a[30],a[31],a[32],a[33],a[34],a[35],a[36],a[37],a[38],a[39], a[40],a[41],a[42],a[43],a[44],a[45],a[46],a[47],a[48],a[49], a[50],a[51],a[52],a[53],a[54],a[55],a[56],a[57],a[58],a[59], a[60],a[61],a[62],a[63])); } } D primitive_iep_apply (FN* fn, int n, D a[]) { Pfunction_ = fn; Pnext_methods_ = DFALSE; return(iep_apply(function_iep(fn), n, a)); } /* required xep's */ D xep_0 (FN* fn, int n) { BASIC_REQUIRED_CALL_CHECK(fn, 0, n); Pfunction_ = fn; Pnext_methods_ = DFALSE; return((function_iep(fn))()); } D xep_1 (FN* fn, int n, D a1) { BASIC_REQUIRED_CALL_CHECK(fn, 1, n); TYPE_CHECK_ARGS_1(fn, a1); Pfunction_ = fn; Pnext_methods_ = DFALSE; return((function_iep(fn))(a1)); } D xep_2 (FN* fn, int n, D a1, D a2) { BASIC_REQUIRED_CALL_CHECK(fn, 2, n); TYPE_CHECK_ARGS_2(fn, a1, a2); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2)); } D xep_3 (FN* fn, int n, D a1, D a2, D a3) { BASIC_REQUIRED_CALL_CHECK(fn, 3, n); TYPE_CHECK_ARGS_3(fn, a1, a2, a3); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3)); } D xep_4 (FN* fn, int n, D a1, D a2, D a3, D a4) { BASIC_REQUIRED_CALL_CHECK(fn, 4, n); TYPE_CHECK_ARGS_4(fn, a1, a2, a3, a4); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4)); } D xep_5 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5) { BASIC_REQUIRED_CALL_CHECK(fn, 5, n); TYPE_CHECK_ARGS_5(fn, a1, a2, a3, a4, a5); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5)); } D xep_6 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6) { BASIC_REQUIRED_CALL_CHECK(fn, 6, n); TYPE_CHECK_ARGS_6(fn, a1, a2, a3, a4, a5, a6); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6)); } D xep_7 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, D a7) { BASIC_REQUIRED_CALL_CHECK(fn, 7, n); TYPE_CHECK_ARGS_7(fn, a1, a2, a3, a4, a5, a6, a7); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6,a7)); } D xep_8 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, D a7, D a8) { BASIC_REQUIRED_CALL_CHECK(fn, 8, n); TYPE_CHECK_ARGS_8(fn, a1, a2, a3, a4, a5, a6, a7, a8); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6,a7,a8)); } D xep_9 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, D a7, D a8, D a9) { BASIC_REQUIRED_CALL_CHECK(fn, 9, n); TYPE_CHECK_ARGS_9(fn, a1, a2, a3, a4, a5, a6, a7, a8, a9); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6,a7,a8,a9)); } D xep (FN* fn, int n, ...) { BUFFER_VARARGS(n, n, arguments); REQUIRED_CALL_CHECK(fn, function_number_required(fn), n, arguments); return(iep_apply(function_iep(fn), n, arguments)); } /* REST XEP'S */ /* numbered by the number of required arguments == # parameters in IEP - 1 */ D rest_xep_0 (FN* fn, int n, ...) { BUFFER_VARARGS(n, n, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 0, n); Pfunction_ = fn; Pnext_methods_ = DFALSE; return((function_iep(fn))(make_vector_from_buffer(n, arguments))); } D rest_xep_1 (FN* fn, int n, D a1, ...) { BUFFER_VARARGS(n - 1, a1, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 1, n); TYPE_CHECK_ARGS_1(fn, a1); Pfunction_ = fn; Pnext_methods_ = DFALSE; return((function_iep(fn))(a1, make_vector_from_buffer(n - 1, arguments))); } D rest_xep_2 (FN* fn, int n, D a1, D a2, ...) { BUFFER_VARARGS(n - 2, a2, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 2, n); TYPE_CHECK_ARGS_2(fn, a1, a2); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,make_vector_from_buffer(n - 2, arguments))); } D rest_xep_3 (FN* fn, int n, D a1, D a2, D a3, ...) { BUFFER_VARARGS(n - 3, a3, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 3, n); TYPE_CHECK_ARGS_3(fn, a1, a2, a3); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,make_vector_from_buffer(n - 3, arguments))); } D rest_xep_4 (FN* fn, int n, D a1, D a2, D a3, D a4, ...) { BUFFER_VARARGS(n - 4, a4, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 4, n); TYPE_CHECK_ARGS_4(fn, a1, a2, a3, a4); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,make_vector_from_buffer(n - 4, arguments))); } D rest_xep_5 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, ...) { BUFFER_VARARGS(n - 5, a5, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 5, n); TYPE_CHECK_ARGS_5(fn, a1, a2, a3, a4, a5); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,make_vector_from_buffer(n - 5, arguments))); } D rest_xep_6 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, ...) { BUFFER_VARARGS(n - 6, a6, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 6, n); TYPE_CHECK_ARGS_6(fn, a1, a2, a3, a4, a5, a6); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6,make_vector_from_buffer(n - 6, arguments))); } D rest_xep_7 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, D a7, ...) { BUFFER_VARARGS(n - 7, a7, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 7, n); TYPE_CHECK_ARGS_7(fn, a1, a2, a3, a4, a5, a6, a7); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6,a7,make_vector_from_buffer(n - 7, arguments))); } D rest_xep_8 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, D a7, D a8, ...) { BUFFER_VARARGS(n - 8, a8, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 8, n); TYPE_CHECK_ARGS_8(fn, a1, a2, a3, a4, a5, a6, a7, a8); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6,a7,a8,make_vector_from_buffer(n - 8, arguments))); } D rest_xep_9 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, D a7, D a8, D a9, ...) { BUFFER_VARARGS(n - 9, a9, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, 9, n); TYPE_CHECK_ARGS_9(fn, a1, a2, a3, a4, a5, a6, a7, a8, a9); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(function_iep(fn)(a1,a2,a3,a4,a5,a6,a7,a8,a9,make_vector_from_buffer(n - 9, arguments))); } D rest_xep (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; D* optional_arguments = &arguments[number_required]; BUFFER_VARARGS(n, n, arguments); OPTIONAL_CALL_CHECK(fn, number_required, n, arguments); COPY_WORDS(new_arguments,arguments,number_required); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, optional_arguments); new_arguments[number_required] = rest_arguments; Pfunction_ = fn; Pnext_methods_ = DFALSE; return(iep_apply(function_iep(fn), number_required + 1, new_arguments)); }} /* ACCESSOR-METHOD XEP'S */ extern D KPslotacc_single_q_instance_getterVKiI(D accmeth, D inst); extern D KPslotacc_single_q_instance_setterVKiI(D value, D accmeth, D inst); extern D KPslotacc_single_q_class_getterVKiI(D accmeth, D inst); extern D KPslotacc_single_q_class_setterVKiI(D value, D accmeth, D inst); extern D KPslotacc_repeated_instance_getterVKiI(D accmeth, D inst, D idx); extern D KPslotacc_repeated_instance_setterVKiI(D value, D accmeth, D inst, D idx); D slotacc_single_q_instance_getter_xep (ACCESSOR* am, int n, D a1) { BASIC_REQUIRED_CALL_CHECK(((FN*)am), 1, n); return(KPslotacc_single_q_instance_getterVKiI(am, a1)); } D slotacc_single_q_instance_setter_xep (ACCESSOR* am, int n, D a1, D a2) { BASIC_REQUIRED_CALL_CHECK(((FN*)am), 2, n); return(KPslotacc_single_q_instance_setterVKiI(am, a1, a2)); } D slotacc_single_q_class_getter_xep (ACCESSOR* am, int n, D a1) { BASIC_REQUIRED_CALL_CHECK(((FN*)am), 1, n); return(KPslotacc_single_q_class_getterVKiI(am, a1)); } D slotacc_single_q_class_setter_xep (ACCESSOR* am, int n, D a1, D a2) { BASIC_REQUIRED_CALL_CHECK(((FN*)am), 2, n); return(KPslotacc_single_q_class_setterVKiI(am, a1, a2)); } D slotacc_repeated_instance_getter_xep (ACCESSOR* am, int n, D a1, D a2) { BASIC_REQUIRED_CALL_CHECK(((FN*)am), 2, n); return(KPslotacc_repeated_instance_getterVKiI(am, a1, a2)); } D slotacc_repeated_instance_setter_xep (ACCESSOR* am, int n, D a1, D a2, D a3) { BASIC_REQUIRED_CALL_CHECK(((FN*)am), 3, n); return(KPslotacc_repeated_instance_setterVKiI(am, a1, a2, a3)); } D primitive_set_accessor_method_xep (D accmeth, D what) { ACCESSOR* am = (ACCESSOR*)accmeth; switch (R(what)) { case 0: am->xep = (DFN)&slotacc_single_q_instance_getter_xep; break; case 1: am->xep = (DFN)&slotacc_single_q_instance_setter_xep; break; case 2: am->xep = (DFN)&slotacc_single_q_class_getter_xep; break; case 3: am->xep = (DFN)&slotacc_single_q_class_setter_xep; break; case 4: am->xep = (DFN)&slotacc_repeated_instance_getter_xep; break; case 5: am->xep = (DFN)&slotacc_repeated_instance_setter_xep; break; }; return((D)am); } /* KEYWORD PROCESSING SUPPORT */ INLINE void default_arguments (int number_required, D* arguments, int number_keywords, D* keyword_specifiers, int keyword_arguments_offset, D* new_arguments) { int i, j; /* copy arguments into staging ground */ for (i=0; i= 0;) { D value = optional_arguments[i--]; D keyword = optional_arguments[i--]; for (j = 0, k = number_required + 1; j < size_keyword_specifiers; k++, j += 2) { D lambda_keyword = keyword_specifiers[j]; if (keyword == lambda_keyword) { new_arguments[k] = value; break; } } } } extern D unknown_keyword_argument_errorVKi(D function, D keyword); INLINE void process_keyword_parameters_into_with_checking (FN* function, int number_required, int number_keywords, D keyword_specifiers[], int argument_count, D arguments[], D new_arguments[]) { int i,j,k; int allow_other_keys_p = function_all_keys_p(function); int size_keyword_specifiers = number_keywords * 2; for (i=argument_count-1; i>=number_required;) { D value = arguments[i--]; D keyword = arguments[i--]; for (j=0,k=number_required;;k++,j+=2) { if (j == size_keyword_specifiers) if (!allow_other_keys_p) unknown_keyword_argument_errorVKi(function, keyword); else break; else { D lambda_keyword = keyword_specifiers[j]; if (keyword == lambda_keyword) { new_arguments[k] = value; break; } } } } } INLINE int process_keyword_call_into (D* new_arguments, FN* function, int argument_count, int number_required, D* required_arguments, int optionals_count, D* optional_arguments, SOV* rest_arguments) { SOV* keyword_specifier_vector = method_keyword_specifiers(function); int number_keywords = vector_size(keyword_specifier_vector) / 2; D* keyword_specifiers = vector_data(keyword_specifier_vector); int new_argument_count = number_required + number_keywords + 1; ignore(argument_count); default_arguments(number_required, required_arguments, number_keywords, keyword_specifiers, number_required + 1, new_arguments); process_keyword_parameters (function, number_required, number_keywords, keyword_specifiers, optionals_count, optional_arguments, new_arguments); new_arguments[number_required] = rest_arguments; return(new_argument_count); } /* TODO: Turn this back into stack allocation. This was a function returning stack allocated data! */ INLINE int process_keyword_call_and_restify_into (D* new_arguments, FN* function, int argument_count, D* arguments, SOV* rest_arguments) { int number_required = function_number_required(function); int optionals_count = argument_count - number_required; KEYWORD_CALL_CHECK(function,number_required,argument_count,arguments); initialize_vector_from_buffer_with_size (rest_arguments, optionals_count, &arguments[number_required], optionals_count); return(process_keyword_call_into (new_arguments, function, argument_count, number_required, arguments, optionals_count, &arguments[number_required], rest_arguments)); } INLINE D* process_keyword_call (FN* function, int argument_count, D* arguments, D rest_arguments) { process_keyword_call_and_restify_into (new_arguments, function, argument_count, arguments, (SOV*)rest_arguments); return(new_arguments); } INLINE D* process_keyword_call_and_n (FN* function, int argument_count, D* arguments, D rest_arguments, int *new_argument_count) { *new_argument_count = process_keyword_call_and_restify_into (new_arguments, function, argument_count, arguments, (SOV*)rest_arguments); return(new_arguments); } /* REST and KEY XEP's */ /* numbered by the total number of parameters in the IEP */ D rest_key_xep_1 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0])); }}} D rest_key_xep_2 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1])); }}} D rest_key_xep_3 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1],a[2])); }}} D rest_key_xep_4 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1],a[2],a[3])); }}} D rest_key_xep_5 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1],a[2],a[3],a[4])); }}} D rest_key_xep_6 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1],a[2],a[3],a[4],a[5])); }}} D rest_key_xep_7 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1],a[2],a[3],a[4],a[5],a[6])); }}} D rest_key_xep_8 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7])); }}} D rest_key_xep_9 (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call(fn, n, arguments, rest_arguments); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(keyword_function_iep(fn)(a[0],a[1],a[2],a[3],a[4],a[5],a[6],a[7],a[8])); }}} D rest_key_xep (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; int new_n; BUFFER_VARARGS(n, n, arguments); KEYWORD_CALL_CHECK(fn, number_required, n, arguments); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); { D* a = process_keyword_call_and_n(fn, n, arguments, rest_arguments, &new_n); Pfunction_ = fn; Pnext_methods_ = DFALSE; return(iep_apply(keyword_function_iep(fn), new_n, a)); }}} /* METHOD ENTRY POINTS -- MEPs */ /* numbered by the total number of parameters in the IEP */ D iep_a[MAX_ARGUMENTS]; D key_mep_1 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0])); }} D key_mep_2 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1])); }} D key_mep_3 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1],iep_a[2])); }} D key_mep_4 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1],iep_a[2],iep_a[3])); }} D key_mep_5 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1],iep_a[2],iep_a[3],iep_a[4])); }} D key_mep_6 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1],iep_a[2],iep_a[3],iep_a[4],iep_a[5])); }} D key_mep_7 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1],iep_a[2],iep_a[3],iep_a[4],iep_a[5],iep_a[6])); }} D key_mep_8 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1],iep_a[2],iep_a[3],iep_a[4],iep_a[5],iep_a[6],iep_a[7])); }} D key_mep_9 (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; process_keyword_call_into (iep_a, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(keyword_function_iep(Pfunction_)(iep_a[0],iep_a[1],iep_a[2],iep_a[3],iep_a[4],iep_a[5],iep_a[6],iep_a[7],iep_a[8])); }} D key_mep (D a1, ...) { int number_required = function_number_required(Pfunction_); a[0] = a1; BUFFER_VARARGS(Pargument_count_ - 1, a1, &a[1]); { SOV* rest = a[number_required]; int new_argument_count = process_keyword_call_into (new_arguments, Pfunction_, Pargument_count_, number_required, a, vector_size(rest), vector_data(rest), rest); return(iep_apply(keyword_function_iep(Pfunction_), new_argument_count, new_arguments)); }} /* NEW GF SUPPORT */ INLINE D gf_iep_0 () { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)()); } INLINE D gf_iep_1 (D a1) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(a1)); } INLINE D gf_iep_2 (D a1, D a2) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(a1, a2)); } INLINE D gf_iep_3 (D a1, D a2, D a3) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(a1, a2, a3)); } INLINE D gf_iep_4 (D a1, D a2, D a3, D a4) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(a1, a2, a3, a4)); } INLINE D gf_iep_5 (D a1, D a2, D a3, D a4, D a5) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(a1, a2, a3, a4, a5)); } INLINE D gf_iep_6 (D a1, D a2, D a3, D a4, D a5, D a6) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(a1, a2, a3, a4, a5, a6)); } INLINE D gf_iep_7 (D a1, D a2, D a3, D a4, D a5, D a6, D a7) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(a1, a2, a3, a4, a5, a6, a7)); } INLINE D gf_iep (D new_arguments) { GFN* gf = (GFN*)Pfunction_; ENGINE* e = gf->engine; /* Unfortunately, due to the vectorization of arguments in this case, we have to check to see if the engine is actually a method in which case we have to invoke it with the args spread. I'm passing the gf as the extra-arg to simulate the "normal" case where the method is blindly invoked. */ if (FUNCTIONP(e)) { return(primitive_mep_apply_with_optionals((FN*)e, (D)gf, new_arguments)); } else { Pnext_methods_ = (D)gf; Pfunction_ = (D)e; return((e->entry_point)(new_arguments)); } } /* GENERIC FUNCTION EXTERNAL ENTRY POINTS -- GF_XEP's */ /* REQ ONLY GF XEP's */ /* numbered by the number of required arguments */ D gf_xep_0 (FN* fn, int n) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 0, n); return(gf_iep_0()); } D gf_xep_1 (FN* fn, int n, D a1) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 1, n); return(gf_iep_1(a1)); } D gf_xep_2 (FN* fn, int n, D a1, D a2) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 2, n); return(gf_iep_2(a1,a2)); } D gf_xep_3 (FN* fn, int n, D a1, D a2, D a3) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 3, n); return(gf_iep_3(a1,a2,a3)); } D gf_xep_4 (FN* fn, int n, D a1, D a2, D a3, D a4) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 4, n); return(gf_iep_4(a1,a2,a3,a4)); } D gf_xep_5 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 5, n); return(gf_iep_5(a1,a2,a3,a4,a5)); } D gf_xep_6 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 6, n); return(gf_iep_6(a1,a2,a3,a4,a5,a6)); } D gf_xep_7 (FN* fn, int n, D a1, D a2, D a3, D a4, D a5, D a6, D a7) { Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, 7, n); return(gf_iep_7(a1,a2,a3,a4,a5,a6,a7)); } D gf_xep (FN* fn, int n, ...) { int number_required = function_number_required(fn); BUFFER_VARARGS(n, n, arguments); Pfunction_ = fn; BASIC_REQUIRED_CALL_CHECK(fn, number_required, n); {DEF_STACK_VECTOR_FROM_BUFFER(new_arguments, number_required, arguments); return(gf_iep(new_arguments)); }} /* OPTIONAL GF XEP's */ /* numbered by the number of required arguments */ D gf_optional_xep_0 (FN* fn, int n, ...) { int optionals_count = n - 0; BASIC_OPTIONAL_CALL_CHECK(fn, 0, n); Pfunction_ = fn; BUFFER_VARARGS(n, n, a); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, &a[0]); a[0] = rest_arguments; return(gf_iep_1(a[0])); }} D gf_optional_xep_1 (FN* fn, int n, ...) { int optionals_count = n - 1; BASIC_OPTIONAL_CALL_CHECK(fn, 1, n); Pfunction_ = fn; BUFFER_VARARGS(n, n, a); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, &a[1]); a[1] = rest_arguments; return(gf_iep_2(a[0], a[1])); }} D gf_optional_xep_2 (FN* fn, int n, ...) { int optionals_count = n - 2; BASIC_OPTIONAL_CALL_CHECK(fn, 2, n); Pfunction_ = fn; BUFFER_VARARGS(n, n, a); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, &a[2]); a[2] = rest_arguments; return(gf_iep_3(a[0],a[1],a[2])); }} D gf_optional_xep_3 (FN* fn, int n, ...) { int optionals_count = n - 3; BASIC_OPTIONAL_CALL_CHECK(fn, 3, n); Pfunction_ = fn; BUFFER_VARARGS(n, n, a); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, &a[3]); a[3] = rest_arguments; return(gf_iep_4(a[0],a[1],a[2],a[3])); }} D gf_optional_xep_4 (FN* fn, int n, ...) { int optionals_count = n - 4; BASIC_OPTIONAL_CALL_CHECK(fn, 4, n); Pfunction_ = fn; BUFFER_VARARGS(n, n, a); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, &a[4]); a[4] = rest_arguments; return(gf_iep_5(a[0],a[1],a[2],a[3],a[4])); }} D gf_optional_xep_5 (FN* fn, int n, ...) { int optionals_count = n - 5; BASIC_OPTIONAL_CALL_CHECK(fn, 5, n); Pfunction_ = fn; BUFFER_VARARGS(n, n, a); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, &a[5]); a[5] = rest_arguments; return(gf_iep_6(a[0],a[1],a[2],a[3],a[4],a[5])); }} D gf_optional_xep_6 (FN* fn, int n, ...) { int optionals_count = n - 6; BASIC_OPTIONAL_CALL_CHECK(fn, 6, n); Pfunction_ = fn; BUFFER_VARARGS(n, n, a); {DEF_STACK_VECTOR_FROM_BUFFER(rest_arguments, optionals_count, &a[6]); a[6] = rest_arguments; return(gf_iep_7(a[0],a[1],a[2],a[3],a[4],a[5],a[6])); }} D gf_optional_xep (FN* fn, int n, ...) { int number_required = function_number_required(fn); int optionals_count = n - number_required; BUFFER_VARARGS(n, n, arguments); BASIC_OPTIONAL_CALL_CHECK(fn, number_required, n); {DEF_STACK_VECTOR_FROM_BUFFER_WITH_SIZE (new_arguments, number_required + 1, arguments, number_required); {DEF_STACK_VECTOR_FROM_BUFFER (rest_arguments, optionals_count, &arguments[number_required]); vector_ref_setter(rest_arguments, new_arguments, number_required); Pfunction_ = fn; return(gf_iep(new_arguments)); }}} /* dynamic setting of gf's entrypoints */ D primitive_set_generic_function_entrypoints(D fn) { D the_xep; FN* function = (FN*)fn; if (function_optionals_p(function)) switch (function_number_required(function)) { case 0: the_xep = gf_optional_xep_0; break; case 1: the_xep = gf_optional_xep_1; break; case 2: the_xep = gf_optional_xep_2; break; case 3: the_xep = gf_optional_xep_3; break; case 4: the_xep = gf_optional_xep_4; break; case 5: the_xep = gf_optional_xep_5; break; case 6: the_xep = gf_optional_xep_6; break; default: the_xep = gf_optional_xep; break; } else switch (function_number_required(function)) { case 0: the_xep = gf_xep_0; break; case 1: the_xep = gf_xep_1; break; case 2: the_xep = gf_xep_2; break; case 3: the_xep = gf_xep_3; break; case 4: the_xep = gf_xep_4; break; case 5: the_xep = gf_xep_5; break; case 6: the_xep = gf_xep_6; break; case 7: the_xep = gf_xep_7; break; default: the_xep = gf_xep; break; } function->xep = (DFN)the_xep; return(function); } D general_engine_node_1_engine (D a1) { ENGINE* e = (ENGINE*)Pfunction_; D parent = Pnext_methods_; return((e->callback)(a1, e, parent)); } D general_engine_node_2_engine (D a1, D a2) { ENGINE* e = (ENGINE*)Pfunction_; D parent = Pnext_methods_; return((e->callback)(a1, a2, e, parent)); } D general_engine_node_3_engine (D a1, D a2, D a3) { ENGINE* e = (ENGINE*)Pfunction_; D parent = Pnext_methods_; DLFN cb = e->callback; return(cb(a1, a2, a3, e, parent)); } D general_engine_node_n_engine (D a1, ...) { ENGINE* e = (ENGINE*)Pfunction_; D parent = Pnext_methods_; GFN* gf = parent_gf(parent); DLFN cb = e->callback; SIG* sig = (SIG*)gf->signature; int nreq = signature_number_required(sig); int impargs = nreq + signature_optionals_p(sig); if (impargs > 7) { /* The calling sequence passes just a vector of MEP args. */ return(cb(a1, e, parent)); } else { /* The args are spread, last one may be a rest vector. */ va_list ap; DEF_STACK_VECTOR_INITTED(svec, impargs); D* svdata = vector_data(svec); if (impargs > 0) { int i; svdata[0] = a1; va_start(ap, a1); for(i=1; icallback; SIG* sig = (SIG*)gf->signature; int nreq = signature_number_required(sig); int impargs = nreq + signature_optionals_p(sig); if (nreq != impargs) { /* If there's optionals, we will need to make a new vector and spread them out. */ if (impargs > 7) { /* All the args are in a stack vector, the last of which is the optionals... */ SOV* mepargvec = (SOV*)a1; D* mepargdata = vector_data(mepargvec); SOV* optargvec = (SOV*)mepargdata[nreq]; D* optargdata = vector_data(optargvec); int nopts = vector_size(optargvec); DEF_STACK_VECTOR_INITTED(svec, nreq + nopts); D* svdata = vector_data(svec); int i; for(i=0; i 7) { /* We have a vector of MEP args, and no optionals, so just use that vector. */ return(cb(a1, e, parent)); } else { /* No optionals, args are spread, copy them into a vector. */ va_list ap; DEF_STACK_VECTOR_INITTED(svec, nreq); D* svdata = vector_data(svec); if (nreq > 0) { int i; svdata[0] = a1; va_start(ap, a1); for(i=1; iproperties)) >> SLOTENGINE_V_INDEX); D slot_value = primitive_initialized_slot_value(object, idx); if (UNBOUND_P(slot_value)) { return(UNBOUND_INSTANCE_SLOT(object, I(idx))); } else { return(slot_value); } } D boxed_instance_slot_setter_engine (D newval, D object) { ENGINE* e = (ENGINE*)Pfunction_; int baseidx = (int)(((DADDR)(e->properties)) >> SLOTENGINE_V_INDEX); primitive_slot_value_setter(newval, object, baseidx); return(newval); } D boxed_repeated_instance_slot_getter_engine (D object, D idx) { ENGINE* e = (ENGINE*)Pfunction_; int baseidx = (int)(((DADDR)(e->properties)) >> SLOTENGINE_V_INDEX); int size = primitive_repeated_instance_size(object, baseidx); int ridx = R(idx); if (ridx >= 0 && ridx < size) { D slot_value = primitive_repeated_slot_value(object, baseidx, ridx); if (UNBOUND_P(slot_value)) { return(UNBOUND_REPEATED_SLOT(object, idx)); } else { return(slot_value); } } else { return(REPEATED_GETTER_OOR(object, idx)); } } D boxed_repeated_instance_slot_setter_engine (D newval, D object, D idx) { ENGINE* e = (ENGINE*)Pfunction_; int baseidx = (int)(((DADDR)(e->properties)) >> SLOTENGINE_V_INDEX); int size = primitive_repeated_instance_size(object, baseidx); int ridx = R(idx); if (ridx >= 0 && ridx < size) { primitive_repeated_slot_value_setter(newval, object, baseidx, ridx); return(newval); } else { return(REPEATED_SETTER_OOR(newval, object, idx)); } } D raw_byte_repeated_instance_slot_getter_engine (D object, D idx) { ENGINE* e = (ENGINE*)Pfunction_; int baseidx = (int)(((DADDR)(e->properties)) >> SLOTENGINE_V_INDEX); int size = primitive_repeated_instance_size(object, baseidx); int ridx = R(idx); if (ridx >= 0 && ridx < size) { return(C(primitive_byte_element(object, baseidx, ridx))); } else { return(REPEATED_GETTER_OOR(object, idx)); } } D raw_byte_repeated_instance_slot_setter_engine (D newval, D object, D idx) { ENGINE* e = (ENGINE*)Pfunction_; int baseidx = (int)(((DADDR)(e->properties)) >> SLOTENGINE_V_INDEX); int size = primitive_repeated_instance_size(object, baseidx); int ridx = R(idx); if (ridx >= 0 && ridx < size) { primitive_byte_element_setter((DBCHR)R(newval), object, baseidx, ridx); return(newval); } else { return(REPEATED_SETTER_OOR(newval, object, idx)); } } /* **************************************************************** */ #define PARAMTEMPLATE0 #define PARAMTEMPLATE1 D a1 #define PARAMTEMPLATE2 D a1, D a2 #define PARAMTEMPLATE3 D a1, D a2, D a3 #define PARAMTEMPLATE4 D a1, D a2, D a3, D a4 #define PARAMTEMPLATE5 D a1, D a2, D a3, D a4, D a5 #define PARAMTEMPLATE6 D a1, D a2, D a3, D a4, D a5, D a6 #define PARAMTEMPLATE7 D a1, D a2, D a3, D a4, D a5, D a6, D a7 #define ARGTEMPLATE0 #define ARGTEMPLATE1 a1 #define ARGTEMPLATE2 a1, a2 #define ARGTEMPLATE3 a1, a2, a3 #define ARGTEMPLATE4 a1, a2, a3, a4 #define ARGTEMPLATE5 a1, a2, a3, a4, a5 #define ARGTEMPLATE6 a1, a2, a3, a4, a5, a6 #define ARGTEMPLATE7 a1, a2, a3, a4, a5, a6, a7 #define TYPETEMPLATE0 #define TYPETEMPLATE1 D #define TYPETEMPLATE2 D, D #define TYPETEMPLATE3 D, D, D #define TYPETEMPLATE4 D, D, D, D #define TYPETEMPLATE5 D, D, D, D, D #define TYPETEMPLATE6 D, D, D, D, D, D #define TYPETEMPLATE7 D, D, D, D, D, D, D #define PARAMTEMPLATEPREFIX0 #define PARAMTEMPLATEPREFIX1 D a1, #define PARAMTEMPLATEPREFIX2 D a1, D a2, #define PARAMTEMPLATEPREFIX3 D a1, D a2, D a3, #define PARAMTEMPLATEPREFIX4 D a1, D a2, D a3, D a4, #define PARAMTEMPLATEPREFIX5 D a1, D a2, D a3, D a4, D a5, #define PARAMTEMPLATEPREFIX6 D a1, D a2, D a3, D a4, D a5, D a6, #define PARAMTEMPLATEPREFIX7 D a1, D a2, D a3, D a4, D a5, D a6, D a7, #define ARGTEMPLATEPREFIX0 #define ARGTEMPLATEPREFIX1 a1, #define ARGTEMPLATEPREFIX2 a1, a2, #define ARGTEMPLATEPREFIX3 a1, a2, a3, #define ARGTEMPLATEPREFIX4 a1, a2, a3, a4, #define ARGTEMPLATEPREFIX5 a1, a2, a3, a4, a5, #define ARGTEMPLATEPREFIX6 a1, a2, a3, a4, a5, a6, #define ARGTEMPLATEPREFIX7 a1, a2, a3, a4, a5, a6, a7, #define PARAMTEMPLATESUFFIX0 #define PARAMTEMPLATESUFFIX1 D a1 #define PARAMTEMPLATESUFFIX2 D a1, D a2 #define PARAMTEMPLATESUFFIX3 D a1, D a2, D a3 #define PARAMTEMPLATESUFFIX4 D a1, D a2, D a3, D a4 #define PARAMTEMPLATESUFFIX5 D a1, D a2, D a3, D a4, D a5 #define PARAMTEMPLATESUFFIX6 D a1, D a2, D a3, D a4, D a5, D a6 #define PARAMTEMPLATESUFFIX7 D a1, D a2, D a3, D a4, D a5, D a6, D a7 #define ARGTEMPLATESUFFIX0 #define ARGTEMPLATESUFFIX1 , a1 #define ARGTEMPLATESUFFIX2 , a1, a2 #define ARGTEMPLATESUFFIX3 , a1, a2, a3 #define ARGTEMPLATESUFFIX4 , a1, a2, a3, a4 #define ARGTEMPLATESUFFIX5 , a1, a2, a3, a4, a5 #define ARGTEMPLATESUFFIX6 , a1, a2, a3, a4, a5, a6 #define ARGTEMPLATESUFFIX7 , a1, a2, a3, a4, a5, a6, a7 #define ARGUMENTNAME1 a1 #define ARGUMENTNAME2 a2 #define ARGUMENTNAME3 a3 #define ARGUMENTNAME4 a4 #define ARGUMENTNAME5 a5 #define ARGUMENTNAME6 a6 #define ARGUMENTNAME7 a7 #define KLUDGEARGS0(_gubble) #define KLUDGEARGS1(_gubble) \ _gubble(0, a1) #define KLUDGEARGS2(_gubble) \ _gubble(0, a1); \ _gubble(1, a2) #define KLUDGEARGS3(_gubble) \ _gubble(0, a1); \ _gubble(1, a2); \ _gubble(2, a3) #define KLUDGEARGS4(_gubble) \ _gubble(0, a1); \ _gubble(1, a2); \ _gubble(2, a3); \ _gubble(3, a4) #define KLUDGEARGS5(_gubble) \ _gubble(0, a1); \ _gubble(1, a2); \ _gubble(2, a3); \ _gubble(3, a4); \ _gubble(4, a5) #define KLUDGEARGS6(_gubble) \ _gubble(0, a1); \ _gubble(1, a2); \ _gubble(2, a3); \ _gubble(3, a4); \ _gubble(4, a5); \ _gubble(5, a6) #define KLUDGEARGS7(_gubble) \ _gubble(0, a1); \ _gubble(1, a2); \ _gubble(2, a3); \ _gubble(3, a4); \ _gubble(4, a5); \ _gubble(5, a6); \ _gubble(6, a7) #define DEFERDECLARE extern /* SINGLE METHOD ENGINE NODES These are used to invoke a method with a specific next-method list. The method is in data_1, the next-method data in data_2. We use a different routine for different number of implementation args; i.e. single_method_engine_3 is used by a function of 3 required args, or of 2 required + optionals. */ #define DEFINE_SINGLE_METHOD_ENGINE(_nparams) \ D single_method_engine_##_nparams (PARAMTEMPLATE##_nparams) { \ SINGLEMETHODENGINE* e = (SINGLEMETHODENGINE*)Pfunction_; \ FN* meth = (FN*)e->meth; \ DLFN mep = ((FN*)meth)->mep; \ Pfunction_ = meth; \ Pnext_methods_ = e->data; \ return(mep(ARGTEMPLATE##_nparams)); \ } DEFINE_SINGLE_METHOD_ENGINE(0) DEFINE_SINGLE_METHOD_ENGINE(1) DEFINE_SINGLE_METHOD_ENGINE(2) DEFINE_SINGLE_METHOD_ENGINE(3) DEFINE_SINGLE_METHOD_ENGINE(4) DEFINE_SINGLE_METHOD_ENGINE(5) DEFINE_SINGLE_METHOD_ENGINE(6) DEFINE_SINGLE_METHOD_ENGINE(7) D single_method_engine_n (D impargvec) { SINGLEMETHODENGINE* e = (SINGLEMETHODENGINE*)Pfunction_; return(primitive_mep_apply_with_optionals(e->meth, e->data, impargvec)); } D check_explicit_kwds (SOV* optionals, SOV* kwds, int kwdskip) { D* optdata = vector_data(optionals); int optsize = vector_size(optionals); D* kwddata = vector_data(kwds); int kwdsize = vector_size(kwds); if (optsize & 1 != 0) { return(DFALSE); } else { int i; int j; for(i=0; ikeywords, 1) #define CHECK_KEYWORDS_implicit(_optionals, _meth, _e) \ check_explicit_kwds((_optionals), ((KFN*)(_meth))->keyword_specifiers, 2) #define CHECK_KEYWORDS_unrestricted(_optionals, _meth, _e) \ check_unrestricted_kwds(_optionals) #define INITMYARGVEC(argnum_, arg_) _argvec_data[argnum_] = arg_ extern D Kodd_number_of_keyword_args_trapVKeI(D gfargs, D gf, D engine); extern D Kinvalid_keyword_trapVKeI(D gfargs, D gf, D engine, D badkwd, D keys, D implicitp); #define INVALID_KEYWORD_explicit(invgf_, invargvec_, invbadkwd_, invmeth_, invengine_) \ ( ( (invbadkwd_) == DFALSE) ? \ Kodd_number_of_keyword_args_trapVKeI((invargvec_), (invgf_), (invengine_)) \ : \ Kinvalid_keyword_trapVKeI((invargvec_), (invgf_), (invengine_), (invbadkwd_), \ (invengine_)->keywords, DFALSE)) #define INVALID_KEYWORD_implicit(invgf_, invargvec_, invbadkwd_, invmeth_, invengine_) \ ( ((invbadkwd_) == DFALSE) ? \ Kodd_number_of_keyword_args_trapVKeI((invargvec_), (invgf_), (invengine_)) \ : \ Kinvalid_keyword_trapVKeI((invargvec_), (invgf_), (invengine_), (invbadkwd_), \ ((KFN*)(invengine_)->meth)->keyword_specifiers, \ DTRUE)) #define INVALID_KEYWORD_unrestricted(invgf_, invargvec_, invbadkwd_, invmeth_, invengine_) \ ( ((invbadkwd_) == DFALSE) ? \ Kodd_number_of_keyword_args_trapVKeI((invargvec_), (invgf_), (invengine_)) \ : \ Kinvalid_keyword_trapVKeI((invargvec_), (invgf_), (invengine_), (invbadkwd_), \ DFALSE, DFALSE)) #define DEFINE_KEYED_SINGLE_METHOD_ENGINE(_how, _nparams) \ D _how##_keyed_single_method_engine_##_nparams (PARAMTEMPLATEPREFIX##_nparams SOV* optionals) \ { SINGLEMETHODENGINE* e = (SINGLEMETHODENGINE*)Pfunction_; \ D parent = Pnext_methods_; \ FN* meth = (FN*)e->meth; \ D badkwd; \ badkwd = CHECK_KEYWORDS_##_how(optionals, meth, e); \ if (badkwd == NULL) { \ Pfunction_ = meth; \ Pnext_methods_ = e->data; \ return((((FN*)meth)->mep)(ARGTEMPLATEPREFIX##_nparams optionals)); \ } else { \ int _argvecsize = _nparams + 1; \ DEF_STACK_VECTOR_INITTED(_argvec, _argvecsize); \ D* _argvec_data = vector_data(_argvec); \ KLUDGEARGS##_nparams(INITMYARGVEC ); \ _argvec_data[_nparams] = optionals; \ return(INVALID_KEYWORD_##_how(parent_gf(parent), _argvec, badkwd, meth, e)); \ } \ } #define DEFINE_KEYED_SINGLE_METHOD_ENGINE_UNSPREAD(_how) \ D _how##_keyed_single_method_engine_n (SOV* mepargvec) \ { SINGLEMETHODENGINE* e = (SINGLEMETHODENGINE*)Pfunction_; \ D parent = Pnext_methods_; \ FN* meth = (FN*)e->meth; \ D badkwd; \ int nimpargs = vector_size(mepargvec); \ badkwd = CHECK_KEYWORDS_##_how(vector_ref(mepargvec, nimpargs-1), meth, e); \ if (badkwd == NULL) { \ return(primitive_mep_apply_with_optionals(meth, e->data, (D)mepargvec)); \ } else { \ return(INVALID_KEYWORD_##_how(parent_gf(parent), mepargvec, badkwd, meth, e)); \ } \ } DEFINE_KEYED_SINGLE_METHOD_ENGINE_UNSPREAD(explicit) DEFINE_KEYED_SINGLE_METHOD_ENGINE_UNSPREAD(implicit) DEFINE_KEYED_SINGLE_METHOD_ENGINE_UNSPREAD(unrestricted) DEFINE_KEYED_SINGLE_METHOD_ENGINE(explicit, 0) DEFINE_KEYED_SINGLE_METHOD_ENGINE(explicit, 1) DEFINE_KEYED_SINGLE_METHOD_ENGINE(explicit, 2) DEFINE_KEYED_SINGLE_METHOD_ENGINE(explicit, 3) DEFINE_KEYED_SINGLE_METHOD_ENGINE(explicit, 4) DEFINE_KEYED_SINGLE_METHOD_ENGINE(explicit, 5) DEFINE_KEYED_SINGLE_METHOD_ENGINE(explicit, 6) DEFINE_KEYED_SINGLE_METHOD_ENGINE(implicit, 0) DEFINE_KEYED_SINGLE_METHOD_ENGINE(implicit, 1) DEFINE_KEYED_SINGLE_METHOD_ENGINE(implicit, 2) DEFINE_KEYED_SINGLE_METHOD_ENGINE(implicit, 3) DEFINE_KEYED_SINGLE_METHOD_ENGINE(implicit, 4) DEFINE_KEYED_SINGLE_METHOD_ENGINE(implicit, 5) DEFINE_KEYED_SINGLE_METHOD_ENGINE(implicit, 6) DEFINE_KEYED_SINGLE_METHOD_ENGINE(unrestricted, 0) DEFINE_KEYED_SINGLE_METHOD_ENGINE(unrestricted, 1) DEFINE_KEYED_SINGLE_METHOD_ENGINE(unrestricted, 2) DEFINE_KEYED_SINGLE_METHOD_ENGINE(unrestricted, 3) DEFINE_KEYED_SINGLE_METHOD_ENGINE(unrestricted, 4) DEFINE_KEYED_SINGLE_METHOD_ENGINE(unrestricted, 5) DEFINE_KEYED_SINGLE_METHOD_ENGINE(unrestricted, 6) /* **************************************************************** */ /* A "cache-header" entry is an entrypoint for use by a cache header of some type, which has had its "next" slot (in data_1) filled in. There may be an issue of it being possible for this to be a method in addition to another engine-node, but for the simple caching I'm imagining now that would be nonsensical. (This is only an issue for the C backend anyway, just as it's an issue for various discriminators.) */ #define DEFINE_CACHE_HEADER_ENGINE(_nparams) \ D cache_header_engine_##_nparams (PARAMTEMPLATE##_nparams) { \ CACHEHEADERENGINE* e = (CACHEHEADERENGINE*)Pfunction_; \ ENGINE* nxt = (ENGINE*)e->nextnode; \ DLFN entrypt = nxt->entry_point; \ Pfunction_ = (FN*)nxt; \ Pnext_methods_ = (D)e; \ return(entrypt(ARGTEMPLATE##_nparams)); \ } extern D cache_header_engine_0 (); extern D cache_header_engine_1 (D a1); extern D cache_header_engine_2 (D a1, D a2); extern D cache_header_engine_3 (D a1, D a2, D a3); extern D cache_header_engine_4 (D a1, D a2, D a3, D a4); extern D cache_header_engine_5 (D a1, D a2, D a3, D a4, D a5); extern D cache_header_engine_6 (D a1, D a2, D a3, D a4, D a5, D a6); extern D cache_header_engine_7 (D a1, D a2, D a3, D a4, D a5, D a6, D a7); extern D cache_header_engine_n (D argvec); DEFINE_CACHE_HEADER_ENGINE(0) DEFINE_CACHE_HEADER_ENGINE(1) DEFINE_CACHE_HEADER_ENGINE(2) DEFINE_CACHE_HEADER_ENGINE(3) DEFINE_CACHE_HEADER_ENGINE(4) DEFINE_CACHE_HEADER_ENGINE(5) DEFINE_CACHE_HEADER_ENGINE(6) DEFINE_CACHE_HEADER_ENGINE(7) D cache_header_engine_n (D theargvec) { SOV* argvec = (SOV*)theargvec; CACHEHEADERENGINE* e = (CACHEHEADERENGINE*)Pfunction_; ENGINE* newengine = (ENGINE*)(e->nextnode); if (FUNCTIONP(newengine)) { return(primitive_mep_apply_with_optionals((FN*)newengine, (D)e, argvec)); } else { Pfunction_ = (FN*)newengine; Pnext_methods_ = (D)e; return((newengine->entry_point)(argvec)); } } #define DEFINE_PROFILING_CACHE_HEADER_ENGINE(_nparams) \ D profiling_cache_header_engine_##_nparams (PARAMTEMPLATE##_nparams) { \ PROFILINGCACHEHEADERENGINE* e = (PROFILINGCACHEHEADERENGINE*)Pfunction_; \ ENGINE* nxt = (ENGINE*)e->nextnode; \ DLFN entrypt = nxt->entry_point; \ Pfunction_ = (FN*)nxt; \ Pnext_methods_ = (D)e; \ e->count1 += 4; \ if ((D)(e->count1) == I(0)) e->count2 += 4; \ return(entrypt(ARGTEMPLATE##_nparams)); \ } extern D profiling_cache_header_engine_0 (); extern D profiling_cache_header_engine_1 (D a1); extern D profiling_cache_header_engine_2 (D a1, D a2); extern D profiling_cache_header_engine_3 (D a1, D a2, D a3); extern D profiling_cache_header_engine_4 (D a1, D a2, D a3, D a4); extern D profiling_cache_header_engine_5 (D a1, D a2, D a3, D a4, D a5); extern D profiling_cache_header_engine_6 (D a1, D a2, D a3, D a4, D a5, D a6); extern D profiling_cache_header_engine_7 (D a1, D a2, D a3, D a4, D a5, D a6, D a7); extern D profiling_cache_header_engine_n (D argvec); DEFINE_PROFILING_CACHE_HEADER_ENGINE(0) DEFINE_PROFILING_CACHE_HEADER_ENGINE(1) DEFINE_PROFILING_CACHE_HEADER_ENGINE(2) DEFINE_PROFILING_CACHE_HEADER_ENGINE(3) DEFINE_PROFILING_CACHE_HEADER_ENGINE(4) DEFINE_PROFILING_CACHE_HEADER_ENGINE(5) DEFINE_PROFILING_CACHE_HEADER_ENGINE(6) DEFINE_PROFILING_CACHE_HEADER_ENGINE(7) D profiling_cache_header_engine_n (D theargvec) { SOV* argvec = (SOV*)theargvec; CACHEHEADERENGINE* e = (CACHEHEADERENGINE*)Pfunction_; ENGINE* newengine = (ENGINE*)(e->nextnode); if (FUNCTIONP(newengine)) { return(primitive_mep_apply_with_optionals((FN*)newengine, (D)e, argvec)); } else { Pfunction_ = (FN*)newengine; Pnext_methods_ = (D)e; return((newengine->entry_point)(argvec)); } } D primitive_enable_cache_header_engine_node (D engine, D genfun) { ENGINE* e = (ENGINE*)engine; GFN* gf = (GFN*)genfun; SIG* sig = (SIG*)gf->signature; DUMINT props = (DUMINT)e->properties; DUMINT etype = (props & EPROPS_M_ENTRY_TYPE) >> EPROPS_V_ENTRY_TYPE; switch (etype) { case ENGINE_cache_header: { switch (signature_number_required(sig) + signature_optionals_p(sig)) { case 0: e->entry_point = (DLFN)&cache_header_engine_0; break; case 1: e->entry_point = (DLFN)&cache_header_engine_1; break; case 2: e->entry_point = (DLFN)&cache_header_engine_2; break; case 3: e->entry_point = (DLFN)&cache_header_engine_3; break; case 4: e->entry_point = (DLFN)&cache_header_engine_4; break; case 5: e->entry_point = (DLFN)&cache_header_engine_5; break; case 6: e->entry_point = (DLFN)&cache_header_engine_6; break; case 7: e->entry_point = (DLFN)&cache_header_engine_7; break; }; break; } case ENGINE_profiling_cache_header: { switch (signature_number_required(sig) + signature_optionals_p(sig)) { case 0: e->entry_point = (DLFN)&profiling_cache_header_engine_0; break; case 1: e->entry_point = (DLFN)&profiling_cache_header_engine_1; break; case 2: e->entry_point = (DLFN)&profiling_cache_header_engine_2; break; case 3: e->entry_point = (DLFN)&profiling_cache_header_engine_3; break; case 4: e->entry_point = (DLFN)&profiling_cache_header_engine_4; break; case 5: e->entry_point = (DLFN)&profiling_cache_header_engine_5; break; case 6: e->entry_point = (DLFN)&profiling_cache_header_engine_6; break; case 7: e->entry_point = (DLFN)&profiling_cache_header_engine_7; break; }; break; } } return(engine); } D primitive_invalidate_cache_engine_node (D engine, D genfun) { ignore(genfun); ((ENGINE*)engine)->entry_point = (DLFN)&general_engine_node_n_engine; return(engine); } /* **************************************************************** */ D primitive_initialize_engine_node (D engine) { ENGINE* eng = (ENGINE*)engine; DUMINT props = (DUMINT)eng->properties; DUMINT etype = (props & EPROPS_M_ENTRY_TYPE) >> EPROPS_V_ENTRY_TYPE; switch (etype) { case ENGINE_absent: eng->entry_point = (DLFN)general_engine_node_n_engine; break; case ENGINE_ambiguous_methods: case ENGINE_inapplicable: eng->entry_point = (DLFN)general_engine_node_spread_engine; break; case ENGINE_unkeyed_single_method: case ENGINE_implicit_keyed_single_method: case ENGINE_explicit_keyed_single_method: case ENGINE_unrestricted_keyed_single_method: { SINGLEMETHODENGINE* e = (SINGLEMETHODENGINE*)eng; FN* meth = (FN*)e->meth; SIG* sig = (SIG*)meth->signature; int nreq = signature_number_required(sig); int impargs = nreq + signature_optionals_p(sig); switch (etype) { case ENGINE_unkeyed_single_method: { switch (impargs) { case 0: e->entry_point = (DLFN)single_method_engine_0; break; case 1: e->entry_point = (DLFN)single_method_engine_1; break; case 2: e->entry_point = (DLFN)single_method_engine_2; break; case 3: e->entry_point = (DLFN)single_method_engine_3; break; case 4: e->entry_point = (DLFN)single_method_engine_4; break; case 5: e->entry_point = (DLFN)single_method_engine_5; break; case 6: e->entry_point = (DLFN)single_method_engine_6; break; case 7: e->entry_point = (DLFN)single_method_engine_7; break; default: e->entry_point = (DLFN)single_method_engine_n; break; } break; } case ENGINE_explicit_keyed_single_method: { switch (nreq) { case 0: e->entry_point = (DLFN)explicit_keyed_single_method_engine_0; break; case 1: e->entry_point = (DLFN)explicit_keyed_single_method_engine_1; break; case 2: e->entry_point = (DLFN)explicit_keyed_single_method_engine_2; break; case 3: e->entry_point = (DLFN)explicit_keyed_single_method_engine_3; break; case 4: e->entry_point = (DLFN)explicit_keyed_single_method_engine_4; break; case 5: e->entry_point = (DLFN)explicit_keyed_single_method_engine_5; break; case 6: e->entry_point = (DLFN)explicit_keyed_single_method_engine_6; break; default: e->entry_point = (DLFN)explicit_keyed_single_method_engine_n; break; } break; } case ENGINE_implicit_keyed_single_method: { switch (nreq) { case 0: e->entry_point = (DLFN)implicit_keyed_single_method_engine_0; break; case 1: e->entry_point = (DLFN)implicit_keyed_single_method_engine_1; break; case 2: e->entry_point = (DLFN)implicit_keyed_single_method_engine_2; break; case 3: e->entry_point = (DLFN)implicit_keyed_single_method_engine_3; break; case 4: e->entry_point = (DLFN)implicit_keyed_single_method_engine_4; break; case 5: e->entry_point = (DLFN)implicit_keyed_single_method_engine_5; break; case 6: e->entry_point = (DLFN)implicit_keyed_single_method_engine_6; break; default: e->entry_point = (DLFN)implicit_keyed_single_method_engine_n; break; } break; } case ENGINE_unrestricted_keyed_single_method: { switch (nreq) { case 0: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_0; break; case 1: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_1; break; case 2: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_2; break; case 3: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_3; break; case 4: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_4; break; case 5: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_5; break; case 6: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_6; break; default: e->entry_point = (DLFN)unrestricted_keyed_single_method_engine_n; break; } break; } } break; } case ENGINE_reserved_terminal_n_a: case ENGINE_reserved_terminal_n_b: case ENGINE_reserved_terminal_n_c: case ENGINE_reserved_terminal_n_d: case ENGINE_reserved_terminal_n_e: case ENGINE_reserved_terminal_n_f: case ENGINE_reserved_terminal_n_g: case ENGINE_profiling_cache_header: case ENGINE_cache_header: primitive_enable_cache_header_engine_node(eng, parent_gf(eng)); /* eng->entry_point = (DLFN)general_engine_node_n_engine; */ break; case ENGINE_boxed_instance_slot_getter: eng->entry_point = (DLFN)boxed_instance_slot_getter_engine; break; case ENGINE_boxed_instance_slot_setter: eng->entry_point = (DLFN)boxed_instance_slot_setter_engine; break; case ENGINE_boxed_repeated_instance_slot_getter: eng->entry_point = (DLFN)boxed_repeated_instance_slot_getter_engine; break; case ENGINE_boxed_repeated_instance_slot_setter: eng->entry_point = (DLFN)boxed_repeated_instance_slot_setter_engine; break; case ENGINE_raw_byte_repeated_instance_slot_getter: eng->entry_point = (DLFN)raw_byte_repeated_instance_slot_getter_engine; break; case ENGINE_raw_byte_repeated_instance_slot_setter: eng->entry_point = (DLFN)raw_byte_repeated_instance_slot_setter_engine; break; case ENGINE_boxed_class_slot_getter: case ENGINE_reserved_slot_a_getter: case ENGINE_reserved_slot_b_getter: eng->entry_point = (DLFN)general_engine_node_1_engine; break; case ENGINE_reserved_slot_a_setter: case ENGINE_reserved_slot_b_setter: case ENGINE_boxed_class_slot_setter: case ENGINE_reserved_repeated_slot_a_getter: case ENGINE_reserved_repeated_slot_b_getter: eng->entry_point = (DLFN)general_engine_node_2_engine; break; case ENGINE_reserved_repeated_slot_a_setter: case ENGINE_reserved_repeated_slot_b_setter: eng->entry_point = (DLFN)general_engine_node_3_engine; break; default: /* FMH */ ; } return(engine); } /* **************************************************************** */ #define DEFINE_DISCRIMINATOR_ENGINE(_argnum, _nargs) \ D discriminate_engine_##_argnum##_##_nargs (PARAMTEMPLATE##_nargs) { \ ENGINE* d_ = (ENGINE*)Pfunction_; \ D parent_ = Pnext_methods_; \ DLFN cb_ = d_->callback; \ ENGINE* newengine_ = (ENGINE*)(cb_((ARGUMENTNAME##_argnum), parent_, d_)); \ DLFN ncb_ = newengine_->entry_point; \ Pfunction_ = (FN*)newengine_; \ Pnext_methods_ = parent_; \ return(ncb_(ARGTEMPLATE##_nargs)); \ } DEFINE_DISCRIMINATOR_ENGINE(1, 1) DEFINE_DISCRIMINATOR_ENGINE(1, 2) DEFINE_DISCRIMINATOR_ENGINE(1, 3) DEFINE_DISCRIMINATOR_ENGINE(1, 4) DEFINE_DISCRIMINATOR_ENGINE(1, 5) DEFINE_DISCRIMINATOR_ENGINE(1, 6) DEFINE_DISCRIMINATOR_ENGINE(1, 7) DEFINE_DISCRIMINATOR_ENGINE(2, 2) DEFINE_DISCRIMINATOR_ENGINE(2, 3) DEFINE_DISCRIMINATOR_ENGINE(2, 4) DEFINE_DISCRIMINATOR_ENGINE(2, 5) DEFINE_DISCRIMINATOR_ENGINE(2, 6) DEFINE_DISCRIMINATOR_ENGINE(2, 7) DEFINE_DISCRIMINATOR_ENGINE(3, 3) DEFINE_DISCRIMINATOR_ENGINE(3, 4) DEFINE_DISCRIMINATOR_ENGINE(3, 5) DEFINE_DISCRIMINATOR_ENGINE(3, 6) DEFINE_DISCRIMINATOR_ENGINE(3, 7) DEFINE_DISCRIMINATOR_ENGINE(4, 4) DEFINE_DISCRIMINATOR_ENGINE(4, 5) DEFINE_DISCRIMINATOR_ENGINE(4, 6) DEFINE_DISCRIMINATOR_ENGINE(4, 7) DEFINE_DISCRIMINATOR_ENGINE(5, 5) DEFINE_DISCRIMINATOR_ENGINE(5, 6) DEFINE_DISCRIMINATOR_ENGINE(5, 7) DEFINE_DISCRIMINATOR_ENGINE(6, 6) DEFINE_DISCRIMINATOR_ENGINE(6, 7) DEFINE_DISCRIMINATOR_ENGINE(7, 7) D discriminate_engine_n_n (SOV* args) { ENGINE* e = (ENGINE*)Pfunction_; D parent = Pnext_methods_; DLFN cb = e->callback; long props = (long)e->properties; long argnum = (props >> 8) & 0xFF; D* a = vector_data(args); D arg = a[argnum]; ENGINE* newengine = (ENGINE*)(cb(arg, parent, e)); if (FUNCTIONP(newengine)) { return(primitive_mep_apply_with_optionals((FN*)newengine, parent, args)); } else { Pfunction_ = (FN*)newengine; Pnext_methods_ = parent; return((newengine->entry_point)(args)); } } /* ---------------------------------------------- */ extern D Dabsent_engine_nodeVKg; extern D Ddirect_object_mm_wrappersVKi; #define MONO_WRAPPER_KEY(x) \ (TAGGEDQ(x) ? ((D*)Ddirect_object_mm_wrappersVKi)[TAG_BITS(x)] : ((OBJECT*)x)->mm_wrapper) #define DEFINE_MONOMORPHIC_DISCRIMINATOR(_argnum, _nargs) \ D monomorphic_discriminator_engine_##_argnum##_##_nargs (PARAMTEMPLATE##_nargs) { \ MONOMORPHICDISCRIMINATOR* d_ = (MONOMORPHICDISCRIMINATOR*)Pfunction_; \ D parent_ = Pnext_methods_; \ DWORD key = (DWORD)(FI(MONO_WRAPPER_KEY(ARGUMENTNAME##_argnum))); \ ENGINE* newengine_ = (ENGINE*)(key == d_->key) \ ? d_->nextnode \ : Dabsent_engine_nodeVKg; \ DLFN ncb_ = newengine_->entry_point; \ Pfunction_ = (FN*)newengine_; \ Pnext_methods_ = parent_; \ return(ncb_(ARGTEMPLATE##_nargs)); \ } DEFINE_MONOMORPHIC_DISCRIMINATOR(1, 1) DEFINE_MONOMORPHIC_DISCRIMINATOR(1, 2) DEFINE_MONOMORPHIC_DISCRIMINATOR(1, 3) DEFINE_MONOMORPHIC_DISCRIMINATOR(1, 4) DEFINE_MONOMORPHIC_DISCRIMINATOR(1, 5) DEFINE_MONOMORPHIC_DISCRIMINATOR(1, 6) DEFINE_MONOMORPHIC_DISCRIMINATOR(1, 7) DEFINE_MONOMORPHIC_DISCRIMINATOR(2, 2) DEFINE_MONOMORPHIC_DISCRIMINATOR(2, 3) DEFINE_MONOMORPHIC_DISCRIMINATOR(2, 4) DEFINE_MONOMORPHIC_DISCRIMINATOR(2, 5) DEFINE_MONOMORPHIC_DISCRIMINATOR(2, 6) DEFINE_MONOMORPHIC_DISCRIMINATOR(2, 7) DEFINE_MONOMORPHIC_DISCRIMINATOR(3, 3) DEFINE_MONOMORPHIC_DISCRIMINATOR(3, 4) DEFINE_MONOMORPHIC_DISCRIMINATOR(3, 5) DEFINE_MONOMORPHIC_DISCRIMINATOR(3, 6) DEFINE_MONOMORPHIC_DISCRIMINATOR(3, 7) DEFINE_MONOMORPHIC_DISCRIMINATOR(4, 4) DEFINE_MONOMORPHIC_DISCRIMINATOR(4, 5) DEFINE_MONOMORPHIC_DISCRIMINATOR(4, 6) DEFINE_MONOMORPHIC_DISCRIMINATOR(4, 7) DEFINE_MONOMORPHIC_DISCRIMINATOR(5, 5) DEFINE_MONOMORPHIC_DISCRIMINATOR(5, 6) DEFINE_MONOMORPHIC_DISCRIMINATOR(5, 7) DEFINE_MONOMORPHIC_DISCRIMINATOR(6, 6) DEFINE_MONOMORPHIC_DISCRIMINATOR(6, 7) DEFINE_MONOMORPHIC_DISCRIMINATOR(7, 7) D monomorphic_discriminator_engine_n_n (SOV* args) { MONOMORPHICDISCRIMINATOR* e = (MONOMORPHICDISCRIMINATOR*)Pfunction_; D parent = Pnext_methods_; DLFN cb = e->callback; long props = (long)e->properties; long argnum = (props >> 8) & 0xFF; D* a = vector_data(args); OBJECT* arg = (OBJECT*)a[argnum]; DWORD key = (DWORD)(FI(MONO_WRAPPER_KEY(arg))); ENGINE* newengine = (ENGINE*)((key == e->key) ? e->nextnode : Dabsent_engine_nodeVKg); if (FUNCTIONP(newengine)) { return(primitive_mep_apply_with_optionals((FN*)newengine, parent, args)); } else { Pfunction_ = (FN*)newengine; Pnext_methods_ = parent; return((newengine->entry_point)(args)); } } /* ---------------------------------------------- */ extern D Dinapplicable_engine_nodeVKg; #define DEFINE_IF_TYPE_DISCRIMINATOR(_argnum, _nargs) \ D if_type_discriminator_engine_##_argnum##_##_nargs (PARAMTEMPLATE##_nargs) { \ IFTYPEDISCRIMINATOR* d_ = (IFTYPEDISCRIMINATOR*)Pfunction_; \ D parent_ = Pnext_methods_; \ ENGINE* newengine_ = (ENGINE*)((INSTANCEP((ARGUMENTNAME##_argnum),d_->type)) \ ? d_->thennode \ : d_->elsenode); \ DLFN ncb_ = newengine_->entry_point; \ Pfunction_ = (FN*)newengine_; \ Pnext_methods_ = parent_; \ return(ncb_(ARGTEMPLATE##_nargs)); \ } DEFINE_IF_TYPE_DISCRIMINATOR(1, 1) DEFINE_IF_TYPE_DISCRIMINATOR(1, 2) DEFINE_IF_TYPE_DISCRIMINATOR(1, 3) DEFINE_IF_TYPE_DISCRIMINATOR(1, 4) DEFINE_IF_TYPE_DISCRIMINATOR(1, 5) DEFINE_IF_TYPE_DISCRIMINATOR(1, 6) DEFINE_IF_TYPE_DISCRIMINATOR(1, 7) DEFINE_IF_TYPE_DISCRIMINATOR(2, 2) DEFINE_IF_TYPE_DISCRIMINATOR(2, 3) DEFINE_IF_TYPE_DISCRIMINATOR(2, 4) DEFINE_IF_TYPE_DISCRIMINATOR(2, 5) DEFINE_IF_TYPE_DISCRIMINATOR(2, 6) DEFINE_IF_TYPE_DISCRIMINATOR(2, 7) DEFINE_IF_TYPE_DISCRIMINATOR(3, 3) DEFINE_IF_TYPE_DISCRIMINATOR(3, 4) DEFINE_IF_TYPE_DISCRIMINATOR(3, 5) DEFINE_IF_TYPE_DISCRIMINATOR(3, 6) DEFINE_IF_TYPE_DISCRIMINATOR(3, 7) DEFINE_IF_TYPE_DISCRIMINATOR(4, 4) DEFINE_IF_TYPE_DISCRIMINATOR(4, 5) DEFINE_IF_TYPE_DISCRIMINATOR(4, 6) DEFINE_IF_TYPE_DISCRIMINATOR(4, 7) DEFINE_IF_TYPE_DISCRIMINATOR(5, 5) DEFINE_IF_TYPE_DISCRIMINATOR(5, 6) DEFINE_IF_TYPE_DISCRIMINATOR(5, 7) DEFINE_IF_TYPE_DISCRIMINATOR(6, 6) DEFINE_IF_TYPE_DISCRIMINATOR(6, 7) DEFINE_IF_TYPE_DISCRIMINATOR(7, 7) D if_type_discriminator_engine_n_n (SOV* args) { IFTYPEDISCRIMINATOR* e = (IFTYPEDISCRIMINATOR*)Pfunction_; D parent = Pnext_methods_; DLFN cb = e->callback; long props = (long)e->properties; long argnum = (props >> 8) & 0xFF; D* a = vector_data(args); D arg = a[argnum]; ENGINE* newengine = (ENGINE*)(INSTANCEP(arg, e->type) ? e->thennode : e->elsenode); if (FUNCTIONP(newengine)) { return(primitive_mep_apply_with_optionals((FN*)newengine, parent, args)); } else { Pfunction_ = (FN*)newengine; Pnext_methods_ = parent; return((newengine->entry_point)(args)); } } /* ---------------------------------------------- */ extern D Dinapplicable_engine_nodeVKg; #define DEFINE_TYPECHECK_DISCRIMINATOR(_argnum, _nargs) \ D typecheck_discriminator_engine_##_argnum##_##_nargs (PARAMTEMPLATE##_nargs) { \ TYPECHECKDISCRIMINATOR* d_ = (TYPECHECKDISCRIMINATOR*)Pfunction_; \ D parent_ = Pnext_methods_; \ ENGINE* newengine_ = (ENGINE*)((INSTANCEP((ARGUMENTNAME##_argnum),d_->type)) \ ? d_->nextnode \ : Dinapplicable_engine_nodeVKg); \ DLFN ncb_ = newengine_->entry_point; \ Pfunction_ = (FN*)newengine_; \ Pnext_methods_ = parent_; \ return(ncb_(ARGTEMPLATE##_nargs)); \ } DEFINE_TYPECHECK_DISCRIMINATOR(1, 1) DEFINE_TYPECHECK_DISCRIMINATOR(1, 2) DEFINE_TYPECHECK_DISCRIMINATOR(1, 3) DEFINE_TYPECHECK_DISCRIMINATOR(1, 4) DEFINE_TYPECHECK_DISCRIMINATOR(1, 5) DEFINE_TYPECHECK_DISCRIMINATOR(1, 6) DEFINE_TYPECHECK_DISCRIMINATOR(1, 7) DEFINE_TYPECHECK_DISCRIMINATOR(2, 2) DEFINE_TYPECHECK_DISCRIMINATOR(2, 3) DEFINE_TYPECHECK_DISCRIMINATOR(2, 4) DEFINE_TYPECHECK_DISCRIMINATOR(2, 5) DEFINE_TYPECHECK_DISCRIMINATOR(2, 6) DEFINE_TYPECHECK_DISCRIMINATOR(2, 7) DEFINE_TYPECHECK_DISCRIMINATOR(3, 3) DEFINE_TYPECHECK_DISCRIMINATOR(3, 4) DEFINE_TYPECHECK_DISCRIMINATOR(3, 5) DEFINE_TYPECHECK_DISCRIMINATOR(3, 6) DEFINE_TYPECHECK_DISCRIMINATOR(3, 7) DEFINE_TYPECHECK_DISCRIMINATOR(4, 4) DEFINE_TYPECHECK_DISCRIMINATOR(4, 5) DEFINE_TYPECHECK_DISCRIMINATOR(4, 6) DEFINE_TYPECHECK_DISCRIMINATOR(4, 7) DEFINE_TYPECHECK_DISCRIMINATOR(5, 5) DEFINE_TYPECHECK_DISCRIMINATOR(5, 6) DEFINE_TYPECHECK_DISCRIMINATOR(5, 7) DEFINE_TYPECHECK_DISCRIMINATOR(6, 6) DEFINE_TYPECHECK_DISCRIMINATOR(6, 7) DEFINE_TYPECHECK_DISCRIMINATOR(7, 7) D typecheck_discriminator_engine_n_n (SOV* args) { TYPECHECKDISCRIMINATOR* e = (TYPECHECKDISCRIMINATOR*)Pfunction_; D parent = Pnext_methods_; DLFN cb = e->callback; long props = (long)e->properties; long argnum = (props >> 8) & 0xFF; D* a = vector_data(args); D arg = a[argnum]; ENGINE* newengine = (ENGINE*)(INSTANCEP(arg, e->type) ? e->nextnode : Dinapplicable_engine_nodeVKg); if (FUNCTIONP(newengine)) { return(primitive_mep_apply_with_optionals((FN*)newengine, parent, args)); } else { Pfunction_ = (FN*)newengine; Pnext_methods_ = parent; return((newengine->entry_point)(args)); } } /* ---------------------------------------------- */ D primitive_initialize_discriminator(D discriminator) { ENGINE* d = (ENGINE*)discriminator; long props = (long)d->properties; long argnum = ((props & DPROPS_M_ARGNUM) >> DPROPS_V_ARGNUM); long nreq = ((props & DPROPS_M_NREQUIRED) >> DPROPS_V_NREQUIRED); long optionals = ((props & DPROPS_M_OPTIONALS) >> DPROPS_V_OPTIONALS); long impargs = nreq + optionals; long etype = ((props & EPROPS_M_ENTRY_TYPE) >> EPROPS_V_ENTRY_TYPE); DLFN handler; if (etype == ENGINE_if_type) { switch (impargs) { case 1: handler = if_type_discriminator_engine_1_1; break; case 2: switch (argnum) { case 0: handler = if_type_discriminator_engine_1_2; break; case 1: handler = if_type_discriminator_engine_2_2; break; } break; case 3: switch (argnum) { case 0: handler = if_type_discriminator_engine_1_3; break; case 1: handler = if_type_discriminator_engine_2_3; break; case 2: handler = if_type_discriminator_engine_3_3; break; } break; case 4: switch (argnum) { case 0: handler = if_type_discriminator_engine_1_4; break; case 1: handler = if_type_discriminator_engine_2_4; break; case 2: handler = if_type_discriminator_engine_3_4; break; case 3: handler = if_type_discriminator_engine_4_4; break; } break; case 5: switch (argnum) { case 0: handler = if_type_discriminator_engine_1_5; break; case 1: handler = if_type_discriminator_engine_2_5; break; case 2: handler = if_type_discriminator_engine_3_5; break; case 3: handler = if_type_discriminator_engine_4_5; break; case 4: handler = if_type_discriminator_engine_5_5; break; } break; case 6: switch (argnum) { case 0: handler = if_type_discriminator_engine_1_6; break; case 1: handler = if_type_discriminator_engine_2_6; break; case 2: handler = if_type_discriminator_engine_3_6; break; case 3: handler = if_type_discriminator_engine_4_6; break; case 4: handler = if_type_discriminator_engine_5_6; break; case 5: handler = if_type_discriminator_engine_6_6; break; } break; case 7: switch (argnum) { case 0: handler = if_type_discriminator_engine_1_7; break; case 1: handler = if_type_discriminator_engine_2_7; break; case 2: handler = if_type_discriminator_engine_3_7; break; case 3: handler = if_type_discriminator_engine_4_7; break; case 4: handler = if_type_discriminator_engine_5_7; break; case 5: handler = if_type_discriminator_engine_6_7; break; case 6: handler = if_type_discriminator_engine_7_7; break; } break; default: handler = if_type_discriminator_engine_n_n; break; } } else if (etype == ENGINE_typecheck) { switch (impargs) { case 1: handler = typecheck_discriminator_engine_1_1; break; case 2: switch (argnum) { case 0: handler = typecheck_discriminator_engine_1_2; break; case 1: handler = typecheck_discriminator_engine_2_2; break; } break; case 3: switch (argnum) { case 0: handler = typecheck_discriminator_engine_1_3; break; case 1: handler = typecheck_discriminator_engine_2_3; break; case 2: handler = typecheck_discriminator_engine_3_3; break; } break; case 4: switch (argnum) { case 0: handler = typecheck_discriminator_engine_1_4; break; case 1: handler = typecheck_discriminator_engine_2_4; break; case 2: handler = typecheck_discriminator_engine_3_4; break; case 3: handler = typecheck_discriminator_engine_4_4; break; } break; case 5: switch (argnum) { case 0: handler = typecheck_discriminator_engine_1_5; break; case 1: handler = typecheck_discriminator_engine_2_5; break; case 2: handler = typecheck_discriminator_engine_3_5; break; case 3: handler = typecheck_discriminator_engine_4_5; break; case 4: handler = typecheck_discriminator_engine_5_5; break; } break; case 6: switch (argnum) { case 0: handler = typecheck_discriminator_engine_1_6; break; case 1: handler = typecheck_discriminator_engine_2_6; break; case 2: handler = typecheck_discriminator_engine_3_6; break; case 3: handler = typecheck_discriminator_engine_4_6; break; case 4: handler = typecheck_discriminator_engine_5_6; break; case 5: handler = typecheck_discriminator_engine_6_6; break; } break; case 7: switch (argnum) { case 0: handler = typecheck_discriminator_engine_1_7; break; case 1: handler = typecheck_discriminator_engine_2_7; break; case 2: handler = typecheck_discriminator_engine_3_7; break; case 3: handler = typecheck_discriminator_engine_4_7; break; case 4: handler = typecheck_discriminator_engine_5_7; break; case 5: handler = typecheck_discriminator_engine_6_7; break; case 6: handler = typecheck_discriminator_engine_7_7; break; } break; default: handler = typecheck_discriminator_engine_n_n; break; } } else if (etype == ENGINE_monomorphic) { switch (impargs) { case 1: handler = monomorphic_discriminator_engine_1_1; break; case 2: switch (argnum) { case 0: handler = monomorphic_discriminator_engine_1_2; break; case 1: handler = monomorphic_discriminator_engine_2_2; break; } break; case 3: switch (argnum) { case 0: handler = monomorphic_discriminator_engine_1_3; break; case 1: handler = monomorphic_discriminator_engine_2_3; break; case 2: handler = monomorphic_discriminator_engine_3_3; break; } break; case 4: switch (argnum) { case 0: handler = monomorphic_discriminator_engine_1_4; break; case 1: handler = monomorphic_discriminator_engine_2_4; break; case 2: handler = monomorphic_discriminator_engine_3_4; break; case 3: handler = monomorphic_discriminator_engine_4_4; break; } break; case 5: switch (argnum) { case 0: handler = monomorphic_discriminator_engine_1_5; break; case 1: handler = monomorphic_discriminator_engine_2_5; break; case 2: handler = monomorphic_discriminator_engine_3_5; break; case 3: handler = monomorphic_discriminator_engine_4_5; break; case 4: handler = monomorphic_discriminator_engine_5_5; break; } break; case 6: switch (argnum) { case 0: handler = monomorphic_discriminator_engine_1_6; break; case 1: handler = monomorphic_discriminator_engine_2_6; break; case 2: handler = monomorphic_discriminator_engine_3_6; break; case 3: handler = monomorphic_discriminator_engine_4_6; break; case 4: handler = monomorphic_discriminator_engine_5_6; break; case 5: handler = monomorphic_discriminator_engine_6_6; break; } break; case 7: switch (argnum) { case 0: handler = monomorphic_discriminator_engine_1_7; break; case 1: handler = monomorphic_discriminator_engine_2_7; break; case 2: handler = monomorphic_discriminator_engine_3_7; break; case 3: handler = monomorphic_discriminator_engine_4_7; break; case 4: handler = monomorphic_discriminator_engine_5_7; break; case 5: handler = monomorphic_discriminator_engine_6_7; break; case 6: handler = monomorphic_discriminator_engine_7_7; break; } break; default: handler = monomorphic_discriminator_engine_n_n; break; } } else { switch (impargs) { case 1: handler = discriminate_engine_1_1; break; case 2: switch (argnum) { case 0: handler = discriminate_engine_1_2; break; case 1: handler = discriminate_engine_2_2; break; } break; case 3: switch (argnum) { case 0: handler = discriminate_engine_1_3; break; case 1: handler = discriminate_engine_2_3; break; case 2: handler = discriminate_engine_3_3; break; } break; case 4: switch (argnum) { case 0: handler = discriminate_engine_1_4; break; case 1: handler = discriminate_engine_2_4; break; case 2: handler = discriminate_engine_3_4; break; case 3: handler = discriminate_engine_4_4; break; } break; case 5: switch (argnum) { case 0: handler = discriminate_engine_1_5; break; case 1: handler = discriminate_engine_2_5; break; case 2: handler = discriminate_engine_3_5; break; case 3: handler = discriminate_engine_4_5; break; case 4: handler = discriminate_engine_5_5; break; } break; case 6: switch (argnum) { case 0: handler = discriminate_engine_1_6; break; case 1: handler = discriminate_engine_2_6; break; case 2: handler = discriminate_engine_3_6; break; case 3: handler = discriminate_engine_4_6; break; case 4: handler = discriminate_engine_5_6; break; case 5: handler = discriminate_engine_6_6; break; } break; case 7: switch (argnum) { case 0: handler = discriminate_engine_1_7; break; case 1: handler = discriminate_engine_2_7; break; case 2: handler = discriminate_engine_3_7; break; case 3: handler = discriminate_engine_4_7; break; case 4: handler = discriminate_engine_5_7; break; case 5: handler = discriminate_engine_6_7; break; case 6: handler = discriminate_engine_7_7; break; } break; default: handler = discriminate_engine_n_n; break; }}; d->entry_point = (DLFN) handler; return(discriminator); } /* MULTIPLE VALUES */ MV Preturn_values = { 0 }; DMINT _unused_arg = 0; DMINT* P_unused_arg = &_unused_arg; INLINE D MV_SPILL_into (D first_value, MV *dest) { int i, n = Preturn_values.count; Preturn_values.value[0] = first_value; for (i = 0; i < n; i++) dest->value[i] = Preturn_values.value[i]; dest->count = n; return (D) dest; } D MV_SPILL (D first_value) { int n = Preturn_values.count; MV *dest = (MV *) primitive_allocate(1 + n); MV_SPILL_into(first_value, dest); return (D) dest; } D MV_UNSPILL (D spill_t) { MV *src = (MV *) spill_t; int i; int n = src->count; for (i = 0; i < n; i++) Preturn_values.value[i] = src->value[i]; Preturn_values.count = n; return Preturn_values.count == 0 ? DFALSE : Preturn_values.value[0]; } D MV_CHECK_TYPE_REST (D first_value, D rest_type, int n, ...) { int i, mv_n = Preturn_values.count; MV spill; va_list ap; va_start(ap, n); MV_SPILL_into(first_value, &spill); for (i = 0; i < n; i++) { D type = va_arg(ap, D); primitive_type_check(spill.value[i], type); } for (; i < mv_n; i++) primitive_type_check(spill.value[i], rest_type); MV_UNSPILL((D)&spill); return first_value; } D MV_GET_REST_AT (D first_value, DSINT first) { int offset = first; int n = Preturn_values.count - offset; Preturn_values.value[0] = first_value; return(make_vector_from_buffer(n < 0 ? 0 : n, &Preturn_values.value[offset])); } D MV_SET_REST_AT (D v, DSINT first) { int i, size = vector_size(v), offset = first; for (i=0; i= count */ Preturn_values.count = n; } /* ****************************** void MV_ADJ (DSINT n) { int i, count=Preturn_values.count; if (count!=n) { for (i=count; ipresent_unwind_protect_frame) { /* invalidate current frame */ Pcurrent_unwind_protect_frame->ultimate_destination = NULL; longjmp(ultimate_destination->destination, 1); } else { Unwind_protect_frame* next_frame = Pcurrent_unwind_protect_frame; /* pop current unwind protect frame */ Pcurrent_unwind_protect_frame = next_frame->previous_unwind_protect_frame; /* register ultimate destination of non-local exit in cupf */ Pcurrent_unwind_protect_frame->ultimate_destination = ultimate_destination; /* do cleanup step in next unwind protect frame */ longjmp(next_frame->destination, 1); } } D FALL_THROUGH_UNWIND (D argument) { Pcurrent_unwind_protect_frame->return_values.count = Preturn_values.count; Pcurrent_unwind_protect_frame->return_values.value[0] = argument; if (Preturn_values.count > 1) COPY_WORDS (&Pcurrent_unwind_protect_frame->return_values.value[1], &Preturn_values.value[1], Preturn_values.count - 1); /* invalidate current frame */ Pcurrent_unwind_protect_frame->ultimate_destination = NULL; return((D)0); /* Keeps some compilers happy */ } D CONTINUE_UNWIND () { if (Pcurrent_unwind_protect_frame->ultimate_destination) { /* nlx? */ nlx_step(Pcurrent_unwind_protect_frame->ultimate_destination); return(DFALSE); /* Keeps some compilers happy */ } else { int i; int n = Pcurrent_unwind_protect_frame->return_values.count; Preturn_values.count = n; for (i = 0; i < n; i++) Preturn_values.value[i] = Pcurrent_unwind_protect_frame->return_values.value[i]; /* pop current unwind protect frame */ Pcurrent_unwind_protect_frame = Pcurrent_unwind_protect_frame->previous_unwind_protect_frame; return n == 0 ? DFALSE : Preturn_values.value[0]; } } void print_frame_count () { int i; Unwind_protect_frame* ptr = Pcurrent_unwind_protect_frame; for (i = 0; ptr != Ptop_unwind_protect_frame; i++) ptr = ptr->previous_unwind_protect_frame; printf("FRAME COUNT = %d\n", i); } D NLX (Bind_exit_frame* target, D argument) { target->return_values.count = Preturn_values.count; target->return_values.value[0] = argument; if (Preturn_values.count > 1) COPY_WORDS (&target->return_values.value[1], &Preturn_values.value[1], Preturn_values.count - 1); nlx_step(target); return((D)0); /* Keeps some compilers happy -- Won't actually get here */ } D MAKE_EXIT_FRAME () { Bind_exit_frame* frame = (Bind_exit_frame*)allocate(sizeof(Bind_exit_frame)); frame->present_unwind_protect_frame = Pcurrent_unwind_protect_frame; return((D)frame); } D MAKE_UNWIND_FRAME () { Unwind_protect_frame* frame = (Unwind_protect_frame*)allocate(sizeof(Unwind_protect_frame)); /* print_frame_count(); */ frame->previous_unwind_protect_frame = Pcurrent_unwind_protect_frame; Pcurrent_unwind_protect_frame = frame; frame->ultimate_destination = (Bind_exit_frame*)0; return((D)frame); } D FRAME_DEST (D frame) { return((D)(((Bind_exit_frame*)frame)->destination)); } D FRAME_RETVAL (D frame) { /* TODO: real multiple values */ Bind_exit_frame *bef = ((Bind_exit_frame*) frame); /* Copy the multiple values into the result values MV */ COPY_WORDS (&(Preturn_values.value[0]), &(bef->return_values.value[0]), bef->return_values.count); Preturn_values.count = bef->return_values.count; return((D)(bef->return_values.value[0])); } /* CLOSURES */ D buffer[MAX_ARGUMENTS]; extern Wrapper KLmethodGVKdW; D MAKE_CLOSURE (D schema, int closure_size) { CFN* fn = (CFN*)allocate(sizeof(CFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(CFN)); return((D)fn); } D MAKE_CLOSURE_SIG (D schema, D sig, int closure_size) { CFN* fn = (CFN*)allocate(sizeof(CFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(CFN)); fn->signature = sig; return((D)fn); } INLINE void init_environment (CFN* fn, int size, D* buf) { if (size > 0) COPY_WORDS(&(fn->environment), buf, size); fn->size = I(size); } void INIT_CLOSURE (D function, int closure_size, ...) { CFN* fn = function; BUFFER_VARARGS(closure_size, closure_size, buffer); init_environment(fn, closure_size, buffer); } D MAKE_CLOSURE_INITD (D schema, int closure_size, ...) { CFN* fn = (CFN*)allocate(sizeof(CFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(CFN)); BUFFER_VARARGS(closure_size, closure_size, buffer); init_environment(fn, closure_size, buffer); return((D)fn); } D MAKE_CLOSURE_INITD_SIG (D schema, D sig, int closure_size, ...) { CFN* fn = (CFN*)allocate(sizeof(CFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(CFN)); fn->signature = sig; BUFFER_VARARGS(closure_size, closure_size, buffer); init_environment(fn, closure_size, buffer); return((D)fn); } D MAKE_METHOD_SIG (D schema, D sig) { CFN* fn = (CFN*)allocate(sizeof(CFN)); memcpy(fn, schema, sizeof(CFN)); fn->signature = sig; return(fn); } D SET_METHOD_SIG (D method, D sig) { CFN* fn = (CFN*)method; fn->signature = sig; return((D)fn); } D MAKE_KEYWORD_CLOSURE (D schema, int closure_size) { KCFN* fn = (KCFN*)allocate(sizeof(KCFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(KCFN)); return((D)fn); } D MAKE_KEYWORD_CLOSURE_SIG (D schema, D sig, int closure_size) { KCFN* fn = (KCFN*)allocate(sizeof(KCFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(KCFN)); fn->signature = sig; return((D)fn); } INLINE void init_keyword_environment (KCFN* fn, int size, D* buf) { if (size > 0) COPY_WORDS(&(fn->environment), buf, size); fn->size = I(size); } void INIT_KEYWORD_CLOSURE (D function, int closure_size, ...) { KCFN* fn = function; BUFFER_VARARGS(closure_size, closure_size, buffer); init_keyword_environment(fn, closure_size, buffer); } D MAKE_KEYWORD_CLOSURE_INITD (D schema, int closure_size, ...) { KCFN* fn = (KCFN*)allocate(sizeof(KCFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(KCFN)); BUFFER_VARARGS(closure_size, closure_size, buffer); init_keyword_environment(fn, closure_size, buffer); return((D)fn); } D MAKE_KEYWORD_CLOSURE_INITD_SIG (D schema, D sig, int closure_size, ...) { KCFN* fn = (KCFN*)allocate(sizeof(KCFN) + closure_size * sizeof(D)); memcpy(fn, schema, sizeof(KCFN)); fn->signature = sig; BUFFER_VARARGS(closure_size, closure_size, buffer); init_keyword_environment(fn, closure_size, buffer); return((D)fn); } D MAKE_KEYWORD_METHOD_SIG (D schema, D sig) { KFN* fn = (KFN*)allocate(sizeof(KFN)); memcpy(fn, schema, sizeof(KFN)); fn->signature = sig; return(fn); } D SET_KEYWORD_METHOD_SIG (D method, D sig) { KCFN* fn = (KCFN*)method; fn->signature = sig; return((D)fn); } /* PRIMITIVES */ D apply_buffer[MAX_ARGUMENTS]; INLINE D primitive_apply_using_buffer (FN* fn, int n, D a[]) { int i, j; SOV* optionals = (SOV*)a[n - 1]; int optionals_size = vector_size(optionals); int new_size = n + optionals_size - 1; for (i = 0; i < n - 1; i++) apply_buffer[i] = a[i]; for (i = n - 1, j = 0; j < optionals_size; i++, j++) apply_buffer[i] = vector_ref(optionals, j); return(primitive_xep_apply(fn, new_size, apply_buffer)); } D primitive_apply (D fn, D args) { return(primitive_apply_using_buffer ((FN*)fn, vector_size((SOV*)args), vector_data((SOV*)args))); } D primitive_apply_spread (D fn, int n, ...) { BUFFER_VARARGS(n, n, buffer); return(primitive_apply_using_buffer((FN*)fn, n, buffer)); } D primitive_mep_apply_spread (D fn, D nm, int n, ...) { BUFFER_VARARGS(n, n, buffer); {SOV* v = (SOV*)buffer[n - 1]; int v_size = vector_size(v); int new_size = n + v_size - 1; {DEF_STACK_VECTOR_FROM_BUFFER_WITH_SIZE (new_arguments, new_size, buffer, n - 1); COPY_WORDS (&(vector_data(new_arguments)[n - 1]), vector_data(v), v_size); return(primitive_mep_apply((FN*)fn, nm, (D *)new_arguments)); }}} D primitive_engine_node_apply_spread (ENGINE* e, D parent, int n, ...) { BUFFER_VARARGS(n, n, buffer); {SOV* v = (SOV*)buffer[n - 1]; int v_size = vector_size(v); int new_size = n + v_size - 1; {DEF_STACK_VECTOR_FROM_BUFFER_WITH_SIZE (new_arguments, new_size, buffer, n - 1); COPY_WORDS (&(vector_data(new_arguments)[n - 1]), vector_data(v), v_size); return(primitive_engine_node_apply(e, parent, (D *)new_arguments)); }}} /* temporary primitives for assignment */ D MAKE_D_CELL(D value) { D cell = primitive_allocate(1); *(D*)cell = value; return cell; } #define define_make_cell(type) \ D MAKE_ ## type ## _CELL(type value) { \ type* cell = (type*)allocate(sizeof(type)); \ *cell = value; \ return cell; \ } define_make_cell(DBCHR) define_make_cell(DDBYTE) define_make_cell(DSFLT) define_make_cell(DDFLT) define_make_cell(DWORD) define_make_cell(DDWORD) D primitive_vector (D n, ...) { BUFFER_VARARGS(R(n), n, arguments); return(make_vector_from_buffer(R(n), arguments)); } D primitive_values (D v) { return(MV_SET_REST_AT(v, 0)); } /* Hack oblist */ #define INITIAL_OBLIST_SIZE (64) extern D LsymbolGVKd; extern D Ksystem_allocate_simple_instanceVKeI (D class_, D Urest_, D fill_); D primitive_make_symbol (D string) { D symbol = Ksystem_allocate_simple_instanceVKeI (LsymbolGVKd, Pempty_vectorVKi, &KPunboundVKi); ((SYMBOL*)symbol)->name = string; return(symbol); } static int oblist_size = 0; static int oblist_cursor = 0; static D *oblist = NULL; D primitive_preboot_symbols () { return(primitive_raw_as_vector((D)(long)oblist_cursor, oblist)); } D primitive_string_as_symbol_using_symbol (D string, D symbol) { int input_string_size = R(((BS*)string)->size); char *input_string_data = ((BS*)string)->data; int i; for (i = 0; i < oblist_cursor; ++i) { SYMBOL *oblist_symbol = (SYMBOL*)oblist[i]; int oblist_string_size = R(((BS*)(oblist_symbol->name))->size); char *oblist_string_data = ((BS*)(oblist_symbol->name))->data; if (oblist_string_size == input_string_size && strncasecmp (oblist_string_data, input_string_data, (size_t)input_string_size) == 0) { return((D)oblist_symbol); } } if (oblist_cursor >= oblist_size) { oblist_size += INITIAL_OBLIST_SIZE; oblist = (D*)GC_realloc(oblist, oblist_size * sizeof(D)); } if (symbol == NULL) { symbol = primitive_make_symbol(string); } oblist[oblist_cursor++] = symbol; return symbol; } D primitive_string_as_symbol (D string) { return(primitive_string_as_symbol_using_symbol(string, NULL)); } D primitive_resolve_symbol (D symbol) { return(primitive_string_as_symbol_using_symbol (((SYMBOL*)symbol)->name, symbol)); } D primitive_slot_value(D object, DSINT position) { D slot_value = primitive_initialized_slot_value(object, position); if (UNBOUND_P(slot_value)) { return(UNBOUND_INSTANCE_SLOT(object, I(position))); } else { return(slot_value); } return(slot_value); } D SLOT_VALUE(D object, DSINT position) { D slot_value = primitive_initialized_slot_value(object, position); if (UNBOUND_P(slot_value)) { return(UNBOUND_INSTANCE_SLOT(object, I(position))); } else { return(slot_value); } } /* LIBC ERROR PRIMITIVES */ /*---*** NOTE: These aren't really primitives but are called ---*** by various Dylan libraries by the direct C-FFI. They ---*** should be renamed psuedo_primitive_... */ #include DSINT primitive_errno () { return(errno); } DSINT primitive_set_errno (DSINT code) { errno = code; return(errno); } DCBSTR primitive_errstr (DSINT no) { #ifdef macintosh static char text[32]; sprintf(text, "error %d", no); return(text); #else return(sys_errlist[no]); #endif } /* FILE PRIMITIVES */ /*---*** NOTE: These aren't really primitives but are called ---*** by various Dylan libraries by the direct C-FFI. They ---*** should be renamed psuedo_primitive_... */ #ifdef macintosh #include #else #include #include #endif DBOOL primitive_file_existsQ(DBSTR filename) { struct stat stat_buffer; int result = stat(filename, &stat_buffer); return(result>=0); } /* TERMINAL */ /* RIH - Moved initialization to startup */ D pseudo_stdout = 0; /* OPERATING SYSTEM */ D Tcommand_nameT; D pseudo_primitive_command_name () { return(Tcommand_nameT); } D Tcommand_argumentsT; D pseudo_primitive_command_arguments () { return(Tcommand_argumentsT); } DSINT primitive_run_application (DBSTR command) { return(system(command)); } void primitive_exit_application (DSINT code) { exit(code); } #if defined (macintosh) || defined (WIN32) int connect_to_numbered_server (char *host, int port) { ignore(host); ignore(port); return(-1); } int connect_to_named_server (char *host, char *service) { ignore(host); ignore(service); return(-1); } #else #if __hp9000s300 || __hp9000s800 || __hp9000s700 #define HPUX 1 #endif #ifdef SUN3 #ifndef HPUX junk #endif #endif #include #include #include #include #ifdef MIPS #ifndef IRIX #include #include #include #include #else /* IRIX */ #include #include #include #include #endif /* IRIX */ #include #else /* MIPS */ #include #include #include #ifdef OLIVETTI #include #else /* OLIVETTI */ #include #if INTERGRAF | HPUX | SOLARIS2 #include #endif #endif /* OLIVETTI */ #endif /* MIPS */ #include #ifndef SO_DONTLINGER #define SO_DONTLINGER ~SO_LINGER #endif int connect_to_numbered_server (host, port) char *host; unsigned port; { struct sockaddr_in inaddr; /* INET socket address. */ struct sockaddr *addr; /* address to connect to */ struct hostent *host_ptr; struct servent *sp; int addrlen; /* length of address */ extern struct hostent *gethostbyname(); int fd; /* Network socket */ { { /* Get the statistics on the specified host. */ if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) { if ((host_ptr = gethostbyname(host)) == NULL) { /* No such host! */ errno = EINVAL; return(-1); } /* Check the address type for an internet host. */ if (host_ptr->h_addrtype != AF_INET) { /* Not an Internet host! */ errno = EPROTOTYPE; return(-1); } /* Set up the socket data. */ inaddr.sin_family = host_ptr->h_addrtype; bcopy((char *)host_ptr->h_addr, (char *)&inaddr.sin_addr, sizeof(inaddr.sin_addr)); } else { inaddr.sin_family = AF_INET; } addr = (struct sockaddr *) &inaddr; addrlen = sizeof (struct sockaddr_in); inaddr.sin_port = htons(port); /* * Open the network connection. */ if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0){ return(-1); /* errno set by system call. */} /* make sure to turn off TCP coalescence */ #ifdef TCP_NODELAY { int mi; setsockopt (fd, IPPROTO_TCP, TCP_NODELAY, &mi, sizeof (int)); } #endif } if (connect(fd, addr, addrlen) == -1) { (void) close (fd); return(-1); /* errno set by system call. */ } } /* * Return the id if the connection succeeded. */ return(fd); } int connect_to_named_server (host, service) char *host ,*service; { struct servent *sp; /* Lets find the service */ if ((sp = getservbyname(service, "tcp")) == NULL) return -1; else return(connect_to_numbered_server(host, ntohs(sp->s_port))); } #endif /* * TIMING PRIMITIVES */ /* Macintosh */ #if defined(macintosh) static UnsignedWide start; void primitive_start_timer() { Microseconds(&start); } D primitive_stop_timer() { UnsignedWide stop; UINT64 *started, *finished, elapsed; INT32 seconds, microseconds; Microseconds(&stop); started = (UINT64*)&start; finished = (UINT64*)&stop; elapsed = *finished - *started; seconds = (INT32)(elapsed / 1000000); microseconds = (INT32)(elapsed % 1000000); { SOV* value = make_vector(2); D* data = (D*)vector_data(value); data[0] = I(seconds); data[1] = I(microseconds); return((D)value); } } /* Win32 (PC) */ #elif defined(WIN32) static _int64 start, stop, frequency; extern int __stdcall QueryPerformanceCounter(_int64*); extern int __stdcall QueryPerformanceFrequency(_int64*); void primitive_start_timer() { QueryPerformanceCounter(&start); } D primitive_stop_timer() { SOV* value = make_vector(2); D* data = (D*)vector_data(value); long seconds = 0, microseconds = 0; QueryPerformanceCounter(&stop); if (QueryPerformanceFrequency(&frequency)) { stop -= start; seconds = (long)(stop / frequency); microseconds = (long)((stop % frequency) * 1000000 / frequency); } data[0] = I(seconds); data[1] = I(microseconds); return((D)value); } /* UNIX curtosey of Ian Piumarta */ #else #include #include static struct rusage start, stop; void primitive_start_timer() { getrusage(RUSAGE_SELF, &start); } D primitive_stop_timer() { getrusage(RUSAGE_SELF, &stop); stop.ru_utime.tv_usec -= start.ru_utime.tv_usec; stop.ru_utime.tv_sec -= start.ru_utime.tv_sec; if (stop.ru_utime.tv_usec < 0) { stop.ru_utime.tv_usec += 1000000; stop.ru_utime.tv_sec -= 1; } { SOV* value = make_vector(2); D* data = (D*)vector_data(value); data[0] = I(stop.ru_utime.tv_sec); data[1] = I(stop.ru_utime.tv_usec); return((D)value); /* printf("%d.%03d", stop.ru_utime.tv_sec, stop.ru_utime.tv_usec / 1000); */ }} #endif /* TOP LEVEL INITIALIZATION */ extern Wrapper KLbyte_stringGVKdW; define_byte_string(BS9, 9); static BS9 bs_boole_ior_ = { &KLbyte_stringGVKdW /* instance-header */, I(9) /* size_ */, "boole-ior" }; static BS9 bs_boole_xor_ = { &KLbyte_stringGVKdW /* instance-header */, I(9) /* size_ */, "boole-xor" }; #define INITIAL_MAX_STACK_SIZE ( 4 * 1024 * 1024) /* Was: 200000 */ #define MAX_HEAP_SIZE (1024 * 1024 * 1024) void GC_set_max_heap_size(unsigned long); void _Init_Run_Time () { int stack_marker; static initp = 0; if (!initp) { initp = 1; GC_set_max_heap_size(MAX_HEAP_SIZE); Pcurrent_unwind_protect_frame = Ptop_unwind_protect_frame; Ptop_unwind_protect_frame->ultimate_destination = (Bind_exit_frame*)0; IKJboole_xor_ = primitive_string_as_symbol(&bs_boole_xor_); IKJboole_ior_ = primitive_string_as_symbol(&bs_boole_ior_); max_stack_size = INITIAL_MAX_STACK_SIZE; bottom_of_stack = (unsigned long)&stack_marker; pseudo_stdout = (D)stdout; } } /* additions to run-time.c specific to handling pass-by-reference of non-first return values of primitives (gts,9/97) */ extern D MV2_byref_(D, DMINT*, DMINT); extern D MV3_byref_(D, DMINT*, DMINT, DMINT*, DMINT); #define MV2_byref(x,v,y) return((DMINT)MV2_byref_((D)(x), (DMINT*)(v), (DMINT)(y))) #define MV2_byrefU(x,v,y) return((DUMINT)MV2_byref_((D)(x), (DMINT*)(v), (DMINT)(y))) #define MV3_byref(x,v1,y,v2,z) return((DMINT)MV3_byref_((D)(x), (DMINT*)(v1), (DMINT)(y), (DMINT*)(v2), (DMINT)(z))) DMINT primitive_single_float_as_double_integer_byref(DSFLT f, DMINT* v2) { #ifdef NO_LONGLONG DMINT i = (DMINT)f; MV2_byref((DMINT)i, v2, (i < 0) ? (DMINT)-1 : (DMINT)0); #else DLMINT i = (DLMINT)f; MV2_byref((DMINT)i, v2, (DMINT)(i >> LONG_BIT)); #endif } DMINT primitive_double_float_as_double_integer_byref(DDFLT f, DMINT* v2) { #ifdef NO_LONGLONG DMINT i = (DMINT)f; MV2_byref((DMINT)i, v2, (i < 0) ? (DMINT)-1 : (DMINT)0); #else DLMINT i = (DLMINT)f; MV2_byref((DMINT)i, v2, (DMINT)(i >> LONG_BIT)); #endif } DMINT primitive_cast_double_float_as_machine_words_byref(DDFLT x, DMINT* v2) { INTDFLT intflt; intflt.f = x; #ifdef NO_LONGLONG MV2_byref((DMINT)intflt.i, v2, 0); #else MV2_byref((DMINT)intflt.i, v2, (DMINT)(intflt.i >> LONG_BIT)); #endif } DMINT primitive_machine_word_divide_byref(DMINT x, DMINT y, DMINT* v2) { ldiv_t z = ldiv(x, y); MV2_byref((DMINT)z.quot, v2, (DMINT)z.rem); } DMINT primitive_machine_word_floorS_byref(DMINT x, DMINT y, DMINT* v2) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem > 0) : (z.rem < 0))) { z.quot--; z.rem += y; } MV2_byref((DMINT)z.quot, v2, (DMINT)z.rem); } DMINT primitive_machine_word_ceilingS_byref(DMINT x, DMINT y, DMINT* v2) { ldiv_t z = ldiv(x, y); if (z.rem && ((y < 0) ? (z.rem < 0) : (z.rem > 0))) { z.quot++; z.rem -= y; } MV2_byref((DMINT)z.quot, v2, (DMINT)z.rem); } DMINT primitive_machine_word_roundS_byref(DMINT x, DMINT y, DMINT* v2) { ldiv_t z = ldiv(x, y); long threshold = labs(y) / 2; if ((z.rem > threshold) || ((z.rem == threshold) && (z.quot & 1))) { if (y < 0) { z.quot--; z.rem += y; } else { z.quot++; z.rem -= y; } } else if ((z.rem < -threshold) || ((z.rem == -threshold) && (z.quot & 1))) { if (y < 0) { z.quot++; z.rem -= y; } else { z.quot--; z.rem += y; } } MV2_byref((DMINT)z.quot, v2, (DMINT)z.rem); } DMINT primitive_machine_word_truncateS_byref(DMINT x, DMINT y, DMINT* v2) { ldiv_t z = ldiv(x, y); MV2_byref((DMINT)z.quot, v2, (DMINT)z.rem); } DMINT primitive_machine_word_double_floorS_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r > 0) : (r < 0))) { q--; r += y; } MV2_byref(q, v2, r); } DMINT primitive_machine_word_double_ceilingS_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DMINT q, r; divide_double(xl, xh, y, &q, &r); if (r && ((y < 0) ? (r < 0) : (r > 0))) { q++; r -= y; } MV2_byref(q, v2, r); } DMINT primitive_machine_word_double_roundS_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DMINT q, r; long threshold = labs(y) / 2; divide_double(xl, xh, y, &q, &r); if ((r > threshold) || ((r == threshold) && (q & 1))) { if (y < 0) { q--; r += y; } else { q++; r -= y; } } else if ((r < -threshold) || ((r == -threshold) && (q & 1))) { if (y < 0) { q++; r -= y; } else { q--; r += y; } } MV2_byref(q, v2, r); } DMINT primitive_machine_word_double_truncateS_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DMINT q, r; divide_double(xl, xh, y, &q, &r); MV2_byref(q, v2, r); } DMINT primitive_machine_word_double_divide_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DMINT q, r; divide_double(xl, xh, y, &q, &r); MV2_byref(q, v2, r); } DMINT primitive_machine_word_add_with_overflow_byref(DMINT x, DMINT y, D* v2) { DMINT r = (DMINT)((DUMINT)x + (DUMINT)y); /* Overflow if signs of inputs are the same but different from sign of result ... */ MV2_byref(r, v2, RAWASBOOL(((x ^ y) >= 0) && ((r ^ x) < 0))); } DMINT primitive_machine_word_subtract_with_overflow_byref(DMINT x, DMINT y, D* v2) { DMINT r = (DMINT)((DUMINT)x - (DUMINT)y); /* Overflow if signs of inputs differ and sign of result isn't sign of X ... */ MV2_byref(r, v2, RAWASBOOL(((x ^ y) < 0) && ((r ^ x) < 0))); } DMINT primitive_machine_word_multiply_with_overflow_byref(DMINT x, DMINT y, DMINT* v2, D* v3) { DUMINT rl, rh; multiply_double(x, y, &rl, &rh); /* Overflow if sign of result is wrong or ? ... */ MV3_byref(rl, v2, rh, v3, RAWASBOOL(((x ^ y) < 0) ? ((DMINT)rh >= 0) : ((DMINT)rh < 0))); } DMINT primitive_machine_word_negative_with_overflow_byref(DMINT x, D* v2) { DMINT r = - x; /* Overflow if input was negative and result is negative or zero ... */ MV2_byref(r, v2, RAWASBOOL(x < 0 && r <= 0)); } DMINT primitive_machine_word_abs_with_overflow_byref(DMINT x, D* v2) { DMINT r = labs(x); /* Overflow if input was negative and result is negative or zero ... */ MV2_byref(r, v2, RAWASBOOL(x < 0 && r <= 0)); } DMINT primitive_machine_word_shift_left_with_overflow_byref(DMINT x, DMINT y, DMINT* v2, D* v3) { /* was: MV2_byref(primitive_machine_word_shift_left_low(x, y), v2, 0); */ MV3_byref(primitive_machine_word_shift_left_low(x, y), v2, 0, v3, RAWASBOOL(0)); } DMINT primitive_machine_word_multiply_lowShigh_byref(DMINT x, DMINT y, DMINT* v2) { DUMINT zl, zh; multiply_double(x, y, &zl, &zh); MV2_byref((DMINT)zl, v2, (DMINT)zh); } DMINT primitive_machine_word_multiply_low_with_overflow_byref(DMINT x, DMINT y, D* v2) { DMINT r = x * y; /* Overflow if result has wrong sign or is smaller than inputs ... */ MV2_byref(r, v2, RAWASBOOL((((x ^ y) < 0) ? r >= 0 : r < 0) || (labs(r) < labs(x)) || (labs(r) < labs(y)))); } DMINT primitive_machine_word_unsigned_add_with_carry_byref(DMINT x, DMINT y, DMINT* v2) { DUMINT ux = (DUMINT)x; DUMINT uy = (DUMINT)y; DUMINT uz = ux + uy; DUMINT bbc = ((ux & 1) && (uy & 1)) ? (DUMINT)1 : (DUMINT)0; MV2_byref(uz, v2, ((DMINT)((ux >> 1) + (uy >> 1) + bbc) < 0) ? (DMINT)1 : (DMINT)0); } DMINT primitive_machine_word_unsigned_subtract_with_borrow_byref(DMINT x, DMINT y, DMINT* v2) { DUMINT ux = (DUMINT)x; DUMINT uy = (DUMINT)y; DUMINT uz = ux - uy; MV2_byref(uz, v2, (uy > ux) ? (DMINT)1 : (DMINT)0); } DMINT primitive_machine_word_unsigned_multiply_byref(DMINT x, DMINT y, DMINT* v2) { DUMINT zl, zh; multiply_double(x, y, &zl, &zh); MV2_byref(zl, v2, zh); } DMINT primitive_machine_word_unsigned_divide_byref(DMINT x, DMINT y, DMINT* v2) { DUMINT q, r; unsigned_divide_double(x, (x < 0) ? -1 : 0, y, &q, &r); MV2_byref(q, v2, r); } DMINT primitive_machine_word_unsigned_double_divide_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DUMINT q, r; unsigned_divide_double(xl, xh, y, &q, &r); MV2_byref(q, v2, r); } DMINT primitive_machine_word_unsigned_double_shift_left_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DUMINT lowpart = (DUMINT)xl >> (LONG_BIT - y); DUMINT highpart = (DUMINT)xh << y; MV2_byref((DUMINT)xl << y, v2, lowpart | highpart); } DMINT primitive_machine_word_unsigned_double_shift_right_byref(DMINT xl, DMINT xh, DMINT y, DMINT* v2) { DUMINT lowpart = (DUMINT)xl >> y; DUMINT highpart = (DUMINT)xh << (LONG_BIT - y); MV2_byref(lowpart | highpart, v2, (DUMINT)xh >> y); } D MV2_byref_ (D x, DMINT* v, DMINT y) { *v = y; return x; } D MV3_byref_ (D x, DMINT* v1, DMINT y, DMINT* v2, DMINT z) { *v1 = y; *v2 = z; return x; } /* eof */