From b04203c4a5c3063531fb14eba3b050ee1ce36d00 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Tue, 3 Aug 1993 08:30:12 +0000 Subject: [PATCH] Change the primitive tables to allow for dynamic declaration of primitives. --- v7/src/microcode/bchmmg.c | 6 +- v7/src/microcode/boot.c | 5 +- v7/src/microcode/cmpauxmd/hppa.m4 | 30 +- v7/src/microcode/cmpint.c | 11 +- v7/src/microcode/cmpintmd/hppa.h | 94 ++- v7/src/microcode/debug.c | 15 +- v7/src/microcode/dostop.c | 16 +- v7/src/microcode/errors.h | 7 +- v7/src/microcode/extern.c | 35 +- v7/src/microcode/fasload.c | 85 +-- v7/src/microcode/findprim.c | 12 +- v7/src/microcode/interp.h | 57 +- v7/src/microcode/memmag.c | 6 +- v7/src/microcode/msdos.h | 108 +--- v7/src/microcode/nt.h | 113 +--- v7/src/microcode/nttop.c | 16 +- v7/src/microcode/object.h | 11 +- v7/src/microcode/prename.h | 62 +- v7/src/microcode/prim.h | 57 +- v7/src/microcode/prims.h | 9 +- v7/src/microcode/primutl.c | 929 +++++++++++++++++------------- v7/src/microcode/usrdef.h | 19 +- v7/src/microcode/utils.c | 32 +- v7/src/microcode/ux.h | 107 +--- v7/src/microcode/uxtop.c | 18 +- v7/src/microcode/version.h | 4 +- v8/src/microcode/cmpauxmd/hppa.m4 | 30 +- v8/src/microcode/cmpint.c | 11 +- v8/src/microcode/cmpintmd/hppa.h | 94 ++- v8/src/microcode/object.h | 11 +- v8/src/microcode/version.h | 4 +- 31 files changed, 943 insertions(+), 1071 deletions(-) diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index bff2c95e3..6cc13330c 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: bchmmg.c,v 9.77 1993/07/27 21:00:46 gjr Exp $ +$Id: bchmmg.c,v 9.78 1993/08/03 08:29:35 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -3024,8 +3024,6 @@ DEFUN (GC, (weak_pair_transport_initialized_p), *free_buffer++ = Fixed_Objects; *free_buffer++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History)); - *free_buffer++ = Undefined_Primitives; - *free_buffer++ = Undefined_Primitives_Arity; *free_buffer++ = Get_Current_Stacklet (); *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ? SHARP_F : @@ -3099,8 +3097,6 @@ DEFUN (GC, (weak_pair_transport_initialized_p), (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2)))); History = (OBJECT_ADDRESS (*root++)); - Undefined_Primitives = *root++; - Undefined_Primitives_Arity = *root++; Set_Current_Stacklet (*root); root += 1; diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index f51c93346..6adc8e39c 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: boot.c,v 9.81 1993/06/29 22:53:46 cph Exp $ +$Id: boot.c,v 9.82 1993/08/03 08:29:38 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -158,12 +158,15 @@ DEFUN (main_name, (argc, argv), } else { + extern void EXFUN (initialize_primitives, (void)); + Heap_Size = option_heap_size; Stack_Size = option_stack_size; Constant_Size = option_constant_size; Setup_Memory ((BLOCKS_TO_BYTES (Heap_Size)), (BLOCKS_TO_BYTES (Stack_Size)), (BLOCKS_TO_BYTES (Constant_Size))); + initialize_primitives (); if (! option_fasl_file) { compiler_initialize (0); diff --git a/v7/src/microcode/cmpauxmd/hppa.m4 b/v7/src/microcode/cmpauxmd/hppa.m4 index 4016dd9cf..56cd4532b 100644 --- a/v7/src/microcode/cmpauxmd/hppa.m4 +++ b/v7/src/microcode/cmpauxmd/hppa.m4 @@ -1,6 +1,6 @@ changecom(`;');;; -*-Midas-*- ;;; -;;; $Id: hppa.m4,v 1.29 1993/07/29 07:02:17 gjr Exp $ +;;; $Id: hppa.m4,v 1.30 1993/08/03 08:28:43 gjr Exp $ ;;; ;;; Copyright (c) 1989-1993 Massachusetts Institute of Technology ;;; @@ -121,7 +121,6 @@ define(TC_LENGTH, ifdef("TYPE_CODE_LENGTH", TYPE_CODE_LENGTH, 8)) define(QUAD_MASK, eval(2 ** (TC_LENGTH - 2))) define(LOW_TC_BIT, eval(TC_LENGTH - 1)) define(DATUM_LENGTH, eval(32 - TC_LENGTH)) -define(HALF_DATUM_LENGTH, eval(DATUM_LENGTH/2)) define(FIXNUM_LENGTH, DATUM_LENGTH) define(FIXNUM_POS, eval(FIXNUM_LENGTH - 1)) define(FIXNUM_BIT, eval(TC_LENGTH + 1)) @@ -933,7 +932,7 @@ stack_and_interrupt_check_signal_interrupt BE 0(5,31) ; return NOP -;;; The following all have the same interface: +;;; invoke_primitive and *cons all have the same interface: ;;; The "return address" in r31 points to a word containing ;;; the distance between itself and the word in memory containing ;;; the primitive object. @@ -945,10 +944,10 @@ invoke_primitive ADDIL L'hppa_primitive_table-$global$,27 LDWX 26(0,31),26 ; get primitive LDW R'hppa_primitive_table-$global$(1),25 - EXTRU 26,31,HALF_DATUM_LENGTH,24 ; get primitive index + EXTRU 26,31,DATUM_LENGTH,24 ; get primitive index STW 26,32(0,4) ; store primitive ADDIL L'Primitive_Arity_Table-$global$,27 - LDO R'Primitive_Arity_Table-$global$(1),18 + LDW R'Primitive_Arity_Table-$global$(1),18 LDWX,S 24(0,25),25 ; find primitive entry point ADDIL L'Ext_Stack_Pointer-$global$,27 STW 22,R'Ext_Stack_Pointer-$global$(1) ; Update stack pointer @@ -968,6 +967,15 @@ invoke_primitive B ep_interface_to_scheme_2 DEP 5,TC_START,TC_LENGTH,26 ; return address as address +;;; The BLE in invoke_primitive can jump here. +;;; The primitive index is in gr24 + +cross_segment_call + ADDIL L'Primitive_Procedure_Table-$global$,27 + LDW R'Primitive_Procedure_Table-$global$(1),22 + LDWX,S 24(0,22),22 + B $$dyncall ; ignore the return address + vector_cons LDW 0(0,22),26 ; length as fixnum COPY 21,2 @@ -1173,6 +1181,7 @@ define(builtin,"ADDIL L'$1-known_pc,3 builtin(shortcircuit_apply_8) builtin(stack_and_interrupt_check) builtin(invoke_primitive) + builtin(cross_segment_call) builtin(vector_cons) builtin(string_allocate) builtin(floating_vector_cons) @@ -1427,8 +1436,10 @@ interface_limit .IMPORT hppa_utility_table,DATA .IMPORT hppa_primitive_table,DATA .IMPORT Primitive_Arity_Table,DATA + .IMPORT Primitive_Procedure_Table,DATA .SPACE $TEXT$ .SUBSPA $CODE$ + .IMPORT $$dyncall,MILLICODE .IMPORT $$remI,MILLICODE .IMPORT declare_builtin,CODE .IMPORT sin,CODE @@ -1444,14 +1455,15 @@ interface_limit .IMPORT floor,CODE .IMPORT atan2,CODE .EXPORT C_to_interface,PRIV_LEV=3,ARGW0=GR,RTNVAL=GR - .EXPORT interface_initialize,PRIV_LEV=3 + .EXPORT ep_interface_to_scheme,PRIV_LEV=3 .EXPORT scheme_to_interface_ble,PRIV_LEV=3 .EXPORT trampoline_to_interface,PRIV_LEV=3 .EXPORT scheme_to_interface,PRIV_LEV=3 .EXPORT hook_jump_table,PRIV_LEV=3 + .EXPORT cross_segment_call,PRIV_LEV=3 + .EXPORT flonum_atan2,PRIV_LEV=3 + .EXPORT ep_interface_to_C,PRIV_LEV=3 + .EXPORT interface_initialize,PRIV_LEV=3 .EXPORT cache_flush_region,PRIV_LEV=3 .EXPORT cache_flush_all,PRIV_LEV=3 - .EXPORT ep_interface_to_C,PRIV_LEV=3 - .EXPORT ep_interface_to_scheme,PRIV_LEV=3 - .EXPORT flonum_atan2,PRIV_LEV=3 .END diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index eab4bf7cd..a7a30334f 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.60 1993/07/29 07:11:02 gjr Exp $ +$Id: cmpint.c,v 1.61 1993/08/03 08:29:39 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -2588,22 +2588,17 @@ loop: case TC_PRIMITIVE: { long arity; - extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT)); - arity = primitive_to_arity (procedure); + arity = (PRIMITIVE_ARITY (procedure)); if (arity == (nactuals - 1)) { nactuals = 0; kind = TRAMPOLINE_K_PRIMITIVE; } else if (arity == LEXPR_PRIMITIVE_ARITY) - { kind = TRAMPOLINE_K_LEXPR_PRIMITIVE; - } else - { kind = TRAMPOLINE_K_OTHER; - } break; } @@ -2931,7 +2926,7 @@ DEFUN (pc_to_utility_index, (pc), unsigned long pc) || (pc >= (UTIL_TABLE_PC_REF (last_util_table_index)))) return (-1); else if (pc < (UTIL_TABLE_PC_REF (1))) - return ((pc_to_builtin_index (pc)) ? -1 : 0); + return (((pc_to_builtin_index (pc)) == -1) ? 0 : -1); else { int low, high, middle; diff --git a/v7/src/microcode/cmpintmd/hppa.h b/v7/src/microcode/cmpintmd/hppa.h index d94500c05..71abb2401 100644 --- a/v7/src/microcode/cmpintmd/hppa.h +++ b/v7/src/microcode/cmpintmd/hppa.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hppa.h,v 1.43 1993/07/29 07:02:09 gjr Exp $ +$Id: hppa.h,v 1.44 1993/08/03 08:28:51 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -709,6 +709,12 @@ DEFUN_VOID (flush_i_cache_initialize) push_d_cache_region (((PTR) (address)), \ ((unsigned long) (nwords))); \ } while (0) + +extern void EXFUN (hppa_update_primitive_table, (int, int)); +extern Boolean EXFUN (hppa_grow_primitive_table, (int)); + +#define UPDATE_PRIMITIVE_TABLE_HOOK hppa_update_primitive_table +#define GROW_PRIMITIVE_TABLE_HOOK hppa_grow_primitive_table /* This is not completely true. Some models (eg. 850) have combined caches, but we have to assume the worst. @@ -732,28 +738,46 @@ DEFUN (assemble_17, (inst), union ble_inst inst) return off.value; } +static unsigned long hppa_closure_hook = 0; + static unsigned long DEFUN (C_closure_entry_point, (closure), unsigned long C_closure) { - if ((C_closure & 0x3) == 0x2) + if ((C_closure & 0x3) != 0x2) + return (C_closure); + else { long offset; + extern int etext; + unsigned long entry_point; char * blp = (* ((char **) (C_closure - 2))); blp = ((char *) (((unsigned long) blp) & ~3)); offset = (assemble_17 (* ((union ble_inst *) blp))); - return ((unsigned long) ((blp + 8) + offset)); + entry_point = ((unsigned long) ((blp + 8) + offset)); + return ((entry_point < ((unsigned long) &etext)) + ? entry_point + : hppa_closure_hook); } - else - return (C_closure); } + +static void +DEFUN (transform_procedure_entries, (len, otable, ntable), + long len AND PTR * otable AND PTR * ntable) +{ + long counter; + + for (counter = 0; counter < len; counter++) + ntable[counter] = + ((PTR) (C_closure_entry_point ((unsigned long) (otable [counter])))); + return; +} -PTR * +static PTR * DEFUN (transform_procedure_table, (table_length, old_table), long table_length AND PTR * old_table) { PTR * new_table; - long counter; new_table = ((PTR *) (malloc (table_length * (sizeof (PTR))))); if (new_table == ((PTR *) NULL)) @@ -762,16 +786,13 @@ DEFUN (transform_procedure_table, (table_length, old_table), (table_length * (sizeof (PTR)))); exit (1); } - - for (counter = 0; counter < table_length; counter++) - new_table[counter] = - ((PTR) (C_closure_entry_point ((unsigned long) (old_table [counter])))); + transform_procedure_entries (table_length, old_table, new_table); return (new_table); } #define UTIL_TABLE_PC_REF(index) \ (C_closure_entry_point (UTIL_TABLE_PC_REF_REAL (index))) - + #ifdef _BSD4_3 # include # define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC) @@ -803,42 +824,61 @@ DEFUN_VOID (change_vm_protection) #endif return; } - + /* This loads the cache information structure for use by flush_i_cache, sets the floating point flags correctly, and accommodates the c function pointer closure format problems for utilities for HP-UX >= 8.0 . It also changes the VM protection of the heap, if necessary. */ -extern PTR * hppa_utility_table, * hppa_primitive_table; -PTR * hppa_utility_table, * hppa_primitive_table; +extern PTR * hppa_utility_table; +extern PTR * hppa_primitive_table; -void -DEFUN (hppa_reset_hook, (utility_length, utility_table, - primitive_length, primitive_table), - long utility_length AND PTR * utility_table - AND long primitive_length AND PTR * primitive_table) +PTR * hppa_utility_table = ((PTR *) NULL); + +static void +DEFUN (hppa_reset_hook, (utility_length, utility_table), + long utility_length AND PTR * utility_table) { extern void EXFUN (interface_initialize, (void)); + extern void EXFUN (cross_segment_call, (void)); flush_i_cache_initialize (); interface_initialize (); change_vm_protection (); - hppa_utility_table = - (transform_procedure_table (utility_length, utility_table)); - hppa_primitive_table = - (transform_procedure_table (primitive_length, primitive_table)); + hppa_closure_hook = (C_closure_entry_point ((unsigned long) cross_segment_call)); + hppa_utility_table + = (transform_procedure_table (utility_length, utility_table)); return; } #define ASM_RESET_HOOK() do \ { \ hppa_reset_hook (((sizeof (utility_table)) / (sizeof (PTR))), \ - ((PTR *) (&utility_table[0])), \ - (MAX_PRIMITIVE + 1), \ - ((PTR *) (&Primitive_Procedure_Table[0]))); \ + ((PTR *) (&utility_table[0]))); \ } while (0) +PTR * hppa_primitive_table = ((PTR *) NULL); + +void +DEFUN (hppa_update_primitive_table, (low, high), int low AND int high) +{ + transform_procedure_entries ((high - low), + ((PTR *) (Primitive_Procedure_Table + low)), + (hppa_primitive_table + low)); + return; +} + +Boolean +DEFUN (hppa_grow_primitive_table, (new_size), int new_size) +{ + PTR * new_table + = ((PTR *) (realloc (hppa_primitive_table, (new_size * (sizeof (PTR)))))); + if (new_table != ((PTR *) NULL)) + hppa_primitive_table = new_table; + return (new_table != ((PTR *) NULL)); +} + #endif /* IN_CMPINT_C */ /* Derived parameters and macros. diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c index bd38c1824..cc8ac9e5c 100644 --- a/v7/src/microcode/debug.c +++ b/v7/src/microcode/debug.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: debug.c,v 9.44 1993/06/24 04:23:41 gjr Exp $ +$Id: debug.c,v 9.45 1993/08/03 08:29:42 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -803,10 +803,9 @@ static Boolean DEFUN (print_primitive_name, (stream, primitive), outf_channel stream AND SCHEME_OBJECT primitive) { - extern char * EXFUN (primitive_to_name, (SCHEME_OBJECT)); - char *name; + char * name; - name = primitive_to_name(primitive); + name = (PRIMITIVE_NAME (primitive)); if (name == ((char *) NULL)) { outf (stream, "Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive)); @@ -822,19 +821,15 @@ DEFUN (print_primitive_name, (stream, primitive), void DEFUN (Print_Primitive, (primitive), SCHEME_OBJECT primitive) { - extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT)); char buffer[40]; int NArgs, i; outf_console ("Primitive: "); if (print_primitive_name (console_output, primitive)) - { - NArgs = primitive_to_arity(primitive); - } + NArgs = (PRIMITIVE_ARITY (primitive)); else - { NArgs = 3; /* Unknown primitive */ - } + outf_console ("\n"); for (i = 0; i < NArgs; i++) diff --git a/v7/src/microcode/dostop.c b/v7/src/microcode/dostop.c index 180d5824a..9e2dc24bb 100644 --- a/v7/src/microcode/dostop.c +++ b/v7/src/microcode/dostop.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: dostop.c,v 1.6 1993/07/16 18:55:14 gjr Exp $ +$Id: dostop.c,v 1.7 1993/08/03 08:29:43 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -132,8 +132,8 @@ DEFUN (OS_quit, (code, abnormal_p), int code AND int abnormal_p) #define EAGAIN ERRNO_NONBLOCK #endif -static enum syserr_names -DEFUN (error_code_to_syserr, (code), int code) +enum syserr_names +DEFUN (OS_error_code_to_syserr, (code), int code) { switch (code) { @@ -180,16 +180,6 @@ DEFUN (syserr_to_error_code, (syserr), enum syserr_names syserr) } } -void -DEFUN (error_system_call, (code, name), int code AND enum syscall_names name) -{ - extern unsigned int syscall_error_code; - extern unsigned int syscall_error_name; - syscall_error_code = ((unsigned int) (error_code_to_syserr (code))); - syscall_error_name = ((unsigned int) name); - signal_error_from_primitive (ERR_IN_SYSTEM_CALL); -} - CONST char * DEFUN (OS_error_code_to_message, (syserr), unsigned int syserr) { diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h index 7065c33bf..bbffb6246 100644 --- a/v7/src/microcode/errors.h +++ b/v7/src/microcode/errors.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: errors.h,v 9.38 1993/02/23 02:38:22 gjr Exp $ +$Id: errors.h,v 9.39 1993/08/03 08:29:44 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -33,6 +33,9 @@ promotional, or sales literature without prior written consent from MIT in each case. */ /* Error and termination code declarations. */ + +#ifndef SCM_ERRORS_H +#define SCM_ERRORS_H /* All error and termination codes must be positive * to allow primitives to return either an error code @@ -279,3 +282,5 @@ MIT in each case. */ /* 0x19 */ "User requested termination after trap", \ /* 0x1a */ "Backing out of non-primitive" \ } + +#endif /* SCM_ERRORS_H /* diff --git a/v7/src/microcode/extern.c b/v7/src/microcode/extern.c index ce18462e0..08b3120f2 100644 --- a/v7/src/microcode/extern.c +++ b/v7/src/microcode/extern.c @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: extern.c,v 9.33 1993/06/24 07:08:24 gjr Exp $ +$Id: extern.c,v 9.34 1993/08/03 08:29:45 gjr Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -60,12 +60,9 @@ number (i.e. external representation) of the desired result.") PRIMITIVE_RETURN (MAKE_OBJECT (tc, number)); case TC_PRIMITIVE: - if (number >= (NUMBER_OF_PRIMITIVES ())) + if (number > (NUMBER_OF_PRIMITIVES ())) error_bad_range_arg (2); - PRIMITIVE_RETURN - ((number > MAX_PRIMITIVE) - ? (MAKE_PRIMITIVE_OBJECT (number, (MAX_PRIMITIVE + 1))) - : (MAKE_PRIMITIVE_OBJECT (0, number))); + PRIMITIVE_RETURN (MAKE_PRIMITIVE_OBJECT (number)); default: error_bad_range_arg (1); @@ -112,25 +109,24 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-ARITY", Prim_primitive_procedure_arity, 1 CHECK_ARG (1, PRIMITIVE_P); { fast SCHEME_OBJECT primitive = (ARG_REF (1)); - extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT)); - if ((PRIMITIVE_NUMBER (primitive)) >= (NUMBER_OF_PRIMITIVES ())) + if ((PRIMITIVE_NUMBER (primitive)) > (NUMBER_OF_PRIMITIVES ())) error_bad_range_arg (1); - PRIMITIVE_RETURN (LONG_TO_FIXNUM (primitive_to_arity (primitive))); + PRIMITIVE_RETURN (LONG_TO_FIXNUM (PRIMITIVE_ARITY (primitive))); } } -DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-DOCUMENTATION", Prim_primitive_procedure_doc, 1, 1, +DEFINE_PRIMITIVE ("PRIMITIVE-PROCEDURE-DOCUMENTATION", + Prim_primitive_procedure_doc, 1, 1, "Given a primitive procedure, return its documentation string.") { PRIMITIVE_HEADER (1); CHECK_ARG (1, PRIMITIVE_P); { fast SCHEME_OBJECT primitive = (ARG_REF (1)); - if ((PRIMITIVE_NUMBER (primitive)) >= (NUMBER_OF_PRIMITIVES ())) + if ((PRIMITIVE_NUMBER (primitive)) > (NUMBER_OF_PRIMITIVES ())) error_bad_range_arg (1); { - extern char * EXFUN (primitive_to_documentation, (SCHEME_OBJECT)); - fast char * answer = (primitive_to_documentation (primitive)); + fast char * answer = (PRIMITIVE_DOCUMENTATION (primitive)); PRIMITIVE_RETURN ((answer == ((char *) 0)) ? SHARP_F @@ -146,8 +142,8 @@ the cdr is the count of undefined primitives that are referenced.") { PRIMITIVE_HEADER (0); PRIMITIVE_RETURN - (cons ((LONG_TO_UNSIGNED_FIXNUM (NUMBER_OF_DEFINED_PRIMITIVES ())), - (LONG_TO_UNSIGNED_FIXNUM (NUMBER_OF_UNDEFINED_PRIMITIVES ())))); + (cons ((LONG_TO_UNSIGNED_FIXNUM ((NUMBER_OF_PRIMITIVES ()))), + (LONG_TO_UNSIGNED_FIXNUM (0)))); } DEFINE_PRIMITIVE ("GET-PRIMITIVE-NAME", Prim_get_primitive_name, 1, 1, @@ -160,10 +156,11 @@ DEFINE_PRIMITIVE ("GET-PRIMITIVE-NAME", Prim_get_primitive_name, 1, 1, error_wrong_type_arg (1); { fast long number = (PRIMITIVE_NUMBER (primitive)); - extern SCHEME_OBJECT EXFUN (primitive_name, (int)); - if ((number < 0) || (number >= NUMBER_OF_PRIMITIVES())) + if ((number < 0) || (number > (NUMBER_OF_PRIMITIVES ()))) error_bad_range_arg (1); - PRIMITIVE_RETURN (primitive_name (number)); + PRIMITIVE_RETURN + (char_pointer_to_string ((unsigned char *) + (PRIMITIVE_NAME (primitive)))); } } } diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index dde875e65..6d21d5582 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: fasload.c,v 9.68 1993/06/24 04:44:55 gjr Exp $ +$Id: fasload.c,v 9.69 1993/08/03 08:29:48 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -66,8 +66,7 @@ extern SCHEME_OBJECT * load_renumber_table; extern SCHEME_OBJECT compiler_utilities; extern SCHEME_OBJECT EXFUN (intern_symbol, (SCHEME_OBJECT)); -extern void EXFUN (install_primitive_table, - (SCHEME_OBJECT *, long, Boolean)); +extern void EXFUN (install_primitive_table, (SCHEME_OBJECT *, long)); extern void EXFUN (compiler_reset_error, (void)); extern void EXFUN (compiler_initialize, (long)); extern void EXFUN (compiler_reset, (SCHEME_OBJECT)); @@ -266,9 +265,7 @@ DEFUN (read_file_end, (mode), int mode) { SET_CONSTANT_TOP (); if (mode != MODE_CHANNEL) - { OS_channel_close_noerror (load_channel); - } signal_error_from_primitive (ERR_IO_ERROR); } computed_checksum = @@ -284,9 +281,7 @@ DEFUN (read_file_end, (mode), int mode) Primitive_Table_Size) { if (mode != MODE_CHANNEL) - { OS_channel_close_noerror (load_channel); - } signal_error_from_primitive (ERR_IO_ERROR); } computed_checksum = @@ -297,15 +292,11 @@ DEFUN (read_file_end, (mode), int mode) Free += Primitive_Table_Size; if (mode != MODE_CHANNEL) - { OS_channel_close_noerror (load_channel); - } if ((computed_checksum != ((unsigned long) 0)) && (dumped_checksum != SHARP_F)) - { signal_error_from_primitive (ERR_IO_ERROR); - } return (table); } @@ -407,6 +398,15 @@ static SCHEME_OBJECT *Relocate_Temp; block of memory. */ +static long +DEFUN (primitive_dumped_number, (datum), unsigned long datum) +{ + unsigned long high_bits = (datum >> HALF_DATUM_LENGTH); + return ((high_bits != 0) ? high_bits : datum); +} + +#define PRIMITIVE_DUMPED_NUMBER(prim) (primitive_dumped_number (OBJECT_DATUM (prim))) + static void DEFUN (Relocate_Block, (Scan, Stop_At), fast SCHEME_OBJECT * Scan AND fast SCHEME_OBJECT * Stop_At) @@ -433,13 +433,13 @@ DEFUN (Relocate_Block, (Scan, Stop_At), break; case TC_PRIMITIVE: - *Scan++ = (load_renumber_table [PRIMITIVE_NUMBER (Temp)]); + *Scan++ = (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)]); break; case TC_PCOMB0: *Scan++ = OBJECT_NEW_TYPE - (TC_PCOMB0, (load_renumber_table [PRIMITIVE_NUMBER (Temp)])); + (TC_PCOMB0, (load_renumber_table [PRIMITIVE_DUMPED_NUMBER (Temp)])); break; case TC_MANIFEST_NM_VECTOR: @@ -578,35 +578,9 @@ DEFUN (check_primitive_numbers, (table, length), { fast long count, top; - top = (NUMBER_OF_DEFINED_PRIMITIVES ()); - if (length < top) - { - top = length; - } - - for (count = 0; count < top; count += 1) - { - if (table[count] != (MAKE_PRIMITIVE_OBJECT (0, count))) - { + for (count = 0; count < length; count += 1) + if (table[count] != (MAKE_PRIMITIVE_OBJECT (count))) return (false); - } - } - /* Is this really correct? Can't this screw up if there - were more implemented primitives in the dumping microcode - than in the loading microcode and they all fell after the - last implemented primitive in the loading microcode? - */ - if (length == top) - { - return (true); - } - for (count = top; count < length; count += 1) - { - if (table[count] != (MAKE_PRIMITIVE_OBJECT (count, top))) - { - return (false); - } - } return (true); } @@ -727,9 +701,7 @@ DEFUN (load_file, (mode), int mode) if ((!band_p) && (dumped_utilities != SHARP_F)) { if (compiler_utilities == SHARP_F) - { signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH); - } const_relocation = (COMPUTE_RELOCATION ((OBJECT_ADDRESS (compiler_utilities)), @@ -740,9 +712,7 @@ DEFUN (load_file, (mode), int mode) (1 + (VECTOR_LENGTH (compiler_utilities)))))); } else - { const_relocation = (COMPUTE_RELOCATION (Orig_Constant, Const_Base)); - } stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top)); #ifdef BYTE_INVERSION @@ -751,24 +721,21 @@ DEFUN (load_file, (mode), int mode) /* Setup the primitive table */ - install_primitive_table (primitive_table, - Primitive_Table_Length, - (mode == MODE_BAND)); + install_primitive_table (primitive_table, Primitive_Table_Length); - if ((mode != MODE_BAND) || - (heap_relocation != ((relocation_type) 0)) || - (const_relocation != ((relocation_type) 0)) || - (stack_relocation != ((relocation_type) 0)) || - (!check_primitive_numbers(load_renumber_table, - Primitive_Table_Length))) + if ((mode != MODE_BAND) + || (heap_relocation != ((relocation_type) 0)) + || (const_relocation != ((relocation_type) 0)) + || (stack_relocation != ((relocation_type) 0)) + || (! (check_primitive_numbers (load_renumber_table, + Primitive_Table_Length)))) { /* We need to relocate. Oh well. */ if (Reloc_Debug) - { - outf_console ("heap_relocation = %ld = %lx; const_relocation = %ld = %lx\n", - ((long) heap_relocation), ((long) heap_relocation), - ((long) const_relocation), ((long) const_relocation)); - } + outf_console + ("heap_relocation = %ld = %lx; const_relocation = %ld = %lx\n", + ((long) heap_relocation), ((long) heap_relocation), + ((long) const_relocation), ((long) const_relocation)); /* Relocate the new data. diff --git a/v7/src/microcode/findprim.c b/v7/src/microcode/findprim.c index efc9bf10f..bfbb2d1b3 100644 --- a/v7/src/microcode/findprim.c +++ b/v7/src/microcode/findprim.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: findprim.c,v 9.47 1993/06/24 03:32:03 gjr Exp $ +$Id: findprim.c,v 9.48 1993/08/03 08:29:50 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -166,12 +166,12 @@ typedef pseudo_void (* TOKEN_PROCESSOR) (); TOKEN_PROCESSOR token_processors [4]; char * the_kind; -char default_kind [] = "Primitive"; +char default_kind [] = "Static_Primitive"; char built_in_kind [] = "Primitive"; char external_kind [] = "External"; char * the_variable; -char default_variable [] = "MAX_PRIMITIVE"; +char default_variable [] = "MAX_STATIC_PRIMITIVE"; char built_in_variable [] = "MAX_PRIMITIVE"; char external_variable [] = "MAX_EXTERNAL_PRIMITIVE"; @@ -580,8 +580,10 @@ DEFUN (print_primitives, (output, limit), /* Print the procedure table. */ #ifdef ASSUME_ANSIDECL - fprintf (output, "\f\nSCHEME_OBJECT EXFUN ((* (%s_Procedure_Table [])), (void)) = {\n", - the_kind); + fprintf + (output, + "\f\nSCHEME_OBJECT EXFUN ((* (%s_Procedure_Table [])), (void)) = {\n", + the_kind); #else fprintf (output, "\f\nSCHEME_OBJECT (* (%s_Procedure_Table [])) () = {\n", the_kind); diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h index 1b619eb91..cb31e2f8c 100644 --- a/v7/src/microcode/interp.h +++ b/v7/src/microcode/interp.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: interp.h,v 9.37 1993/06/24 05:45:06 gjr Exp $ +$Id: interp.h,v 9.38 1993/08/03 08:29:51 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -159,7 +159,7 @@ extern int EXFUN (abort_to_interpreter_argument, (void)); #define Store_Expression(P) Expression = (P) #define Store_Env(P) Env = (P) #define Store_Return(P) \ - Return = MAKE_OBJECT (TC_RETURN_CODE, (P)) + Return = (MAKE_OBJECT (TC_RETURN_CODE, (P))) #define Save_Env() STACK_PUSH (Env) #define Restore_Env() Env = (STACK_POP ()) @@ -205,42 +205,6 @@ extern int EXFUN (abort_to_interpreter_argument, (void)); /* Primitive utility macros */ -/* A primitive object has two components (besides the type code), a - table index in the low 12 bits (assuming datum fields are 24 bits - wide), and a virtual index in the upper 12 bits. The table index - is always guaranteed to be a valid entry into - Primitive_Procedure_Table. For unimplemented primitives it is the - index of the last entry in the table, which causes an error when - invoked. For implemented primitives it is the real index. The - virtual index is 0 for implemented primitives (for histerical - reasons), and the actual virtual index (higher than any real table - index) for unimplemented primitives. - */ - -#define PRIMITIVE_TABLE_INDEX(primitive) \ -((primitive) & HALF_DATUM_MASK) - -#define PRIMITIVE_VIRTUAL_INDEX(primitive) \ -(((primitive) >> HALF_DATUM_LENGTH) & HALF_DATUM_MASK) - -#define MAKE_PRIMITIVE_OBJECT(virtual, real) \ -(MAKE_OBJECT (TC_PRIMITIVE, (((virtual) << HALF_DATUM_LENGTH) | (real)))) - -/* Does this fail for the first unimplemented primitive if there are no - implemented primitives? - */ - -#define IMPLEMENTED_PRIMITIVE_P(primitive) \ -(PRIMITIVE_VIRTUAL_INDEX(primitive) == 0) - -#define PRIMITIVE_NUMBER(primitive) \ -((IMPLEMENTED_PRIMITIVE_P(primitive)) ? \ - (PRIMITIVE_TABLE_INDEX(primitive)) : \ - (PRIMITIVE_VIRTUAL_INDEX(primitive))) - -/* This will automagically cause an error if the primitive is - not implemented. */ - #ifndef ENABLE_DEBUGGING_TOOLS #define PRIMITIVE_APPLY PRIMITIVE_APPLY_INTERNAL @@ -254,10 +218,6 @@ extern SCHEME_OBJECT EXFUN #endif -extern char * EXFUN (primitive_to_name, (SCHEME_OBJECT primitive)); -extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT primitive)); -extern long EXFUN (primitive_to_arguments, (SCHEME_OBJECT primitive)); - #define PRIMITIVE_APPLY_INTERNAL(loc, primitive) \ { \ (Regs[REGBLOCK_PRIMITIVE]) = (primitive); \ @@ -265,26 +225,17 @@ extern long EXFUN (primitive_to_arguments, (SCHEME_OBJECT primitive)); /* Save the dynamic-stack position. */ \ PTR PRIMITIVE_APPLY_INTERNAL_position = dstack_position; \ (loc) = \ - ((* \ - (Primitive_Procedure_Table \ - [PRIMITIVE_TABLE_INDEX (primitive)])) \ + ((* (Primitive_Procedure_Table [PRIMITIVE_NUMBER (primitive)])) \ ()); \ /* If the primitive failed to unwind the dynamic stack, lose. */ \ if (PRIMITIVE_APPLY_INTERNAL_position != dstack_position) \ { \ outf_fatal ("\nPrimitive slipped the dynamic stack: %s\n", \ - (primitive_to_name (primitive))); \ + (PRIMITIVE_NAME (primitive))); \ Microcode_Termination (TERM_EXIT); \ } \ } \ (Regs[REGBLOCK_PRIMITIVE]) = SHARP_F; \ } -/* This is only valid for implemented primitives. */ - -#define PRIMITIVE_ARITY(primitive) \ - (Primitive_Arity_Table [PRIMITIVE_TABLE_INDEX (primitive)]) - -#define PRIMITIVE_N_PARAMETERS primitive_to_arity -#define PRIMITIVE_N_ARGUMENTS primitive_to_arguments #define POP_PRIMITIVE_FRAME(arity) Stack_Pointer = (STACK_LOC (arity)) diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c index 02b16cf59..e87c0491e 100644 --- a/v7/src/microcode/memmag.c +++ b/v7/src/microcode/memmag.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: memmag.c,v 9.51 1993/07/27 21:00:50 gjr Exp $ +$Id: memmag.c,v 9.52 1993/08/03 08:29:52 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -344,8 +344,6 @@ DEFUN_VOID (GC) *Free++ = Fixed_Objects; *Free++ = (MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History)); - *Free++ = Undefined_Primitives; - *Free++ = Undefined_Primitives_Arity; *Free++ = Get_Current_Stacklet (); *Free++ = ((Prev_Restore_History_Stacklet == NULL) @@ -440,8 +438,6 @@ DEFUN_VOID (GC) (Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (Root2)))); History = (OBJECT_ADDRESS (*Root++)); - Undefined_Primitives = *Root++; - Undefined_Primitives_Arity = *Root++; Set_Current_Stacklet (*Root); Root += 1; diff --git a/v7/src/microcode/msdos.h b/v7/src/microcode/msdos.h index 948c01d9a..715c6b160 100644 --- a/v7/src/microcode/msdos.h +++ b/v7/src/microcode/msdos.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: msdos.h,v 1.5 1993/06/24 05:58:01 gjr Exp $ +$Id: msdos.h,v 1.6 1993/08/03 08:29:53 gjr Exp $ Copyright (c) 1992-1993 Massachusetts Institute of Technology @@ -70,111 +70,7 @@ MIT in each case. */ #include "dstack.h" #include "osscheme.h" #include "dossys.h" - -enum syscall_names -{ - syscall_accept, - syscall_bind, - syscall_chdir, - syscall_chmod, - syscall_close, - syscall_connect, - syscall_fcntl_GETFL, - syscall_fcntl_SETFL, - syscall_fork, - syscall_fstat, - syscall_ftruncate, - syscall_getcwd, - syscall_gethostname, - syscall_gettimeofday, - syscall_ioctl_TIOCGPGRP, - syscall_ioctl_TIOCSIGSEND, - syscall_kill, - syscall_link, - syscall_listen, - syscall_localtime, - syscall_lseek, - syscall_malloc, - syscall_mkdir, - syscall_open, - syscall_opendir, - syscall_pause, - syscall_pipe, - syscall_read, - syscall_readlink, - syscall_realloc, - syscall_rename, - syscall_rmdir, - syscall_select, - syscall_setitimer, - syscall_setpgid, - syscall_sighold, - syscall_sigprocmask, - syscall_sigsuspend, - syscall_sleep, - syscall_socket, - syscall_symlink, - syscall_tcdrain, - syscall_tcflush, - syscall_tcgetpgrp, - syscall_tcsetpgrp, - syscall_terminal_get_state, - syscall_terminal_set_state, - syscall_time, - syscall_times, - syscall_unlink, - syscall_utime, - syscall_vfork, - syscall_write, - syscall_stat, - syscall_lstat, - syscall_mktime -}; - -enum syserr_names -{ - syserr_unknown, - syserr_arg_list_too_long, - syserr_bad_address, - syserr_bad_file_descriptor, - syserr_broken_pipe, - syserr_directory_not_empty, - syserr_domain_error, - syserr_exec_format_error, - syserr_file_exists, - syserr_file_too_large, - syserr_filename_too_long, - syserr_function_not_implemented, - syserr_improper_link, - syserr_inappropriate_io_control_operation, - syserr_interrupted_function_call, - syserr_invalid_argument, - syserr_invalid_seek, - syserr_io_error, - syserr_is_a_directory, - syserr_no_child_processes, - syserr_no_locks_available, - syserr_no_space_left_on_device, - syserr_no_such_device, - syserr_no_such_device_or_address, - syserr_no_such_file_or_directory, - syserr_no_such_process, - syserr_not_a_directory, - syserr_not_enough_space, - syserr_operation_not_permitted, - syserr_permission_denied, - syserr_read_only_file_system, - syserr_resource_busy, - syserr_resource_deadlock_avoided, - syserr_resource_temporarily_unavailable, - syserr_result_too_large, - syserr_too_many_links, - syserr_too_many_open_files, - syserr_too_many_open_files_in_system -}; - -extern void EXFUN (error_system_call, (int code, enum syscall_names name)); - +#include "syscall.h" #include #include #include diff --git a/v7/src/microcode/nt.h b/v7/src/microcode/nt.h index 3403336cc..0516c5fb5 100644 --- a/v7/src/microcode/nt.h +++ b/v7/src/microcode/nt.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: nt.h,v 1.3 1993/06/24 02:13:22 gjr Exp $ +$Id: nt.h,v 1.4 1993/08/03 08:29:54 gjr Exp $ -Copyright (c) 1992-1993 Massachusetts Institute of Technology +Copyright (c) 1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -32,7 +32,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* DOS system include file */ +/* NT system include file */ #ifndef SCM_NT_H #define SCM_NT_H @@ -79,111 +79,7 @@ MIT in each case. */ #include "dstack.h" #include "osscheme.h" #include "ntsys.h" - -enum syscall_names -{ - syscall_accept, - syscall_bind, - syscall_chdir, - syscall_chmod, - syscall_close, - syscall_connect, - syscall_fcntl_GETFL, - syscall_fcntl_SETFL, - syscall_fork, - syscall_fstat, - syscall_ftruncate, - syscall_getcwd, - syscall_gethostname, - syscall_gettimeofday, - syscall_ioctl_TIOCGPGRP, - syscall_ioctl_TIOCSIGSEND, - syscall_kill, - syscall_link, - syscall_listen, - syscall_localtime, - syscall_lseek, - syscall_malloc, - syscall_mkdir, - syscall_open, - syscall_opendir, - syscall_pause, - syscall_pipe, - syscall_read, - syscall_readlink, - syscall_realloc, - syscall_rename, - syscall_rmdir, - syscall_select, - syscall_setitimer, - syscall_setpgid, - syscall_sighold, - syscall_sigprocmask, - syscall_sigsuspend, - syscall_sleep, - syscall_socket, - syscall_symlink, - syscall_tcdrain, - syscall_tcflush, - syscall_tcgetpgrp, - syscall_tcsetpgrp, - syscall_terminal_get_state, - syscall_terminal_set_state, - syscall_time, - syscall_times, - syscall_unlink, - syscall_utime, - syscall_vfork, - syscall_write, - syscall_stat, - syscall_lstat, - syscall_mktime -}; - -enum syserr_names -{ - syserr_unknown, - syserr_arg_list_too_long, - syserr_bad_address, - syserr_bad_file_descriptor, - syserr_broken_pipe, - syserr_directory_not_empty, - syserr_domain_error, - syserr_exec_format_error, - syserr_file_exists, - syserr_file_too_large, - syserr_filename_too_long, - syserr_function_not_implemented, - syserr_improper_link, - syserr_inappropriate_io_control_operation, - syserr_interrupted_function_call, - syserr_invalid_argument, - syserr_invalid_seek, - syserr_io_error, - syserr_is_a_directory, - syserr_no_child_processes, - syserr_no_locks_available, - syserr_no_space_left_on_device, - syserr_no_such_device, - syserr_no_such_device_or_address, - syserr_no_such_file_or_directory, - syserr_no_such_process, - syserr_not_a_directory, - syserr_not_enough_space, - syserr_operation_not_permitted, - syserr_permission_denied, - syserr_read_only_file_system, - syserr_resource_busy, - syserr_resource_deadlock_avoided, - syserr_resource_temporarily_unavailable, - syserr_result_too_large, - syserr_too_many_links, - syserr_too_many_open_files, - syserr_too_many_open_files_in_system -}; - -extern void EXFUN (error_system_call, (int code, enum syscall_names name)); - +#include "syscall.h" #include #include /*#include */ @@ -197,7 +93,6 @@ extern void EXFUN (error_system_call, (int code, enum syscall_names name)); #define VOID_SIGNAL_HANDLERS /*#include */ - typedef void Tsignal_handler_result; #define SIGNAL_HANDLER_RETURN() return diff --git a/v7/src/microcode/nttop.c b/v7/src/microcode/nttop.c index ba318fa51..0ec7f2d38 100644 --- a/v7/src/microcode/nttop.c +++ b/v7/src/microcode/nttop.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: nttop.c,v 1.5 1993/07/27 21:00:55 gjr Exp $ +$Id: nttop.c,v 1.6 1993/08/03 08:29:55 gjr Exp $ Copyright (c) 1993 Massachusetts Institute of Technology @@ -137,8 +137,8 @@ DEFUN (OS_quit, (code, abnormal_p), int code AND int abnormal_p) #define EAGAIN ERRNO_NONBLOCK #endif -static enum syserr_names -DEFUN (error_code_to_syserr, (code), int code) +enum syserr_names +DEFUN (OS_error_code_to_syserr, (code), int code) { switch (code) { @@ -185,16 +185,6 @@ DEFUN (syserr_to_error_code, (syserr), enum syserr_names syserr) } } -void -DEFUN (error_system_call, (code, name), int code AND enum syscall_names name) -{ - extern unsigned int syscall_error_code; - extern unsigned int syscall_error_name; - syscall_error_code = ((unsigned int) (error_code_to_syserr (code))); - syscall_error_name = ((unsigned int) name); - signal_error_from_primitive (ERR_IN_SYSTEM_CALL); -} - CONST char * DEFUN (OS_error_code_to_message, (syserr), unsigned int syserr) { diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index 0f04a2a74..79e1ca435 100644 --- a/v7/src/microcode/object.h +++ b/v7/src/microcode/object.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: object.h,v 9.40 1992/12/02 18:11:14 cph Exp $ +$Id: object.h,v 9.41 1993/08/03 08:29:56 gjr Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,7 +33,10 @@ promotional, or sales literature without prior written consent from MIT in each case. */ /* This file defines the macros which define and manipulate Scheme - objects. This is the lowest level of abstraction in this program. */ + objects. This is the lowest level of abstraction in this program. +*/ +#ifndef SCM_OBJECT_H +#define SCM_OBJECT_H /* The value in "Wsize.c" for `TYPE_CODE_LENGTH' must match this!! */ #ifndef TYPE_CODE_LENGTH @@ -511,3 +514,5 @@ if ((ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Old_Pointer))) && \ #define ALIGN_FLOAT(Where) #endif /* not FLOATING_ALIGNMENT */ + +#endif /* SCM_OBJECT_H */ diff --git a/v7/src/microcode/prename.h b/v7/src/microcode/prename.h index 343ebc401..9b53b5225 100644 --- a/v7/src/microcode/prename.h +++ b/v7/src/microcode/prename.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: prename.h,v 1.7 1993/01/12 19:49:25 gjr Exp $ +$Id: prename.h,v 1.8 1993/08/03 08:29:57 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -34,29 +34,37 @@ MIT in each case. */ /* Definitions of aliases for primitives. */ -static struct primitive_alias aliases [] = - { - { "NULL?", "NOT" }, - { "FALSE?", "NOT" }, - { "PRIMITIVE-TYPE", "OBJECT-TYPE" }, - { "PRIMITIVE-TYPE?", "OBJECT-TYPE?" }, - { "&MAKE-OBJECT", "PRIMITIVE-OBJECT-SET-TYPE" }, - { "SYSTEM-MEMORY-REF", "PRIMITIVE-OBJECT-REF" }, - { "PRIMITIVE-OBJECT-NEW-TYPE", "PRIMITIVE-OBJECT-SET-TYPE" }, - { "FILE-CLOSE-CHANNEL", "CHANNEL-CLOSE" }, - { "PHOTO-OPEN", "TRANSCRIPT-ON" }, - { "PHOTO-CLOSE", "TRANSCRIPT-OFF" }, - { "GET-NEXT-INTERRUPT-CHARACTER", "TTY-NEXT-INTERRUPT-CHAR" }, - { "CHECK-AND-CLEAN-UP-INPUT-CHANNEL", "TTY-CLEAN-INTERRUPTS" }, - { "REMOVE-FILE", "FILE-REMOVE" }, - { "RENAME-FILE", "FILE-RENAME" }, - { "COPY-FILE", "FILE-COPY" }, - { "MAKE-DIRECTORY", "DIRECTORY-MAKE" }, - { "SCREEN-X-SIZE", "TTY-X-SIZE" }, - { "SCREEN-Y-SIZE", "TTY-Y-SIZE" }, - { "FILE-SYMLINK?", "FILE-SOFT-LINK?" }, - { "X-GRAPHICS-SET-CLASS-HINT", "X-WINDOW-SET-CLASS-HINT" }, - { "CURRENT-FILE-TIME", "ENCODED-TIME" } - }; - -#define N_ALIASES 21 +#ifndef SCM_PRENAME_H +#define SCM_PRENAME_H + +struct primitive_alias_s +{ + char * alias; + char * name; +}; + +static struct primitive_alias_s primitive_aliases [] = +{ + { "FALSE?", "NOT" }, + { "PRIMITIVE-TYPE", "OBJECT-TYPE" }, + { "PRIMITIVE-TYPE?", "OBJECT-TYPE?" }, + { "&MAKE-OBJECT", "PRIMITIVE-OBJECT-SET-TYPE" }, + { "SYSTEM-MEMORY-REF", "PRIMITIVE-OBJECT-REF" }, + { "PRIMITIVE-OBJECT-NEW-TYPE", "PRIMITIVE-OBJECT-SET-TYPE" }, + { "FILE-CLOSE-CHANNEL", "CHANNEL-CLOSE" }, + { "GET-NEXT-INTERRUPT-CHARACTER", "TTY-NEXT-INTERRUPT-CHAR" }, + { "REMOVE-FILE", "FILE-REMOVE" }, + { "RENAME-FILE", "FILE-RENAME" }, + { "COPY-FILE", "FILE-COPY" }, + { "MAKE-DIRECTORY", "DIRECTORY-MAKE" }, + { "SCREEN-X-SIZE", "TTY-X-SIZE" }, + { "SCREEN-Y-SIZE", "TTY-Y-SIZE" }, + { "FILE-SYMLINK?", "FILE-SOFT-LINK?" }, + { "X-GRAPHICS-SET-CLASS-HINT", "X-WINDOW-SET-CLASS-HINT" }, + { "CURRENT-FILE-TIME", "ENCODED-TIME" } +}; + +#define N_PRIMITIVE_ALIASES \ + ((sizeof (primitive_aliases)) / (sizeof (struct primitive_alias_s))) + +#endif /* SCM_PRENAME_H */ diff --git a/v7/src/microcode/prim.h b/v7/src/microcode/prim.h index 08d9a5f55..e9984b163 100644 --- a/v7/src/microcode/prim.h +++ b/v7/src/microcode/prim.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: prim.h,v 9.43 1993/06/24 07:09:18 gjr Exp $ +$Id: prim.h,v 9.44 1993/08/03 08:29:58 gjr Exp $ -Copyright (c) 1987-92 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -34,28 +34,47 @@ MIT in each case. */ /* Primitive declarations. Note that the following cannot be changed without changing - Findprim.c. */ + findprim.c. + */ -extern SCHEME_OBJECT EXFUN ((*(Primitive_Procedure_Table[])), (void)); -extern int Primitive_Arity_Table[]; -extern int Primitive_Count_Table[]; -extern char *Primitive_Name_Table[]; -extern char *Primitive_Documentation_Table[]; +#ifndef SCM_PRIM_H +#define SCM_PRIM_H + +typedef SCHEME_OBJECT EXFUN ((* primitive_procedure_t), (void)); + +extern primitive_procedure_t * Primitive_Procedure_Table; +extern int * Primitive_Arity_Table; +extern int * Primitive_Count_Table; +extern char ** Primitive_Name_Table; +extern char ** Primitive_Documentation_Table; extern long MAX_PRIMITIVE; -#define CHUNK_SIZE 20 /* Grow undefined vector by this much */ +extern SCHEME_OBJECT EXFUN (Prim_unimplemented, (void)); + +#define PRIMITIVE_NUMBER(primitive) (OBJECT_DATUM (primitive)) + +#define MAKE_PRIMITIVE_OBJECT(index) (MAKE_OBJECT (TC_PRIMITIVE, (index))) + +#define IMPLEMENTED_PRIMITIVE_P(prim) \ + ((Primitive_Procedure_Table[(PRIMITIVE_NUMBER (prim))]) \ + != Prim_unimplemented) + +#define NUMBER_OF_PRIMITIVES() (MAX_PRIMITIVE) + +#define PRIMITIVE_ARITY(prim) \ + (Primitive_Arity_Table [PRIMITIVE_NUMBER (prim)]) -extern SCHEME_OBJECT Undefined_Primitives; -extern SCHEME_OBJECT Undefined_Primitives_Arity; +#define PRIMITIVE_DOCUMENTATION(prim) \ + (Primitive_Documentation_Table[(PRIMITIVE_NUMBER (prim))]) -/* Utility macros */ +#define PRIMITIVE_NAME(prim) \ + (Primitive_Name_Table[(PRIMITIVE_NUMBER (prim))]) -#define NUMBER_OF_DEFINED_PRIMITIVES() (MAX_PRIMITIVE + 1) +#define PRIMITIVE_N_PARAMETERS(prim) (PRIMITIVE_ARITY (prim)) -#define NUMBER_OF_UNDEFINED_PRIMITIVES() \ - ((Undefined_Primitives == SHARP_F) \ - ? 0 \ - : (UNSIGNED_FIXNUM_TO_LONG (VECTOR_REF (Undefined_Primitives, 0)))) +#define PRIMITIVE_N_ARGUMENTS(prim) \ + (((PRIMITIVE_ARITY (prim)) == LEXPR_PRIMITIVE_ARITY) \ + ? ((long) (Regs[REGBLOCK_LEXPR_ACTUALS])) \ + : (PRIMITIVE_ARITY (prim))) -#define NUMBER_OF_PRIMITIVES() \ - ((NUMBER_OF_UNDEFINED_PRIMITIVES ()) + (NUMBER_OF_DEFINED_PRIMITIVES ())) +#endif /* SCM_PRIM_H */ diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h index d9449464b..dcc7d9699 100644 --- a/v7/src/microcode/prims.h +++ b/v7/src/microcode/prims.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: prims.h,v 9.42 1993/07/23 19:43:45 nick Exp $ +$Id: prims.h,v 9.43 1993/08/03 08:29:59 gjr Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -36,6 +36,9 @@ MIT in each case. */ for argument type or value checking, and for accessing the arguments. */ +#ifndef SCM_PRIMS_H +#define SCM_PRIMS_H + #include "ansidecl.h" /* Definition of primitives. */ @@ -135,3 +138,5 @@ extern long EXFUN (arg_ascii_integer, (int)); ((FLONUM_P (ARG_REF (arg))) \ ? ((double *) (VECTOR_LOC (ARG_REF(arg), 0))) \ : ((error_wrong_type_arg (arg)), ((double *) 0))) + +#endif /* SCM_PRIMS_H */ diff --git a/v7/src/microcode/primutl.c b/v7/src/microcode/primutl.c index a819cd7ea..a93a0ac92 100644 --- a/v7/src/microcode/primutl.c +++ b/v7/src/microcode/primutl.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: primutl.c,v 9.60 1993/06/24 18:11:30 gjr Exp $ +$Id: primutl.c,v 9.61 1993/08/03 08:30:00 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -43,457 +43,594 @@ MIT in each case. */ #include "scheme.h" #include "prims.h" +#include "usrdef.h" +#include "prename.h" +#include "syscall.h" +#include "cmpgc.h" #include + +extern SCHEME_OBJECT * load_renumber_table; + +#ifndef UPDATE_PRIMITIVE_TABLE_HOOK +# define UPDATE_PRIMITIVE_TABLE_HOOK(low, high) do { } while (0) +#endif + +#ifndef GROW_PRIMITIVE_TABLE_HOOK +# define GROW_PRIMITIVE_TABLE_HOOK(size) true +#endif -SCHEME_OBJECT Undefined_Primitives = SHARP_F; -SCHEME_OBJECT Undefined_Primitives_Arity = SHARP_F; +/* + Exported variables: + */ -/* Common utilities. */ +long MAX_PRIMITIVE = 0; -extern int EXFUN (strcmp_ci, (char *, char *)); +primitive_procedure_t * Primitive_Procedure_Table + = ((primitive_procedure_t *) NULL); -int -DEFUN (strcmp_ci, (s1, s2), fast char * s1 AND fast char * s2) -{ - int length1 = (strlen (s1)); - int length2 = (strlen (s2)); - fast int length = ((length1 < length2) ? length1 : length2); +int * Primitive_Arity_Table = ((int *) NULL); - while ((length--) > 0) - { - fast int c1 = (*s1++); - fast int c2 = (*s2++); - if (islower (c1)) c1 = (toupper (c1)); - if (islower (c2)) c2 = (toupper (c2)); - if (c1 < c2) return (-1); - if (c1 > c2) return (1); - } - return (length1 - length2); -} +int * Primitive_Count_Table = ((int *) NULL); -struct primitive_alias - { - char *alias; - char *name; - }; +char ** Primitive_Name_Table = ((char **) NULL); -#include "prename.h" +char ** Primitive_Documentation_Table = ((char **) NULL); -static char * -DEFUN (primitive_alias_to_name, (alias), char * alias) -{ - fast struct primitive_alias *alias_ptr; - fast struct primitive_alias *alias_end; +SCHEME_OBJECT * load_renumber_table = ((SCHEME_OBJECT *) NULL); - alias_ptr = aliases; - alias_end = (alias_ptr + N_ALIASES); - while (alias_ptr < alias_end) - { - if ((strcmp_ci (alias, (alias_ptr -> alias))) == 0) - return (alias_ptr -> name); - alias_ptr += 1; - } - return (alias); -} - /* - In primitive_name_to_code, size is really 1 less than size. - It is really the index of the last valid entry. + Exported utilities: */ -#if FALSE +extern void + EXFUN (initialize_primitives, (void)), + EXFUN (install_primitive_table, (SCHEME_OBJECT *, long)); + +extern SCHEME_OBJECT + EXFUN (make_primitive, (char *)), + EXFUN (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int)), + EXFUN (declare_primitive, (char *, primitive_procedure_t, int, int, char *)), + EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)), + * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)), + * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)), + * EXFUN (cons_whole_primitive_table, + (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)), + EXFUN (Prim_unimplemented, (void)); + +extern int + EXFUN (strcmp_ci, (char *, char *)); -/* This version performs an expensive linear search. */ + +/* Common utilities. */ -long -DEFUN (primitive_name_to_code, (name, table, size), - char * name AND char * table[] AND int size) +#ifndef _toupper +# define _toupper toupper +#endif + +int +DEFUN (strcmp_ci, (s1, s2), fast char * s1 AND fast char * s2) { - fast int i; + fast int diff; - name = (primitive_alias_to_name (name)); - for (i = size; i >= 0; i -= 1) + while ((*s1 != '\0') && (*s2 != '\0')) { - fast char *s1, *s2; + fast int c1 = (*s1++); + fast int c2 = (*s2++); + c1 = (_toupper (c1)); + c2 = (_toupper (c2)); + diff = (c1 - c2); + if (diff != 0) + return ((diff > 0) ? 1 : -1); + } + diff = (*s1 - *s2); + return ((diff == 0) ? 0 : ((diff > 0) ? 1 : -1)); +} - s1 = name; - s2 = table[i]; +SCHEME_OBJECT +DEFUN_VOID (Prim_unimplemented) +{ + PRIMITIVE_HEADER (-1); - while (*s1++ == *s2) - { - if (*s2++ == '\0') - return ((long) i); - } - } - return ((long) (-1)); + signal_error_from_primitive (ERR_UNIMPLEMENTED_PRIMITIVE); + /*NOTREACHED*/ } -#else /* not FALSE */ - -/* This version performs a log (base 2) search. - The table is assumed to be ordered alphabetically. - */ +static char * tree_error_message = ((char *) NULL); +static char * tree_error_noise = ((char *) NULL); -long -DEFUN (primitive_name_to_code, (name, table, size), - char * name AND fast char *table[] AND int size) +static void +DEFUN (tree_error, (message, noise), char * message AND char * noise) { - fast int low, high, middle, result; + tree_error_message = message; + tree_error_noise = noise; + return; +} + +/* AVL trees. o(log n) lookup, insert (and delete, not implemented here). + AVL condition: for every node + abs (height (node.left) - height (node.right)) < 2 + This guarantees that the least-balanced AVL tree has Fibonacci-sized + branches, and therefore the height is at most the log base phi of the + number of nodes, where phi is the golden ratio. + With random insertion (or when created as below), + they are better, approaching log base 2. - name = (primitive_alias_to_name (name)); - low = 0; - high = size; + This version does not allow duplicate entries. + */ - while(low < high) - { - middle = ((low + high) / 2); - result = (strcmp_ci (name, table[middle])); - if (result < 0) - high = (middle - 1); - else if (result > 0) - low = (middle + 1); - else - return ((long) middle); - } +typedef struct node_s * node; - /* This takes care of the fact that division rounds down. - If division were to round up, we would have to use high. - */ +struct node_s +{ + int height; + node left; + node rite; + char * name; + int value; +}; + +#define BRANCH_HEIGHT(tree) (((tree) == ((node) NULL)) ? 0 : (tree)->height) - if (strcmp_ci (name, table[low]) == 0) - return ((long) low); +#ifndef MAX +# define MAX(a,b) (((a) >= (b)) ? (a) : (b)) +#endif - return ((long) -1); +static void +DEFUN (update_height, (tree), node tree) +{ + tree->height = (1 + (MAX ((BRANCH_HEIGHT (tree->left)), + (BRANCH_HEIGHT (tree->rite))))); + return; } -#endif /* false */ - -long -DEFUN (primitive_code_to_arity, (number), long number) +static node +DEFUN (leaf_make, (name, value), + char * name AND int value) { - if (number <= MAX_PRIMITIVE) - return ((long) Primitive_Arity_Table[number]); - else + node leaf = ((node) (malloc (sizeof (struct node_s)))); + if (leaf == ((node) NULL)) { - SCHEME_OBJECT entry; - long arity; + tree_error ("leaf_make: malloc failed.\n", NULL); + return (leaf); + } + leaf->name = name; + leaf->value = value; + leaf->height = 1; + leaf->left = ((node) NULL); + leaf->rite = ((node) NULL); + return (leaf); +} + +static node +DEFUN (rotate_left, (tree), node tree) +{ + node rite = tree->rite; + node beta = rite->left; + tree->rite = beta; + rite->left = tree; + update_height (tree); + update_height (rite); + return (rite); +} - entry = VECTOR_REF (Undefined_Primitives_Arity, (number - MAX_PRIMITIVE)); - if (entry == SHARP_F) - return ((long) UNKNOWN_PRIMITIVE_ARITY); - else - arity = FIXNUM_TO_LONG (entry); +static node +DEFUN (rotate_rite, (tree), node tree) +{ + node left = tree->left; + node beta = left->rite; + tree->left = beta; + left->rite = tree; + update_height (tree); + update_height (left); + return (left); +} - return (arity); +static node +DEFUN (rebalance_left, (tree), node tree) +{ + if ((1 + (BRANCH_HEIGHT (tree->rite))) >= (BRANCH_HEIGHT (tree->left))) + { + update_height (tree); + return (tree); + } + else + { + node q = tree->left; + if ((BRANCH_HEIGHT (q->rite)) > (BRANCH_HEIGHT (q->left))) + tree->left = (rotate_left (q)); + return (rotate_rite (tree)); } } -char * -DEFUN (primitive_code_to_documentation, (number), long number) +static node +DEFUN (rebalance_rite, (tree), node tree) { - return - ((number > MAX_PRIMITIVE) - ? ((char *) 0) - : (Primitive_Documentation_Table [number])); + if ((1 + (BRANCH_HEIGHT (tree->left))) >= (BRANCH_HEIGHT (tree->rite))) + { + update_height (tree); + return (tree); + } + else + { + node q = tree->rite; + if ((BRANCH_HEIGHT (q->left)) > (BRANCH_HEIGHT (q->rite))) + tree->rite = (rotate_rite (q)); + return (rotate_left (tree)); + } } -/* Externally visible utilities */ - -extern SCHEME_OBJECT EXFUN - (find_primitive, (SCHEME_OBJECT, Boolean, Boolean, int)); - -extern SCHEME_OBJECT -EXFUN (search_for_primitive, - (SCHEME_OBJECT scheme_name, unsigned char * c_name, - Boolean intern_p, Boolean allow_p, int arity)); - -SCHEME_OBJECT -DEFUN (make_primitive, (name), char * name) +static node +DEFUN (tree_insert, (tree, name, value), + node tree + AND char * name + AND int value) { + if (tree == ((node) NULL)) + return (leaf_make (name, value)); + switch (strcmp_ci (name, tree->name)) + { + case 0: + tree_error ("tree_insert: Duplicate entry %s.\n", name); + return (tree); + + case -1: + { + /* To the left */ + tree->left = (tree_insert (tree->left, name, value)); + return (rebalance_left (tree)); + } - return (search_for_primitive (SHARP_F, - ((unsigned char *) name), - true, true, - UNKNOWN_PRIMITIVE_ARITY)); + case 1: + { + /* To the right */ + tree->rite = (tree_insert (tree->rite, name, value)); + return (rebalance_rite (tree)); + } + } } -SCHEME_OBJECT -DEFUN (find_primitive, (name, intern_p, allow_p, arity), - SCHEME_OBJECT name - AND Boolean intern_p AND Boolean allow_p - AND int arity) +static node +DEFUN (tree_lookup, (tree, name), node tree AND char * name) { + while (tree != ((node) NULL)) + switch (strcmp_ci (name, tree->name)) + { + case 0: + return (tree); + + case -1: + tree = tree->left; + break; - return (search_for_primitive (name, (STRING_LOC (name, 0)), - intern_p, allow_p, arity)); + case 1: + tree = tree->rite; + break; + } + return (tree); } -extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT)); - -long -DEFUN (primitive_to_arity, (primitive), SCHEME_OBJECT primitive) +static node +DEFUN (tree_build, (high, names, values), + int high AND char ** names AND int value) { - return (primitive_code_to_arity (PRIMITIVE_NUMBER (primitive))); -} + static int bias = 0; -extern char * EXFUN (primitive_to_documentation, (SCHEME_OBJECT)); + if (high > 1) + { + node tree; + int middle = (high / 2); + int next; -char * -DEFUN (primitive_to_documentation, (primitive), SCHEME_OBJECT primitive) + if ((high & 1) == 0) + { + middle -= bias; + bias = (1 - bias); + } + next = (middle + 1); + tree = (leaf_make (names[middle], (value + middle))); + tree->left = (tree_build (middle, names, value)); + tree->rite = (tree_build ((high - next), &names[next], (value + next))); + update_height (tree); + return (tree); + } + else if (high == 1) + return (leaf_make (* names, value)); + else + return ((node) NULL); +} + +static void +DEFUN (initialization_error, (reason, item), char * reason AND char * item) { - return (primitive_code_to_documentation (PRIMITIVE_NUMBER (primitive))); + outf_fatal ("initialize_primitives: Error %s %s.\n", + reason, item); + termination_init_error (); } -extern long EXFUN (primitive_to_arguments, (SCHEME_OBJECT)); - -/* - This is only valid during the invocation of a primitive. - It is used by various utilities to back out of code. - */ +static long prim_table_size = 0; -long -DEFUN (primitive_to_arguments, (primitive), SCHEME_OBJECT primitive) +static Boolean +DEFUN (copy_table, (ltable, otable, item_size), + PTR * ltable AND PTR otable AND int item_size) { - long arity; - - arity = (primitive_code_to_arity (PRIMITIVE_NUMBER (primitive))); + long size = (((long) item_size) * prim_table_size); + PTR ntable; - if (arity == ((long) LEXPR_PRIMITIVE_ARITY)) - arity = ((long) Regs[REGBLOCK_LEXPR_ACTUALS]); + if (*ltable != ((PTR) NULL)) + ntable = ((PTR) (realloc (*ltable, size))); + else + { + ntable = ((PTR) (malloc (size))); + if (ntable != ((PTR) NULL)) + memcpy (ntable, otable, size); + } + if (ntable != ((PTR) NULL)) + *ltable = ntable; + return (ntable != ((PTR) NULL)); +} - return (arity); +static Boolean +DEFUN_VOID (grow_primitive_tables) +{ + Boolean result; + long old_prim_table_size = prim_table_size; + + prim_table_size = (MAX_PRIMITIVE + (MAX_PRIMITIVE / 10)); + + result = ( (copy_table (((PTR *) &Primitive_Arity_Table), + ((PTR) &Static_Primitive_Arity_Table[0]), + (sizeof (int)))) + && (copy_table (((PTR *) &Primitive_Count_Table), + ((PTR) &Static_Primitive_Count_Table[0]), + (sizeof (int)))) + && (copy_table (((PTR *) &Primitive_Name_Table), + ((PTR) &Static_Primitive_Name_Table[0]), + (sizeof (char *)))) + && (copy_table (((PTR *) &Primitive_Documentation_Table), + ((PTR) &Static_Primitive_Documentation_Table[0]), + (sizeof (char *)))) + && (copy_table (((PTR *) &Primitive_Procedure_Table), + ((PTR) &Static_Primitive_Procedure_Table[0]), + (sizeof (primitive_procedure_t)))) + && (GROW_PRIMITIVE_TABLE_HOOK (prim_table_size))); + if (result) + UPDATE_PRIMITIVE_TABLE_HOOK (0, MAX_PRIMITIVE); + else + prim_table_size = prim_table_size; + return (result); } -char * -DEFUN (primitive_code_to_name, (code), int code) +static node prim_procedure_tree = ((node) NULL); + +void +DEFUN_VOID (initialize_primitives) { - char *string; + int counter; - if (code <= MAX_PRIMITIVE) + /* MAX_STATIC_PRIMITIVE is the index of the last primitive */ + + MAX_PRIMITIVE = (MAX_STATIC_PRIMITIVE + 1); + if (! (grow_primitive_tables ())) + initialization_error ("allocating", "the primitive tables"); + + tree_error_message = ((char *) NULL); + prim_procedure_tree = (tree_build (MAX_PRIMITIVE, Primitive_Name_Table, 0)); + if (tree_error_message != ((char *) NULL)) { - string = Primitive_Name_Table[code]; + outf_fatal (tree_error_message, tree_error_noise); + initialization_error ("building", "prim_procedure_tree"); } - else + + for (counter = 0; counter < N_PRIMITIVE_ALIASES; counter++) { - /* NOTE: - This is invoked by cons_primitive_table which is invoked by - fasdump before the "fixups" are undone. This means that the scheme - string may actually have a broken heart as its first word, but - this code will still work because the characters will still be there. - */ - - SCHEME_OBJECT scheme_string; - - scheme_string = - (VECTOR_REF (Undefined_Primitives, (code - MAX_PRIMITIVE))); - string = ((char *) (STRING_LOC (scheme_string, 0))); + node orig = (tree_lookup (prim_procedure_tree, + primitive_aliases[counter].name)); + + if (orig == ((node) NULL)) + { + outf_fatal ("Aliasing unknown primitive %s.\n", + primitive_aliases[counter].name, + primitive_aliases[counter].alias); + initialization_error ("aliasing", primitive_aliases[counter].alias); + } + else + { + node new = (tree_insert (prim_procedure_tree, + primitive_aliases[counter].alias, + orig->value)); + if (tree_error_message != ((char *) NULL)) + { + outf_fatal (tree_error_message, tree_error_noise); + initialization_error ("aliasing", primitive_aliases[counter].alias); + } + prim_procedure_tree = new; + } } - return (string); + return; } -extern char *EXFUN (primitive_to_name, (SCHEME_OBJECT)); - -char * -DEFUN (primitive_to_name, (primitive), SCHEME_OBJECT primitive) -{ - return (primitive_code_to_name (PRIMITIVE_NUMBER (primitive))); -} - -/* this avoids some consing. */ +/* declare_primitive returns SHARP_F if it could not allocate + the storage needed for the new primitive, or a primitive object. + The primitive object may correspond to a pre-existend primitive + if there is already a primitive by the same name. + If it is a new primitive, its PRIMITIVE_NUMBER will be the + previous value of MAX_PRIMITIVE. + Note that it can return the value of an old primitive if it + was previously unimplemented and the arity matches. + */ SCHEME_OBJECT -DEFUN (primitive_name, (code), int code) +DEFUN (declare_primitive, (name, code, nargs_lo, nargs_hi, docstr), + char * name + AND primitive_procedure_t code + AND int nargs_lo + AND int nargs_hi + AND char * docstr) +/* nargs_lo ignored, for now */ { - SCHEME_OBJECT scheme_string; + int index; + SCHEME_OBJECT primitive; + node prim = (tree_lookup (prim_procedure_tree, name)); - if (code <= MAX_PRIMITIVE) + if (prim != ((node) NULL)) { - scheme_string = - (char_pointer_to_string ((unsigned char *) Primitive_Name_Table[code])); + index = prim->value; + primitive = (MAKE_PRIMITIVE_OBJECT (prim->value)); + if ((IMPLEMENTED_PRIMITIVE_P (primitive)) + || (((PRIMITIVE_ARITY (primitive)) != nargs_hi) + && ((PRIMITIVE_ARITY (primitive)) != UNKNOWN_PRIMITIVE_ARITY))) + return (primitive); } else { - scheme_string = - (VECTOR_REF (Undefined_Primitives, (code - MAX_PRIMITIVE))); + if (MAX_PRIMITIVE == prim_table_size) + if (! (grow_primitive_tables ())) + return (SHARP_F); + + /* Allocate a new primitive index, and insert in data base. */ + + index = MAX_PRIMITIVE; + prim = (tree_insert (prim_procedure_tree, name, index)); + if (tree_error_message != ((char *) NULL)) + { + outf_error (tree_error_message, tree_error_noise); + tree_error_message = ((char *) NULL); + return (SHARP_F); + } + prim_procedure_tree = prim; + + MAX_PRIMITIVE += 1; + primitive = (MAKE_PRIMITIVE_OBJECT (index)); + Primitive_Name_Table[index] = name; } - return (scheme_string); + + Primitive_Procedure_Table[index] = code; + Primitive_Arity_Table[index] = nargs_hi; + Primitive_Count_Table[index] = (nargs_hi + * (sizeof (SCHEME_OBJECT))); + Primitive_Documentation_Table[index] = docstr; + UPDATE_PRIMITIVE_TABLE_HOOK (index, (index + 1)); + return (primitive); } /* - scheme_name can be #F, meaning cons up from c_name as needed. - c_name must always be provided. + make_primitive returns a primitive object, + constructing one if necessary. */ SCHEME_OBJECT -DEFUN (search_for_primitive, - (scheme_name, c_name, intern_p, allow_p, arity), - SCHEME_OBJECT scheme_name AND unsigned char * c_name - AND Boolean intern_p AND Boolean allow_p - AND int arity) +DEFUN (make_primitive, (name), char * name) { - long i, max, old_arity; - SCHEME_OBJECT * next; + return (declare_primitive (name, + Prim_unimplemented, + UNKNOWN_PRIMITIVE_ARITY, + UNKNOWN_PRIMITIVE_ARITY, + ((char *) NULL))); +} - i = (primitive_name_to_code (((char *) c_name), - &Primitive_Name_Table[0], - MAX_PRIMITIVE)); - if (i != -1) - { - old_arity = Primitive_Arity_Table[i]; - if ((arity == UNKNOWN_PRIMITIVE_ARITY) || (arity == old_arity)) - return (MAKE_PRIMITIVE_OBJECT (0, i)); - else - return (LONG_TO_FIXNUM (old_arity)); - } - /* Search the undefined primitives table if allowed. */ +/* This returns all sorts of different things that the runtime + system decodes. + */ - if (!allow_p) - return (SHARP_F); - - /* The vector should be sorted for faster comparison. */ +SCHEME_OBJECT +DEFUN (find_primitive, (sname, intern_p, allow_p, arity), + SCHEME_OBJECT sname AND Boolean intern_p + AND Boolean allow_p AND int arity) +{ + node prim = (tree_lookup (prim_procedure_tree, (STRING_LOC (sname, 0)))); - max = (NUMBER_OF_UNDEFINED_PRIMITIVES ()); - if (max > 0) + if (prim != ((node) NULL)) { - next = (MEMORY_LOC (Undefined_Primitives, 2)); - - for (i = 1; i <= max; i++) + SCHEME_OBJECT primitive = (MAKE_PRIMITIVE_OBJECT (prim->value)); + + if ((! allow_p) && (! (IMPLEMENTED_PRIMITIVE_P (primitive)))) + return (SHARP_F); + + if ((arity == UNKNOWN_PRIMITIVE_ARITY) + || (arity == (PRIMITIVE_ARITY (primitive)))) + return (primitive); + else if ((PRIMITIVE_ARITY (primitive)) == UNKNOWN_PRIMITIVE_ARITY) { - SCHEME_OBJECT temp; - - temp = *next++; - if (strcmp_ci (((char *) c_name), ((char *) (STRING_LOC (temp, 0)))) - == 0) - { - if (arity != UNKNOWN_PRIMITIVE_ARITY) - { - temp = (VECTOR_REF (Undefined_Primitives_Arity, i)); - if (temp == SHARP_F) - VECTOR_SET (Undefined_Primitives_Arity, i, - (LONG_TO_FIXNUM (arity))); - else - { - old_arity = FIXNUM_TO_LONG (temp); - if (arity != old_arity) - return (temp); - } - } - return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + i), - (MAX_PRIMITIVE + 1))); - } + /* We've just learned the arity of the primitive. */ + Primitive_Arity_Table[PRIMITIVE_NUMBER (primitive)] = arity; + return (primitive); } + else + /* Arity mismatch, notify the runtime system. */ + return (LONG_TO_FIXNUM (PRIMITIVE_ARITY (primitive))); } - - /* - Intern the primitive name by adding it to the vector of - undefined primitives, if interning is allowed. - */ - - if (!intern_p) + else if (! intern_p) return (SHARP_F); - - if (scheme_name == SHARP_F) - scheme_name = (char_pointer_to_string (c_name)); - - if ((max % CHUNK_SIZE) == 0) - { - long new_max = (max + 1); - SCHEME_OBJECT new_prims, new_arities; - - if (max > 0) - next = (MEMORY_LOC (Undefined_Primitives, 2)); - new_prims = - (allocate_marked_vector (TC_VECTOR, (new_max + CHUNK_SIZE), true)); - FAST_VECTOR_SET - (new_prims, 0, (LONG_TO_UNSIGNED_FIXNUM (new_max))); - for (i = 1; (i < new_max); i += 1) - FAST_VECTOR_SET (new_prims, i, (MEMORY_FETCH (*next++))); - FAST_VECTOR_SET (new_prims, new_max, scheme_name); - for (i = 1; (i < CHUNK_SIZE); i += 1) - FAST_VECTOR_SET (new_prims, (i + new_max), SHARP_F); - - if (max > 0) - next = (MEMORY_LOC (Undefined_Primitives_Arity, 2)); - new_arities = - (allocate_marked_vector (TC_VECTOR, (new_max + CHUNK_SIZE), true)); - FAST_VECTOR_SET (new_arities, 0, SHARP_F); - for (i = 1; (i < new_max); i += 1) - FAST_VECTOR_SET (new_arities, i, (MEMORY_FETCH (*next++))); - FAST_VECTOR_SET (new_arities, - new_max, - ((arity != UNKNOWN_PRIMITIVE_ARITY) - ? (LONG_TO_FIXNUM (arity)) - : SHARP_F)); - for (i = 1; (i < CHUNK_SIZE); i += 1) - FAST_VECTOR_SET (new_arities, (i + new_max), SHARP_F); - - Undefined_Primitives = new_prims; - Undefined_Primitives_Arity = new_arities; - max = new_max; - } else { - long new_max = (max + 1); - VECTOR_SET (Undefined_Primitives, new_max, scheme_name); - /* SHARP_F inserted in slot when vector was initialized above. */ - if (arity != UNKNOWN_PRIMITIVE_ARITY) - VECTOR_SET (Undefined_Primitives_Arity, new_max, - (LONG_TO_FIXNUM (arity))); - - VECTOR_SET (Undefined_Primitives, 0, (LONG_TO_UNSIGNED_FIXNUM (new_max))); - max = new_max; + SCHEME_OBJECT primitive; + char * cname = ((char *) (malloc (1 + (STRING_LENGTH (sname))))); + + if (cname == ((char *) NULL)) + error_in_system_call (syserr_not_enough_space, syscall_malloc); + strcpy (cname, (STRING_LOC (sname, 0))); + primitive = + (declare_primitive (cname, + Prim_unimplemented, + ((arity < 0) ? 0 : arity), + arity, + ((char *) NULL))); + if (primitive == SHARP_F) + error_in_system_call (syserr_not_enough_space, syscall_malloc); + return (primitive); } - return (MAKE_PRIMITIVE_OBJECT ((MAX_PRIMITIVE + max), (MAX_PRIMITIVE + 1))); } -/* Dumping and loading primitive object references. */ - -extern SCHEME_OBJECT - * load_renumber_table, - EXFUN (dump_renumber_primitive, (SCHEME_OBJECT)), - * EXFUN (initialize_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *)), - * EXFUN (cons_primitive_table, (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)), - * EXFUN (cons_whole_primitive_table, - (SCHEME_OBJECT *, SCHEME_OBJECT *, long *)); - -extern void EXFUN (install_primitive_table, - (SCHEME_OBJECT *, long, Boolean)); +/* These are used by fasdump to renumber primitives on the way out. + Only those primitives actually referenced by the object being + dumped are described in the output. The primitives being + dumped are renumbered in the output to a contiguous range + starting at 0. + */ -SCHEME_OBJECT *load_renumber_table; -static SCHEME_OBJECT *internal_renumber_table; -static SCHEME_OBJECT *external_renumber_table; +static SCHEME_OBJECT * internal_renumber_table; +static SCHEME_OBJECT * external_renumber_table; static long next_primitive_renumber; +/* This is called during fasdump setup. */ + SCHEME_OBJECT * DEFUN (initialize_primitive_table, (where, end), - fast SCHEME_OBJECT *where AND SCHEME_OBJECT *end) + fast SCHEME_OBJECT * where AND SCHEME_OBJECT * end) { - SCHEME_OBJECT *top; + SCHEME_OBJECT * top; fast long number_of_primitives; - number_of_primitives = (NUMBER_OF_PRIMITIVES ()); - top = &where[2 * number_of_primitives]; + top = &where[2 * MAX_PRIMITIVE]; if (top < end) { internal_renumber_table = where; - external_renumber_table = &where[number_of_primitives]; + external_renumber_table = &where[MAX_PRIMITIVE]; next_primitive_renumber = 0; - while (--number_of_primitives >= 0) + for (number_of_primitives = MAX_PRIMITIVE; + (--number_of_primitives >= 0);) (*where++) = SHARP_F; } return (top); } - + +/* This is called every time fasdump meets a primitive to be renumbered. + It is called on objects with tag TC_PRIMITIVE or TC_PCOMB0, + so it preserves the tag of its argument. + */ + SCHEME_OBJECT DEFUN (dump_renumber_primitive, (primitive), fast SCHEME_OBJECT primitive) { fast long number; fast SCHEME_OBJECT result; - number = PRIMITIVE_NUMBER (primitive); + number = (PRIMITIVE_NUMBER (primitive)); result = internal_renumber_table[number]; - if (result == SHARP_F) + if (result != SHARP_F) + return (MAKE_OBJECT_FROM_OBJECTS (primitive, result)); + else { result = (OBJECT_NEW_DATUM (primitive, next_primitive_renumber)); internal_renumber_table[number] = result; @@ -501,123 +638,117 @@ DEFUN (dump_renumber_primitive, (primitive), fast SCHEME_OBJECT primitive) next_primitive_renumber += 1; return (result); } - else - { - return (MAKE_OBJECT_FROM_OBJECTS (primitive, result)); - } } + +/* Utility for fasdump and dump-band */ -/* Is supposed to have a null character. */ -static char null_string [] = ""; - -SCHEME_OBJECT * +static SCHEME_OBJECT * DEFUN (copy_primitive_information, (code, start, end), - long code - AND fast SCHEME_OBJECT * start AND fast SCHEME_OBJECT * end) + long code AND fast SCHEME_OBJECT * start AND fast SCHEME_OBJECT * end) { + static char null_string [] = "\0"; + fast char * source, * dest, * limit; + long char_count, word_count; + SCHEME_OBJECT * saved; + + if (start < end) + (*start++) = (LONG_TO_FIXNUM (Primitive_Arity_Table [code])); + + source = (Primitive_Name_Table [code]); + saved = start; + start += STRING_CHARS; + dest = ((char *) start); + limit = ((char *) end); + if (source == ((char *) 0)) + source = ((char *) (& (null_string [0]))); + while ((dest < limit) && (((*dest++) = (*source++)) != '\0')) + ; + if (dest >= limit) + while ((*source++) != '\0') + dest += 1; + char_count = ((dest - 1) - ((char *) start)); + word_count = (STRING_LENGTH_TO_GC_LENGTH (char_count)); + start = (saved + 1 + word_count); if (start < end) - (*start++) = (LONG_TO_FIXNUM (primitive_code_to_arity ((int) code))); { - fast char * source = (primitive_code_to_name ((int) code)); - SCHEME_OBJECT * saved = start; - start += STRING_CHARS; - { - fast char * dest = ((char *) start); - fast char * limit = ((char *) end); - if (source == ((char *) 0)) - source = ((char *) (& (null_string [0]))); - while ((dest < limit) && (((*dest++) = (*source++)) != '\0')) - ; - if (dest >= limit) - while ((*source++) != '\0') - dest += 1; - { - long char_count = ((dest - 1) - ((char *) start)); - long word_count = (STRING_LENGTH_TO_GC_LENGTH (char_count)); - start = (saved + 1 + word_count); - if (start < end) - { - (saved [STRING_HEADER]) = - (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, word_count)); - (saved [STRING_LENGTH_INDEX]) = ((SCHEME_OBJECT) char_count); - } - return (start); - } - } + (saved [STRING_HEADER]) = + (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, word_count)); + (saved [STRING_LENGTH_INDEX]) = ((SCHEME_OBJECT) char_count); } + return (start); } - + +/* This is called at the end of the relocation step to + allocate the actual table to dump on the output file. + */ + SCHEME_OBJECT * DEFUN (cons_primitive_table, (start, end, length), - SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND - long * length) + SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND long * length) + { - SCHEME_OBJECT *saved; + SCHEME_OBJECT * saved; long count, code; saved = start; - *length = next_primitive_renumber; + * length = next_primitive_renumber; for (count = 0; ((count < next_primitive_renumber) && (start < end)); count += 1) { - code = (PRIMITIVE_NUMBER(external_renumber_table[count])); - start = copy_primitive_information (code, start, end); + code = (PRIMITIVE_NUMBER (external_renumber_table[count])); + start = (copy_primitive_information (code, start, end)); } return (start); } + +/* This is called when a band is dumped. + All the primitives are dumped unceremoniously. + */ SCHEME_OBJECT * DEFUN (cons_whole_primitive_table, (start, end, length), - SCHEME_OBJECT * start AND SCHEME_OBJECT * end - AND long * length) + SCHEME_OBJECT * start AND SCHEME_OBJECT * end AND long * length) { - SCHEME_OBJECT *saved; - long count, number_of_primitives; + SCHEME_OBJECT * saved; + long count; - number_of_primitives = NUMBER_OF_PRIMITIVES(); - *length = number_of_primitives; saved = start; + * length = MAX_PRIMITIVE; for (count = 0; - ((count < number_of_primitives) && (start < end)); + ((count < MAX_PRIMITIVE) && (start < end)); count += 1) - start = copy_primitive_information (count, start, end); + start = (copy_primitive_information (count, start, end)); return (start); } - + +/* This is called from fasload and load-band */ + void -DEFUN (install_primitive_table, (table, length, flush_p), +DEFUN (install_primitive_table, (table, length), fast SCHEME_OBJECT * table - AND fast long length - AND Boolean flush_p) + AND fast long length) { - fast SCHEME_OBJECT *translation_table; + fast SCHEME_OBJECT * translation_table; SCHEME_OBJECT result; long arity; - if (flush_p) - { - Undefined_Primitives = SHARP_F; - Undefined_Primitives_Arity = SHARP_F; - } - translation_table = load_renumber_table; while (--length >= 0) { - arity = FIXNUM_TO_LONG (*table); + arity = (FIXNUM_TO_LONG (* table)); table += 1; result = - (search_for_primitive (MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, table), - ((unsigned char *) (&table[STRING_CHARS])), - true, true, arity)); - if (OBJECT_TYPE (result) != TC_PRIMITIVE) + (find_primitive ((MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, table)), + true, true, arity)); + if ((OBJECT_TYPE (result)) != TC_PRIMITIVE) signal_error_from_primitive (ERR_WRONG_ARITY_PRIMITIVES); *translation_table++ = result; - table += (1 + (OBJECT_DATUM (*table))); + table += (1 + (OBJECT_DATUM (* table))); } return; } diff --git a/v7/src/microcode/usrdef.h b/v7/src/microcode/usrdef.h index 6f1b10a1b..a55c0811c 100644 --- a/v7/src/microcode/usrdef.h +++ b/v7/src/microcode/usrdef.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: usrdef.h,v 9.39 1993/06/24 07:10:05 gjr Exp $ +$Id: usrdef.h,v 9.40 1993/08/03 08:30:02 gjr Exp $ -Copyright (c) 1987-92 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -34,6 +34,9 @@ MIT in each case. */ /* Macros and header for usrdef.c and variants. */ +#ifndef SCM_USRDEF_H +#define SCM_USRDEF_H + #include "ansidecl.h" #include "config.h" #include "object.h" @@ -41,6 +44,18 @@ MIT in each case. */ #include "prim.h" #include "prims.h" +extern SCHEME_OBJECT EXFUN ((* (Static_Primitive_Procedure_Table[])), (void)); +extern int Static_Primitive_Arity_Table[]; +extern int Static_Primitive_Count_Table[]; +extern char * Static_Primitive_Name_Table[]; +extern char * Static_Primitive_Documentation_Table[]; +extern long MAX_STATIC_PRIMITIVE; + +extern SCHEME_OBJECT + EXFUN (declare_primitive, (char *, primitive_procedure_t, int, int, char *)); + extern void EXFUN (Microcode_Termination, (int)), EXFUN (signal_error_from_primitive, (long)); + +#endif /* SCM_USRDEF_H */ diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index 2e3a0e91e..0ba965548 100644 --- a/v7/src/microcode/utils.c +++ b/v7/src/microcode/utils.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: utils.c,v 9.59 1993/06/29 22:53:54 cph Exp $ +$Id: utils.c,v 9.60 1993/08/03 08:30:06 gjr Exp $ Copyright (c) 1987-1993 Massachusetts Institute of Technology @@ -39,6 +39,7 @@ MIT in each case. */ #include "winder.h" #include "history.h" #include "cmpint.h" +#include "syscall.h" /* Helper procedures for Setup_Interrupt, which follows. */ @@ -361,13 +362,35 @@ DEFUN (error_bad_range_arg, (n), int n) } signal_error_from_primitive (error_code); } - + void DEFUN_VOID (error_external_return) { signal_error_from_primitive (ERR_EXTERNAL_RETURN); } - + +unsigned int syscall_error_code; +unsigned int syscall_error_name; + +void +DEFUN (error_in_system_call, (err, name), + enum syserr_names err AND enum syscall_names name) +{ + syscall_error_code = ((unsigned int) err); + syscall_error_name = ((unsigned int) name); + signal_error_from_primitive (ERR_IN_SYSTEM_CALL); + /*NOTREACHED*/ +} + +void +DEFUN (error_system_call, (code, name), + int code AND enum syscall_names name) +{ + error_in_system_call ((OS_error_code_to_syserr, (code)), + name); + /*NOTREACHED*/ +} + long DEFUN (arg_integer, (arg_number), int arg_number) { @@ -490,9 +513,6 @@ DEFUN (interpreter_applicable_p, (object), fast SCHEME_OBJECT object) * and Interrupt-Enables. */ -unsigned int syscall_error_code; -unsigned int syscall_error_name; - void DEFUN (Do_Micro_Error, (Err, From_Pop_Return), long Err AND Boolean From_Pop_Return) diff --git a/v7/src/microcode/ux.h b/v7/src/microcode/ux.h index 9e0941d85..2d69bf9ad 100644 --- a/v7/src/microcode/ux.h +++ b/v7/src/microcode/ux.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: ux.h,v 1.49 1993/07/17 05:07:46 cph Exp $ +$Id: ux.h,v 1.50 1993/08/03 08:30:08 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -71,110 +71,7 @@ extern int EXFUN (kill, (pid_t, int)); #include "intext.h" #include "dstack.h" #include "osscheme.h" - -enum syscall_names -{ - syscall_accept, - syscall_bind, - syscall_chdir, - syscall_chmod, - syscall_close, - syscall_connect, - syscall_fcntl_GETFL, - syscall_fcntl_SETFL, - syscall_fork, - syscall_fstat, - syscall_ftruncate, - syscall_getcwd, - syscall_gethostname, - syscall_gettimeofday, - syscall_ioctl_TIOCGPGRP, - syscall_ioctl_TIOCSIGSEND, - syscall_kill, - syscall_link, - syscall_listen, - syscall_localtime, - syscall_lseek, - syscall_malloc, - syscall_mkdir, - syscall_open, - syscall_opendir, - syscall_pause, - syscall_pipe, - syscall_read, - syscall_readlink, - syscall_realloc, - syscall_rename, - syscall_rmdir, - syscall_select, - syscall_setitimer, - syscall_setpgid, - syscall_sighold, - syscall_sigprocmask, - syscall_sigsuspend, - syscall_sleep, - syscall_socket, - syscall_symlink, - syscall_tcdrain, - syscall_tcflush, - syscall_tcgetpgrp, - syscall_tcsetpgrp, - syscall_terminal_get_state, - syscall_terminal_set_state, - syscall_time, - syscall_times, - syscall_unlink, - syscall_utime, - syscall_vfork, - syscall_write, - syscall_stat, - syscall_lstat, - syscall_mktime -}; - -enum syserr_names -{ - syserr_unknown, - syserr_arg_list_too_long, - syserr_bad_address, - syserr_bad_file_descriptor, - syserr_broken_pipe, - syserr_directory_not_empty, - syserr_domain_error, - syserr_exec_format_error, - syserr_file_exists, - syserr_file_too_large, - syserr_filename_too_long, - syserr_function_not_implemented, - syserr_improper_link, - syserr_inappropriate_io_control_operation, - syserr_interrupted_function_call, - syserr_invalid_argument, - syserr_invalid_seek, - syserr_io_error, - syserr_is_a_directory, - syserr_no_child_processes, - syserr_no_locks_available, - syserr_no_space_left_on_device, - syserr_no_such_device, - syserr_no_such_device_or_address, - syserr_no_such_file_or_directory, - syserr_no_such_process, - syserr_not_a_directory, - syserr_not_enough_space, - syserr_operation_not_permitted, - syserr_permission_denied, - syserr_read_only_file_system, - syserr_resource_busy, - syserr_resource_deadlock_avoided, - syserr_resource_temporarily_unavailable, - syserr_result_too_large, - syserr_too_many_links, - syserr_too_many_open_files, - syserr_too_many_open_files_in_system -}; - -extern void EXFUN (error_system_call, (int code, enum syscall_names name)); +#include "syscall.h" /* Conditionalizations that are overridden by _POSIX. */ diff --git a/v7/src/microcode/uxtop.c b/v7/src/microcode/uxtop.c index 7e4e983ac..2684a6010 100644 --- a/v7/src/microcode/uxtop.c +++ b/v7/src/microcode/uxtop.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: uxtop.c,v 1.10 1993/02/06 05:45:28 gjr Exp $ +$Id: uxtop.c,v 1.11 1993/08/03 08:30:09 gjr Exp $ Copyright (c) 1990-1993 Massachusetts Institute of Technology @@ -191,8 +191,8 @@ DEFUN_VOID (OS_restore_external_state) UX_ctty_restore_external_state (); } -static enum syserr_names -DEFUN (error_code_to_syserr, (code), int code) +enum syserr_names +DEFUN (OS_error_code_to_syserr, (code), int code) { switch (code) { @@ -242,7 +242,7 @@ DEFUN (error_code_to_syserr, (code), int code) default: return (syserr_unknown); } } - + static int DEFUN (syserr_to_error_code, (syserr), enum syserr_names syserr) { @@ -295,16 +295,6 @@ DEFUN (syserr_to_error_code, (syserr), enum syserr_names syserr) } } -void -DEFUN (error_system_call, (code, name), int code AND enum syscall_names name) -{ - extern unsigned int syscall_error_code; - extern unsigned int syscall_error_name; - syscall_error_code = ((unsigned int) (error_code_to_syserr (code))); - syscall_error_name = ((unsigned int) name); - signal_error_from_primitive (ERR_IN_SYSTEM_CALL); -} - CONST char * DEFUN (OS_error_code_to_message, (syserr), unsigned int syserr) { diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 256404a63..2a4c654e9 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: version.h,v 11.133 1993/06/29 22:53:56 cph Exp $ +$Id: version.h,v 11.134 1993/08/03 08:30:12 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 133 +#define SUBVERSION 134 #endif diff --git a/v8/src/microcode/cmpauxmd/hppa.m4 b/v8/src/microcode/cmpauxmd/hppa.m4 index 4016dd9cf..56cd4532b 100644 --- a/v8/src/microcode/cmpauxmd/hppa.m4 +++ b/v8/src/microcode/cmpauxmd/hppa.m4 @@ -1,6 +1,6 @@ changecom(`;');;; -*-Midas-*- ;;; -;;; $Id: hppa.m4,v 1.29 1993/07/29 07:02:17 gjr Exp $ +;;; $Id: hppa.m4,v 1.30 1993/08/03 08:28:43 gjr Exp $ ;;; ;;; Copyright (c) 1989-1993 Massachusetts Institute of Technology ;;; @@ -121,7 +121,6 @@ define(TC_LENGTH, ifdef("TYPE_CODE_LENGTH", TYPE_CODE_LENGTH, 8)) define(QUAD_MASK, eval(2 ** (TC_LENGTH - 2))) define(LOW_TC_BIT, eval(TC_LENGTH - 1)) define(DATUM_LENGTH, eval(32 - TC_LENGTH)) -define(HALF_DATUM_LENGTH, eval(DATUM_LENGTH/2)) define(FIXNUM_LENGTH, DATUM_LENGTH) define(FIXNUM_POS, eval(FIXNUM_LENGTH - 1)) define(FIXNUM_BIT, eval(TC_LENGTH + 1)) @@ -933,7 +932,7 @@ stack_and_interrupt_check_signal_interrupt BE 0(5,31) ; return NOP -;;; The following all have the same interface: +;;; invoke_primitive and *cons all have the same interface: ;;; The "return address" in r31 points to a word containing ;;; the distance between itself and the word in memory containing ;;; the primitive object. @@ -945,10 +944,10 @@ invoke_primitive ADDIL L'hppa_primitive_table-$global$,27 LDWX 26(0,31),26 ; get primitive LDW R'hppa_primitive_table-$global$(1),25 - EXTRU 26,31,HALF_DATUM_LENGTH,24 ; get primitive index + EXTRU 26,31,DATUM_LENGTH,24 ; get primitive index STW 26,32(0,4) ; store primitive ADDIL L'Primitive_Arity_Table-$global$,27 - LDO R'Primitive_Arity_Table-$global$(1),18 + LDW R'Primitive_Arity_Table-$global$(1),18 LDWX,S 24(0,25),25 ; find primitive entry point ADDIL L'Ext_Stack_Pointer-$global$,27 STW 22,R'Ext_Stack_Pointer-$global$(1) ; Update stack pointer @@ -968,6 +967,15 @@ invoke_primitive B ep_interface_to_scheme_2 DEP 5,TC_START,TC_LENGTH,26 ; return address as address +;;; The BLE in invoke_primitive can jump here. +;;; The primitive index is in gr24 + +cross_segment_call + ADDIL L'Primitive_Procedure_Table-$global$,27 + LDW R'Primitive_Procedure_Table-$global$(1),22 + LDWX,S 24(0,22),22 + B $$dyncall ; ignore the return address + vector_cons LDW 0(0,22),26 ; length as fixnum COPY 21,2 @@ -1173,6 +1181,7 @@ define(builtin,"ADDIL L'$1-known_pc,3 builtin(shortcircuit_apply_8) builtin(stack_and_interrupt_check) builtin(invoke_primitive) + builtin(cross_segment_call) builtin(vector_cons) builtin(string_allocate) builtin(floating_vector_cons) @@ -1427,8 +1436,10 @@ interface_limit .IMPORT hppa_utility_table,DATA .IMPORT hppa_primitive_table,DATA .IMPORT Primitive_Arity_Table,DATA + .IMPORT Primitive_Procedure_Table,DATA .SPACE $TEXT$ .SUBSPA $CODE$ + .IMPORT $$dyncall,MILLICODE .IMPORT $$remI,MILLICODE .IMPORT declare_builtin,CODE .IMPORT sin,CODE @@ -1444,14 +1455,15 @@ interface_limit .IMPORT floor,CODE .IMPORT atan2,CODE .EXPORT C_to_interface,PRIV_LEV=3,ARGW0=GR,RTNVAL=GR - .EXPORT interface_initialize,PRIV_LEV=3 + .EXPORT ep_interface_to_scheme,PRIV_LEV=3 .EXPORT scheme_to_interface_ble,PRIV_LEV=3 .EXPORT trampoline_to_interface,PRIV_LEV=3 .EXPORT scheme_to_interface,PRIV_LEV=3 .EXPORT hook_jump_table,PRIV_LEV=3 + .EXPORT cross_segment_call,PRIV_LEV=3 + .EXPORT flonum_atan2,PRIV_LEV=3 + .EXPORT ep_interface_to_C,PRIV_LEV=3 + .EXPORT interface_initialize,PRIV_LEV=3 .EXPORT cache_flush_region,PRIV_LEV=3 .EXPORT cache_flush_all,PRIV_LEV=3 - .EXPORT ep_interface_to_C,PRIV_LEV=3 - .EXPORT ep_interface_to_scheme,PRIV_LEV=3 - .EXPORT flonum_atan2,PRIV_LEV=3 .END diff --git a/v8/src/microcode/cmpint.c b/v8/src/microcode/cmpint.c index eab4bf7cd..a7a30334f 100644 --- a/v8/src/microcode/cmpint.c +++ b/v8/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: cmpint.c,v 1.60 1993/07/29 07:11:02 gjr Exp $ +$Id: cmpint.c,v 1.61 1993/08/03 08:29:39 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -2588,22 +2588,17 @@ loop: case TC_PRIMITIVE: { long arity; - extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT)); - arity = primitive_to_arity (procedure); + arity = (PRIMITIVE_ARITY (procedure)); if (arity == (nactuals - 1)) { nactuals = 0; kind = TRAMPOLINE_K_PRIMITIVE; } else if (arity == LEXPR_PRIMITIVE_ARITY) - { kind = TRAMPOLINE_K_LEXPR_PRIMITIVE; - } else - { kind = TRAMPOLINE_K_OTHER; - } break; } @@ -2931,7 +2926,7 @@ DEFUN (pc_to_utility_index, (pc), unsigned long pc) || (pc >= (UTIL_TABLE_PC_REF (last_util_table_index)))) return (-1); else if (pc < (UTIL_TABLE_PC_REF (1))) - return ((pc_to_builtin_index (pc)) ? -1 : 0); + return (((pc_to_builtin_index (pc)) == -1) ? 0 : -1); else { int low, high, middle; diff --git a/v8/src/microcode/cmpintmd/hppa.h b/v8/src/microcode/cmpintmd/hppa.h index d94500c05..71abb2401 100644 --- a/v8/src/microcode/cmpintmd/hppa.h +++ b/v8/src/microcode/cmpintmd/hppa.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: hppa.h,v 1.43 1993/07/29 07:02:09 gjr Exp $ +$Id: hppa.h,v 1.44 1993/08/03 08:28:51 gjr Exp $ Copyright (c) 1989-1993 Massachusetts Institute of Technology @@ -709,6 +709,12 @@ DEFUN_VOID (flush_i_cache_initialize) push_d_cache_region (((PTR) (address)), \ ((unsigned long) (nwords))); \ } while (0) + +extern void EXFUN (hppa_update_primitive_table, (int, int)); +extern Boolean EXFUN (hppa_grow_primitive_table, (int)); + +#define UPDATE_PRIMITIVE_TABLE_HOOK hppa_update_primitive_table +#define GROW_PRIMITIVE_TABLE_HOOK hppa_grow_primitive_table /* This is not completely true. Some models (eg. 850) have combined caches, but we have to assume the worst. @@ -732,28 +738,46 @@ DEFUN (assemble_17, (inst), union ble_inst inst) return off.value; } +static unsigned long hppa_closure_hook = 0; + static unsigned long DEFUN (C_closure_entry_point, (closure), unsigned long C_closure) { - if ((C_closure & 0x3) == 0x2) + if ((C_closure & 0x3) != 0x2) + return (C_closure); + else { long offset; + extern int etext; + unsigned long entry_point; char * blp = (* ((char **) (C_closure - 2))); blp = ((char *) (((unsigned long) blp) & ~3)); offset = (assemble_17 (* ((union ble_inst *) blp))); - return ((unsigned long) ((blp + 8) + offset)); + entry_point = ((unsigned long) ((blp + 8) + offset)); + return ((entry_point < ((unsigned long) &etext)) + ? entry_point + : hppa_closure_hook); } - else - return (C_closure); } + +static void +DEFUN (transform_procedure_entries, (len, otable, ntable), + long len AND PTR * otable AND PTR * ntable) +{ + long counter; + + for (counter = 0; counter < len; counter++) + ntable[counter] = + ((PTR) (C_closure_entry_point ((unsigned long) (otable [counter])))); + return; +} -PTR * +static PTR * DEFUN (transform_procedure_table, (table_length, old_table), long table_length AND PTR * old_table) { PTR * new_table; - long counter; new_table = ((PTR *) (malloc (table_length * (sizeof (PTR))))); if (new_table == ((PTR *) NULL)) @@ -762,16 +786,13 @@ DEFUN (transform_procedure_table, (table_length, old_table), (table_length * (sizeof (PTR)))); exit (1); } - - for (counter = 0; counter < table_length; counter++) - new_table[counter] = - ((PTR) (C_closure_entry_point ((unsigned long) (old_table [counter])))); + transform_procedure_entries (table_length, old_table, new_table); return (new_table); } #define UTIL_TABLE_PC_REF(index) \ (C_closure_entry_point (UTIL_TABLE_PC_REF_REAL (index))) - + #ifdef _BSD4_3 # include # define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC) @@ -803,42 +824,61 @@ DEFUN_VOID (change_vm_protection) #endif return; } - + /* This loads the cache information structure for use by flush_i_cache, sets the floating point flags correctly, and accommodates the c function pointer closure format problems for utilities for HP-UX >= 8.0 . It also changes the VM protection of the heap, if necessary. */ -extern PTR * hppa_utility_table, * hppa_primitive_table; -PTR * hppa_utility_table, * hppa_primitive_table; +extern PTR * hppa_utility_table; +extern PTR * hppa_primitive_table; -void -DEFUN (hppa_reset_hook, (utility_length, utility_table, - primitive_length, primitive_table), - long utility_length AND PTR * utility_table - AND long primitive_length AND PTR * primitive_table) +PTR * hppa_utility_table = ((PTR *) NULL); + +static void +DEFUN (hppa_reset_hook, (utility_length, utility_table), + long utility_length AND PTR * utility_table) { extern void EXFUN (interface_initialize, (void)); + extern void EXFUN (cross_segment_call, (void)); flush_i_cache_initialize (); interface_initialize (); change_vm_protection (); - hppa_utility_table = - (transform_procedure_table (utility_length, utility_table)); - hppa_primitive_table = - (transform_procedure_table (primitive_length, primitive_table)); + hppa_closure_hook = (C_closure_entry_point ((unsigned long) cross_segment_call)); + hppa_utility_table + = (transform_procedure_table (utility_length, utility_table)); return; } #define ASM_RESET_HOOK() do \ { \ hppa_reset_hook (((sizeof (utility_table)) / (sizeof (PTR))), \ - ((PTR *) (&utility_table[0])), \ - (MAX_PRIMITIVE + 1), \ - ((PTR *) (&Primitive_Procedure_Table[0]))); \ + ((PTR *) (&utility_table[0]))); \ } while (0) +PTR * hppa_primitive_table = ((PTR *) NULL); + +void +DEFUN (hppa_update_primitive_table, (low, high), int low AND int high) +{ + transform_procedure_entries ((high - low), + ((PTR *) (Primitive_Procedure_Table + low)), + (hppa_primitive_table + low)); + return; +} + +Boolean +DEFUN (hppa_grow_primitive_table, (new_size), int new_size) +{ + PTR * new_table + = ((PTR *) (realloc (hppa_primitive_table, (new_size * (sizeof (PTR)))))); + if (new_table != ((PTR *) NULL)) + hppa_primitive_table = new_table; + return (new_table != ((PTR *) NULL)); +} + #endif /* IN_CMPINT_C */ /* Derived parameters and macros. diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h index 0f04a2a74..79e1ca435 100644 --- a/v8/src/microcode/object.h +++ b/v8/src/microcode/object.h @@ -1,8 +1,8 @@ /* -*-C-*- -$Id: object.h,v 9.40 1992/12/02 18:11:14 cph Exp $ +$Id: object.h,v 9.41 1993/08/03 08:29:56 gjr Exp $ -Copyright (c) 1987-1992 Massachusetts Institute of Technology +Copyright (c) 1987-1993 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -33,7 +33,10 @@ promotional, or sales literature without prior written consent from MIT in each case. */ /* This file defines the macros which define and manipulate Scheme - objects. This is the lowest level of abstraction in this program. */ + objects. This is the lowest level of abstraction in this program. +*/ +#ifndef SCM_OBJECT_H +#define SCM_OBJECT_H /* The value in "Wsize.c" for `TYPE_CODE_LENGTH' must match this!! */ #ifndef TYPE_CODE_LENGTH @@ -511,3 +514,5 @@ if ((ADDRESS_CONSTANT_P (OBJECT_ADDRESS (Old_Pointer))) && \ #define ALIGN_FLOAT(Where) #endif /* not FLOATING_ALIGNMENT */ + +#endif /* SCM_OBJECT_H */ diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index 256404a63..2a4c654e9 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Id: version.h,v 11.133 1993/06/29 22:53:56 cph Exp $ +$Id: version.h,v 11.134 1993/08/03 08:30:12 gjr Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 133 +#define SUBVERSION 134 #endif -- 2.25.1