From aeef9b634be786a45f1c8bbf8cfb9a5cb6726140 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 12 Jan 1987 17:20:13 +0000 Subject: [PATCH] Please refer to the ChangeLog file under the following entry for this log message, which is too long for RCS to handle at present: Mon Jan 12 17:11:49 1987 Chris Hanson (cph at kleph) --- v7/src/microcode/object.h | 130 ++++--- v7/src/microcode/prims.h | 131 +++++-- v7/src/microcode/string.c | 764 +++++++++++++++++--------------------- v8/src/microcode/object.h | 130 ++++--- 4 files changed, 579 insertions(+), 576 deletions(-) diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index 02b8fbd22..a33d54569 100644 --- a/v7/src/microcode/object.h +++ b/v7/src/microcode/object.h @@ -1,6 +1,6 @@ /* -*-C-*- -Copyright (c) 1986 Massachusetts Institute of Technology +Copyright (c) 1987 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -30,13 +30,11 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 5.2 1986/12/17 06:35:06 cph Exp $ - * - * This file contains definitions pertaining to the C view of - * Scheme pointers: widths of fields, extraction macros, pre-computed - * extraction masks, etc. - * - */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 5.3 1987/01/12 17:17:33 cph Exp $ */ + +/* This file contains definitions pertaining to the C view of + Scheme pointers: widths of fields, extraction macros, pre-computed + extraction masks, etc. */ /* The C type Pointer is defined at the end of CONFIG.H The definition of POINTER_LENGTH here assumes that Pointer is the same @@ -52,8 +50,7 @@ MIT in each case. */ particular binding of a variable to a value has been shadowed by an auxiliary variable in a nested environment. It means that variables cached to this address must be recached since the address may be invalid. - See lookup.c -*/ + See lookup.c */ #define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */ #define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */ @@ -88,73 +85,82 @@ MIT in each case. */ #endif #ifndef UNSIGNED_SHIFT /* Safe version */ -#define Type_Code(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) -#define Safe_Type_Code(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) +#define pointer_type(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) +#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) #else /* Faster for logical shifts */ -#define Type_Code(P) ((P) >> ADDRESS_LENGTH) -#define Safe_Type_Code(P) (Type_Code(P) & SAFE_TYPE_MASK) +#define pointer_type(P) ((P) >> ADDRESS_LENGTH) +#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) #endif -#define Datum(P) ((P) & ADDRESS_MASK) +#define pointer_datum(P) ((P) & ADDRESS_MASK) + +/* compatibility definitions */ +#define Type_Code(P) (pointer_type (P)) +#define Safe_Type_Code(P) (safe_pointer_type (P)) +#define Datum(P) (pointer_datum (P)) #define Make_Object(TC, D) \ - ((((unsigned) (TC)) << ADDRESS_LENGTH) | (Datum(D))) +((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D))) #ifndef Heap_In_Low_Memory /* Safe version */ -typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ +typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ extern Pointer *Memory_Base; + /* The "-1" in the value returned is guarantee that there is one word reserved exclusively for use by the garbage collector. */ + #define Allocate_Heap_Space(space) \ - (Memory_Base = (Pointer *) malloc(sizeof(Pointer) * (space)), \ + (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ Heap = Memory_Base, \ - Memory_Base + (space) - 1) -#define Get_Pointer(P) ((Pointer *) (Memory_Base+Datum(P))) -#define C_To_Scheme(P) ((Pointer) ((P)-Memory_Base)) + ((Memory_Base + (space)) - 1)) + +#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P)))) +#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base)) #else /* Storing absolute addresses */ typedef long relocation_type; /* Used to relocate pointers on fasload */ +#define Allocate_Heap_Space(space) \ + (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ + ((Heap + (space)) - 1)) + #ifdef spectrum #define Quad1_Tag 0x40000000 -#define Allocate_Heap_Space(space) \ - (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \ - Heap + (space) - 1) #define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag)) #define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK)) #else /* Not Spectrum, fast case */ -#define Allocate_Heap_Space(space) \ - (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \ - Heap + (space) - 1) -#define Get_Pointer(P) ((Pointer *) Datum(P)) +#define Get_Pointer(P) ((Pointer *) (pointer_datum (P))) #define C_To_Scheme(P) ((Pointer) (P)) #endif /* spectrum */ #endif /* Heap_In_Low_Memory */ - + #define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A)) #define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D))) #define Make_Unsigned_Fixnum(N) (FIXNUM_0 + (N)) #define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) -/* Make_New_Pointer(TC, A) may be more efficient than - Make_Pointer(TC, Get_Pointer(A)) -*/ -#define Make_New_Pointer(TC, A) Make_Object(TC, ((Pointer) A)) +/* (Make_New_Pointer (TC, A)) may be more efficient than + (Make_Pointer (TC, (Get_Pointer (A)))) */ + +#define Make_New_Pointer(TC, A) (Make_Object (TC, ((Pointer) A))) + +#define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P))) -#define Store_Type_Code(P, TC) P = Make_Object((TC), (P)) #define Store_Address(P, A) \ - P = (((P) & TYPE_CODE_MASK) | Datum((Pointer) (A))) -#define Address(P) Datum(P) + P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A)))) + +#define Address(P) (pointer_datum (P)) /* These are used only where the object is known to be immutable. On a parallel processor they don't require atomic references */ + #define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N]) #define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S) #define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1) @@ -163,25 +169,37 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0))) /* General case vector handling requires atomicity for parallel processors */ + #define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N)) #define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S) #define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1) #define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S) #ifdef FLOATING_ALIGNMENT -#define Align_Float(Where) \ -while ((((long) (Where+1)) & FLOATING_ALIGNMENT) != 0) \ - *Where++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); -#else + +#define Align_Float(Where) \ +while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ + *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); + +#else /* ifdef FLOATING_ALIGNMENT */ + #define Align_Float(Where) -#endif -#define Get_Float(P) (* ((double *) Nth_Vector_Loc((P), 1))) -#define Get_Integer(P) Datum(P) + +#endif /* ifdef FLOATING_ALIGNMENT */ + +#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM) +#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1)))) +#define Get_Integer(P) (pointer_datum (P)) + +#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0) + #define Sign_Extend(P, S) \ - { (S) = Get_Integer(P); \ - if (((S) & FIXNUM_SIGN_BIT) != 0) \ - (S) |= (-1 << ADDRESS_LENGTH); \ - } +{ \ + (S) = (Get_Integer (P)); \ + if (((S) & FIXNUM_SIGN_BIT) != 0) \ + (S) |= (-1 << ADDRESS_LENGTH); \ +} + #define Fixnum_Fits(x) \ ((((x) & SIGN_MASK) == 0) || \ (((x) & SIGN_MASK) == SIGN_MASK)) @@ -195,18 +213,14 @@ while ((((long) (Where+1)) & FLOATING_ALIGNMENT) != 0) \ /* Side effect testing */ #define Is_Constant(address) \ -(((address) >= Constant_Space) && ((address) < Free_Constant)) + (((address) >= Constant_Space) && ((address) < Free_Constant)) #define Is_Pure(address) \ -((Is_Constant(address)) && (Pure_Test(address))) + ((Is_Constant (address)) && (Pure_Test (address))) #define Side_Effect_Impurify(Old_Pointer, Will_Contain) \ -if ((Is_Constant(Get_Pointer(Old_Pointer))) && \ - (GC_Type(Will_Contain) != GC_Non_Pointer) && \ - (!(Is_Constant(Get_Pointer(Will_Contain)))) && \ - (Pure_Test(Get_Pointer(Old_Pointer)))) \ - Primitive_Error(ERR_WRITE_INTO_PURE_SPACE); - - - - +if ((Is_Constant (Get_Pointer (Old_Pointer))) && \ + (GC_Type (Will_Contain) != GC_Non_Pointer) && \ + (! (Is_Constant (Get_Pointer (Will_Contain)))) && \ + (Pure_Test (Get_Pointer (Old_Pointer)))) \ + Primitive_Error (ERR_WRITE_INTO_PURE_SPACE); diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h index b1ab6df78..3ee131ff9 100644 --- a/v7/src/microcode/prims.h +++ b/v7/src/microcode/prims.h @@ -1,6 +1,6 @@ /* -*-C-*- -Copyright (c) 1986 Massachusetts Institute of Technology +Copyright (c) 1987 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -30,13 +30,11 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* File: primitive.h - * - * This file contains some macros for defining primitives, - * for argument type or value checking, and for accessing - * the arguments. - * - */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 5.2 1987/01/12 17:18:44 cph Exp $ */ + +/* This file contains some macros for defining primitives, + for argument type or value checking, and for accessing + the arguments. */ /* Definition of primitives. See storage.c for some information. */ @@ -86,63 +84,114 @@ Built_In_Primitive(C_Name, Number_of_args, Scheme_Name) \ /* Various utilities */ #define Primitive_Error(Err_No) \ - { Back_Out_Of_Primitive(); \ - longjmp(*Back_To_Eval, Err_No); \ - } +{ \ + signal_error_from_primitive (Err_No); \ +} #define Primitive_Interrupt() \ - { Back_Out_Of_Primitive(); \ - longjmp(*Back_To_Eval, PRIM_INTERRUPT); \ - } +{ \ + signal_interrupt_from_primitive (); \ +} #define Primitive_GC(Amount) \ - { Request_GC(Amount); \ - Primitive_Interrupt(); \ - } +{ \ + Request_GC (Amount); \ + Primitive_Interrupt (); \ +} #define Primitive_GC_If_Needed(Amount) \ - if (GC_Check(Amount)) Primitive_GC(Amount) +if (GC_Check (Amount)) Primitive_GC(Amount) +#define Range_Check(To_Where, P, Low, High, Error) \ +{ \ + To_Where = Get_Integer (P); \ + if ((To_Where < (Low)) || (To_Where > (High))) \ + Primitive_Error (Error); \ +} + +#define Sign_Extend_Range_Check(To_Where, P, Low, High, Error) \ +{ \ + Sign_Extend ((P), To_Where); \ + if ((To_Where < (Low)) || (To_Where > (High))) \ + Primitive_Error (Error); \ +} + #define Arg_1_Type(TC) \ -if (Type_Code(Arg1) != (TC)) Primitive_Error(ERR_ARG_1_WRONG_TYPE) +if ((pointer_type (Arg1)) != (TC)) error_wrong_type_arg_1 () #define Arg_2_Type(TC) \ -if (Type_Code(Arg2) != (TC)) Primitive_Error(ERR_ARG_2_WRONG_TYPE) +if ((pointer_type (Arg2)) != (TC)) error_wrong_type_arg_2 () #define Arg_3_Type(TC) \ -if (Type_Code(Arg3) != (TC)) Primitive_Error(ERR_ARG_3_WRONG_TYPE) +if ((pointer_type (Arg3)) != (TC)) error_wrong_type_arg_3 () #define Arg_4_Type(TC) \ -if (Type_Code(Arg4) != (TC)) Primitive_Error(ERR_ARG_4_WRONG_TYPE) +if ((pointer_type (Arg4)) != (TC)) error_wrong_type_arg_4 () #define Arg_5_Type(TC) \ -if (Type_Code(Arg5) != (TC)) Primitive_Error(ERR_ARG_5_WRONG_TYPE) +if ((pointer_type (Arg5)) != (TC)) error_wrong_type_arg_5 () #define Arg_6_Type(TC) \ -if (Type_Code(Arg6) != (TC)) Primitive_Error(ERR_ARG_6_WRONG_TYPE) +if ((pointer_type (Arg6)) != (TC)) error_wrong_type_arg_6 () #define Arg_7_Type(TC) \ -if (Type_Code(Arg7) != (TC)) Primitive_Error(ERR_ARG_7_WRONG_TYPE) +if ((pointer_type (Arg7)) != (TC)) error_wrong_type_arg_7 () +#define Arg_8_Type(TC) \ +if ((pointer_type (Arg8)) != (TC)) error_wrong_type_arg_8 () -#define Arg_1_GC_Type(GCTC) \ -if (GC_Type(Arg1) != GCTC) Primitive_Error(ERR_ARG_1_WRONG_TYPE) +#define Arg_9_Type(TC) \ +if ((pointer_type (Arg9)) != (TC)) error_wrong_type_arg_9 () -#define Arg_2_GC_Type(GCTC) \ -if (GC_Type(Arg2) != GCTC) Primitive_Error(ERR_ARG_2_WRONG_TYPE) +#define Arg_10_Type(TC) \ +if ((pointer_type (Arg10)) != (TC)) error_wrong_type_arg_10 () -#define Arg_3_GC_Type(GCTC) \ -if (GC_Type(Arg3) != GCTC) Primitive_Error(ERR_ARG_3_WRONG_TYPE) +#define Arg_1_GC_Type(GCTC) \ +if ((GC_Type (Arg1)) != GCTC) error_wrong_type_arg_1 () -/* And a procedure or two for range checking */ - -#define Range_Check(To_Where, P, Low, High, Error) \ - { To_Where = Get_Integer(P); \ - if ((To_Where < (Low)) || (To_Where > (High))) \ - Primitive_Error(Error); } +#define Arg_2_GC_Type(GCTC) \ +if ((GC_Type (Arg2)) != GCTC) error_wrong_type_arg_2 () -#define Sign_Extend_Range_Check(To_Where, P, Low, High, Error) \ - { Sign_Extend(P,To_Where); \ - if ((To_Where < (Low)) || (To_Where > (High))) \ - Primitive_Error(Error); } +#define Arg_3_GC_Type(GCTC) \ +if ((GC_Type (Arg3)) != GCTC) error_wrong_type_arg_3 () + +#define guarantee_fixnum_arg_1() \ +if (! (fixnum_p (Arg1))) error_wrong_type_arg_1 () + +#define guarantee_fixnum_arg_2() \ +if (! (fixnum_p (Arg2))) error_wrong_type_arg_2 () + +#define guarantee_fixnum_arg_3() \ +if (! (fixnum_p (Arg3))) error_wrong_type_arg_3 () + +#define guarantee_fixnum_arg_4() \ +if (! (fixnum_p (Arg4))) error_wrong_type_arg_4 () + +#define guarantee_fixnum_arg_5() \ +if (! (fixnum_p (Arg5))) error_wrong_type_arg_5 () + +#define guarantee_fixnum_arg_6() \ +if (! (fixnum_p (Arg6))) error_wrong_type_arg_6 () + +extern long guarantee_nonnegative_integer_arg_1(); +extern long guarantee_nonnegative_integer_arg_2(); +extern long guarantee_nonnegative_integer_arg_3(); +extern long guarantee_nonnegative_integer_arg_4(); +extern long guarantee_nonnegative_integer_arg_5(); +extern long guarantee_nonnegative_integer_arg_6(); +extern long guarantee_nonnegative_integer_arg_7(); +extern long guarantee_nonnegative_integer_arg_8(); +extern long guarantee_nonnegative_integer_arg_9(); +extern long guarantee_nonnegative_integer_arg_10(); + +extern long guarantee_index_arg_1(); +extern long guarantee_index_arg_2(); +extern long guarantee_index_arg_3(); +extern long guarantee_index_arg_4(); +extern long guarantee_index_arg_5(); +extern long guarantee_index_arg_6(); +extern long guarantee_index_arg_7(); +extern long guarantee_index_arg_8(); +extern long guarantee_index_arg_9(); +extern long guarantee_index_arg_10(); diff --git a/v7/src/microcode/string.c b/v7/src/microcode/string.c index eb4921d44..c1e31ae24 100644 --- a/v7/src/microcode/string.c +++ b/v7/src/microcode/string.c @@ -30,273 +30,240 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 5.2 1987/01/11 13:18:20 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 5.3 1987/01/12 17:20:13 cph Exp $ */ -String primitives. */ +/* String primitives. */ #include "scheme.h" #include "primitive.h" #include "character.h" #include "stringprim.h" -/* The first 6 primitives are in RRRS: -1. STRING? -2. STRING-LENGTH -3. STRING-REF -4. STRING-SET -5. SUBSTRING-MOVE-RIGHT! -6. SUBSTRING-MOVE-LEFT! -*/ - -Built_In_Primitive(Prim_String_P, 1, "STRING?") -{ Primitive_1_Args(); - if (Type_Code(Arg1) != (TC_CHARACTER_STRING)) return NIL; - else return TRUTH; -} +/* Currently the strings used in symbols have type codes in the length + field. They should be changed to have just longwords there. */ -Built_In_Primitive(Prim_String_Length, 1, "STRING-LENGTH") -{ Primitive_1_Args(); - Arg_1_Type(TC_CHARACTER_STRING); - return Make_Unsigned_Fixnum(String_Length(Arg1)); +Built_In_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE") +{ + long length, count; + Pointer result; + Primitive_1_Arg (); + + length = (guarantee_nonnegative_integer_arg_1 (Arg1)); + /* Add 1 to length to account for '\0' at end of string. + Add 2 to count to account for string header words. */ + count = + ((((length + 1) + ((sizeof (Pointer)) - 1)) + / (sizeof (Pointer))) + + 2); + Primitive_GC_If_Needed (count); + result = ((Pointer) Free); + Free[STRING_HEADER] = + (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, (count - 1))); + Free[STRING_LENGTH] = ((long) length); + *(string_pointer (result, length)) = '\0'; + Free += count; + return (Make_Pointer (TC_CHARACTER_STRING, result)); } -Built_In_Primitive(Prim_String_Ref, 2, "STRING-REF") -{ long index; - char *first; - Primitive_2_Args(); - - Arg_1_Type(TC_CHARACTER_STRING); - Arg_2_Type(TC_FIXNUM); - MY_Range_Check(index, Arg2, - BEGINNING, String_Length(Arg1), - ERR_ARG_2_BAD_RANGE); - - first = (char *) String_Index(Arg1, index); - return (c_char_to_scheme_char( *first)); -} +Built_In_Primitive (Prim_String_P, 1, "STRING?") +{ + Primitive_1_Arg (); -Built_In_Primitive(Prim_String_Set, 3, "STRING-SET!") -{ long index, ascii; - Pointer Result; - char *first; - Primitive_3_Args(); - - Arg_1_Type(TC_CHARACTER_STRING); - Arg_2_Type(TC_FIXNUM); - Arg_3_Type(TC_CHARACTER); - MY_Range_Check(index, Arg2, - BEGINNING, String_Length(Arg1), - ERR_ARG_2_BAD_RANGE); - - ascii = scheme_char_to_c_char( Arg3); - if (ascii == NOT_ASCII) Primitive_Error(ERR_ARG_3_BAD_RANGE); - first = (char *) String_Index(Arg1, index); - Result = c_char_to_scheme_char( *first); - *first = ascii; - return (Result); + return ((string_p (Arg1)) ? TRUTH : NIL); } -Built_In_Primitive(Prim_Substring_Move_Right, 5, "SUBSTRING-MOVE-RIGHT!") -{ long diff, start, end, length; - char *first, *second, *firststart; - Primitive_5_Args(); - - Arg_4_Type(TC_CHARACTER_STRING); - Arg_5_Type(TC_FIXNUM); - Check_Substring_Args(); - diff = end - start; - Check_Substring_Index(Arg4, Arg5, SUM_ARG_AND_INTEGER(Arg5, diff), - ERR_ARG_5_BAD_RANGE, ERR_ARG_3_BAD_RANGE, - second, start, end, length); - - firststart = first + diff; - second += diff; - while (first < firststart) *--second = *--firststart; - return (NIL); -} +Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH") +{ + Primitive_1_Arg (); -Built_In_Primitive(Prim_Substring_Move_Left, 5, "SUBSTRING-MOVE-LEFT!") -{ long diff, start, end, length; - char *first, *second, *firstend; - - Primitive_5_Args(); - Arg_4_Type(TC_CHARACTER_STRING); - Arg_5_Type(TC_FIXNUM); - Check_Substring_Args(); - diff = end - start; - Check_Substring_Index(Arg4, Arg5, SUM_ARG_AND_INTEGER(Arg5, diff), - ERR_ARG_5_BAD_RANGE, ERR_ARG_3_BAD_RANGE, - second, - start, end, length); - - firstend = first + diff; - while (first < firstend) *second++ = *first++; - return (NIL); + guarantee_string_arg_1 (); + return (Make_Unsigned_Fixnum (string_length (Arg1))); } - -/* Eventually the strings used in symbols must be reformatted - to be the same as this format. Specifically, they can't have - type codes in the length field. */ - -/* Some length primitives -1. STRING-ALLOCATE like calling make-string with no character - obj -2. STRING-MAXIMUM-LENGTH returns the max length of a string - which is = or > string-length -3. SET-STRING-LENGTH! changes string from string-length to a - length < or = string-max-length. -*/ - -Built_In_Primitive(Prim_String_Allocate, 1, "STRING-ALLOCATE") -{ long length, count; - Pointer result; - Primitive_1_Arg(); - Arg_1_Type(TC_FIXNUM); +Built_In_Primitive (Prim_String_Maximum_Length, 1, "STRING-MAXIMUM-LENGTH") +{ + Primitive_1_Arg (); - length = Get_Integer(Arg1); - Allocate_String(result, length, count); - return result; + guarantee_string_arg_1 (); + return (Make_Unsigned_Fixnum ((maximum_string_length (Arg1)) - 1)); } -Built_In_Primitive(Prim_String_Maximum_Length, 1, "STRING-MAXIMUM-LENGTH") -{ Primitive_1_Args(); - Arg_1_Type(TC_CHARACTER_STRING); +Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!") +{ + long length, result; + Primitive_2_Args (); - return Make_Unsigned_Fixnum(Max_String_Length(Arg1) - 1); -} /* -1 for null at end */ + guarantee_string_arg_1 (); + length = (guarantee_nonnegative_integer_arg_2 (Arg2)); + if (length > (maximum_string_length (Arg1))) + error_bad_range_arg_2 (); -Built_In_Primitive(Prim_Set_String_Length, 2, "SET-STRING-LENGTH!") -{ long length; - Pointer Result; + result = (string_length (Arg1)); + set_string_length (Arg1, length); + return (Make_Unsigned_Fixnum (result)); +} - Primitive_2_Args(); - Arg_1_Type(TC_CHARACTER_STRING); - Arg_2_Type(TC_FIXNUM); - Range_Check(length, Arg2, - BEGINNING, (Max_String_Length(Arg1)), - ERR_ARG_2_BAD_RANGE); +long +substring_length_min (start1, end1, start2, end2) + long start1, end1, start2, end2; +{ + fast long length1, length2; - Result = Make_Unsigned_Fixnum(String_Length(Arg1)); - Set_String_Length(Arg1, length); - return Result; + length1 = (end1 - start1); + length2 = (end2 - start2); + return ((length1 < length2) ? length1 : length2); } -Built_In_Primitive(Prim_Vector_8b_Ref, 2, "VECTOR-8B-REF") -{ long index; - char *first; - - Primitive_2_Args(); - Arg_1_Type(TC_CHARACTER_STRING); - Arg_2_Type(TC_FIXNUM); - MY_Range_Check(index, Arg2, - BEGINNING, String_Length(Arg1), - ERR_ARG_2_BAD_RANGE); - - first = (char *) String_Index(Arg1, index); - return Make_Unsigned_Fixnum(*first); +#define string_ref_body(process_result) \ +{ \ + long index; \ + long result; \ + Primitive_2_Args (); \ + \ + guarantee_string_arg_1 (); \ + index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \ + \ + return (process_result (string_ref (Arg1, index))); \ } -Built_In_Primitive(Prim_Vector_8b_Set, 3, "VECTOR-8B-SET!") -{ long index, ascii; - Pointer Result; - char *first; - - Primitive_3_Args(); - Arg_1_Type(TC_CHARACTER_STRING); - Arg_2_Type(TC_FIXNUM); - Arg_3_Type(TC_FIXNUM); - MY_Range_Check(index, Arg2, - BEGINNING, String_Length(Arg1), - ERR_ARG_2_BAD_RANGE); - MY_Range_Check(ascii, Arg3, - BEGINNING, MAX_ASCII, - ERR_ARG_3_BAD_RANGE); - - first = (char *) String_Index(Arg1, index); - Result = Make_Unsigned_Fixnum(*first); - *first = ascii; - return Result; +Built_In_Primitive (Prim_String_Ref, 2, "STRING-REF") + string_ref_body (c_char_to_scheme_char) + +Built_In_Primitive (Prim_Vector_8b_Ref, 2, "VECTOR-8B-REF") + string_ref_body (Make_Unsigned_Fixnum) + +#define string_set_body(get_ascii, process_result) \ +{ \ + long index, ascii; \ + char *char_pointer; \ + Pointer result; \ + Primitive_3_Args (); \ + \ + guarantee_string_arg_1 (); \ + index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \ + ascii = (get_ascii (Arg3)); \ + \ + char_pointer = (string_pointer (Arg1, index)); \ + result = (char_to_long (*char_pointer)); \ + *char_pointer = ascii; \ + return (process_result (result)); \ } -Built_In_Primitive(Prim_Vector_8b_Fill, 4, "VECTOR-8B-FILL!") -{ long start, end, ascii, length; - char *first, *firstend; +Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!") + string_set_body (guarantee_ascii_character_arg_3, c_char_to_scheme_char) + +Built_In_Primitive (Prim_Vector_8b_Set, 3, "VECTOR-8B-SET!") + string_set_body (guarantee_ascii_integer_arg_3, Make_Unsigned_Fixnum) + +#define substring_move_prefix() \ + long start1, end1, start2, end2, length; \ + fast char *scan1, *scan2; \ + Primitive_5_Args (); \ + \ + guarantee_string_arg_1 (); \ + start1 = (guarantee_nonnegative_integer_arg_2 (Arg2)); \ + end1 = (guarantee_nonnegative_integer_arg_3 (Arg3)); \ + guarantee_string_arg_4 (); \ + start2 = (guarantee_nonnegative_integer_arg_5 (Arg5)); \ + \ + if (end1 > (string_length (Arg1))) \ + error_bad_range_arg_2 (); \ + if (start1 > end1) \ + error_bad_range_arg_1 (); \ + length = (end1 - start1); \ + \ + end2 = (start2 + length); \ + if (end2 > (string_length (Arg4))) \ + error_bad_range_arg_3 (); + +Built_In_Primitive (Prim_Substring_Move_Right, 5, "SUBSTRING-MOVE-RIGHT!") +{ + substring_move_prefix() - Primitive_4_Args(); - Arg_4_Type(TC_FIXNUM); - Check_Substring_Args(); - MY_Range_Check(ascii, Arg4, - BEGINNING, MAX_ASCII, - ERR_ARG_4_BAD_RANGE); + scan1 = (string_pointer (Arg1, end1)); + scan2 = (string_pointer (Arg4, end2)); + while (length-- > 0) + *--scan2 = *--scan1; + return (NIL); +} - firstend = first + end - start; - while (first < firstend) *first++ = ascii; - return NIL; +Built_In_Primitive (Prim_Substring_Move_Left, 5, "SUBSTRING-MOVE-LEFT!") +{ + substring_move_prefix() + + scan1 = (string_pointer (Arg1, start1)); + scan2 = (string_pointer (Arg4, start2)); + while (length-- > 0) + *scan2++ = *scan1++; + return (NIL); } -Built_In_Primitive(Prim_Vector_8b_Find_Next_Char, 4, - "VECTOR-8B-FIND-NEXT-CHAR") +#define vector_8b_substring_prefix() \ + long start, end, ascii; \ + long length; \ + char *scan; \ + Primitive_4_Args (); \ + \ + guarantee_string_arg_1 (); \ + start = (guarantee_nonnegative_integer_arg_2 (Arg2)); \ + end = (guarantee_nonnegative_integer_arg_3 (Arg3)); \ + ascii = (guarantee_ascii_integer_arg_4 (Arg4)); \ + \ + if (end > (string_length (Arg1))) \ + error_bad_range_arg_3 (); \ + if (start > end) \ + error_bad_range_arg_2 (); + +Built_In_Primitive (Prim_Vector_8b_Fill, 4, "VECTOR-8B-FILL!") { - long start, end, ascii, length; - char *first, *firstend; + vector_8b_substring_prefix (); + + length = (end - start); + scan = (string_pointer (Arg1, start)); + while (length-- > 0) + *scan++ = ascii; + return (NIL); +} - Primitive_4_Args(); - Arg_4_Type(TC_FIXNUM); - Check_Substring_Args(); - MY_Range_Check(ascii, Arg4, - BEGINNING, MAX_ASCII, - ERR_ARG_4_BAD_RANGE); +Built_In_Primitive (Prim_Vector_8b_Find_Next_Char, 4, + "VECTOR-8B-FIND-NEXT-CHAR") +{ + vector_8b_substring_prefix (); + scan = (string_pointer (Arg1, start)); while (start < end) { - if (*first++ == ascii) - return (Make_Unsigned_Fixnum( start)); + if ((char_to_long (*scan++)) == ascii) + return (Make_Unsigned_Fixnum (start)); start += 1; } return (NIL); } - -Built_In_Primitive(Prim_Vector_8b_Find_Previous_Char, 4, - "VECTOR-8B-FIND-PREVIOUS-CHAR") + +Built_In_Primitive (Prim_Vector_8b_Find_Previous_Char, 4, + "VECTOR-8B-FIND-PREVIOUS-CHAR") { - long start, end, ascii, length; - char *first, *firststart; - - Primitive_4_Args(); - Arg_4_Type(TC_FIXNUM); - Check_Substring_Args(); - MY_Range_Check(ascii, Arg4, - BEGINNING, MAX_ASCII, - ERR_ARG_4_BAD_RANGE); - - first = String_Index( Arg1, end); - while (end > start) - { - end -= 1; - if (*--first == ascii) - return (Make_Unsigned_Fixnum( end)); - } + vector_8b_substring_prefix (); + + scan = (string_pointer (Arg1, end)); + while (end-- > start) + if ((char_to_long (*--scan)) == ascii) + return (Make_Unsigned_Fixnum (end)); return (NIL); } - + Built_In_Primitive(Prim_Vector_8b_Find_Next_Char_Ci, 4, "VECTOR-8B-FIND-NEXT-CHAR-CI") { - long start, end, ascii, length; - char *first, *firstend; - - Primitive_4_Args(); - Arg_4_Type(TC_FIXNUM); - Check_Substring_Args(); - MY_Range_Check(ascii, Arg4, - BEGINNING, MAX_ASCII, - ERR_ARG_4_BAD_RANGE); + char char1, char2; + vector_8b_substring_prefix (); - ascii = Real_To_Upper( ascii); + scan = (string_pointer (Arg1, start)); + char1 = Real_To_Upper (ascii); while (start < end) { - if (Real_To_Upper( *first++) == ascii) + char2 = (*scan++); + if ((Real_To_Upper (char2)) == char1) return (Make_Unsigned_Fixnum( start)); start += 1; } @@ -306,63 +273,48 @@ Built_In_Primitive(Prim_Vector_8b_Find_Next_Char_Ci, 4, Built_In_Primitive(Prim_Vector_8b_Find_Previous_Char_Ci, 4, "VECTOR-8B-FIND-PREVIOUS-CHAR-CI") { - long start, end, ascii, length; - char *first, *firststart; - - Primitive_4_Args(); - Arg_4_Type(TC_FIXNUM); - Check_Substring_Args(); - MY_Range_Check(ascii, Arg4, - BEGINNING, MAX_ASCII, - ERR_ARG_4_BAD_RANGE); - - first = String_Index( Arg1, end); - ascii = Real_To_Upper( ascii); - while (end > start) + char char1, char2; + vector_8b_substring_prefix (); + + scan = (string_pointer (Arg1, end)); + char1 = Real_To_Upper (ascii); + while (end-- > start) { - end -= 1; - if (Real_To_Upper( *--first) == ascii) - return (Make_Unsigned_Fixnum( end)); + char2 = (*--scan); + if ((Real_To_Upper (char2)) == char1) + return (Make_Unsigned_Fixnum (end)); } return (NIL); } -/* Substring primitives: -1. SUBSTRING-FIND-NEXT-CHAR-IN-SET -2. SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET Searches through the specified - substring to find the next - character in the given char set. -3. SUBSTRING=? -4. SUBSTRING-CI=? Comparisons of substrings, done -5. SUBSTRING (string_length (Arg1))) \ + error_bad_range_arg_3 (); \ + if (start > end) \ + error_bad_range_arg_2 (); \ + if ((string_length (Arg4)) != MAX_ASCII) \ + error_bad_range_arg_4 (); + Built_In_Primitive(Prim_Substring_Find_Next_Char_In_Set, 4, "SUBSTRING-FIND-NEXT-CHAR-IN-SET") { - long length; - fast char *first, *char_set; - fast long start, end, c; - Primitive_4_Args(); - - Check_Substring_Args(); - Arg_4_Type(TC_CHARACTER_STRING); - if (String_Length(Arg4) != MAX_ASCII) - Primitive_Error(ERR_ARG_4_BAD_RANGE); - char_set = Scheme_String_To_C_String(Arg4); + substring_find_char_in_set_prefix (); + char_set = (Scheme_String_To_C_String (Arg4)); + scan = (string_pointer (Arg1, start)); while (start < end) { - c = *first++; - if (char_set[c] != '\0') - return (Make_Unsigned_Fixnum( start)); + if (char_set[(char_to_long (*scan++))] != '\0') + return (Make_Unsigned_Fixnum (start)); start += 1; } return (NIL); @@ -371,192 +323,166 @@ Built_In_Primitive(Prim_Substring_Find_Next_Char_In_Set, 4, Built_In_Primitive(Prim_Substring_Find_Previous_Char_In_Set, 4, "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET") { - long length; - fast char *first, *char_set; - fast long start, end, c; - Primitive_4_Args(); - - Check_Substring_Args(); - Arg_4_Type(TC_CHARACTER_STRING); - if (String_Length(Arg4) != MAX_ASCII) - Primitive_Error(ERR_ARG_4_BAD_RANGE); - char_set = Scheme_String_To_C_String(Arg4); + substring_find_char_in_set_prefix (); - first = String_Index( Arg1, end); - while (end > start) - { - end -= 1; - c = *--first; - if (char_set[c] != '\0') - return (Make_Unsigned_Fixnum( end)); - } + char_set = Scheme_String_To_C_String(Arg4); + scan = (string_pointer (Arg1, end)); + while (end-- > start) + if (char_set[(char_to_long (*--scan))] != '\0') + return (Make_Unsigned_Fixnum (end)); return (NIL); } -Built_In_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?") -{ long start, start_2, end, end_2, j, length, length_2, diff; - char *first, *second, *firstend; - - Primitive_6_Args(); - Check_Substring_Args(); - Check_Substring_Args_B(); - - diff = end - start; - firstend = diff + first; - if (diff != end_2 - start_2) return (NIL); - for (; first < firstend; first++, second++) - if (*first != *second) return NIL; - return TRUTH; +#define substring_compare_prefix(index1, index2) \ + long start1, end1, start2, end2; \ + char *scan1, *scan2; \ + Primitive_6_Args (); \ + \ + guarantee_string_arg_1 (); \ + start1 = (guarantee_nonnegative_integer_arg_2 (Arg2)); \ + end1 = (guarantee_nonnegative_integer_arg_3 (Arg3)); \ + guarantee_string_arg_4 (); \ + start2 = (guarantee_nonnegative_integer_arg_5 (Arg5)); \ + end2 = (guarantee_nonnegative_integer_arg_6 (Arg6)); \ + \ + if (end1 > (string_length (Arg1))) \ + error_bad_range_arg_3 (); \ + if (start1 > end1) \ + error_bad_range_arg_2 (); \ + \ + if (end2 > (string_length (Arg4))) \ + error_bad_range_arg_6 (); \ + if (start2 > end2) \ + error_bad_range_arg_5 (); \ + \ + scan1 = (string_pointer (Arg1, index1)); \ + scan2 = (string_pointer (Arg4, index2)); + +#define substring_equal_prefix() \ + long length; \ + substring_compare_prefix (start1, start2); \ + \ + length = (end1 - start1); \ + if (length != (end2 - start2)) \ + return (NIL); + +Built_In_Primitive (Prim_Substring_Equal, 6, "SUBSTRING=?") +{ + substring_equal_prefix (); + + while (length-- > 0) + if ((*scan1++) != (*scan2++)) + return (NIL); + return (TRUTH); } Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?") -{ long start, start_2, end, end_2, j, length, length_2, diff; - char *first, *second, *firstend; - - Primitive_6_Args(); - Check_Substring_Args(); - Check_Substring_Args_B(); - - diff = end - start; - firstend = first + diff; - if (diff != end_2 - start_2) return (NIL); - for (; first < firstend; first++, second++) - if (Real_To_Upper(*first) != Real_To_Upper(*second)) - return NIL; +{ + substring_equal_prefix (); + + while (length-- > 0) + if ((Real_To_Upper (*scan1++)) != (Real_To_Upper (*scan2++))) + return (NIL); return (TRUTH); } -Built_In_Primitive(Prim_Substring_Less, 6, "SUBSTRING *second) return NIL; - else if (*first < *second) return TRUTH; - return Equal_Answer; +Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING 0) + if ((*scan1++) != (*scan2++)) + return (((scan1[-1]) < (scan2[-1])) ? TRUTH : NIL); + + return ((length1 < length2) ? TRUTH : NIL); } -Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!") -{ long start, end, length; - char *first, *firstend; +#define substring_modification_prefix() \ + long start, end, length; \ + char *scan; \ + Primitive_3_Args (); \ + \ + guarantee_string_arg_1 (); \ + start = (guarantee_nonnegative_integer_arg_2 (Arg2)); \ + end = (guarantee_nonnegative_integer_arg_3 (Arg3)); \ + \ + if (end > (string_length (Arg1))) \ + error_bad_range_arg_3 (); \ + if (start > end) \ + error_bad_range_arg_2 (); \ + \ + length = (end - start); \ + scan = (string_pointer (Arg1, start)); - Primitive_3_Args(); - Check_Substring_Args(); +Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!") +{ + substring_modification_prefix (); - firstend = first + end - start; - while (first < firstend) *first++ = Real_To_Upper(*first); + while (length-- > 0) + *scan++ = (Real_To_Upper (*scan)); return (NIL); } Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!") -{ long start, end, length; - char *first, *firstend; - - Primitive_3_Args(); - Check_Substring_Args(); +{ + substring_modification_prefix (); - firstend = first + end - start; - while (first < firstend) *first++ = Real_To_Lower(*first); + while (length-- > 0) + *scan++ = (Real_To_Lower (*scan)); return (NIL); } -Built_In_Primitive(Prim_Substring_Match_Forward, 6, "SUBSTRING-MATCH-FORWARD") -{ long start, start_2, end, end_2, length, length_2, - diff, diff_2, count, firstend; - char *first, *second; - - Primitive_6_Args(); - Check_Substring_Args(); - Check_Substring_Args_B(); - - diff = end - start; - diff_2 = end_2 - start_2; - if (diff > diff_2) firstend = diff_2; - else firstend = diff; - for (count=0; count < firstend; first++, second++, count++) - if (*first != *second) return Make_Unsigned_Fixnum(count); - return Make_Unsigned_Fixnum(count); +#define substring_match_prefix(index1, index2) \ + long length, unmatched; \ + substring_compare_prefix (index1, index2); \ + \ + length = (substring_length_min (start1, end1, start2, end2)); \ + unmatched = length; + +Built_In_Primitive (Prim_Substring_Match_Forward, 6, "SUBSTRING-MATCH-FORWARD") +{ + substring_match_prefix (start1, start2); + + while (unmatched-- > 0) + if ((*scan1++) != (*scan2++)) + return (Make_Unsigned_Fixnum (length - (unmatched + 1))); + return (Make_Unsigned_Fixnum (length)); } -Built_In_Primitive(Prim_Substring_Match_Forward_Ci, 6, +Built_In_Primitive (Prim_Substring_Match_Forward_Ci, 6, "SUBSTRING-MATCH-FORWARD-CI") -{ long start, start_2, end, end_2, length, length_2, - diff, diff_2, firstend, count; - char *first, *second; - - Primitive_6_Args(); - Check_Substring_Args(); - Check_Substring_Args_B(); - - diff = end - start; - diff_2 = end_2 - start_2; - if (diff > diff_2) firstend = diff_2; - else firstend = diff; - for (count=0; count < firstend; first++, second++, count++) - if (Real_To_Upper(*first) != Real_To_Upper(*second)) - return Make_Unsigned_Fixnum(count); - return Make_Unsigned_Fixnum(count); +{ + substring_match_prefix (start1, start2); + + while (unmatched-- > 0) + if ((Real_To_Upper (*scan1++)) != (Real_To_Upper (*scan2++))) + return (Make_Unsigned_Fixnum (length - (unmatched + 1))); + return (Make_Unsigned_Fixnum (length)); } - -Built_In_Primitive(Prim_Substring_Match_Backward, 6, + +Built_In_Primitive (Prim_Substring_Match_Backward, 6, "SUBSTRING-MATCH-BACKWARD") -{ long start, start_2, end, end_2, length, length_2, - diff, diff_2, min_length, count; - char *first, *second, *firststart; - - Primitive_6_Args(); - Check_Substring_Args(); - Check_Substring_Args_B(); - - diff = end - start; - diff_2 = end_2 - start_2; - if (diff > diff_2) min_length = diff_2; - else min_length = diff; - first += diff - 1; - second += diff_2 - 1; - - for (count = 0; count < min_length; first--, second--, count++) - if (*first != *second) - return Make_Unsigned_Fixnum(count); - return Make_Unsigned_Fixnum(count); +{ + substring_match_prefix (end1, end2); + + while (unmatched-- > 0) + if ((*--scan1) != (*--scan2)) + return (Make_Unsigned_Fixnum (length - (unmatched + 1))); + return (Make_Unsigned_Fixnum (length)); } Built_In_Primitive(Prim_Substring_Match_Backward_Ci, 6, "SUBSTRING-MATCH-BACKWARD-CI") -{ long start, start_2, end, end_2, length, length_2, - diff, diff_2, min_length, count; - char *first, *second, *firststart; - - Primitive_6_Args(); - Check_Substring_Args(); - Check_Substring_Args_B(); - - diff = end - start; - diff_2 = end_2 - start_2; - if (diff > diff_2) min_length = diff_2; - else min_length = diff; - first += diff - 1; - second += diff_2 - 1; - - for (count = 0; count < min_length; first--, second--, count++) - if (Real_To_Upper(*first) != Real_To_Upper(*second)) - return Make_Unsigned_Fixnum(count); - return Make_Unsigned_Fixnum(count); +{ + substring_match_prefix (end1, end2); + + while (unmatched-- > 0) + if ((Real_To_Upper (*--scan1)) != (Real_To_Upper (*--scan2))) + return (Make_Unsigned_Fixnum (length - (unmatched + 1))); + return (Make_Unsigned_Fixnum (length)); } diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h index 73b3cbc8e..d792508ee 100644 --- a/v8/src/microcode/object.h +++ b/v8/src/microcode/object.h @@ -1,6 +1,6 @@ /* -*-C-*- -Copyright (c) 1986 Massachusetts Institute of Technology +Copyright (c) 1987 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -30,13 +30,11 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 5.2 1986/12/17 06:35:06 cph Exp $ - * - * This file contains definitions pertaining to the C view of - * Scheme pointers: widths of fields, extraction macros, pre-computed - * extraction masks, etc. - * - */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 5.3 1987/01/12 17:17:33 cph Exp $ */ + +/* This file contains definitions pertaining to the C view of + Scheme pointers: widths of fields, extraction macros, pre-computed + extraction masks, etc. */ /* The C type Pointer is defined at the end of CONFIG.H The definition of POINTER_LENGTH here assumes that Pointer is the same @@ -52,8 +50,7 @@ MIT in each case. */ particular binding of a variable to a value has been shadowed by an auxiliary variable in a nested environment. It means that variables cached to this address must be recached since the address may be invalid. - See lookup.c -*/ + See lookup.c */ #define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */ #define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */ @@ -88,73 +85,82 @@ MIT in each case. */ #endif #ifndef UNSIGNED_SHIFT /* Safe version */ -#define Type_Code(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) -#define Safe_Type_Code(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) +#define pointer_type(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) +#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) #else /* Faster for logical shifts */ -#define Type_Code(P) ((P) >> ADDRESS_LENGTH) -#define Safe_Type_Code(P) (Type_Code(P) & SAFE_TYPE_MASK) +#define pointer_type(P) ((P) >> ADDRESS_LENGTH) +#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) #endif -#define Datum(P) ((P) & ADDRESS_MASK) +#define pointer_datum(P) ((P) & ADDRESS_MASK) + +/* compatibility definitions */ +#define Type_Code(P) (pointer_type (P)) +#define Safe_Type_Code(P) (safe_pointer_type (P)) +#define Datum(P) (pointer_datum (P)) #define Make_Object(TC, D) \ - ((((unsigned) (TC)) << ADDRESS_LENGTH) | (Datum(D))) +((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D))) #ifndef Heap_In_Low_Memory /* Safe version */ -typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ +typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ extern Pointer *Memory_Base; + /* The "-1" in the value returned is guarantee that there is one word reserved exclusively for use by the garbage collector. */ + #define Allocate_Heap_Space(space) \ - (Memory_Base = (Pointer *) malloc(sizeof(Pointer) * (space)), \ + (Memory_Base = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ Heap = Memory_Base, \ - Memory_Base + (space) - 1) -#define Get_Pointer(P) ((Pointer *) (Memory_Base+Datum(P))) -#define C_To_Scheme(P) ((Pointer) ((P)-Memory_Base)) + ((Memory_Base + (space)) - 1)) + +#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P)))) +#define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base)) #else /* Storing absolute addresses */ typedef long relocation_type; /* Used to relocate pointers on fasload */ +#define Allocate_Heap_Space(space) \ + (Heap = ((Pointer *) (malloc ((sizeof (Pointer)) * (space)))), \ + ((Heap + (space)) - 1)) + #ifdef spectrum #define Quad1_Tag 0x40000000 -#define Allocate_Heap_Space(space) \ - (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \ - Heap + (space) - 1) #define Get_Pointer(P) ((Pointer *) (((P) & ADDRESS_MASK) | Quad1_Tag)) #define C_To_Scheme(P) ((Pointer) (((long) (P)) & ADDRESS_MASK)) #else /* Not Spectrum, fast case */ -#define Allocate_Heap_Space(space) \ - (Heap = (Pointer *) malloc(sizeof(Pointer) * (space)), \ - Heap + (space) - 1) -#define Get_Pointer(P) ((Pointer *) Datum(P)) +#define Get_Pointer(P) ((Pointer *) (pointer_datum (P))) #define C_To_Scheme(P) ((Pointer) (P)) #endif /* spectrum */ #endif /* Heap_In_Low_Memory */ - + #define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A)) #define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D))) #define Make_Unsigned_Fixnum(N) (FIXNUM_0 + (N)) #define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) -/* Make_New_Pointer(TC, A) may be more efficient than - Make_Pointer(TC, Get_Pointer(A)) -*/ -#define Make_New_Pointer(TC, A) Make_Object(TC, ((Pointer) A)) +/* (Make_New_Pointer (TC, A)) may be more efficient than + (Make_Pointer (TC, (Get_Pointer (A)))) */ + +#define Make_New_Pointer(TC, A) (Make_Object (TC, ((Pointer) A))) + +#define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P))) -#define Store_Type_Code(P, TC) P = Make_Object((TC), (P)) #define Store_Address(P, A) \ - P = (((P) & TYPE_CODE_MASK) | Datum((Pointer) (A))) -#define Address(P) Datum(P) + P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A)))) + +#define Address(P) (pointer_datum (P)) /* These are used only where the object is known to be immutable. On a parallel processor they don't require atomic references */ + #define Fast_Vector_Ref(P, N) ((Get_Pointer(P))[N]) #define Fast_Vector_Set(P, N, S) Fast_Vector_Ref(P, N) = (S) #define Fast_User_Vector_Ref(P, N) Fast_Vector_Ref(P, (N)+1) @@ -163,25 +169,37 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #define Vector_Length(P) (Get_Integer(Fast_Vector_Ref((P), 0))) /* General case vector handling requires atomicity for parallel processors */ + #define Vector_Ref(P, N) Fetch(Fast_Vector_Ref(P, N)) #define Vector_Set(P, N, S) Store(Fast_Vector_Ref(P, N), S) #define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1) #define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S) #ifdef FLOATING_ALIGNMENT -#define Align_Float(Where) \ -while ((((long) (Where+1)) & FLOATING_ALIGNMENT) != 0) \ - *Where++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); -#else + +#define Align_Float(Where) \ +while ((((long) ((Where) + 1)) & FLOATING_ALIGNMENT) != 0) \ + *Where++ = (Make_Non_Pointer (TC_MANIFEST_NM_VECTOR, 0)); + +#else /* ifdef FLOATING_ALIGNMENT */ + #define Align_Float(Where) -#endif -#define Get_Float(P) (* ((double *) Nth_Vector_Loc((P), 1))) -#define Get_Integer(P) Datum(P) + +#endif /* ifdef FLOATING_ALIGNMENT */ + +#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM) +#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1)))) +#define Get_Integer(P) (pointer_datum (P)) + +#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0) + #define Sign_Extend(P, S) \ - { (S) = Get_Integer(P); \ - if (((S) & FIXNUM_SIGN_BIT) != 0) \ - (S) |= (-1 << ADDRESS_LENGTH); \ - } +{ \ + (S) = (Get_Integer (P)); \ + if (((S) & FIXNUM_SIGN_BIT) != 0) \ + (S) |= (-1 << ADDRESS_LENGTH); \ +} + #define Fixnum_Fits(x) \ ((((x) & SIGN_MASK) == 0) || \ (((x) & SIGN_MASK) == SIGN_MASK)) @@ -195,18 +213,14 @@ while ((((long) (Where+1)) & FLOATING_ALIGNMENT) != 0) \ /* Side effect testing */ #define Is_Constant(address) \ -(((address) >= Constant_Space) && ((address) < Free_Constant)) + (((address) >= Constant_Space) && ((address) < Free_Constant)) #define Is_Pure(address) \ -((Is_Constant(address)) && (Pure_Test(address))) + ((Is_Constant (address)) && (Pure_Test (address))) #define Side_Effect_Impurify(Old_Pointer, Will_Contain) \ -if ((Is_Constant(Get_Pointer(Old_Pointer))) && \ - (GC_Type(Will_Contain) != GC_Non_Pointer) && \ - (!(Is_Constant(Get_Pointer(Will_Contain)))) && \ - (Pure_Test(Get_Pointer(Old_Pointer)))) \ - Primitive_Error(ERR_WRITE_INTO_PURE_SPACE); - - - - +if ((Is_Constant (Get_Pointer (Old_Pointer))) && \ + (GC_Type (Will_Contain) != GC_Non_Pointer) && \ + (! (Is_Constant (Get_Pointer (Will_Contain)))) && \ + (Pure_Test (Get_Pointer (Old_Pointer)))) \ + Primitive_Error (ERR_WRITE_INTO_PURE_SPACE); -- 2.25.1