primitives.
/* -*-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
*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 :
(Lost_Objects_Base, (LONG_TO_UNSIGNED_FIXNUM (ADDRESS_TO_DATUM (root2))));
History = (OBJECT_ADDRESS (*root++));
- Undefined_Primitives = *root++;
- Undefined_Primitives_Arity = *root++;
\f
Set_Current_Stacklet (*root);
root += 1;
/* -*-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
}
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);
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
;;;
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))
BE 0(5,31) ; return
NOP
\f
-;;; 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.
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
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
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)
.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
.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
/* -*-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
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;
}
|| (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;
/* -*-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
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
\f
/* This is not completely true. Some models (eg. 850) have combined caches,
but we have to assume the worst.
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);
}
+\f
+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))
(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)))
-\f
+
#ifdef _BSD4_3
# include <sys/mman.h>
# define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
#endif
return;
}
-
+\f
/* 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 */
\f
/* Derived parameters and macros.
/* -*-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
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));
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++)
/* -*-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
#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)
{
}
}
-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)
{
/* -*-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
MIT in each case. */
/* Error and termination code declarations. */
+
+#ifndef SCM_ERRORS_H
+#define SCM_ERRORS_H
\f
/* All error and termination codes must be positive
* to allow primitives to return either an error code
/* 0x19 */ "User requested termination after trap", \
/* 0x1a */ "Backing out of non-primitive" \
}
+
+#endif /* SCM_ERRORS_H /*
/* -*-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
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);
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
{
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,
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))));
}
}
}
/* -*-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
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));
{
SET_CONSTANT_TOP ();
if (mode != MODE_CHANNEL)
- {
OS_channel_close_noerror (load_channel);
- }
signal_error_from_primitive (ERR_IO_ERROR);
}
computed_checksum =
Primitive_Table_Size)
{
if (mode != MODE_CHANNEL)
- {
OS_channel_close_noerror (load_channel);
- }
signal_error_from_primitive (ERR_IO_ERROR);
}
computed_checksum =
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);
}
\f
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)
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:
{
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);
}
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)),
(1 + (VECTOR_LENGTH (compiler_utilities))))));
}
else
- {
const_relocation = (COMPUTE_RELOCATION (Orig_Constant, Const_Base));
- }
stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top));
\f
#ifdef BYTE_INVERSION
/* 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.
/* -*-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
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";
/* 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);
/* -*-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
#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 ())
\f
/* 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
#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); \
/* 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))
/* -*-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
*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)
(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;
/* -*-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
#include "dstack.h"
#include "osscheme.h"
#include "dossys.h"
-\f
-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
-};
-\f
-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 <limits.h>
#include <time.h>
#include <termio.h>
/* -*-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
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
#include "dstack.h"
#include "osscheme.h"
#include "ntsys.h"
-\f
-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
-};
-\f
-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 <limits.h>
#include <time.h>
/*#include <termio.h>*/
#define VOID_SIGNAL_HANDLERS
/*#include <sys/dir.h>*/
-
\f
typedef void Tsignal_handler_result;
#define SIGNAL_HANDLER_RETURN() return
/* -*-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
#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)
{
}
}
-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)
{
/* -*-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
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
\f
/* The value in "Wsize.c" for `TYPE_CODE_LENGTH' must match this!! */
#ifndef TYPE_CODE_LENGTH
#define ALIGN_FLOAT(Where)
#endif /* not FLOATING_ALIGNMENT */
+
+#endif /* SCM_OBJECT_H */
/* -*-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
/* 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 */
/* -*-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
/* 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 */
/* -*-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
for argument type or value checking, and for accessing
the arguments. */
+#ifndef SCM_PRIMS_H
+#define SCM_PRIMS_H
+
#include "ansidecl.h"
\f
/* Definition of primitives. */
((FLONUM_P (ARG_REF (arg))) \
? ((double *) (VECTOR_LOC (ARG_REF(arg), 0))) \
: ((error_wrong_type_arg (arg)), ((double *) 0)))
+
+#endif /* SCM_PRIMS_H */
/* -*-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
#include "scheme.h"
#include "prims.h"
+#include "usrdef.h"
+#include "prename.h"
+#include "syscall.h"
+#include "cmpgc.h"
#include <ctype.h>
+
+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
\f
-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);
-}
-\f
/*
- 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. */
+\f
+/* 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 */
-\f
-/* 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;
+}
+\f
+/* 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 */
-\f
-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);
+}
+\f
+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));
+ }
}
\f
-/* 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);
}
\f
-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);
+}
+\f
+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);
}
\f
-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;
}
\f
-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);
}
\f
/*
- 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);
-\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));
-\f
- 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)));
}
\f
-/* 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);
}
-\f
+
+/* 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;
next_primitive_renumber += 1;
return (result);
}
- else
- {
- return (MAKE_OBJECT_FROM_OBJECTS (primitive, result));
- }
}
+\f
+/* 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);
}
-\f
+
+/* 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);
}
+\f
+/* 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);
}
-\f
+
+/* 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;
}
/* -*-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
/* 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"
#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 */
/* -*-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
#include "winder.h"
#include "history.h"
#include "cmpint.h"
+#include "syscall.h"
\f
/* Helper procedures for Setup_Interrupt, which follows. */
}
signal_error_from_primitive (error_code);
}
-
+\f
void
DEFUN_VOID (error_external_return)
{
signal_error_from_primitive (ERR_EXTERNAL_RETURN);
}
-\f
+
+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)
{
* 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)
/* -*-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
#include "intext.h"
#include "dstack.h"
#include "osscheme.h"
-\f
-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"
\f
/* Conditionalizations that are overridden by _POSIX. */
/* -*-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
UX_ctty_restore_external_state ();
}
\f
-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)
{
default: return (syserr_unknown);
}
}
-
+\f
static int
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)
{
/* -*-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
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 133
+#define SUBVERSION 134
#endif
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
;;;
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))
BE 0(5,31) ; return
NOP
\f
-;;; 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.
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
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
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)
.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
.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
/* -*-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
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;
}
|| (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;
/* -*-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
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
\f
/* This is not completely true. Some models (eg. 850) have combined caches,
but we have to assume the worst.
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);
}
+\f
+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))
(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)))
-\f
+
#ifdef _BSD4_3
# include <sys/mman.h>
# define VM_PROT_SCHEME (PROT_READ | PROT_WRITE | PROT_EXEC)
#endif
return;
}
-
+\f
/* 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 */
\f
/* Derived parameters and macros.
/* -*-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
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
\f
/* The value in "Wsize.c" for `TYPE_CODE_LENGTH' must match this!! */
#ifndef TYPE_CODE_LENGTH
#define ALIGN_FLOAT(Where)
#endif /* not FLOATING_ALIGNMENT */
+
+#endif /* SCM_OBJECT_H */
/* -*-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
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 133
+#define SUBVERSION 134
#endif
projects / mit-scheme.git / commitdiff