/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.51 1990/06/20 21:13:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.52 1990/11/21 07:03:52 jinx Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
-#include "osio.h"
+#include "uxio.h"
#include "osfile.h"
#include "trap.h"
#include "lookup.h" /* UNCOMPILED_VARIABLE */
#define Write_Data(size, buffer) \
((OS_channel_write_dump_file \
- (dump_channel, (buffer), ((size) * (sizeof (SCHEME_OBJECT))))) \
+ (dump_channel, \
+ ((char *) (buffer)), \
+ ((size) * (sizeof (SCHEME_OBJECT))))) \
/ (sizeof (SCHEME_OBJECT)))
#include "dump.c"
extern SCHEME_OBJECT
- dump_renumber_primitive(),
- *initialize_primitive_table(),
- *cons_primitive_table(),
- *cons_whole_primitive_table();
+ dump_renumber_primitive (),
+ *initialize_primitive_table (),
+ *cons_primitive_table (),
+ *cons_whole_primitive_table ();
static char *dump_file_name;
static int real_gc_file, dump_file;
#define fasdump_remember_to_fix(location, contents) \
{ \
- if ((fixup == fixup_buffer) && (!reset_fixes())) \
+ if ((fixup == fixup_buffer) && (!(reset_fixes ()))) \
{ \
return (PRIM_INTERRUPT); \
} \
#define fasdump_normal_setup() \
{ \
- Old = OBJECT_ADDRESS (Temp); \
- if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
+ Old = (OBJECT_ADDRESS (Temp)); \
+ if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) \
{ \
*Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old)); \
continue; \
} \
New_Address = (MAKE_BROKEN_HEART (To_Address)); \
- fasdump_remember_to_fix(Old, *Old); \
+ fasdump_remember_to_fix (Old, *Old); \
}
#ifdef FLOATING_ALIGNMENT
#define fasdump_flonum_setup() \
{ \
- Old = OBJECT_ADDRESS (Temp); \
- if (OBJECT_TYPE (*Old) == TC_BROKEN_HEART) \
+ Old = (OBJECT_ADDRESS (Temp)); \
+ if ((OBJECT_TYPE (*Old)) == TC_BROKEN_HEART) \
{ \
*Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, *Old)); \
continue; \
} \
- FLOAT_ALIGN_FREE(To_Address, To); \
+ FLOAT_ALIGN_FREE (To_Address, To); \
New_Address = (MAKE_BROKEN_HEART (To_Address)); \
- fasdump_remember_to_fix(Old, *Old); \
+ fasdump_remember_to_fix (Old, *Old); \
}
#else /* FLOATING_ALIGNMENT */
-#define fasdump_flonum_setup() fasdump_normal_setup()
+#define fasdump_flonum_setup() fasdump_normal_setup ()
#endif /* FLOATING_ALIGNMENT */
To_Address += (length); \
if (To >= free_buffer_top) \
{ \
- To = dump_and_reset_free_buffer((To - free_buffer_top), &success); \
+ To = (dump_and_reset_free_buffer ((To - free_buffer_top), \
+ &success)); \
if (!success) \
{ \
return (PRIM_INTERRUPT); \
#define fasdump_normal_transport(copy_code, length) \
{ \
copy_code; \
- fasdump_transport_end(length); \
+ fasdump_transport_end (length); \
}
#define fasdump_normal_end() \
{ \
- *OBJECT_ADDRESS (Temp) = New_Address; \
+ *(OBJECT_ADDRESS (Temp)) = New_Address; \
*Scan = (MAKE_OBJECT_FROM_OBJECTS (Temp, New_Address)); \
continue; \
}
#define fasdump_normal_pointer(copy_code, length) \
{ \
- fasdump_normal_setup(); \
- fasdump_normal_transport(copy_code, length); \
- fasdump_normal_end(); \
+ fasdump_normal_setup (); \
+ fasdump_normal_transport (copy_code, length); \
+ fasdump_normal_end (); \
}
\f
#define fasdump_typeless_setup() \
continue; \
} \
New_Address = ((SCHEME_OBJECT) To_Address); \
- fasdump_remember_to_fix(Old, *Old); \
+ fasdump_remember_to_fix (Old, *Old); \
}
#define fasdump_typeless_end() \
#define fasdump_typeless_pointer(copy_code, length) \
{ \
- fasdump_typeless_setup(); \
- fasdump_normal_transport(copy_code, length); \
- fasdump_typeless_end(); \
+ fasdump_typeless_setup (); \
+ fasdump_normal_transport (copy_code, length); \
+ fasdump_typeless_end (); \
}
#define fasdump_compiled_entry() \
do { \
compiled_code_present_p = true; \
Old = OBJECT_ADDRESS (Temp); \
- Compiled_BH(false, continue); \
+ Compiled_BH (false, continue); \
{ \
SCHEME_OBJECT *Saved_Old = Old; \
\
- fasdump_remember_to_fix(Old, *Old); \
+ fasdump_remember_to_fix (Old, *Old); \
New_Address = (MAKE_BROKEN_HEART (To_Address)); \
- copy_vector(&success); \
+ copy_vector (&success); \
if (!success) \
{ \
return (PRIM_INTERRUPT); \
} \
*Saved_Old = New_Address; \
- Temp = RELOCATE_COMPILED(Temp, (OBJECT_ADDRESS (New_Address)), \
- Saved_Old); \
+ Temp = RELOCATE_COMPILED (Temp, (OBJECT_ADDRESS (New_Address)), \
+ Saved_Old); \
continue; \
} \
} while (false)
{ \
Scan = ((SCHEME_OBJECT *) (word_ptr)); \
EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); \
- fasdump_compiled_entry(); \
+ fasdump_compiled_entry (); \
STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); \
}
{ \
Scan = ((SCHEME_OBJECT *) (word_ptr)); \
EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan); \
- fasdump_compiled_entry(); \
+ fasdump_compiled_entry (); \
STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan); \
}
\f
Boolean
-fasdump_exit(length)
- long length;
+DEFUN (fasdump_exit, (length), long length)
{
fast SCHEME_OBJECT *fixes, *fix_address;
Boolean result;
Free = saved_free;
gc_file = real_gc_file;
+
#if true
{
- extern int ftruncate();
+ extern int ftruncate ();
- ftruncate(dump_file, length);
- result = (close(dump_file) == 0);
+ ftruncate (dump_file, length);
+ result = ((close (dump_file)) == 0);
}
#else
{
- extern int truncate();
+ extern int truncate ();
- result = (close(dump_file) == 0);
- truncate(dump_file_name, length);
+ result = (close (dump_file) == 0);
+ truncate (dump_file_name, length);
}
#endif
+
if (length == 0)
{
- extern int unlink();
+ extern int unlink ();
- unlink(dump_file_name);
+ (void) (unlink (dump_file_name));
}
dump_file_name = ((char *) NULL);
fixes = fixup;
-\f
+
next_buffer:
while (fixes != fixup_buffer_end)
if (fixup_count >= 0)
{
- if ((lseek(real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0) == -1) ||
- (read(real_gc_file, fixup_buffer, GC_BUFFER_BYTES) !=
+ if (((lseek (real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0)) == -1) ||
+ ((read (real_gc_file, fixup_buffer, GC_BUFFER_BYTES)) !=
GC_BUFFER_BYTES))
{
- gc_death(TERM_EXIT,
- "fasdump: Could not read back the fasdump fixup information",
- NULL, NULL);
+ gc_death (TERM_EXIT,
+ "fasdump: Could not read back the fasdump fixup information",
+ NULL, NULL);
/*NOTREACHED*/
}
fixup_count -= 1;
}
fixup = fixes;
- Fasdump_Exit_Hook();
+ Fasdump_Exit_Hook ();
return (result);
}
Boolean
-reset_fixes()
+DEFUN_VOID (reset_fixes)
{
fixup_count += 1;
- if ((lseek(real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0) == -1) ||
- (write(real_gc_file, fixup_buffer, GC_BUFFER_BYTES) != GC_BUFFER_BYTES))
+ if (((lseek (real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0)) == -1) ||
+ ((write (real_gc_file, fixup_buffer, GC_BUFFER_BYTES)) != GC_BUFFER_BYTES))
{
return (false);
}
/* A copy of GCLoop, with minor modifications. */
long
-dumploop(Scan, To_ptr, To_Address_ptr)
- fast SCHEME_OBJECT *Scan;
- SCHEME_OBJECT **To_ptr, **To_Address_ptr;
+DEFUN (dumploop, (Scan, To_ptr, To_Address_ptr),
+ fast SCHEME_OBJECT *Scan AND
+ SCHEME_OBJECT **To_ptr AND
+ SCHEME_OBJECT **To_Address_ptr)
{
fast SCHEME_OBJECT *To, *Old, Temp, *To_Address, New_Address;
Boolean success;
for ( ; Scan != To; Scan++)
{
Temp = *Scan;
- Switch_by_GC_Type(Temp)
+ Switch_by_GC_Type (Temp)
{
case TC_BROKEN_HEART:
- if (OBJECT_DATUM (Temp) == 0)
+ if ((OBJECT_DATUM (Temp)) == 0)
{
break;
}
if (Scan != (OBJECT_ADDRESS (Temp)))
{
- sprintf(gc_death_message_buffer,
- "purifyloop: broken heart (0x%lx) in scan",
- Temp);
- gc_death(TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
+ sprintf (gc_death_message_buffer,
+ "purifyloop: broken heart (0x%lx) in scan",
+ Temp);
+ gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
/*NOTREACHED*/
}
if (Scan != scan_buffer_top)
/* The -1 is here because of the Scan++ in the for header. */
- Scan = (dump_and_reload_scan_buffer(0, &success) - 1);
+ Scan = ((dump_and_reload_scan_buffer (0, &success)) - 1);
if (!success)
{
return (PRIM_INTERRUPT);
case TC_MANIFEST_SPECIAL_NM_VECTOR:
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
- Scan += OBJECT_DATUM (Temp);
+ Scan += (OBJECT_DATUM (Temp));
if (Scan < scan_buffer_top)
{
break;
unsigned long overflow;
/* The + & -1 are here because of the Scan++ in the for header. */
- overflow = (Scan - scan_buffer_top) + 1;
- Scan = ((dump_and_reload_scan_buffer((overflow /
- GC_DISK_BUFFER_SIZE),
- &success) +
+ overflow = ((Scan - scan_buffer_top) + 1);
+ Scan = (((dump_and_reload_scan_buffer ((overflow /
+ GC_DISK_BUFFER_SIZE),
+ &success)) +
(overflow % GC_DISK_BUFFER_SIZE)) - 1);
if (!success)
{
case TC_PRIMITIVE:
case TC_PCOMB0:
- *Scan = dump_renumber_primitive(*Scan);
+ *Scan = (dump_renumber_primitive (*Scan));
break;
\f
case_compiled_entry_point:
- fasdump_compiled_entry();
+ fasdump_compiled_entry ();
*Scan = Temp;
break;
case TC_LINKAGE_SECTION:
{
- if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ if ((READ_LINKAGE_KIND (Temp)) != OPERATOR_LINKAGE_KIND)
{
/* count typeless pointers to quads follow. */
Scan++;
max_here = (scan_buffer_top - Scan);
- max_count = READ_CACHE_LINKAGE_COUNT(Temp);
+ max_count = (READ_CACHE_LINKAGE_COUNT (Temp));
while (max_count != 0)
{
count = ((max_count > max_here) ? max_here : max_count);
for ( ; --count >= 0; Scan += 1)
{
Temp = *Scan;
- fasdump_typeless_pointer(copy_quadruple(), 4);
+ fasdump_typeless_pointer (copy_quadruple (), 4);
}
if (max_count != 0)
{
/* We stopped because we needed to relocate too many. */
- Scan = dump_and_reload_scan_buffer(0, NULL);
+ Scan = (dump_and_reload_scan_buffer (0, NULL));
max_here = GC_DISK_BUFFER_SIZE;
}
}
}
\f
case_Cell:
- fasdump_normal_pointer(copy_cell(), 1);
+ fasdump_normal_pointer (copy_cell (), 1);
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
+ if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
case TC_WEAK_CONS:
case_Fasdump_Pair:
- fasdump_normal_pointer(copy_pair(), 2);
+ fasdump_normal_pointer (copy_pair (), 2);
case TC_INTERNED_SYMBOL:
{
- fasdump_normal_setup();
+ fasdump_normal_setup ();
*To++ = *Old;
*To++ = BROKEN_HEART_ZERO;
- fasdump_transport_end(2);
- fasdump_normal_end();
+ fasdump_transport_end (2);
+ fasdump_normal_end ();
}
case TC_UNINTERNED_SYMBOL:
{
- fasdump_normal_setup();
+ fasdump_normal_setup ();
*To++ = *Old;
*To++ = UNBOUND_OBJECT;
- fasdump_transport_end(2);
- fasdump_normal_end();
+ fasdump_transport_end (2);
+ fasdump_normal_end ();
}
case_Triple:
- fasdump_normal_pointer(copy_triple(), 3);
+ fasdump_normal_pointer (copy_triple (), 3);
case TC_VARIABLE:
{
- fasdump_normal_setup();
+ fasdump_normal_setup ();
*To++ = *Old;
*To++ = UNCOMPILED_VARIABLE;
*To++ = SHARP_F;
- fasdump_transport_end(3);
- fasdump_normal_end();
+ fasdump_transport_end (3);
+ fasdump_normal_end ();
}
\f
case_Quadruple:
- fasdump_normal_pointer(copy_quadruple(), 4);
+ fasdump_normal_pointer (copy_quadruple (), 4);
case TC_BIG_FLONUM:
- fasdump_flonum_setup();
+ fasdump_flonum_setup ();
goto Move_Vector;
case TC_COMPILED_CODE_BLOCK:
case_Purify_Vector:
- fasdump_normal_setup();
+ fasdump_normal_setup ();
Move_Vector:
- copy_vector(&success);
+ copy_vector (&success);
if (!success)
{
return (PRIM_INTERRUPT);
}
- fasdump_normal_end();
+ fasdump_normal_end ();
case TC_ENVIRONMENT:
/* Make fasdump fail */
return (ERR_FASDUMP_ENVIRONMENT);
case TC_FUTURE:
- fasdump_normal_setup();
- if (!(Future_Spliceable(Temp)))
+ fasdump_normal_setup ();
+ if (!(Future_Spliceable (Temp)))
{
goto Move_Vector;
}
- *Scan = Future_Value(Temp);
+ *Scan = (Future_Value (Temp));
Scan -= 1;
continue;
default:
- GC_BAD_TYPE("dumploop");
+ GC_BAD_TYPE ("dumploop");
/* Fall Through */
case TC_STACK_ENVIRONMENT:
return (PRIM_DONE);
}
\f
-/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
- Dump an object into a file so that it can be loaded using
- BINARY-FASLOAD. A spare heap is required for this operation. The
- first argument is the object to be dumped. The second is the
- filename and the third a flag. The flag, if #T, means that the
- object is to be dumped for reloading into constant space. If the
- flag is #F, it means that it will be reloaded into the heap. This
- flag is currently ignored. The primitive returns #T or #F
- indicating whether it successfully dumped the object (it can fail
- on an object that is too large). */
-
-DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
+static SCHEME_OBJECT
+DEFUN (dump_to_file, (root, fname),
+ SCHEME_OBJECT root AND
+ char *fname)
{
Boolean success;
long value, length, hlength, tlength, tsize;
SCHEME_OBJECT *dumped_object, *free_buffer, *dummy;
SCHEME_OBJECT *table_start, *table_end, *table_top;
SCHEME_OBJECT header[FASL_HEADER_LENGTH];
- PRIMITIVE_HEADER (3);
- dump_file_name = (STRING_ARG (2));
+
+ dump_file_name = fname;
dump_file = (open (dump_file_name, GC_FILE_FLAGS, 0666));
if (dump_file < 0)
error_bad_range_arg (2);
fixup = fixup_buffer_end;
fixup_count = -1;
- table_top = &saved_free[Space_Before_GC()];
- table_start = initialize_primitive_table(saved_free, table_top);
+ table_top = (&saved_free[Space_Before_GC ()]);
+ table_start = (initialize_primitive_table (saved_free, table_top));
if (table_start >= table_top)
{
- fasdump_exit(0);
- Primitive_GC(table_start - saved_free);
+ fasdump_exit (0);
+ Primitive_GC (table_start - saved_free);
}
-\f
+
#if (GC_DISK_BUFFER_SIZE <= FASL_HEADER_LENGTH)
-#include "error in bchdmp.c: FASL_HEADER_LENGTH too large"
+# include "error in bchdmp.c: FASL_HEADER_LENGTH too large"
#endif
- free_buffer = initialize_free_buffer();
+ free_buffer = (initialize_free_buffer ());
Free = ((SCHEME_OBJECT *) NULL);
free_buffer += FASL_HEADER_LENGTH;
dummy = free_buffer;
- FLOAT_ALIGN_FREE(Free, dummy);
+ FLOAT_ALIGN_FREE (Free, dummy);
- *free_buffer++ = (ARG_REF (1));
+ *free_buffer++ = root;
dumped_object = Free;
Free += 1;
-
- value = dumploop((initialize_scan_buffer() + FASL_HEADER_LENGTH),
- &free_buffer, &Free);
+\f
+ value = dumploop (((initialize_scan_buffer ()) + FASL_HEADER_LENGTH),
+ &free_buffer, &Free);
if (value != PRIM_DONE)
{
- fasdump_exit(0);
+ fasdump_exit (0);
if (value == PRIM_INTERRUPT)
{
- PRIMITIVE_RETURN (SHARP_F);
+ return (SHARP_F);
}
else
{
signal_error_from_primitive (value);
}
}
- end_transport(&success);
+ end_transport (&success);
if (!success)
{
- fasdump_exit(0);
- PRIMITIVE_RETURN (SHARP_F);
+ fasdump_exit (0);
+ return (SHARP_F);
}
length = (Free - dumped_object);
- table_end = cons_primitive_table(table_start, table_top, &tlength);
+ table_end = (cons_primitive_table (table_start, table_top, &tlength));
if (table_end >= table_top)
{
- fasdump_exit(0);
- Primitive_GC(table_end - saved_free);
+ fasdump_exit (0);
+ Primitive_GC (table_end - saved_free);
}
tsize = (table_end - table_start);
- hlength = (sizeof(SCHEME_OBJECT) * tsize);
- if ((lseek(gc_file,
- (sizeof(SCHEME_OBJECT) * (length + FASL_HEADER_LENGTH)),
- 0) == -1) ||
- (write(gc_file, ((char *) &table_start[0]), hlength) != hlength))
+ hlength = ((sizeof (SCHEME_OBJECT)) * tsize);
+ if (((lseek (gc_file,
+ ((sizeof (SCHEME_OBJECT)) * (length + FASL_HEADER_LENGTH)),
+ 0)) == -1) ||
+ ((write (gc_file, ((char *) &table_start[0]), hlength)) != hlength))
{
- fasdump_exit(0);
- PRIMITIVE_RETURN (SHARP_F);
+ fasdump_exit (0);
+ return (SHARP_F);
}
- hlength = (sizeof(SCHEME_OBJECT) * FASL_HEADER_LENGTH);
- prepare_dump_header(header, dumped_object, length, dumped_object,
- 0, Constant_Space, tlength, tsize,
- compiled_code_present_p, false);
- if ((lseek(gc_file, 0, 0) == -1) ||
- (write(gc_file, ((char *) &header[0]), hlength) != hlength))
+ hlength = ((sizeof (SCHEME_OBJECT)) * FASL_HEADER_LENGTH);
+ prepare_dump_header (header, dumped_object, length, dumped_object,
+ 0, Constant_Space, tlength, tsize,
+ compiled_code_present_p, false);
+ if (((lseek (gc_file, 0, 0)) == -1) ||
+ ((write (gc_file, ((char *) &header[0]), hlength)) != hlength))
{
- fasdump_exit(0);
- PRIMITIVE_RETURN (SHARP_F);
+ fasdump_exit (0);
+ return (SHARP_F);
+ }
+ return (fasdump_exit (((sizeof (SCHEME_OBJECT)) *
+ (length + tsize)) + hlength) ?
+ SHARP_T : SHARP_F);
+}
+\f
+/* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag)
+
+ Dump an object into a file so that it can be loaded using
+ BINARY-FASLOAD. A spare heap is required for this operation. The
+ first argument is the object to be dumped. The second is the
+ filename or channel. The third argument, FLAG, is currently
+ ignored. The primitive returns #T or #F indicating whether it
+ successfully dumped the object (it can fail on an object that is
+ too large). It should signal an error rather than return false,
+ but ... some other time.
+
+ This version of fasdump can only handle files (actually lseek-able
+ streams), since the header is written at the beginning of the
+ output but its contents are only know after the rest of the output
+ has been written.
+
+ Thus, for arbitrary channels, a temporary file is allocated, and on
+ completion, the file is copied to the channel.
+
+*/
+
+DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
+{
+ SCHEME_OBJECT root;
+ PRIMITIVE_HEADER (3);
+
+ root = (ARG_REF (1));
+
+ if (STRING_P (ARG_REF (2)))
+ {
+ PRIMITIVE_RETURN (dump_to_file (root, (STRING_ARG (2))));
+ }
+ else
+ {
+ extern char *mktemp ();
+ extern int EXFUN (OS_channel_copy,
+ (off_t source_length,
+ Tchannel source_channel,
+ Tchannel destination_channel));
+
+ int copy_result;
+ SCHEME_OBJECT fasdump_result;
+ Tchannel channel, temp_channel;
+ char temp_name[] = "/tmp/fasdumpXXXXXX";
+
+ channel = (arg_channel (2));
+
+ (void) mktemp (temp_name);
+ fasdump_result = (dump_to_file (root, (temp_name)));
+ if (fasdump_result != SHARP_T)
+ {
+ PRIMITIVE_RETURN (fasdump_result);
+ }
+
+ temp_channel = (OS_open_input_file (temp_name));
+ copy_result = (OS_channel_copy ((OS_file_length (temp_channel)),
+ temp_channel,
+ channel));
+ OS_channel_close (temp_channel);
+ OS_file_remove (temp_name);
+ if (copy_result < 0)
+ {
+ signal_error_from_primitive (ERR_IO_ERROR);
+ }
+ PRIMITIVE_RETURN (SHARP_T);
}
- PRIMITIVE_RETURN(fasdump_exit((sizeof(SCHEME_OBJECT) *
- (length + tsize)) + hlength) ?
- SHARP_T : SHARP_F);
}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
long table_length;
Boolean result;
PRIMITIVE_HEADER (2);
+
Band_Dump_Permitted ();
CHECK_ARG (1, INTERPRETER_APPLICABLE_P);
CHECK_ARG (2, STRING_P);
Primitive_GC_If_Needed (5);
saved_free = Free;
- Combination = MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free);
+ Combination = (MAKE_POINTER_OBJECT (TC_COMBINATION_1, Free));
Free[COMB_1_FN] = (ARG_REF (1));
Free[COMB_1_ARG_1] = SHARP_F;
Free += 2;
*Free++ = Combination;
*Free++ = compiler_utilities;
- *Free = MAKE_POINTER_OBJECT (TC_LIST, (Free - 2));
+ *Free = (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)));
Free++; /* Some compilers are TOO clever about this and increment Free
before calculating Free-2! */
table_start = Free;
- table_end = cons_whole_primitive_table(Free, Heap_Top, &table_length);
+ table_end = (cons_whole_primitive_table (Free, Heap_Top, &table_length));
if (table_end >= Heap_Top)
{
result = false;
CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
dump_channel = (OS_open_dump_file (filename));
if (dump_channel == NO_CHANNEL)
+ {
error_bad_range_arg (2);
- result = Write_File((Free - 1),
- ((long) (Free - Heap_Bottom)), Heap_Bottom,
- ((long) (Free_Constant - Constant_Space)),
- Constant_Space,
- table_start, table_length,
- ((long) (table_end - table_start)),
- (compiler_utilities != SHARP_F), true);
+ }
+ result = (Write_File ((Free - 1),
+ ((long) (Free - Heap_Bottom)), Heap_Bottom,
+ ((long) (Free_Constant - Constant_Space)),
+ Constant_Space,
+ table_start, table_length,
+ ((long) (table_end - table_start)),
+ (compiler_utilities != SHARP_F), true));
OS_channel_close_noerror (dump_channel);
if (!result)
+ {
OS_file_remove (filename);
+ }
}
Band_Dump_Exit_Hook ();
Free = saved_free;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.46 1990/10/05 18:57:37 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.47 1990/11/21 07:03:30 jinx Rel $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
/* IO definitions */
+#include "ansidecl.h"
#include "psbmap.h"
#include "trap.h"
#include "limits.h"
#define portable_file output_file
long
-Load_Data(Count, To_Where)
- long Count;
- char *To_Where;
+DEFUN (Load_Data, (Count, To_Where),
+ long Count AND
+ SCHEME_OBJECT *To_Where)
{
- return (fread (To_Where, (sizeof (SCHEME_OBJECT)), Count, internal_file));
+ return (fread (((char *) To_Where),
+ (sizeof (SCHEME_OBJECT)),
+ Count,
+ internal_file));
}
#define INHIBIT_FASL_VERSION_CHECK
\f
/* Character macros and procedures */
-extern int strlen();
+extern int strlen ();
#ifndef isalpha
punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
Boolean
-ispunct(c)
- fast char c;
+DEFUN (ispunct, (c),
+ fast char c)
{
fast char *;
allow_compiled_p = false,
allow_nmv_p = false,
shuffle_bytes_p = false,
+ swap_bytes_p = false,
upgrade_compiled_p = false,
upgrade_lengths_p = false,
upgrade_primitives_p = false,
}
void
-print_a_char(c, name)
- fast char c;
- char *name;
+DEFUN (print_a_char, (c, name),
+ fast char c AND
+ char *name)
{
switch(c)
{
do_flonum_kernel (Code, Scn, Obj, FObj))
\f
void
-print_a_fixnum(val)
- long val;
+DEFUN (print_a_fixnum, (val),
+ long val)
{
fast long size_in_bits;
fast unsigned long temp;
}
\f
void
-print_a_string_internal(len, str)
- fast long len;
- fast char *str;
+DEFUN (print_a_string_internal, (len, str),
+ fast long len AND
+ fast char *str)
{
fprintf(portable_file, "%ld ", len);
if (shuffle_bytes_p)
}
\f
void
-print_a_string(from)
- SCHEME_OBJECT *from;
+DEFUN (print_a_string, (from),
+ SCHEME_OBJECT *from)
{
long len;
long maxlen;
- maxlen = pointer_to_char((OBJECT_DATUM (*from++)) - 1);
- len = STRING_LENGTH_TO_LONG(*from++);
+ maxlen = (pointer_to_char ((OBJECT_DATUM (*from++)) - 1));
+ len = (STRING_LENGTH_TO_LONG (*from++));
- fprintf(portable_file,
- "%02x %ld ",
- TC_CHARACTER_STRING,
- (compact_p ? len : maxlen));
+ fprintf (portable_file,
+ "%02x %ld ",
+ TC_CHARACTER_STRING,
+ (compact_p ? len : maxlen));
- print_a_string_internal(len, ((char *) from));
+ print_a_string_internal (len, ((char *) from));
return;
}
void
-print_a_primitive(arity, length, name)
- long arity, length;
- char *name;
+DEFUN (print_a_primitive, (arity, length, name),
+ long arity AND
+ long length AND
+ char *name)
{
- fprintf(portable_file, "%ld ", arity);
- print_a_string_internal(length, name);
+ fprintf (portable_file, "%ld ", arity);
+ print_a_string_internal (length, name);
return;
}
\f
static long
-bignum_length (bignum)
- SCHEME_OBJECT bignum;
+DEFUN (bignum_length, (bignum),
+ SCHEME_OBJECT bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
}
\f
void
-print_a_bignum (bignum)
- SCHEME_OBJECT bignum;
+DEFUN (print_a_bignum, (bignum_ptr),
+ SCHEME_OBJECT *bignum_ptr)
{
+ SCHEME_OBJECT bignum;
+
+ bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr));
+
if (BIGNUM_ZERO_P (bignum))
{
fprintf (portable_file, "%02x + 0\n",
/* The following procedure assumes that a C long is at least 4 bits. */
void
-print_a_bit_string(from)
- SCHEME_OBJECT *from;
+DEFUN (print_a_bit_string, (from),
+ SCHEME_OBJECT *from)
{
SCHEME_OBJECT the_bit_string;
fast long bits_remaining, leftover_bits;
}
\f
void
-print_a_flonum(val)
- double val;
+DEFUN (print_a_flonum, (val),
+ double val)
{
fast long size_in_bits;
fast double mant, temp;
}
\f
void
-out_of_range_pointer(ptr)
- SCHEME_OBJECT ptr;
+DEFUN (out_of_range_pointer, (ptr),
+ SCHEME_OBJECT ptr)
{
fprintf(stderr,
"%s: The input file is not portable: Out of range pointer.\n",
}
SCHEME_OBJECT *
-relocate(object)
- SCHEME_OBJECT object;
+DEFUN (relocate, (object),
+ SCHEME_OBJECT object)
{
long the_datum;
SCHEME_OBJECT *result;
found_ext_prims = false;
SCHEME_OBJECT
-upgrade_primitive(prim)
- SCHEME_OBJECT prim;
+DEFUN (upgrade_primitive, (prim),
+ SCHEME_OBJECT prim)
{
long the_datum, the_type, new_type, code;
SCHEME_OBJECT new;
}
\f
SCHEME_OBJECT *
-setup_primitive_upgrade(Heap)
- SCHEME_OBJECT *Heap;
+DEFUN (setup_primitive_upgrade, (Heap),
+ SCHEME_OBJECT *Heap)
{
fast long count, length;
SCHEME_OBJECT *old_prims_vector;
\f
/* Processing of a single area */
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
- Process_Area(Code, &Area, &Bound, &Obj, &FObj)
+#define Do_Area(Code, Area, Bound, Obj, FObj) \
+ Process_Area (Code, &Area, &Bound, &Obj, &FObj)
-Process_Area(Code, Area, Bound, Obj, FObj)
- int Code;
- fast long *Area, *Bound;
- fast long *Obj;
- fast SCHEME_OBJECT **FObj;
+void
+DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
+ int Code AND
+ fast long *Area AND
+ fast long *Bound AND
+ fast long *Obj AND
+ fast SCHEME_OBJECT **FObj)
{
fast SCHEME_OBJECT This, *Old_Address, Old_Contents;
/* Output procedures */
void
-print_external_objects(from, count)
- fast SCHEME_OBJECT *from;
- fast long count;
+DEFUN (print_external_objects, (from, count),
+ fast SCHEME_OBJECT *from AND
+ fast long count)
{
while (--count >= 0)
{
break;
case TC_BIT_STRING:
- print_a_bit_string(++from);
- from += (1 + OBJECT_DATUM (*from));
+ print_a_bit_string (++from);
+ from += (1 + (OBJECT_DATUM (*from)));
break;
case TC_BIG_FIXNUM:
print_a_bignum (++from);
- from += (1 + OBJECT_DATUM (*from));
+ from += (1 + (OBJECT_DATUM (*from)));
break;
case TC_CHARACTER_STRING:
- print_a_string(++from);
- from += (1 + OBJECT_DATUM (*from));
+ print_a_string (++from);
+ from += (1 + (OBJECT_DATUM (*from)));
break;
case TC_BIG_FLONUM:
- print_a_flonum(*((double *) (from + 1)));
+ print_a_flonum (*((double *) (from + 1)));
from += (1 + float_to_pointer);
break;
case TC_CHARACTER:
- fprintf(portable_file, "%02x %03x\n",
- TC_CHARACTER, (*from & MASK_MIT_ASCII));
+ fprintf (portable_file, "%02x %03x\n",
+ TC_CHARACTER, ((*from) & MASK_MIT_ASCII));
from += 1;
break;
}
\f
void
-print_objects(from, to)
- fast SCHEME_OBJECT *from, *to;
+DEFUN (print_objects, (from, to),
+ fast SCHEME_OBJECT *from AND
+ fast SCHEME_OBJECT *to)
{
fast long the_datum, the_type;
#define WHEN(condition, message) when(condition, message)
void
-when(what, message)
- Boolean what;
- char *message;
+DEFUN (when, (what, message),
+ Boolean what AND
+ char *message)
{
if (what)
{
/* The main program */
void
-do_it()
+DEFUN_VOID (do_it)
{
- SCHEME_OBJECT *Heap;
- long Initial_Free;
+ while (true)
+ {
+ /* Load the Data */
- /* Load the Data */
+ SCHEME_OBJECT *Heap, *Storage;
+ long Initial_Free;
- if (Read_Header() != FASL_FILE_FINE)
- {
- fprintf(stderr,
- "%s: Input file does not appear to be in an appropriate format.\n",
- program_name);
- quit(1);
- }
+ switch (Read_Header ())
+ {
+ /* There should really be a difference between no header
+ and a short header.
+ */
- if ((Version > FASL_READ_VERSION) ||
- (Version < FASL_OLDEST_VERSION) ||
- (Sub_Version > FASL_READ_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUBVERSION) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) &&
- (!shuffle_bytes_p)))
- {
- fprintf(stderr, "%s:\n", program_name);
- fprintf(stderr,
- "FASL File Version %ld Subversion %ld Machine Type %ld\n",
- Version, Sub_Version , Machine_Type);
- fprintf(stderr,
- "Expected: Version %d Subversion %d Machine Type %d\n",
- FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
- quit(1);
- }
+ case FASL_FILE_TOO_SHORT:
+ return;
+
+ case FASL_FILE_FINE:
+ break;
+
+ default:
+ fprintf (stderr,
+ "%s: Input is not a Scheme binary file.\n",
+ program_name);
+ quit (1);
+ /* NOTREACHED */
+ }
+
+ if ((Version > FASL_READ_VERSION) ||
+ (Version < FASL_OLDEST_VERSION) ||
+ (Sub_Version > FASL_READ_SUBVERSION) ||
+ (Sub_Version < FASL_OLDEST_SUBVERSION) ||
+ ((Machine_Type != FASL_INTERNAL_FORMAT) &&
+ (!swap_bytes_p)))
+ {
+ fprintf (stderr, "%s:\n", program_name);
+ fprintf (stderr,
+ "FASL File Version %ld Subversion %ld Machine Type %ld\n",
+ Version, Sub_Version , Machine_Type);
+ fprintf (stderr,
+ "Expected: Version %d Subversion %d Machine Type %d\n",
+ FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
+ quit (1);
+ }
\f
- if ((((compiler_processor_type != 0) &&
- (dumped_processor_type != 0) &&
- (compiler_processor_type != dumped_processor_type)) ||
- ((compiler_interface_version != 0) &&
- (dumped_interface_version != 0) &&
- (compiler_interface_version != dumped_interface_version))) &&
- (!upgrade_compiled_p))
+ if ((((compiler_processor_type != 0) &&
+ (dumped_processor_type != 0) &&
+ (compiler_processor_type != dumped_processor_type)) ||
+ ((compiler_interface_version != 0) &&
+ (dumped_interface_version != 0) &&
+ (compiler_interface_version != dumped_interface_version))) &&
+ (!upgrade_compiled_p))
{
- fprintf(stderr, "\nread_file:\n");
- fprintf(stderr,
- "FASL File: compiled code interface %4d; processor %4d.\n",
- dumped_interface_version, dumped_processor_type);
- fprintf(stderr,
- "Expected: compiled code interface %4d; processor %4d.\n",
- compiler_interface_version, compiler_processor_type);
- quit(1);
+ fprintf (stderr, "\nread_file:\n");
+ fprintf (stderr,
+ "FASL File: compiled code interface %4d; processor %4d.\n",
+ dumped_interface_version, dumped_processor_type);
+ fprintf (stderr,
+ "Expected: compiled code interface %4d; processor %4d.\n",
+ compiler_interface_version, compiler_processor_type);
+ quit (1);
+ }
+ if (compiler_processor_type != 0)
+ {
+ dumped_processor_type = compiler_processor_type;
+ }
+ if (compiler_interface_version != 0)
+ {
+ dumped_interface_version = compiler_interface_version;
}
- if (compiler_processor_type != 0)
- {
- dumped_processor_type = compiler_processor_type;
- }
- if (compiler_interface_version != 0)
- {
- dumped_interface_version = compiler_interface_version;
- }
- /* Constant Space and bands not currently supported */
+ /* Constant Space and bands not currently supported */
- if (band_p)
- {
- fprintf(stderr, "%s: Input file is a band.\n", program_name);
- quit(1);
- }
+ if (band_p)
+ {
+ fprintf (stderr, "%s: Input file is a band.\n", program_name);
+ quit (1);
+ }
- if (Const_Count != 0)
- {
- fprintf(stderr,
- "%s: Input file has a constant space area.\n",
- program_name);
- quit(1);
- }
+ if (Const_Count != 0)
+ {
+ fprintf (stderr,
+ "%s: Input file has a constant space area.\n",
+ program_name);
+ quit (1);
+ }
\f
- allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
- allow_nmv_p = (allow_nmv_p || allow_compiled_p || vax_invert_p);
- if (null_nmv_p && allow_nmv_p)
- {
- fprintf(stderr,
- "%s: NMVs are both allowed and to be nulled out!\n",
- program_name);
- quit(1);
- }
-
- if (Machine_Type == FASL_INTERNAL_FORMAT)
- {
- shuffle_bytes_p = false;
- }
+ shuffle_bytes_p = swap_bytes_p;
+ if (Machine_Type == FASL_INTERNAL_FORMAT)
+ {
+ shuffle_bytes_p = false;
+ }
- upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
- upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
- upgrade_lengths_p = upgrade_primitives_p;
+ upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
+ upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
+ upgrade_lengths_p = upgrade_primitives_p;
- DEBUGGING(fprintf(stderr,
- "Dumped Heap Base = 0x%08x\n",
- Heap_Base));
+ DEBUGGING (fprintf (stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Base = 0x%08x\n",
- Const_Base));
+ DEBUGGING (fprintf (stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Top = 0x%08x\n",
- Dumped_Constant_Top));
+ DEBUGGING (fprintf (stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
- DEBUGGING(fprintf(stderr,
- "Heap Count = %6d\n",
- Heap_Count));
+ DEBUGGING (fprintf (stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
- DEBUGGING(fprintf(stderr,
- "Constant Count = %6d\n",
- Const_Count));
+ DEBUGGING (fprintf (stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
\f
- {
- long Size;
+ {
+ long Size;
- /* This is way larger than needed, but... what the hell? */
+ /* This is way larger than needed, but... what the hell? */
- Size = ((3 * (Heap_Count + Const_Count)) +
- (NROOTS + 1) +
- (upgrade_primitives_p ?
- (3 * PRIMITIVE_UPGRADE_SPACE) :
- Primitive_Table_Size) +
- (allow_compiled_p ?
- (2 * (Heap_Count + Const_Count)) :
- 0));
+ Size = ((3 * (Heap_Count + Const_Count)) +
+ (NROOTS + 1) +
+ (upgrade_primitives_p ?
+ (3 * PRIMITIVE_UPGRADE_SPACE) :
+ Primitive_Table_Size) +
+ (allow_compiled_p ?
+ (2 * (Heap_Count + Const_Count)) :
+ 0));
- ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE);
+ ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE);
- if (Heap == ((SCHEME_OBJECT *) 0))
- {
- fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
- program_name, Size);
- quit(1);
+ if (Heap == ((SCHEME_OBJECT *) 0))
+ {
+ fprintf (stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
+ program_name, Size);
+ quit (1);
+ }
}
- }
- Heap += HEAP_BUFFER_SPACE;
- INITIAL_ALIGN_FLOAT(Heap);
- Load_Data(Heap_Count, &Heap[0]);
- Load_Data(Const_Count, &Heap[Heap_Count]);
- Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
- Constant_Relocation = ((&Heap[Heap_Count]) - (OBJECT_ADDRESS (Const_Base)));
+ Storage = Heap;
+ Heap += HEAP_BUFFER_SPACE;
+ INITIAL_ALIGN_FLOAT (Heap);
+ if ((Load_Data (Heap_Count, Heap)) != Heap_Count)
+ {
+ fprintf (stderr, "%s: Could not load the heap's contents.\n",
+ program_name);
+ quit (1);
+ }
+ if ((Load_Data (Const_Count, (Heap + Heap_Count))) != Const_Count)
+ {
+ fprintf (stderr, "%s: Could not load constant space.\n",
+ program_name);
+ quit (1);
+ }
+ Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
+ Constant_Relocation = ((&Heap[Heap_Count]) -
+ (OBJECT_ADDRESS (Const_Base)));
\f
- /* Setup compiled code and primitive tables. */
+ /* Setup compiled code and primitive tables. */
- compiled_entry_table = &Heap[Heap_Count + Const_Count];
- compiled_entry_pointer = compiled_entry_table;
- compiled_entry_table_end = compiled_entry_table;
+ compiled_entry_table = &Heap[Heap_Count + Const_Count];
+ compiled_entry_pointer = compiled_entry_table;
+ compiled_entry_table_end = compiled_entry_table;
- if (allow_compiled_p)
- {
- compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
- }
+ if (allow_compiled_p)
+ {
+ compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
+ }
- primitive_table = compiled_entry_table_end;
- if (upgrade_primitives_p)
- {
- primitive_table_end = setup_primitive_upgrade(primitive_table);
- }
- else
- {
- fast SCHEME_OBJECT *table;
- fast long count, char_count;
-
- Load_Data(Primitive_Table_Size, primitive_table);
- for (char_count = 0,
- count = Primitive_Table_Length,
- table = primitive_table;
- --count >= 0;)
+ primitive_table = compiled_entry_table_end;
+ if (upgrade_primitives_p)
{
- char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH_INDEX]);
- table += (2 + OBJECT_DATUM (table[1 + STRING_HEADER]));
+ primitive_table_end = (setup_primitive_upgrade (primitive_table));
}
- NPChars = char_count;
- primitive_table_end = &primitive_table[Primitive_Table_Size];
- }
- Mem_Base = primitive_table_end;
+ else
+ {
+ fast SCHEME_OBJECT *table;
+ fast long count, char_count;
+
+ if ((Load_Data (Primitive_Table_Size, primitive_table)) !=
+ Primitive_Table_Size)
+ {
+ fprintf (stderr, "%s: Could not load the primitive table.\n",
+ program_name);
+ quit (1);
+ }
+ for (char_count = 0,
+ count = Primitive_Table_Length,
+ table = primitive_table;
+ --count >= 0;)
+ {
+ char_count += (STRING_LENGTH_TO_LONG (table[1 + STRING_LENGTH_INDEX]));
+ table += (2 + (OBJECT_DATUM (table[1 + STRING_HEADER])));
+ }
+ NPChars = char_count;
+ primitive_table_end = (&primitive_table[Primitive_Table_Size]);
+ }
+ Mem_Base = primitive_table_end;
\f
- /* Reformat the data */
+ /* Reformat the data */
- NFlonums = NIntegers = NStrings = 0;
- NBits = NBBits = NChars = 0;
+ NFlonums = NIntegers = NStrings = 0;
+ NBits = NBBits = NChars = 0;
- Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
- Initial_Free = NROOTS;
- Scan = 0;
+ Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
+ Initial_Free = NROOTS;
+ Scan = 0;
- Free = Initial_Free;
- Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
- Objects = 0;
+ Free = Initial_Free;
+ Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
+ Objects = 0;
- Free_Constant = (2 * Heap_Count) + Initial_Free;
- Scan_Constant = Free_Constant;
- Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
- Constant_Objects = 0;
+ Free_Constant = (2 * Heap_Count) + Initial_Free;
+ Scan_Constant = Free_Constant;
+ Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
+ Constant_Objects = 0;
#if true
- Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+ Do_Area (HEAP_CODE, Scan, Free, Objects, Free_Objects);
#else
- /*
- When Constant Space finally becomes supported,
- something like this must be done.
- */
+ /*
+ When Constant Space finally becomes supported,
+ something like this must be done.
+ */
- while (true)
- {
- Do_Area(HEAP_CODE, Scan, Free,
- Objects, Free_Objects);
- Do_Area(CONSTANT_CODE, Scan_Constant, Free_Constant,
- Constant_Objects, Free_Cobjects);
- Do_Area(PURE_CODE, Scan_Pure, Free_Pure,
- Pure_Objects, Free_Pobjects);
- if (Scan == Free)
+ while (true)
{
- break;
+ Do_Area (HEAP_CODE, Scan, Free,
+ Objects, Free_Objects);
+ Do_Area (CONSTANT_CODE, Scan_Constant, Free_Constant,
+ Constant_Objects, Free_Cobjects);
+ Do_Area (PURE_CODE, Scan_Pure, Free_Pure,
+ Pure_Objects, Free_Pobjects);
+ if (Scan == Free)
+ {
+ break;
+ }
}
- }
#endif
\f
- /* Consistency checks */
+ /* Consistency checks */
- WHEN(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+ WHEN (((Free - Initial_Free) > Heap_Count), "Free overran Heap");
- WHEN(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
- Heap_Count),
- "Free_Objects overran Heap Object Space");
+ WHEN (((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
+ Heap_Count),
+ "Free_Objects overran Heap Object Space");
- WHEN(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
- "Free_Constant overran Constant Space");
+ WHEN (((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+ "Free_Constant overran Constant Space");
- WHEN(((Free_Cobjects - &Mem_Base[Initial_Free +
- (2 * Heap_Count) + Const_Count]) >
- Const_Count),
- "Free_Cobjects overran Constant Object Space");
+ WHEN (((Free_Cobjects - &Mem_Base[Initial_Free +
+ (2 * Heap_Count) + Const_Count]) >
+ Const_Count),
+ "Free_Cobjects overran Constant Object Space");
\f
- /* Output the data */
+ /* Output the data */
- if (found_ext_prims)
- {
- fprintf(stderr, "%s:\n", program_name);
- fprintf(stderr, "NOTE: The arity of some primitives is not known.\n");
- fprintf(stderr, " The portable file has %ld as their arity.\n",
- UNKNOWN_PRIMITIVE_ARITY);
- fprintf(stderr, " You may want to fix this by hand.\n");
- }
+ if (found_ext_prims)
+ {
+ fprintf (stderr, "%s:\n", program_name);
+ fprintf (stderr, "NOTE: The arity of some primitives is not known.\n");
+ fprintf (stderr, " The portable file has %ld as their arity.\n",
+ UNKNOWN_PRIMITIVE_ARITY);
+ fprintf (stderr, " You may want to fix this by hand.\n");
+ }
- /* Header */
+ /* Header */
- WRITE_HEADER("Portable Version", "%ld", PORTABLE_VERSION);
- WRITE_HEADER("Machine", "%ld", FASL_INTERNAL_FORMAT);
- WRITE_HEADER("Version", "%ld", FASL_FORMAT_VERSION);
- WRITE_HEADER("Sub Version", "%ld", FASL_SUBVERSION);
- WRITE_HEADER("Flags", "%ld", (MAKE_FLAGS()));
+ WRITE_HEADER ("Portable Version", "%ld", PORTABLE_VERSION);
+ WRITE_HEADER ("Machine", "%ld", FASL_INTERNAL_FORMAT);
+ WRITE_HEADER ("Version", "%ld", FASL_FORMAT_VERSION);
+ WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION);
+ WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ()));
- WRITE_HEADER("Heap Count", "%ld", (Free - NROOTS));
- WRITE_HEADER("Heap Base", "%ld", NROOTS);
- WRITE_HEADER("Heap Objects", "%ld", Objects);
+ WRITE_HEADER ("Heap Count", "%ld", (Free - NROOTS));
+ WRITE_HEADER ("Heap Base", "%ld", NROOTS);
+ WRITE_HEADER ("Heap Objects", "%ld", Objects);
- /* Currently Constant and Pure not supported, but the header is ready */
+ /* Currently Constant and Pure not supported, but the header is ready */
- WRITE_HEADER("Pure Count", "%ld", 0);
- WRITE_HEADER("Pure Base", "%ld", Free_Constant);
- WRITE_HEADER("Pure Objects", "%ld", 0);
+ WRITE_HEADER ("Pure Count", "%ld", 0);
+ WRITE_HEADER ("Pure Base", "%ld", Free_Constant);
+ WRITE_HEADER ("Pure Objects", "%ld", 0);
- WRITE_HEADER("Constant Count", "%ld", 0);
- WRITE_HEADER("Constant Base", "%ld", Free_Constant);
- WRITE_HEADER("Constant Objects", "%ld", 0);
+ WRITE_HEADER ("Constant Count", "%ld", 0);
+ WRITE_HEADER ("Constant Base", "%ld", Free_Constant);
+ WRITE_HEADER ("Constant Objects", "%ld", 0);
- WRITE_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
+ WRITE_HEADER ("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
- WRITE_HEADER("Number of flonums", "%ld", NFlonums);
- WRITE_HEADER("Number of integers", "%ld", NIntegers);
- WRITE_HEADER("Number of bits in integers", "%ld", NBits);
- WRITE_HEADER("Number of bit strings", "%ld", NBitstrs);
- WRITE_HEADER("Number of bits in bit strings", "%ld", NBBits);
- WRITE_HEADER("Number of character strings", "%ld", NStrings);
- WRITE_HEADER("Number of characters in strings", "%ld", NChars);
+ WRITE_HEADER ("Number of flonums", "%ld", NFlonums);
+ WRITE_HEADER ("Number of integers", "%ld", NIntegers);
+ WRITE_HEADER ("Number of bits in integers", "%ld", NBits);
+ WRITE_HEADER ("Number of bit strings", "%ld", NBitstrs);
+ WRITE_HEADER ("Number of bits in bit strings", "%ld", NBBits);
+ WRITE_HEADER ("Number of character strings", "%ld", NStrings);
+ WRITE_HEADER ("Number of characters in strings", "%ld", NChars);
- WRITE_HEADER("Number of primitives", "%ld", Primitive_Table_Length);
- WRITE_HEADER("Number of characters in primitives", "%ld", NPChars);
+ WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length);
+ WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars);
- if (!compiled_p)
- {
- dumped_processor_type = 0;
- dumped_interface_version = 0;
- }
+ if (!compiled_p)
+ {
+ dumped_processor_type = 0;
+ dumped_interface_version = 0;
+ }
- WRITE_HEADER("CPU type", "%ld", dumped_processor_type);
- WRITE_HEADER("Compiled code interface version", "%ld",
- dumped_interface_version);
+ WRITE_HEADER ("CPU type", "%ld", dumped_processor_type);
+ WRITE_HEADER ("Compiled code interface version", "%ld",
+ dumped_interface_version);
#if false
- WRITE_HEADER("Compiler utilities vector", "%ld",
- OBJECT_DATUM (dumped_utilities));
+ WRITE_HEADER ("Compiler utilities vector", "%ld",
+ (OBJECT_DATUM (dumped_utilities)));
#endif
\f
- /* External Objects */
+ /* External Objects */
- print_external_objects(&Mem_Base[Initial_Free + Heap_Count],
- Objects);
+ print_external_objects (&Mem_Base[Initial_Free + Heap_Count],
+ Objects);
#if false
- print_external_objects(&Mem_Base[Pure_Objects_Start],
- Pure_Objects);
- print_external_objects(&Mem_Base[Constant_Objects_Start],
- Constant_Objects);
+ print_external_objects (&Mem_Base[Pure_Objects_Start],
+ Pure_Objects);
+ print_external_objects (&Mem_Base[Constant_Objects_Start],
+ Constant_Objects);
#endif
- /* Pointer Objects */
+ /* Pointer Objects */
- print_objects(&Mem_Base[NROOTS], &Mem_Base[Free]);
+ print_objects (&Mem_Base[NROOTS], &Mem_Base[Free]);
#if false
- print_objects(&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
- print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
+ print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
+ print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
#endif
\f
- /* Primitives */
-
- if (upgrade_primitives_p)
- {
- SCHEME_OBJECT obj;
- fast SCHEME_OBJECT *table;
- fast long count, the_datum;
+ /* Primitives */
- for (count = Primitive_Table_Length,
- table = external_renumber_table;
- --count >= 0;)
+ if (upgrade_primitives_p)
{
- obj = *table++;
- the_datum = OBJECT_DATUM (obj);
- if (OBJECT_TYPE (obj) == TC_PRIMITIVE_EXTERNAL)
- {
- SCHEME_OBJECT *strobj;
+ SCHEME_OBJECT obj;
+ fast SCHEME_OBJECT *table;
+ fast long count, the_datum;
- strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
- print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
- (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH_INDEX])),
- ((char *) &strobj[STRING_CHARS]));
- }
- else
+ for (count = Primitive_Table_Length,
+ table = external_renumber_table;
+ --count >= 0;)
{
- char *str;
+ obj = *table++;
+ the_datum = (OBJECT_DATUM (obj));
+ if ((OBJECT_TYPE (obj)) == TC_PRIMITIVE_EXTERNAL)
+ {
+ SCHEME_OBJECT *strobj;
+
+ strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
+ print_a_primitive (((long) UNKNOWN_PRIMITIVE_ARITY),
+ (STRING_LENGTH_TO_LONG
+ (strobj[STRING_LENGTH_INDEX])),
+ ((char *) &strobj[STRING_CHARS]));
+ }
+ else
+ {
+ char *str;
- str = builtin_prim_name_table[the_datum];
- print_a_primitive(((long) builtin_prim_arity_table[the_datum]),
- ((long) strlen(str)),
- str);
+ str = builtin_prim_name_table[the_datum];
+ print_a_primitive (((long) builtin_prim_arity_table[the_datum]),
+ ((long) strlen(str)),
+ str);
+ }
}
}
- }
- else
- {
- fast SCHEME_OBJECT *table;
- fast long count;
- long arity;
-
- for (count = Primitive_Table_Length, table = primitive_table;
- --count >= 0;)
+ else
{
- arity = (FIXNUM_TO_LONG (*table));
- table += 1;
- print_a_primitive(arity,
- (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
- ((char *) &table[STRING_CHARS]));
- table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
+ fast SCHEME_OBJECT *table;
+ fast long count;
+ long arity;
+
+ for (count = Primitive_Table_Length, table = primitive_table;
+ --count >= 0;)
+ {
+ arity = (FIXNUM_TO_LONG (*table));
+ table += 1;
+ print_a_primitive (arity,
+ (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
+ ((char *) &table[STRING_CHARS]));
+ table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
+ }
}
+ fflush (portable_file);
+ free ((char *) Storage);
}
- return;
}
\f
/* Top Level */
static struct keyword_struct
options[] = {
- KEYWORD("swap_bytes", &shuffle_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
- &ci_version_sup_p),
- KEYWORD("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
- &ci_processor_sup_p),
- KEYWORD("vax_invert", &vax_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
- OUTPUT_KEYWORD(),
- INPUT_KEYWORD(),
- END_KEYWORD()
+ KEYWORD ("swap_bytes", &swap_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
+ &ci_version_sup_p),
+ KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
+ &ci_processor_sup_p),
+ KEYWORD ("vax_invert", &vax_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
+ OUTPUT_KEYWORD (),
+ INPUT_KEYWORD (),
+ END_KEYWORD ()
};
-main(argc, argv)
- int argc;
- char *argv[];
+void
+DEFUN (main, (argc, argv),
+ int argc AND
+ char **argv)
{
- parse_keywords(argc, argv, options, false);
+ parse_keywords (argc, argv, options, false);
+
if (help_sup_p && help_p)
{
print_usage_and_exit(options, 0);
/*NOTREACHED*/
}
- setup_io();
- do_it();
- quit(0);
+
+ allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p || vax_invert_p);
+ if (null_nmv_p && allow_nmv_p)
+ {
+ fprintf (stderr,
+ "%s: NMVs are both allowed and to be nulled out!\n",
+ program_name);
+ quit (1);
+ }
+
+ setup_io ();
+ do_it ();
+ quit (0);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.31 1990/10/05 18:58:04 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.32 1990/11/21 07:04:02 jinx Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
extern long compiler_interface_version, compiler_processor_type;
void
-prepare_dump_header (Buffer, Dumped_Object,
- Heap_Count, Heap_Relocation,
- Constant_Count, Constant_Relocation,
- table_length, table_size,
- cc_code_p, band_p)
- SCHEME_OBJECT
- *Buffer, *Dumped_Object,
- *Heap_Relocation, *Constant_Relocation;
- long
- Heap_Count, Constant_Count,
- table_length, table_size;
- Boolean cc_code_p, band_p;
+DEFUN (prepare_dump_header,
+ (Buffer, Dumped_Object,
+ Heap_Count, Heap_Relocation,
+ Constant_Count, Constant_Relocation,
+ table_length, table_size,
+ cc_code_p, band_p),
+ SCHEME_OBJECT *Buffer AND
+ SCHEME_OBJECT *Dumped_Object AND
+ long Heap_Count AND
+ SCHEME_OBJECT *Heap_Relocation AND
+ long Constant_Count AND
+ SCHEME_OBJECT *Constant_Relocation AND
+ long table_length AND
+ long table_size AND
+ Boolean cc_code_p AND
+ Boolean band_p)
{
long i;
Buffer[FASL_Offset_Ut_Base] = SHARP_F;
}
+ Buffer[FASL_Offset_Check_Sum] = SHARP_F;
for (i = FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
{
Buffer[i] = SHARP_F;
}
\f
Boolean
-Write_File (Dumped_Object, Heap_Count, Heap_Relocation,
- Constant_Count, Constant_Relocation,
- table_start, table_length, table_size,
- cc_code_p, band_p)
- SCHEME_OBJECT
- *Dumped_Object,
- *Heap_Relocation, *Constant_Relocation,
- *table_start;
- long
- Heap_Count, Constant_Count,
- table_length, table_size;
- Boolean cc_code_p, band_p;
+DEFUN (Write_File,
+ (Dumped_Object, Heap_Count, Heap_Relocation,
+ Constant_Count, Constant_Relocation,
+ table_start, table_length, table_size,
+ cc_code_p, band_p),
+ SCHEME_OBJECT *Dumped_Object AND
+ long Heap_Count AND
+ SCHEME_OBJECT *Heap_Relocation AND
+ long Constant_Count AND
+ SCHEME_OBJECT *Constant_Relocation AND
+ SCHEME_OBJECT *table_start AND
+ long table_length AND
+ long table_size AND
+ Boolean cc_code_p AND
+ Boolean band_p)
{
SCHEME_OBJECT Buffer[FASL_HEADER_LENGTH];
unsigned long checksum, checksum_area ();
checksum));
Buffer[FASL_Offset_Check_Sum] = checksum;
- if (Write_Data (FASL_HEADER_LENGTH, ((char *) Buffer)) !=
+ if ((Write_Data (FASL_HEADER_LENGTH, Buffer)) !=
FASL_HEADER_LENGTH)
{
return (false);
}
if (Heap_Count != 0)
{
- if (Write_Data(Heap_Count, ((char *) Heap_Relocation)) !=
+ if ((Write_Data (Heap_Count, Heap_Relocation)) !=
Heap_Count)
{
return (false);
}
if (Constant_Count != 0)
{
- if (Write_Data(Constant_Count, ((char *) Constant_Relocation)) !=
+ if ((Write_Data (Constant_Count, Constant_Relocation)) !=
Constant_Count)
{
return (false);
}
if (table_size != 0)
{
- if (Write_Data(table_size, ((char *) table_start)) != table_size)
+ if ((Write_Data (table_size, table_start)) !=
+ table_size)
{
return (false);
}
extern unsigned long checksum_area ();
unsigned long
-checksum_area (start, count, initial_value)
- register unsigned long *start;
- register long count;
- unsigned long initial_value;
+DEFUN (checksum_area, (start, count, initial_value),
+ register unsigned long *start AND
+ register long count AND
+ unsigned long initial_value)
{
register unsigned long value;
}
return (value);
}
-
+
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.34 1990/10/03 15:12:51 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.35 1990/11/21 07:04:07 jinx Rel $
*
* Error and termination code declarations.
*
#define ERR_FASDUMP_ENVIRONMENT 0x38
#define ERR_FASLOAD_BAND 0x39
#define ERR_FASLOAD_COMPILED_MISMATCH 0x3A
+#define ERR_UNKNOWN_PRIMITIVE_CONTINUATION 0x3B
/*
If you add any error codes here, add them to
the table below and to utabmd.scm as well.
*/
-#define MAX_ERROR 0x3A
+#define MAX_ERROR 0x3B
\f
#define ERROR_NAME_TABLE \
{ \
/* 0x37 */ "IO-ERROR", \
/* 0x38 */ "FASDUMP-ENVIRONMENT", \
/* 0x39 */ "FASLOAD-BAND", \
-/* 0x3A */ "FASLOAD-COMPILED-MISMATCH" \
+/* 0x3A */ "FASLOAD-COMPILED-MISMATCH", \
+/* 0x3B */ "UNKNOWN-PRIMITIVE-CONTINUATION" \
}
\f
/* Termination codes: the interpreter halts on these */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.48 1990/06/20 17:40:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.49 1990/11/21 07:04:12 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#define Write_Data(size, buffer) \
((OS_channel_write_dump_file \
- (dump_channel, (buffer), ((size) * (sizeof (SCHEME_OBJECT))))) \
+ (dump_channel, \
+ ((char *) (buffer)), \
+ ((size) * (sizeof (SCHEME_OBJECT))))) \
/ (sizeof (SCHEME_OBJECT)))
#include "dump.c"
extern SCHEME_OBJECT
- dump_renumber_primitive(),
- *initialize_primitive_table(),
- *cons_primitive_table(),
- *cons_whole_primitive_table();
+ dump_renumber_primitive (),
+ *initialize_primitive_table (),
+ *cons_primitive_table (),
+ *cons_whole_primitive_table ();
\f
/* Some statics used freely in this file */
static SCHEME_OBJECT *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
static Boolean compiled_code_present_p;
-static CONST char * dump_file_name = 0;
+static CONST char * dump_file_name = ((char *) 0);
/* FASDUMP:
Argument 1: Object to dump.
Argument 2: File name.
Argument 3: Flag.
- where the flag is #!true for a dump into constant
- space at reload time, () for a dump into heap.
-
- Currently flag is ignored.
+ Currently, flag is ignored.
*/
\f
/*
*/
#define Setup_Pointer_for_Dump(Extra_Code) \
-Dump_Pointer(Fasdump_Setup_Pointer(Extra_Code, Normal_BH(false, continue)))
+Dump_Pointer (Fasdump_Setup_Pointer (Extra_Code, Normal_BH (false, continue)))
#define Dump_Pointer(Code) \
-Old = OBJECT_ADDRESS (Temp); \
-Code
+ Old = (OBJECT_ADDRESS (Temp)); \
+ Code
#define Dump_Compiled_Entry(label) \
{ \
- Dump_Pointer(Fasdump_Setup_Pointer(Transport_Compiled(), \
- Compiled_BH(false, goto label))); \
+ Dump_Pointer (Fasdump_Setup_Pointer (Transport_Compiled (), \
+ Compiled_BH (false, goto label))); \
}
/* Dump_Mode is currently a fossil. It should be resurrected. */
#define FASDUMP_FIX_BUFFER 10
long
-DumpLoop(Scan, Dump_Mode)
- fast SCHEME_OBJECT *Scan;
- int Dump_Mode;
+DEFUN (DumpLoop, (Scan, Dump_Mode),
+ fast SCHEME_OBJECT *Scan AND
+ int Dump_Mode)
{
fast SCHEME_OBJECT *To, *Old, Temp, New_Address, *Fixes;
long result;
{
Temp = *Scan;
\f
- Switch_by_GC_Type(Temp)
+ Switch_by_GC_Type (Temp)
{
case TC_PRIMITIVE:
case TC_PCOMB0:
case TC_BROKEN_HEART:
if (OBJECT_DATUM (Temp) != 0)
{
- sprintf(gc_death_message_buffer,
- "dumploop: broken heart (0x%lx) in scan",
- Temp);
- gc_death(TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
+ sprintf (gc_death_message_buffer,
+ "dumploop: broken heart (0x%lx) in scan",
+ ((long) Temp));
+ gc_death (TERM_BROKEN_HEART, gc_death_message_buffer, Scan, To);
/*NOTREACHED*/
}
break;
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
- Scan += OBJECT_DATUM (Temp);
+ Scan += (OBJECT_DATUM (Temp));
break;
/* Compiled code relocation. */
case_compiled_entry_point:
compiled_code_present_p = true;
- Dump_Compiled_Entry(after_entry);
+ Dump_Compiled_Entry (after_entry);
after_entry:
*Scan = Temp;
break;
case TC_LINKAGE_SECTION:
{
compiled_code_present_p = true;
- if (READ_LINKAGE_KIND(Temp) != OPERATOR_LINKAGE_KIND)
+ if ((READ_LINKAGE_KIND (Temp)) != OPERATOR_LINKAGE_KIND)
{
/* Assumes that all others are objects of type TC_QUAD without
their type codes.
fast long count;
Scan++;
- for (count = READ_CACHE_LINKAGE_COUNT(Temp);
+ for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
--count >= 0;
Scan += 1)
{
Temp = *Scan;
- Setup_Pointer_for_Dump(Transport_Quadruple());
+ Setup_Pointer_for_Dump (Transport_Quadruple ());
}
Scan -= 1;
break;
}
\f
case_Cell:
- Setup_Pointer_for_Dump(Transport_Cell());
+ Setup_Pointer_for_Dump (Transport_Cell ());
break;
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
+ if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
{
/* It is a non pointer. */
break;
case TC_WEAK_CONS:
case_Fasdump_Pair:
- Setup_Pointer_for_Dump(Transport_Pair());
+ Setup_Pointer_for_Dump (Transport_Pair ());
break;
case TC_INTERNED_SYMBOL:
break;
case_Triple:
- Setup_Pointer_for_Dump(Transport_Triple());
+ Setup_Pointer_for_Dump (Transport_Triple ());
break;
case TC_VARIABLE:
- Setup_Pointer_for_Dump(Fasdump_Variable());
+ Setup_Pointer_for_Dump (Fasdump_Variable ());
break;
\f
case_Quadruple:
- Setup_Pointer_for_Dump(Transport_Quadruple());
+ Setup_Pointer_for_Dump (Transport_Quadruple ());
break;
case TC_BIG_FLONUM:
Setup_Pointer_for_Dump({
- Transport_Flonum();
+ Transport_Flonum ();
break;
});
case TC_COMPILED_CODE_BLOCK:
case_Purify_Vector:
- Setup_Pointer_for_Dump(Transport_Vector());
+ Setup_Pointer_for_Dump (Transport_Vector ());
break;
case TC_ENVIRONMENT:
goto exit_dumploop;
case TC_FUTURE:
- Setup_Pointer_for_Dump(Transport_Future());
+ Setup_Pointer_for_Dump (Transport_Future ());
break;
default:
- GC_BAD_TYPE("dumploop");
+ GC_BAD_TYPE ("dumploop");
/* Fall Through */
case TC_STACK_ENVIRONMENT:
{ \
long value; \
\
- value = DumpLoop(obj, code); \
+ value = (DumpLoop (obj, code)); \
if (value != PRIM_DONE) \
{ \
- PRIMITIVE_RETURN(Fasdump_Exit(value, false)); \
+ PRIMITIVE_RETURN (Fasdump_Exit (value, false)); \
} \
}
#define FASDUMP_INTERRUPT() \
{ \
- PRIMITIVE_RETURN(Fasdump_Exit(PRIM_INTERRUPT, false)); \
+ PRIMITIVE_RETURN (Fasdump_Exit (PRIM_INTERRUPT, false)); \
}
SCHEME_OBJECT
-Fasdump_Exit(code, close_p)
- long code;
- Boolean close_p;
+DEFUN (Fasdump_Exit, (code, close_p),
+ long code AND
+ Boolean close_p)
{
Boolean result;
fast SCHEME_OBJECT *Fixes;
Fixes = Fixup;
if (close_p)
+ {
OS_channel_close_noerror (dump_channel);
+ }
result = true;
while (Fixes != NewMemTop)
{
fast SCHEME_OBJECT *Fix_Address;
- Fix_Address = OBJECT_ADDRESS (*Fixes++); /* Where it goes. */
+ Fix_Address = (OBJECT_ADDRESS (*Fixes++)); /* Where it goes. */
*Fix_Address = *Fixes++; /* Put it there. */
}
Fixup = Fixes;
if ((close_p) && ((!result) || (code != PRIM_DONE)))
+ {
OS_file_remove (dump_file_name);
- dump_file_name = 0;
+ }
+ dump_file_name = ((char *) 0);
Fasdump_Exit_Hook ();
if (!result)
{
}
}
\f
-/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
+/* (PRIMITIVE-FASDUMP object-to-dump filename-or-channel flag)
+
Dump an object into a file so that it can be loaded using
- BINARY-FASLOAD. A spare heap is required for this operation.
- The first argument is the object to be dumped. The second is
- the filename and the third a flag. The flag, if #T, means
- that the object is to be dumped for reloading into constant
- space. This is currently disabled. If the flag is #F, it means
- that it will be reloaded into the heap. The primitive returns
- #T or #F indicating whether it successfully dumped the
- object (it can fail on an object that is too large).
-
- The code for dumping pure is severely broken and conditionalized out.
+ BINARY-FASLOAD. A spare heap is required for this operation. The
+ first argument is the object to be dumped. The second is the
+ filename or channel. The third argument, FLAG, is currently
+ ignored. The primitive returns #T or #F indicating whether it
+ successfully dumped the object (it can fail on an object that is
+ too large). It should signal an error rather than return false,
+ but ... some other time.
+
*/
DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0)
{
- SCHEME_OBJECT Object, File_Name, Flag, *New_Object;
+ Tchannel channel;
+ Boolean arg_string_p;
+ SCHEME_OBJECT Object, *New_Object, arg2;
SCHEME_OBJECT *table_start, *table_end;
long Length, table_length;
Boolean result;
PRIMITIVE_HEADER (3);
- CHECK_ARG (2, STRING_P);
- compiled_code_present_p = false;
+
Object = (ARG_REF (1));
- File_Name = (ARG_REF (2));
- Flag = (ARG_REF (3));
-#if false
- CHECK_ARG (3, BOOLEAN_P);
-#else
- if (Flag != SHARP_F)
- error_wrong_type_arg (3);
-#endif
- table_end = &Free[Space_Before_GC()];
- table_start = initialize_primitive_table(Free, table_end);
+ arg2 = (ARG_REF (2));
+ arg_string_p = (STRING_P (arg2));
+ if (!arg_string_p)
+ {
+ channel = (arg_channel (2));
+ }
+
+ compiled_code_present_p = false;
+
+ table_end = &Free[(Space_Before_GC ())];
+ table_start = (initialize_primitive_table (Free, table_end));
if (table_start >= table_end)
{
Primitive_GC (table_start - Free);
}
- dump_file_name = ((CONST char *) (STRING_LOC (File_Name, 0)));
- Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
+
+ Fasdump_Free_Calc (NewFree, NewMemTop, Orig_New_Free);
Fixup = NewMemTop;
ALIGN_FLOAT (NewFree);
New_Object = NewFree;
*NewFree++ = Object;
-\f
-#if false
- /* NOTE: This is wrong!
-
- Many things will break, among them:
-
- Symbols will not be interned correctly in the new system.
-
- The primitive dumping mechanism will break, since
- dump_renumber_primitive is not being invoked by
- either phase.
- The special entry point relocation code depends on the fact that
- fasdumped files (as opposed to bands) contain no constant space
- segment. See fasload.c for further information.
-*/
+ if (arg_string_p)
+ {
+ /* This needs to be done before Fasdump_Exit is called.
+ DUMPLOOP may do that.
+ It should not be done if the primitive will not call
+ Fasdump_Exit on its way out (ie. Primitive_GC above).
+ */
+ dump_file_name = ((CONST char *) (STRING_LOC (arg2, 0)));
+ }
- if (Flag == SHARP_T)
+ DUMPLOOP (New_Object, NORMAL_GC);
+ Length = (NewFree - New_Object);
+ table_start = NewFree;
+ table_end = (cons_primitive_table (NewFree, Fixup, &table_length));
+ if (table_end >= Fixup)
{
- SCHEME_OBJECT *Addr_Of_New_Object;
-
- *New_Free++ = SHARP_F;
- DUMPLOOP(New_Object, PURE_COPY);
- Pure_Length = ((NewFree - New_Object) + 1);
- *NewFree++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *NewFree++ = MAKE_OBJECT (CONSTANT_PART, Pure_Length);
- DUMPLOOP(New_Object, CONSTANT_COPY);
- Length = ((NewFree - New_Object) + 2);
- *NewFree++ = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *NewFree++ = MAKE_OBJECT (END_OF_BLOCK, (Length - 1));
- Addr_Of_New_Object = OBJECT_ADDRESS (New_Object[0]);
- New_Object[0] = MAKE_OBJECT (TC_MANIFEST_SPECIAL_NM_VECTOR, Pure_Length);
- New_Object[1] = MAKE_OBJECT (PURE_PART, (Length - 1));
- table_start = NewFree;
- table_end = cons_primitive_table(NewFree, Fixup, &table_length);
- if (table_end >= Fixup)
- {
- FASDUMP_INTERRUPT();
- }
- dump_channel = (OS_open_dump_file (STRING_LOC (File_Name, 0)));
- if (dump_channel == NO_CHANNEL)
- PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false));
- result = Write_File(Addr_Of_New_Object, 0, 0,
- Length, New_Object,
- table_start, table_length,
- ((long) (table_end - table_start)),
- compiled_code_present_p, false);
+ FASDUMP_INTERRUPT ();
}
- else
-#endif /* Dumping for reload into heap */
-\f
+
+ if (arg_string_p)
{
- DUMPLOOP(New_Object, NORMAL_GC);
- Length = (NewFree - New_Object);
- table_start = NewFree;
- table_end = cons_primitive_table(NewFree, Fixup, &table_length);
- if (table_end >= Fixup)
+ channel = (OS_open_dump_file (dump_file_name));
+ if (channel == NO_CHANNEL)
{
- FASDUMP_INTERRUPT();
- }
- dump_channel =
- (OS_open_dump_file ((CONST char *) (STRING_LOC (File_Name, 0))));
- if (dump_channel == NO_CHANNEL)
PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false));
- result = Write_File(New_Object,
+ }
+ }
+
+ dump_channel = channel;
+ result = (Write_File (New_Object,
Length, New_Object,
0, Constant_Space,
table_start, table_length,
((long) (table_end - table_start)),
- compiled_code_present_p, false);
- }
+ compiled_code_present_p, false));
PRIMITIVE_RETURN (Fasdump_Exit ((result ? PRIM_DONE : PRIM_INTERRUPT),
- true));
+ arg_string_p));
}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.58 1990/11/15 23:18:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.59 1990/11/21 07:04:18 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
+#include "osscheme.h"
#include "osfile.h"
#include "osio.h"
#include "gccode.h"
#include "trap.h"
#include "option.h"
+#include "prmcon.h"
static Tchannel load_channel;
#define Load_Data(size, buffer) \
((OS_channel_read_load_file \
- (load_channel, (buffer), ((size) * (sizeof (SCHEME_OBJECT))))) \
+ (load_channel, \
+ ((char *) (buffer)), \
+ ((size) * (sizeof (SCHEME_OBJECT))))) \
/ (sizeof (SCHEME_OBJECT)))
#include "load.c"
\f
static long failed_heap_length = -1;
+#define MODE_BAND 0
+#define MODE_CHANNEL 1
+#define MODE_FNAME 2
+
static void
-DEFUN (read_file_start, (file_name, from_band_load),
- CONST char * file_name AND
- Boolean from_band_load)
+DEFUN (read_channel_continue, (header, mode, repeat_p),
+ SCHEME_OBJECT *header AND
+ int mode AND
+ Boolean repeat_p)
{
long value, heap_length;
- load_channel = (OS_open_load_file (file_name));
- if (Per_File)
- {
- debug_edit_flags ();
- }
- if (load_channel == NO_CHANNEL)
- {
- error_bad_range_arg (1);
- }
- value = (Read_Header ());
+ value = (initialize_variables_from_fasl_header (header));
+
if (value != FASL_FILE_FINE)
{
- OS_channel_close_noerror (load_channel);
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
switch (value)
{
/* These may want to be separated further. */
}
}
- if (Or2(Reloc_Debug, File_Load_Debug))
+ if (Or2 (Reloc_Debug, File_Load_Debug))
{
print_fasl_information();
}
- if (!Test_Pure_Space_Top(Free_Constant + Const_Count))
+ if (!Test_Pure_Space_Top (Free_Constant + Const_Count))
{
- failed_heap_length = 0;
- OS_channel_close_noerror (load_channel);
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
/*NOTREACHED*/
}
heap_length = (Heap_Count + Primitive_Table_Size + Primitive_Table_Length);
-
+\f
if (GC_Check (heap_length))
{
- if (from_band_load ||
- (failed_heap_length == heap_length))
+ if (repeat_p ||
+ (heap_length == failed_heap_length) ||
+ (mode == MODE_BAND))
{
- /* Heuristic check. It may fail.
- The GC should be modified to do this right.
- */
- failed_heap_length = -1;
- OS_channel_close_noerror (load_channel);
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
/*NOTREACHED*/
}
+ else if (mode == MODE_CHANNEL)
+ {
+ SCHEME_OBJECT reentry_record[1];
+
+ /* IMPORTANT: This KNOWS that it was called from BINARY-FASLOAD.
+ If this is ever called from elsewhere with MODE_CHANNEL,
+ it will have to be parameterized better.
+
+ This reentry record must match the expectations of
+ continue_fasload below.
+ */
+
+ Request_GC (heap_length);
+
+ /* This assumes that header == (Free + 1) */
+ header = Free;
+ Free += (FASL_HEADER_LENGTH + 1);
+ *header = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, FASL_HEADER_LENGTH));
+
+ reentry_record[0] = (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, header));
+
+ suspend_primitive (CONT_FASLOAD,
+ ((sizeof (reentry_record)) /
+ (sizeof (SCHEME_OBJECT))),
+ &reentry_record[0]);
+ immediate_interrupt ();
+ /*NOTREACHED*/
+ }
else
{
failed_heap_length = heap_length;
OS_channel_close_noerror (load_channel);
- Request_GC(heap_length);
+ Request_GC (heap_length);
signal_interrupt_from_primitive ();
/*NOTREACHED*/
}
}
failed_heap_length = -1;
- if ((band_p) && (!from_band_load))
+ if ((band_p) && (mode != MODE_BAND))
{
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
signal_error_from_primitive (ERR_FASLOAD_BAND);
}
return;
}
\f
+static void
+DEFUN (read_channel_start, (channel, mode),
+ Tchannel channel AND
+ int mode)
+{
+ load_channel = channel;
+
+ if (GC_Check (FASL_HEADER_LENGTH + 1))
+ {
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
+ Request_GC (FASL_HEADER_LENGTH + 1);
+ signal_interrupt_from_primitive ();
+ /* NOTREACHED */
+ }
+
+ if (Load_Data (FASL_HEADER_LENGTH, ((char *) (Free + 1))) !=
+ FASL_HEADER_LENGTH)
+ {
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
+ signal_error_from_primitive (ERR_FASL_FILE_BAD_DATA);
+ }
+
+ read_channel_continue ((Free + 1), mode, false);
+ return;
+}
+
+static void
+DEFUN (read_file_start, (file_name, from_band_load),
+ CONST char * file_name AND
+ Boolean from_band_load)
+{
+ Tchannel channel;
+
+ channel = (OS_open_load_file (file_name));
+ if (Per_File)
+ {
+ debug_edit_flags ();
+ }
+ if (channel == NO_CHANNEL)
+ {
+ error_bad_range_arg (1);
+ }
+ read_channel_start (channel,
+ (from_band_load ? MODE_BAND : MODE_FNAME));
+ return;
+}
+\f
static SCHEME_OBJECT *
-DEFUN_VOID (read_file_end)
+DEFUN (read_file_end, (mode), int mode)
{
SCHEME_OBJECT *table;
extern unsigned long checksum_area ();
- if ((Load_Data(Heap_Count, ((char *) Free))) != Heap_Count)
+ if ((Load_Data (Heap_Count, ((char *) Free))) != Heap_Count)
{
- OS_channel_close_noerror (load_channel);
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
signal_error_from_primitive (ERR_IO_ERROR);
}
computed_checksum =
if ((Load_Data(Const_Count, ((char *) Free_Constant))) != Const_Count)
{
- OS_channel_close_noerror (load_channel);
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
signal_error_from_primitive (ERR_IO_ERROR);
}
computed_checksum =
if ((Load_Data(Primitive_Table_Size, ((char *) Free))) !=
Primitive_Table_Size)
{
- OS_channel_close_noerror (load_channel);
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
signal_error_from_primitive (ERR_IO_ERROR);
}
computed_checksum =
NORMALIZE_REGION(((char *) table), Primitive_Table_Size);
Free += Primitive_Table_Size;
- OS_channel_close_noerror (load_channel);
+ if (mode != MODE_CHANNEL)
+ {
+ OS_channel_close_noerror (load_channel);
+ }
if ((computed_checksum != ((unsigned long) 0)) &&
(dumped_checksum != SHARP_F))
static Boolean Warned = false;
SCHEME_OBJECT *
-Relocate(P)
- long P;
+DEFUN (Relocate, (P), long P)
{
SCHEME_OBJECT *Result;
}
else
{
- printf("Pointer out of range: 0x%x\n", P, P);
+ printf ("Pointer out of range: 0x%lx\n", P);
if (!Warned)
{
- printf("Heap: %x-%x, Constant: %x-%x, Stack: ?-0x%x\n",
- Heap_Base, Dumped_Heap_Top,
- Const_Base, Dumped_Constant_Top, Dumped_Stack_Top);
+ printf ("Heap: %lx-%lx, Constant: %lx-%lx, Stack: ?-0x%lx\n",
+ ((long) Heap_Base), ((long) Dumped_Heap_Top),
+ ((long) Const_Base), ((long) Dumped_Constant_Top),
+ ((long) Dumped_Stack_Top));
Warned = true;
}
Result = ((SCHEME_OBJECT *) 0);
}
if (Reloc_Debug)
{
- printf("0x%06x -> 0x%06x\n", P, Result);
+ printf ("0x%06lx -> 0x%06lx\n", P, ((long) Result));
}
return (Result);
}
*/
void
-Relocate_Block(Scan, Stop_At)
- fast SCHEME_OBJECT *Scan, *Stop_At;
+DEFUN (Relocate_Block, (Scan, Stop_At),
+ fast SCHEME_OBJECT *Scan AND
+ fast SCHEME_OBJECT *Stop_At)
{
- fast SCHEME_OBJECT Temp;
fast long address;
+ fast SCHEME_OBJECT Temp;
if (Reloc_Debug)
{
- fprintf(stderr,
- "\nRelocate_Block: block = 0x%x, length = 0x%x, end = 0x%x.\n",
- Scan, ((Stop_At - Scan) - 1), Stop_At);
+ fprintf (stderr,
+ "\nRelocate_Block: block = 0x%lx, length = 0x%lx, end = 0x%lx.\n",
+ ((long) Scan), ((long) ((Stop_At - Scan) - 1)), ((long) Stop_At));
}
while (Scan < Stop_At)
{
Temp = *Scan;
- Switch_by_GC_Type(Temp)
+ Switch_by_GC_Type (Temp)
{
case TC_BROKEN_HEART:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
fast long count;
Scan++;
- for (count = READ_CACHE_LINKAGE_COUNT(Temp);
+ for (count = (READ_CACHE_LINKAGE_COUNT (Temp));
--count >= 0;
)
{
address = (ADDRESS_TO_DATUM ((SCHEME_OBJECT *) (*Scan)));
- *Scan++ = ((SCHEME_OBJECT) Relocate(address));
+ *Scan++ = ((SCHEME_OBJECT) (Relocate (address)));
}
break;
}
word_ptr = (NEXT_LINKAGE_OPERATOR_ENTRY (word_ptr));
EXTRACT_OPERATOR_LINKAGE_ADDRESS (address, Scan);
address = (ADDRESS_TO_DATUM ((SCHEME_OBJECT *) address));
- address = ((long) (Relocate(address)));
+ address = ((long) (Relocate (address)));
STORE_OPERATOR_LINKAGE_ADDRESS (address, Scan);
}
Scan = &end_scan[1];
\f
#ifdef BYTE_INVERSION
case TC_CHARACTER_STRING:
- String_Inversion(Relocate(OBJECT_DATUM (Temp)));
+ String_Inversion (Relocate (OBJECT_DATUM (Temp)));
goto normal_pointer;
#endif
case TC_REFERENCE_TRAP:
- if (OBJECT_DATUM (Temp) <= TRAP_MAX_IMMEDIATE)
+ if ((OBJECT_DATUM (Temp)) <= TRAP_MAX_IMMEDIATE)
{
Scan += 1;
break;
#ifdef BYTE_INVERSION
normal_pointer:
#endif
- address = OBJECT_DATUM (Temp);
- *Scan++ = MAKE_POINTER_OBJECT (OBJECT_TYPE (Temp), Relocate(address));
+ address = (OBJECT_DATUM (Temp));
+ *Scan++ = (MAKE_POINTER_OBJECT ((OBJECT_TYPE (Temp)),
+ (Relocate (address))));
break;
}
}
}
\f
Boolean
-check_primitive_numbers(table, length)
- fast SCHEME_OBJECT *table;
- fast long length;
+DEFUN (check_primitive_numbers, (table, length),
+ fast SCHEME_OBJECT *table AND
+ fast long length)
{
fast long count, top;
- top = NUMBER_OF_DEFINED_PRIMITIVES();
+ 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))
+ if (table[count] != (MAKE_PRIMITIVE_OBJECT (0, count)))
+ {
return (false);
+ }
}
/* Is this really correct? Can't this screw up if there
were more implemented primitives in the dumping microcode
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))
+ if (table[count] != (MAKE_PRIMITIVE_OBJECT (count, top)))
+ {
return (false);
+ }
}
return (true);
}
}
\f
void
-Intern_Block(Next_Pointer, Stop_At)
- fast SCHEME_OBJECT *Next_Pointer, *Stop_At;
+DEFUN (Intern_Block, (Next_Pointer, Stop_At),
+ fast SCHEME_OBJECT *Next_Pointer AND
+ fast SCHEME_OBJECT *Stop_At)
{
if (Reloc_Debug)
{
- printf("Interning a block.\n");
+ printf ("Interning a block.\n");
}
while (Next_Pointer < Stop_At)
switch (OBJECT_TYPE (*Next_Pointer))
{
case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += (1 + OBJECT_DATUM (*Next_Pointer));
+ Next_Pointer += (1 + (OBJECT_DATUM (* Next_Pointer)));
break;
case TC_INTERNED_SYMBOL:
- if (OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
+ if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_GLOBAL_VALUE))) ==
TC_BROKEN_HEART)
{
SCHEME_OBJECT old_symbol = (*Next_Pointer);
}
}
}
- else if (OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_NAME)) ==
+ else if ((OBJECT_TYPE (MEMORY_REF (*Next_Pointer, SYMBOL_NAME))) ==
TC_BROKEN_HEART)
{
*Next_Pointer =
}
if (Reloc_Debug)
{
- printf("Done interning block.\n");
+ printf ("Done interning block.\n");
}
return;
}
#endif
SCHEME_OBJECT
-load_file (from_band_load)
- Boolean from_band_load;
+DEFUN (load_file, (mode), int mode)
{
SCHEME_OBJECT
*Orig_Heap,
ALIGN_FLOAT (Free);
Orig_Heap = Free;
Orig_Constant = Free_Constant;
- primitive_table = read_file_end();
+ primitive_table = (read_file_end (mode));
Constant_End = Free_Constant;
heap_relocation = (COMPUTE_RELOCATION (Orig_Heap, Heap_Base));
stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top));
\f
#ifdef BYTE_INVERSION
- Setup_For_String_Inversion();
+ Setup_For_String_Inversion ();
#endif
/* Setup the primitive table */
- install_primitive_table(primitive_table,
- Primitive_Table_Length,
- from_band_load);
+ install_primitive_table (primitive_table,
+ Primitive_Table_Length,
+ (mode == MODE_BAND));
- if ((!from_band_load) ||
+ if ((mode != MODE_BAND) ||
(heap_relocation != ((relocation_type) 0)) ||
(const_relocation != ((relocation_type) 0)) ||
(stack_relocation != ((relocation_type) 0)) ||
/* We need to relocate. Oh well. */
if (Reloc_Debug)
{
- printf("heap_relocation = %d = %x; const_relocation = %d = %x\n",
- heap_relocation, heap_relocation,
- const_relocation, const_relocation);
+ printf ("heap_relocation = %ld = %lx; const_relocation = %ld = %lx\n",
+ ((long) heap_relocation), ((long) heap_relocation),
+ ((long) const_relocation), ((long) const_relocation));
}
/*
there is no need to relocate it.
*/
- Relocate_Block(Orig_Heap, primitive_table);
- Relocate_Block(Orig_Constant, Free_Constant);
+ Relocate_Block (Orig_Heap, primitive_table);
+ Relocate_Block (Orig_Constant, Free_Constant);
}
\f
#ifdef BYTE_INVERSION
- Finish_String_Inversion();
+ Finish_String_Inversion ();
#endif
- if (!from_band_load)
+ if (mode != MODE_BAND)
{
/* Again, there are no symbols in the primitive table. */
- Intern_Block(Orig_Heap, primitive_table);
- Intern_Block(Orig_Constant, Constant_End);
+ Intern_Block (Orig_Heap, primitive_table);
+ Intern_Block (Orig_Constant, Constant_End);
}
- Set_Pure_Top();
+ Set_Pure_Top ();
FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Free_Constant);
- Relocate_Into(temp, Dumped_Object);
+ Relocate_Into (temp, Dumped_Object);
return (*temp);
}
\f
-/* (BINARY-FASLOAD FILE-NAME)
- Load the contents of FILE-NAME into memory. The file was
- presumably made by a call to PRIMITIVE-FASDUMP, and may contain
- data for the heap and/or the pure area. The value returned is
- the object which was dumped. Typically (but not always) this
- will be a piece of SCode which is then evaluated to perform
- definitions in some environment.
+/* (BINARY-FASLOAD FILE-NAME-OR-CHANNEL)
+ Load the contents of FILE-NAME-OR-CHANNEL into memory. The file
+ was presumably made by a call to PRIMITIVE-FASDUMP, and may contain
+ data for the heap and/or the pure area. The value returned is the
+ object which was dumped. Typically (but not always) this will be a
+ piece of SCode which is then evaluated to perform definitions in
+ some environment.
+ If a file name is given, the corresponding file is opened before
+ loading and closed after loading. A channel remains open.
*/
DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, 0)
{
+ SCHEME_OBJECT arg;
PRIMITIVE_HEADER (1);
- read_file_start ((STRING_ARG (1)), false);
- PRIMITIVE_RETURN (load_file (false));
+
+ PRIMITIVE_CANONICALIZE_CONTEXT();
+ arg = (ARG_REF (1));
+ if (STRING_P (arg))
+ {
+ read_file_start ((STRING_ARG (1)), false);
+ PRIMITIVE_RETURN (load_file (MODE_FNAME));
+ }
+ else
+ {
+ read_channel_start ((arg_channel (1)), MODE_CHANNEL);
+ PRIMITIVE_RETURN (load_file (MODE_CHANNEL));
+ }
}
+SCHEME_OBJECT
+DEFUN (continue_fasload, (reentry_record), SCHEME_OBJECT *reentry_record)
+{
+ SCHEME_OBJECT header;
+
+ /* The reentry record was prepared by read_channel_continue above. */
+
+ load_channel = (arg_channel (1));
+ header = (reentry_record[0]);
+ read_channel_continue ((VECTOR_LOC (header, 0)), MODE_CHANNEL, true);
+ PRIMITIVE_RETURN (load_file (MODE_CHANNEL));
+}
+\f
/* Band loading. */
static char *reload_band_name = 0;
{
int abort_value = (abort_to_interpreter_argument ());
if (abort_value > 0)
- fprintf (stderr, "Error %d (%s)",
- abort_value,
+ fprintf (stderr, "Error %ld (%s)",
+ ((long) abort_value),
(Error_Names [abort_value]));
else
- fprintf (stderr, "Abort %d (%s)",
- abort_value,
+ fprintf (stderr, "Abort %ld (%s)",
+ ((long) abort_value),
(Abort_Names [(-abort_value) - 1]));
}
fputs (" past the point of no return.\n", stderr);
long length = ((strlen (file_name)) + 1);
char * band_name = (malloc (length));
if (band_name != 0)
+ {
strcpy (band_name, file_name);
+ }
transaction_begin ();
{
char ** ap = (dstack_alloc (sizeof (char *)));
(*ap) = band_name;
transaction_record_action (tat_abort, terminate_band_load, ap);
}
- result = (load_file (true));
+ result = (load_file (MODE_BAND));
transaction_commit ();
if (reload_band_name != 0)
+ {
free (reload_band_name);
+ }
reload_band_name = band_name;
}
}
END_BAND_LOAD (true, false);
Band_Load_Hook ();
/* Return in a non-standard way. */
- PRIMITIVE_ABORT(PRIM_DO_EXPRESSION);
+ PRIMITIVE_ABORT (PRIM_DO_EXPRESSION);
/*NOTREACHED*/
}
\f
SCHEME_OBJECT String_Chain, Last_String;
-Setup_For_String_Inversion()
+Setup_For_String_Inversion ()
{
String_Chain = SHARP_F;
Last_String = SHARP_F;
return;
}
-Finish_String_Inversion()
+Finish_String_Inversion ()
{
if (Byte_Invert_Fasl_Files)
{
SCHEME_OBJECT Next;
Count = OBJECT_DATUM (FAST_MEMORY_REF (String_Chain, STRING_HEADER));
- Count = 4*(Count-2)+OBJECT_TYPE (String_Chain)-MAGIC_OFFSET;
+ Count = 4 * (Count - 2) + (OBJECT_TYPE (String_Chain)) - MAGIC_OFFSET;
if (Reloc_Debug)
{
- printf("String at 0x%x: restoring length of %d.\n",
- OBJECT_ADDRESS (String_Chain), Count);
+ printf ("String at 0x%lx: restoring length of %ld.\n",
+ ((long) (OBJECT_ADDRESS (String_Chain))),
+ ((long) Count));
}
Next = (STRING_LENGTH (String_Chain));
SET_STRING_LENGTH (String_Chain, Count);
return;
}
\f
-#define print_char(C) printf(((C < ' ') || (C > '|')) ? \
- "\\%03o" : "%c", (C && MAX_CHAR));
+#define print_char(C) printf (((C < ' ') || (C > '|')) ? \
+ "\\%03o" : "%c", (C && MAX_CHAR));
-String_Inversion(Orig_Pointer)
+String_Inversion (Orig_Pointer)
SCHEME_OBJECT *Orig_Pointer;
{
SCHEME_OBJECT *Pointer_Address;
{
long Count, old_size, new_size, i;
- old_size = OBJECT_DATUM (Orig_Pointer[STRING_HEADER]);
+ old_size = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER]));
new_size =
2 + (((long) (Orig_Pointer[STRING_LENGTH_INDEX]))) / 4;
if (Reloc_Debug)
{
- printf("\nString at 0x%x with %d characters",
- Orig_Pointer,
- ((long) (Orig_Pointer[STRING_LENGTH_INDEX])));
+ printf ("\nString at 0x%lx with %ld characters",
+ ((long) Orig_Pointer),
+ ((long) (Orig_Pointer[STRING_LENGTH_INDEX])));
}
if (old_size != new_size)
{
- printf("\nWord count changed from %d to %d: ",
- old_size , new_size);
- printf("\nWhich, of course, is impossible!!\n");
- Microcode_Termination(TERM_EXIT);
+ printf ("\nWord count changed from %ld to %ld: ",
+ ((long) old_size), ((long) new_size));
+ printf ("\nWhich, of course, is impossible!!\n");
+ Microcode_Termination (TERM_EXIT);
}
Count = ((long) (Orig_Pointer[STRING_LENGTH_INDEX])) % 4;
{
FAST_MEMORY_SET
(Last_String, STRING_LENGTH_INDEX,
- MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer));
+ (MAKE_POINTER_OBJECT ((Count + MAGIC_OFFSET), Orig_Pointer)));
}
\f
- Last_String = MAKE_POINTER_OBJECT (TC_NULL, Orig_Pointer);
+ Last_String = (MAKE_POINTER_OBJECT (TC_NULL, Orig_Pointer));
Orig_Pointer[STRING_LENGTH_INDEX] = SHARP_F;
- Count = OBJECT_DATUM (Orig_Pointer[STRING_HEADER]) - 1;
+ Count = (OBJECT_DATUM (Orig_Pointer[STRING_HEADER])) - 1;
if (Reloc_Debug)
{
- printf("\nCell count=%d\n", Count);
+ printf ("\nCell count = %ld\n", ((long) Count));
}
Pointer_Address = &(Orig_Pointer[STRING_CHARS]);
To_Char = (char *) Pointer_Address;
}
if (Reloc_Debug)
{
- printf("\n");
+ printf ("\n");
}
return;
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.58 1990/10/03 18:57:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.59 1990/11/21 07:04:25 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#include "history.h"
#include "cmpint.h"
#include "zones.h"
+#include "prmcon.h"
extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
extern void EXFUN (free, (PTR ptr));
Val = Fetch_Expression();
break;
+ case RC_PRIMITIVE_CONTINUE:
+ Export_Registers ();
+ Val = (continue_primitive ());
+ Import_Registers ();
+ break;
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.29 1990/10/05 18:58:18 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.30 1990/11/21 07:04:33 jinx Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
dumped_utilities;
\f
void
-print_fasl_information ()
+DEFUN_VOID (print_fasl_information)
{
printf ("FASL File Information:\n\n");
printf ("Machine = %ld; Version = %ld; Subversion = %ld\n",
}
\f
long
-Read_Header ()
+DEFUN (initialize_variables_from_fasl_header, (buffer),
+ SCHEME_OBJECT *buffer)
{
- SCHEME_OBJECT Buffer[FASL_HEADER_LENGTH];
SCHEME_OBJECT Pointer_Heap_Base, Pointer_Const_Base;
- if (Load_Data (FASL_HEADER_LENGTH, ((char *) Buffer)) !=
- FASL_HEADER_LENGTH)
- {
- return (FASL_FILE_TOO_SHORT);
- }
- if (Buffer[FASL_Offset_Marker] != FASL_FILE_MARKER)
+ if (buffer[FASL_Offset_Marker] != FASL_FILE_MARKER)
{
return (FASL_FILE_NOT_FASL);
}
- NORMALIZE_HEADER (Buffer,
- (sizeof(Buffer) / sizeof(SCHEME_OBJECT)),
- Buffer[FASL_Offset_Heap_Base],
- Buffer[FASL_Offset_Heap_Count]);
- Heap_Count = OBJECT_DATUM (Buffer[FASL_Offset_Heap_Count]);
- Pointer_Heap_Base = Buffer[FASL_Offset_Heap_Base];
+ NORMALIZE_HEADER (buffer,
+ (sizeof(buffer) / sizeof(SCHEME_OBJECT)),
+ buffer[FASL_Offset_Heap_Base],
+ buffer[FASL_Offset_Heap_Count]);
+ Heap_Count = OBJECT_DATUM (buffer[FASL_Offset_Heap_Count]);
+ Pointer_Heap_Base = buffer[FASL_Offset_Heap_Base];
Heap_Base = OBJECT_DATUM (Pointer_Heap_Base);
- Dumped_Object = OBJECT_DATUM (Buffer[FASL_Offset_Dumped_Obj]);
- Const_Count = OBJECT_DATUM (Buffer[FASL_Offset_Const_Count]);
- Pointer_Const_Base = Buffer[FASL_Offset_Const_Base];
+ Dumped_Object = OBJECT_DATUM (buffer[FASL_Offset_Dumped_Obj]);
+ Const_Count = OBJECT_DATUM (buffer[FASL_Offset_Const_Count]);
+ Pointer_Const_Base = buffer[FASL_Offset_Const_Base];
Const_Base = OBJECT_DATUM (Pointer_Const_Base);
- Version = The_Version(Buffer[FASL_Offset_Version]);
- Sub_Version = The_Sub_Version(Buffer[FASL_Offset_Version]);
- Machine_Type = The_Machine_Type(Buffer[FASL_Offset_Version]);
- Dumped_Stack_Top = OBJECT_DATUM (Buffer[FASL_Offset_Stack_Top]);
+ Version = The_Version(buffer[FASL_Offset_Version]);
+ Sub_Version = The_Sub_Version(buffer[FASL_Offset_Version]);
+ Machine_Type = The_Machine_Type(buffer[FASL_Offset_Version]);
+ Dumped_Stack_Top = OBJECT_DATUM (buffer[FASL_Offset_Stack_Top]);
Dumped_Heap_Top =
ADDRESS_TO_DATUM (MEMORY_LOC (Pointer_Heap_Base, Heap_Count));
Dumped_Constant_Top =
Primitive_Table_Length = 0;
Primitive_Table_Size = 0;
Ext_Prim_Vector =
- (OBJECT_NEW_TYPE (TC_CELL, (Buffer [FASL_Offset_Ext_Loc])));
+ (OBJECT_NEW_TYPE (TC_CELL, (buffer [FASL_Offset_Ext_Loc])));
}
else
{
- Primitive_Table_Length = OBJECT_DATUM (Buffer[FASL_Offset_Prim_Length]);
- Primitive_Table_Size = OBJECT_DATUM (Buffer[FASL_Offset_Prim_Size]);
+ Primitive_Table_Length = OBJECT_DATUM (buffer[FASL_Offset_Prim_Length]);
+ Primitive_Table_Size = OBJECT_DATUM (buffer[FASL_Offset_Prim_Size]);
Ext_Prim_Vector = SHARP_F;
}
{
SCHEME_OBJECT temp;
- temp = Buffer[FASL_Offset_Ci_Version];
+ temp = buffer[FASL_Offset_Ci_Version];
band_p = CI_BAND_P(temp);
dumped_processor_type = CI_PROCESSOR(temp);
dumped_interface_version = CI_VERSION(temp);
- dumped_utilities = Buffer[FASL_Offset_Ut_Base];
+ dumped_utilities = buffer[FASL_Offset_Ut_Base];
}
\f
#ifndef INHIBIT_FASL_VERSION_CHECK
#endif /* INHIBIT_COMPILED_VERSION_CHECK */
- dumped_checksum = (Buffer [FASL_Offset_Check_Sum]);
+ dumped_checksum = (buffer [FASL_Offset_Check_Sum]);
#ifndef INHIBIT_CHECKSUMS
extern unsigned long checksum_area ();
computed_checksum =
- (checksum_area (((unsigned long *) &Buffer[0]),
+ (checksum_area (((unsigned long *) &buffer[0]),
((unsigned long) (FASL_HEADER_LENGTH)),
((unsigned long) 0)));
return (FASL_FILE_FINE);
}
+
+long
+DEFUN_VOID (Read_Header)
+{
+ SCHEME_OBJECT header[FASL_HEADER_LENGTH];
+
+ if ((Load_Data (FASL_HEADER_LENGTH, header)) !=
+ FASL_HEADER_LENGTH)
+ {
+ return (FASL_FILE_TOO_SHORT);
+ }
+ return (initialize_variables_from_fasl_header (&header[0]));
+}
\f
#ifdef BYTE_INVERSION
static Boolean Byte_Invert_Fasl_Files;
void
-Byte_Invert_Header(Header, Headsize, Test1, Test2)
- long *Header, Headsize, Test1, Test2;
+DEFUN (Byte_Invert_Header, (Header, Headsize, Test1, Test2),
+ long *Header AND
+ long Headsize AND
+ long Test1 AND
+ long Test2)
{
Byte_Invert_Fasl_Files = false;
}
void
-Byte_Invert_Region(Region, Size)
- long *Region, Size;
+DEFUN (Byte_Invert_Region, (Region, Size),
+ long *Region AND
+ long Size)
{
register long word, size;
}
#endif /* BYTE_INVERSION */
-
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.40 1990/11/16 21:20:15 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.41 1990/11/21 07:03:39 jinx Exp $
Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
#endif /* OS2 */
long
-DEFUN (Load_Data, (Count, To_Where), long Count AND char *To_Where)
+DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
{
#ifdef OS2
- setmode (fileno (stdin), O_BINARY);
+ setmode ((fileno (stdin)), O_BINARY);
#endif /* OS2 */
- return (fread ((char *) To_Where, (sizeof (SCHEME_OBJECT)), Count, stdin));
+ return (fread (((char *) To_Where),
+ (sizeof (SCHEME_OBJECT)),
+ Count,
+ stdin));
}
#define INHIBIT_COMPILED_VERSION_CHECK
\f
#ifdef HEAP_IN_LOW_MEMORY
#ifdef hp9000s800
-#define File_To_Pointer(P) \
- ((((long) (P)) & DATUM_MASK) / sizeof(SCHEME_OBJECT))
+# define File_To_Pointer(P) \
+ ((((long) (P)) & DATUM_MASK) / (sizeof (SCHEME_OBJECT)))
#else
-#define File_To_Pointer(P) ((P) / sizeof(SCHEME_OBJECT))
+# define File_To_Pointer(P) ((P) / (sizeof (SCHEME_OBJECT)))
#endif /* hp9000s800 */
#else
-#define File_To_Pointer(P) (P)
+# define File_To_Pointer(P) (P)
#endif
#ifndef Conditional_Bug
-#define Relocate(P) \
+# define Relocate(P) \
(((long) (P) < Const_Base) ? \
- File_To_Pointer(((long) (P)) - Heap_Base) : \
- (Heap_Count + File_To_Pointer(((long) (P)) - Const_Base)))
+ (File_To_Pointer (((long) (P)) - Heap_Base)) : \
+ (Heap_Count + (File_To_Pointer (((long) (P)) - Const_Base))))
#else
-#define Relocate_Into(What, P) \
+# define Relocate_Into(What, P) \
if (((long) (P)) < Const_Base) \
- (What) = File_To_Pointer(((long) (P)) - Heap_Base); \
+ (What) = (File_To_Pointer (((long) (P)) - Heap_Base)); \
else \
- (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base);
+ (What) = Heap_Count + (File_To_Pointer (((long) P) - Const_Base));
static long Relocate_Temp;
-#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
+# define Relocate(P) (Relocate_Into (Relocate_Temp, P), Relocate_Temp)
#endif
static SCHEME_OBJECT *Data, *end_of_memory;
{
if (Quoted)
{
- putchar('\"');
+ putchar ('\"');
}
for (i = 0; i < Count; i++)
{
- printf("%c", *Chars++);
+ printf ("%c", *Chars++);
}
if (Quoted)
{
- putchar('\"');
+ putchar ('\"');
}
- putchar('\n');
+ putchar ('\n');
return (true);
}
}
if (Quoted)
{
- printf("String not in memory; datum = %lx\n", From);
+ printf ("String not in memory; datum = %lx\n", From);
}
return (false);
}
-#define via(File_Address) Relocate(OBJECT_DATUM (Data[File_Address]))
+#define via(File_Address) Relocate (OBJECT_DATUM (Data[File_Address]))
void
DEFUN (scheme_symbol, (From), long From)
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
- (!(scheme_string(via(From + SYMBOL_NAME), false))))
+ (!(scheme_string (via (From + SYMBOL_NAME), false))))
{
- printf("symbol not in memory; datum = %lx\n", From);
+ printf ("symbol not in memory; datum = %lx\n", From);
}
return;
}
#define PRINT_OBJECT(type, datum) \
{ \
- printf("[%s %lx]", type, datum); \
+ printf ("[%s %lx]", type, datum); \
}
#define NON_POINTER(string) \
char *the_string;
long Points_To;
- printf("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
- Points_To = Relocate((SCHEME_OBJECT *) The_Datum);
+ printf ("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
+ Points_To = Relocate ((SCHEME_OBJECT *) The_Datum);
switch (Type)
{ /* "Strange" cases */
case TC_NULL:
if (The_Datum == 0)
{
- printf("#F\n");
+ printf ("#F\n");
return;
}
- NON_POINTER("NULL");
+ NON_POINTER ("NULL");
case TC_TRUE:
if (The_Datum == 0)
{
- printf("#T\n");
+ printf ("#T\n");
return;
}
/* fall through */
case TC_PCOMB0:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case TC_MANIFEST_NM_VECTOR:
- NON_POINTER(Type_Names[Type]);
+ NON_POINTER (Type_Names[Type]);
\f
case TC_INTERNED_SYMBOL:
- PRINT_OBJECT("INTERNED-SYMBOL", Points_To);
- printf(" = ");
- scheme_symbol(Points_To);
+ PRINT_OBJECT ("INTERNED-SYMBOL", Points_To);
+ printf (" = ");
+ scheme_symbol (Points_To);
return;
case TC_UNINTERNED_SYMBOL:
- PRINT_OBJECT("UNINTERNED-SYMBOL", Points_To);
- printf(" = ");
- scheme_symbol(Points_To);
+ PRINT_OBJECT ("UNINTERNED-SYMBOL", Points_To);
+ printf (" = ");
+ scheme_symbol (Points_To);
return;
case TC_CHARACTER_STRING:
- PRINT_OBJECT("CHARACTER-STRING", Points_To);
- printf(" = ");
- scheme_string(Points_To, true);
+ PRINT_OBJECT ("CHARACTER-STRING", Points_To);
+ printf (" = ");
+ scheme_string (Points_To, true);
return;
case TC_FIXNUM:
- PRINT_OBJECT("FIXNUM", The_Datum);
+ PRINT_OBJECT ("FIXNUM", The_Datum);
Points_To = (FIXNUM_TO_LONG (The_Datum));
- printf(" = %ld\n", Points_To);
+ printf (" = %ld\n", Points_To);
return;
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
- NON_POINTER("REFERENCE-TRAP");
+ NON_POINTER ("REFERENCE-TRAP");
}
else
{
- POINTER("REFERENCE-TRAP");
+ POINTER ("REFERENCE-TRAP");
}
case TC_BROKEN_HEART:
default:
if (Type <= LAST_TYPE_CODE)
{
- POINTER(Type_Names[Type]);
+ POINTER (Type_Names[Type]);
}
else
{
- sprintf(&string_buf[0], "0x%02lx ", Type);
- POINTER(&string_buf[0]);
+ sprintf (&string_buf[0], "0x%02lx ", Type);
+ POINTER (&string_buf[0]);
}
}
- PRINT_OBJECT(the_string, Points_To);
- putchar('\n');
+ PRINT_OBJECT (the_string, Points_To);
+ putchar ('\n');
return;
}
\f
{
fast long i;
- printf("\n%s contents:\n\n", name);
+ printf ("\n%s contents:\n\n", name);
for (i = start; i < end; area++, i++)
{
if ((OBJECT_TYPE (*area) == TC_MANIFEST_NM_VECTOR) ||
((OBJECT_TYPE (*area) == TC_LINKAGE_SECTION)
? (READ_CACHE_LINKAGE_COUNT (*area))
: (OBJECT_DATUM (*area)));
- Display(i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
+ Display (i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
area += 1;
for (j = 0; j < count ; j++, area++)
{
- printf(" %02lx%06lx\n",
- (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
+ printf (" %02lx%06lx\n",
+ (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
}
i += count;
area -= 1;
}
else
{
- Display(i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
+ Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
}
}
return (area);
}
\f
-main(argc, argv)
- int argc;
- char **argv;
+void
+DEFUN (main, (argc, argv),
+ int argc AND
+ char **argv)
{
- fast SCHEME_OBJECT *Next;
- long total_length, load_length;
+ int counter = 0;
- if (argc == 1)
+ while (1)
{
- if (Read_Header() != FASL_FILE_FINE)
+ fast SCHEME_OBJECT *Next;
+ long total_length, load_length;
+
+ if (argc == 1)
{
- fprintf(stderr,
- "%s: Input does not appear to be in correct FASL format.\n",
- argv[0]);
- exit(1);
+ switch (Read_Header ())
+ {
+ case FASL_FILE_FINE :
+ if (counter != 0)
+ {
+ printf ("\f\n\t*** New object ***\n\n");
+ }
+ break;
+
+ /* There should really be a difference between no header
+ and a short header.
+ */
+
+ case FASL_FILE_TOO_SHORT:
+ exit (0);
+
+ default:
+ {
+ fprintf (stderr,
+ "%s: Input does not appear to be in correct FASL format.\n",
+ argv[0]);
+ exit (1);
+ /* NOTREACHED */
+ }
+ }
+ print_fasl_information ();
+ printf ("Dumped object (relocated) at 0x%lx\n",
+ (Relocate (Dumped_Object)));
}
- print_fasl_information();
- printf("Dumped object (relocated) at 0x%lx\n", Relocate(Dumped_Object));
- }
- else
- {
- Const_Count = 0;
- Primitive_Table_Size = 0;
- sscanf(argv[1], "%lx", ((long) &Heap_Base));
- sscanf(argv[2], "%lx", ((long) &Const_Base));
- sscanf(argv[3], "%ld", ((long) &Heap_Count));
- printf("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
- Heap_Base, Const_Base, Heap_Count);
- }
-\f
- load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
- Data = ((SCHEME_OBJECT *) malloc(sizeof(SCHEME_OBJECT) * (load_length + 4)));
- if (Data == NULL)
- {
- fprintf(stderr, "Allocation of %ld words failed.\n", (load_length + 4));
- exit(1);
- }
- total_length = Load_Data (load_length, ((char *) Data));
- end_of_memory = &Data[total_length];
- if (total_length != load_length)
- {
- printf("The FASL file does not have the right length.\n");
- printf("Expected %ld objects. Obtained %ld objects.\n\n",
- ((long) load_length), ((long) total_length));
- if (total_length < Heap_Count)
+ else
{
- Heap_Count = total_length;
+ Const_Count = 0;
+ Primitive_Table_Size = 0;
+ sscanf (argv[1], "%lx", ((long) &Heap_Base));
+ sscanf (argv[2], "%lx", ((long) &Const_Base));
+ sscanf (argv[3], "%ld", ((long) &Heap_Count));
+ printf ("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
+ Heap_Base, Const_Base, Heap_Count);
}
- total_length -= Heap_Count;
- if (total_length < Const_Count)
+\f
+ load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
+ Data = ((SCHEME_OBJECT *) malloc (sizeof (SCHEME_OBJECT) * (load_length + 4)));
+ if (Data == NULL)
{
- Const_Count = total_length;
+ fprintf (stderr, "Allocation of %ld words failed.\n", (load_length + 4));
+ exit (1);
}
- total_length -= Const_Count;
- if (total_length < Primitive_Table_Size)
+ total_length = (Load_Data (load_length, Data));
+ end_of_memory = &Data[total_length];
+ if (total_length != load_length)
{
- Primitive_Table_Size = total_length;
+ printf ("The FASL file does not have the right length.\n");
+ printf ("Expected %ld objects. Obtained %ld objects.\n\n",
+ ((long) load_length), ((long) total_length));
+ if (total_length < Heap_Count)
+ {
+ Heap_Count = total_length;
+ }
+ total_length -= Heap_Count;
+ if (total_length < Const_Count)
+ {
+ Const_Count = total_length;
+ }
+ total_length -= Const_Count;
+ if (total_length < Primitive_Table_Size)
+ {
+ Primitive_Table_Size = total_length;
+ }
}
- }
\f
- if (Heap_Count > 0)
- {
- Next = show_area(Data, 0, Heap_Count, "Heap");
- }
- if (Const_Count > 0)
- {
- Next = show_area(Next, Heap_Count, Const_Count, "Constant Space");
- }
- if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
- {
- long arity, size;
- fast long entries, count;
+ if (Heap_Count > 0)
+ {
+ Next = show_area (Data, 0, Heap_Count, "Heap");
+ }
+ if (Const_Count > 0)
+ {
+ Next = show_area (Next, Heap_Count, Const_Count, "Constant Space");
+ }
+ if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
+ {
+ long arity, size;
+ fast long entries, count;
- /* This is done in case the file is short. */
- end_of_memory[0] = ((SCHEME_OBJECT) 0);
- end_of_memory[1] = ((SCHEME_OBJECT) 0);
- end_of_memory[2] = ((SCHEME_OBJECT) 0);
- end_of_memory[3] = ((SCHEME_OBJECT) 0);
+ /* This is done in case the file is short. */
+ end_of_memory[0] = ((SCHEME_OBJECT) 0);
+ end_of_memory[1] = ((SCHEME_OBJECT) 0);
+ end_of_memory[2] = ((SCHEME_OBJECT) 0);
+ end_of_memory[3] = ((SCHEME_OBJECT) 0);
- entries = Primitive_Table_Length;
- printf("\nPrimitive table: number of entries = %ld\n\n", entries);
+ entries = Primitive_Table_Length;
+ printf ("\nPrimitive table: number of entries = %ld\n\n", entries);
- for (count = 0;
- ((count < entries) && (Next < end_of_memory));
- count += 1)
+ for (count = 0;
+ ((count < entries) && (Next < end_of_memory));
+ count += 1)
+ {
+ arity = (FIXNUM_TO_LONG (*Next));
+ Next += 1;
+ size = (OBJECT_DATUM (*Next));
+ printf ("Number = %3lx; Arity = %2ld; Name = ", count, arity);
+ scheme_string ((Next - Data), true);
+ Next += (1 + size);
+ }
+ printf ("\n");
+ }
+ if (argc != 1)
{
- arity = (FIXNUM_TO_LONG (*Next));
- Next += 1;
- size = (OBJECT_DATUM (*Next));
- printf("Number = %3lx; Arity = %2ld; Name = ", count, arity);
- scheme_string((Next - Data), true);
- Next += (1 + size);
+ exit (0);
}
- printf("\n");
+ free ((char *) Data);
+ counter = 1;
}
- exit(0);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosfs.c,v 1.1 1990/06/20 19:38:24 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prosfs.c,v 1.2 1990/11/21 07:04:38 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#define FILE_COPY_BUFFER_LENGTH 8192
#endif
-static void
+extern int EXFUN (OS_channel_copy,
+ (off_t source_length,
+ Tchannel source_channel,
+ Tchannel destination_channel));
+
+int
+DEFUN (OS_channel_copy, (source_length, source_channel, destination_channel),
+ off_t source_length AND
+ Tchannel source_channel AND
+ Tchannel destination_channel)
+{
+ char buffer [FILE_COPY_BUFFER_LENGTH];
+ off_t transfer_length =
+ ((source_length > (sizeof (buffer))) ? (sizeof (buffer)) : source_length);
+
+ while (source_length > 0)
+ {
+ long nread =
+ (OS_channel_read (source_channel, buffer, transfer_length));
+ if (nread <= 0)
+ {
+ return (-1);
+ }
+ if ((OS_channel_write (destination_channel, buffer, nread)) <
+ nread)
+ {
+ return (-1);
+ }
+ source_length -= nread;
+ if (source_length < (sizeof (buffer)))
+ transfer_length = source_length;
+ }
+ return (0);
+}
+
+void
DEFUN (OS_file_copy, (from_name, to_name),
CONST char * from_name AND
CONST char * to_name)
{
- char buffer [FILE_COPY_BUFFER_LENGTH];
+ int result;
Tchannel source_channel = (OS_open_input_file (from_name));
Tchannel destination_channel = (OS_open_output_file (to_name));
off_t source_length = (OS_file_length (source_channel));
- off_t transfer_length =
- ((source_length > (sizeof (buffer))) ? (sizeof (buffer)) : source_length);
- if (source_length > 0)
- while (1)
- {
- long nread =
- (OS_channel_read (source_channel, buffer, transfer_length));
- if (nread == 0)
- break;
- OS_channel_write (destination_channel, buffer, nread);
- source_length -= nread;
- if (source_length == 0)
- break;
- if (source_length < (sizeof (buffer)))
- transfer_length = source_length;
- }
+
+ result = (OS_channel_copy (source_length,
+ source_channel,
+ destination_channel));
+
OS_channel_close (source_channel);
OS_channel_close (destination_channel);
+
+ if (result < 0)
+ {
+ signal_error_from_primitive (ERR_IO_ERROR);
+ }
+ return;
}
DEFINE_PRIMITIVE ("FILE-COPY", Prim_file_copy, 2, 2,
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.41 1990/04/17 21:56:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.42 1990/11/21 07:03:45 jinx Rel $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
/* Cheap renames */
+#include "ansidecl.h"
#include "psbmap.h"
#include "float.h"
#define portable_file input_file
*Stack_Top;
long
-Write_Data(Count, From_Where)
- long Count;
- SCHEME_OBJECT *From_Where;
+DEFUN (Write_Data, (Count, From_Where),
+ long Count AND
+ SCHEME_OBJECT *From_Where)
{
return (fwrite (((char *) From_Where),
(sizeof (SCHEME_OBJECT)),
#include "dump.c"
\f
void
-inconsistency()
+DEFUN_VOID (inconsistency)
{
/* Provide some context (2 lines). */
char yow[100];
- fgets(&yow[0], 100, portable_file);
- fprintf(stderr, "%s\n", &yow[0]);
- fgets(&yow[0], 100, portable_file);
- fprintf(stderr, "%s\n", &yow[0]);
+ fgets (&yow[0], 100, portable_file);
+ fprintf (stderr, "%s\n", &yow[0]);
+ fgets (&yow[0], 100, portable_file);
+ fprintf (stderr, "%s\n", &yow[0]);
- quit(1);
+ quit (1);
/*NOTREACHED*/
}
\f
#define OUT(c) return ((long) ((c) & MAX_CHAR))
long
-read_a_char()
+DEFUN_VOID (read_a_char)
{
fast char C;
- C = getc(portable_file);
+ C = getc (portable_file);
if (C != '\\')
{
- OUT(C);
+ OUT (C);
}
- C = getc(portable_file);
- switch(C)
+ C = getc (portable_file);
+ switch (C)
{
- case 'n': OUT('\n');
- case 't': OUT('\n');
- case 'r': OUT('\r');
- case 'f': OUT('\f');
- case '0': OUT('\0');
+ case 'n': OUT ('\n');
+ case 't': OUT ('\n');
+ case 'r': OUT ('\r');
+ case 'f': OUT ('\f');
+ case '0': OUT ('\0');
case 'X':
{
long Code;
- fprintf(stderr,
- "%s: File is not Portable. Character Code Found.\n",
- program_name);
- fscanf(portable_file, "%ld", &Code);
- getc(portable_file); /* Space */
- OUT(Code);
+ fprintf (stderr,
+ "%s: File is not Portable. Character Code Found.\n",
+ program_name);
+ fscanf (portable_file, "%ld", &Code);
+ getc (portable_file); /* Space */
+ OUT (Code);
}
- case '\\': OUT('\\');
- default : OUT(C);
+ case '\\': OUT ('\\');
+ default : OUT (C);
}
}
\f
SCHEME_OBJECT *
-read_a_string_internal(To, maxlen)
- SCHEME_OBJECT *To;
- long maxlen;
+DEFUN (read_a_string_internal, (To, maxlen),
+ SCHEME_OBJECT *To AND
+ long maxlen)
{
long ilen, Pointer_Count;
fast char *str;
fast long len;
str = ((char *) (&To[STRING_CHARS]));
- fscanf(portable_file, "%ld", &ilen);
+ fscanf (portable_file, "%ld", &ilen);
len = ilen;
if (maxlen == -1)
maxlen += 1;
- Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
+ Pointer_Count = STRING_CHARS + (char_to_pointer (maxlen));
To[STRING_HEADER] =
- MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)));
To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
/* Space */
- getc(portable_file);
+ getc (portable_file);
while (--len >= 0)
{
- *str++ = ((char) read_a_char());
+ *str++ = ((char) read_a_char ());
}
*str = '\0';
return (To + Pointer_Count);
}
SCHEME_OBJECT *
-read_a_string(To, Slot)
- SCHEME_OBJECT *To, *Slot;
+DEFUN (read_a_string, (To, Slot),
+ SCHEME_OBJECT *To AND
+ SCHEME_OBJECT *Slot)
{
long maxlen;
- *Slot = MAKE_POINTER_OBJECT(TC_CHARACTER_STRING, To);
- fscanf(portable_file, "%ld", &maxlen);
- return (read_a_string_internal(To, maxlen));
+ *Slot = (MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, To));
+ fscanf (portable_file, "%ld", &maxlen);
+ return (read_a_string_internal (To, maxlen));
}
\f
/*
#define read_hex_digit(var) \
{ \
- fscanf(portable_file, "%1lx", &var); \
+ fscanf (portable_file, "%1lx", &var); \
}
#else
#define VMS_BUG(stmt) stmt
-#define read_hex_digit(var) \
+#define read_hex_digit (var) \
{ \
- var = read_hex_digit_procedure(); \
+ var = (read_hex_digit_procedure ()); \
}
long
-read_hex_digit_procedure()
+read_hex_digit_procedure ()
{
long digit;
int c;
- while ((c = fgetc(portable_file)) == ' ')
+ while ((c = fgetc (portable_file)) == ' ')
{};
digit = ((c >= 'a') ? (c - 'a' + 10)
: ((c >= 'A') ? (c - 'A' + 10)
: ((c >= '0') ? (c - '0')
- : fprintf(stderr, "Losing big: %d\n", c))));
+ : fprintf (stderr, "Losing big: %d\n", c))));
return (digit);
}
#endif
\f
SCHEME_OBJECT *
-read_an_integer(The_Type, To, Slot)
- int The_Type;
- SCHEME_OBJECT *To;
- SCHEME_OBJECT *Slot;
+DEFUN (read_an_integer, (The_Type, To, Slot),
+ int The_Type AND
+ SCHEME_OBJECT *To AND
+ SCHEME_OBJECT *Slot)
{
Boolean negative;
fast long length_in_bits;
- getc(portable_file); /* Space */
- negative = ((getc(portable_file)) == '-');
+ getc (portable_file); /* Space */
+ negative = ((getc (portable_file)) == '-');
{
long l;
fscanf (portable_file, "%ld", (&l));
if (length_in_bits != 0)
{
- for(Normalization = 0,
- ndigits = hex_digits(length_in_bits);
+ for (Normalization = 0,
+ ndigits = hex_digits (length_in_bits);
--ndigits >= 0;
Normalization += 4)
{
- read_hex_digit(digit);
+ read_hex_digit (digit);
Value += (digit << Normalization);
}
}
{
Value = -Value;
}
- *Slot = LONG_TO_FIXNUM(Value);
+ *Slot = (LONG_TO_FIXNUM (Value));
return (To);
}
else if (length_in_bits == 0)
}
\f
SCHEME_OBJECT *
-read_a_bit_string(To, Slot)
- SCHEME_OBJECT *To, *Slot;
+DEFUN (read_a_bit_string, (To, Slot),
+ SCHEME_OBJECT *To AND
+ SCHEME_OBJECT *Slot)
{
long size_in_bits, size_in_words;
SCHEME_OBJECT the_bit_string;
- fscanf(portable_file, "%ld", &size_in_bits);
+ fscanf (portable_file, "%ld", &size_in_bits);
size_in_words = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (size_in_bits)));
- the_bit_string = MAKE_POINTER_OBJECT (TC_BIT_STRING, To);
- *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words);
+ the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, To));
+ *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words));
*To = size_in_bits;
To += size_in_words;
accumulator = 0;
bits_accumulated = 0;
- scan = BIT_STRING_LOW_PTR(the_bit_string);
- for(bits_remaining = size_in_bits;
+ scan = (BIT_STRING_LOW_PTR (the_bit_string));
+ for (bits_remaining = size_in_bits;
bits_remaining > 0;
bits_remaining -= 4)
{
- read_hex_digit(temp);
+ read_hex_digit (temp);
if ((bits_accumulated + 4) > OBJECT_LENGTH)
{
accumulator |=
- ((temp & LOW_MASK(OBJECT_LENGTH - bits_accumulated)) <<
+ ((temp & LOW_MASK (OBJECT_LENGTH - bits_accumulated)) <<
bits_accumulated);
- *(INC_BIT_STRING_PTR(scan)) = accumulator;
+ *(INC_BIT_STRING_PTR (scan)) = accumulator;
accumulator = (temp >> (OBJECT_LENGTH - bits_accumulated));
bits_accumulated -= (OBJECT_LENGTH - 4);
- temp &= LOW_MASK(bits_accumulated);
+ temp &= LOW_MASK (bits_accumulated);
}
else
{
}
if (bits_accumulated != 0)
{
- *(INC_BIT_STRING_PTR(scan)) = accumulator;
+ *(INC_BIT_STRING_PTR (scan)) = accumulator;
}
}
*Slot = the_bit_string;
static double the_max = 0.0;
#define dflmin() 0.0 /* Cop out */
-#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
+#define dflmax() ((the_max == 0.0) ? (compute_max ()) : the_max)
double
-compute_max()
+DEFUN_VOID (compute_max)
{
fast double Result;
fast int expt;
expt != 0;
expt >>= 1)
{
- Result += ldexp(1.0, expt);
+ Result += (ldexp (1.0, expt));
}
the_max = Result;
return (Result);
}
\f
long
-read_signed_decimal (stream)
- fast FILE * stream;
+DEFUN (read_signed_decimal, (stream),
+ fast FILE *stream)
{
fast int c = (getc (stream));
fast long result = (-1);
int negative_p = 0;
while (c == ' ')
+ {
c = (getc (stream));
+ }
if (c == '-')
- {
- negative_p = 1;
- c = (getc (stream));
- }
+ {
+ negative_p = 1;
+ c = (getc (stream));
+ }
else if (c == '+')
+ {
c = (getc (stream));
+ }
if ((c >= '0') && (c <= '9'))
+ {
+ result = (c - '0');
+ c = (getc (stream));
+ while ((c >= '0') && (c <= '9'))
{
- result = (c - '0');
+ result = ((result * 10) + (c - '0'));
c = (getc (stream));
- while ((c >= '0') && (c <= '9'))
- {
- result = ((result * 10) + (c - '0'));
- c = (getc (stream));
- }
}
+ }
if (c != EOF)
+ {
ungetc (c, stream);
+ }
if (result == (-1))
- {
- fprintf (stderr, "%s: Unable to read expected decimal integer\n",
- program_name);
- inconsistency ();
- }
+ {
+ fprintf (stderr, "%s: Unable to read expected decimal integer\n",
+ program_name);
+ inconsistency ();
+ }
return (negative_p ? (-result) : result);
}
\f
double
-read_a_flonum ()
+DEFUN_VOID (read_a_flonum)
{
Boolean negative;
long exponent;
{
int c = (getc (portable_file));
if (c == '\n')
+ {
return (0);
+ }
ungetc (c, portable_file);
}
size_in_bits = (read_signed_decimal (portable_file));
if (size_in_bits == 0)
+ {
return (0);
+ }
if ((exponent > DBL_MAX_EXP) || (exponent < DBL_MIN_EXP))
{
/* Skip over mantissa */
- while (getc(portable_file) != '\n')
+ while ((getc (portable_file)) != '\n')
{};
- fprintf(stderr,
- "%s: Floating point exponent too %s!\n",
- program_name,
- ((exponent < 0) ? "small" : "large"));
- Result = ((exponent < 0) ? dflmin() : dflmax());
+ fprintf (stderr,
+ "%s: Floating point exponent too %s!\n",
+ program_name,
+ ((exponent < 0) ? "small" : "large"));
+ Result = ((exponent < 0) ? (dflmin ()) : (dflmax ()));
}
else
{
if (size_in_bits > DBL_MANT_DIG)
{
- fprintf(stderr,
- "%s: Some precision may be lost.",
- program_name);
+ fprintf (stderr,
+ "%s: Some precision may be lost.",
+ program_name);
}
- getc(portable_file); /* Space */
- for (ndigits = hex_digits(size_in_bits),
+ getc (portable_file); /* Space */
+ for (ndigits = (hex_digits (size_in_bits)),
Result = 0.0,
Normalization = (1.0 / 16.0);
--ndigits >= 0;
Normalization /= 16.0)
{
- read_hex_digit(digit);
+ read_hex_digit (digit);
Result += (((double ) digit) * Normalization);
}
- Result = ldexp(Result, ((int) exponent));
+ Result = (ldexp (Result, ((int) exponent)));
}
if (negative)
{
}
\f
SCHEME_OBJECT *
-Read_External(N, Table, To)
- long N;
- fast SCHEME_OBJECT *Table, *To;
+DEFUN (Read_External, (N, Table, To),
+ long N AND
+ fast SCHEME_OBJECT *Table AND
+ SCHEME_OBJECT *To)
{
fast SCHEME_OBJECT *Until = &Table[N];
int The_Type;
while (Table < Until)
{
- fscanf(portable_file, "%2x", &The_Type);
- switch(The_Type)
+ fscanf (portable_file, "%2x", &The_Type);
+ switch (The_Type)
{
case TC_CHARACTER_STRING:
- To = read_a_string(To, Table++);
+ To = (read_a_string (To, Table++));
continue;
case TC_BIT_STRING:
- To = read_a_bit_string(To, Table++);
+ To = (read_a_bit_string (To, Table++));
continue;
case TC_FIXNUM:
case TC_BIG_FIXNUM:
- To = read_an_integer(The_Type, To, Table++);
+ To = (read_an_integer (The_Type, To, Table++));
continue;
case TC_CHARACTER:
{
long the_char_code;
- getc(portable_file); /* Space */
- VMS_BUG(the_char_code = 0);
- fscanf( portable_file, "%3lx", &the_char_code);
- *Table++ = MAKE_OBJECT (TC_CHARACTER, the_char_code);
+ getc (portable_file); /* Space */
+ VMS_BUG (the_char_code = 0);
+ fscanf (portable_file, "%3lx", &the_char_code);
+ *Table++ = (MAKE_OBJECT (TC_CHARACTER, the_char_code));
continue;
}
\f
case TC_BIG_FLONUM:
{
- double The_Flonum = read_a_flonum();
+ double The_Flonum = (read_a_flonum ());
ALIGN_FLOAT (To);
- *Table++ = MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To);
- *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer));
+ *Table++ = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To));
+ *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer)));
*((double *) To) = The_Flonum;
To += float_to_pointer;
continue;
}
default:
- fprintf(stderr,
- "%s: Unknown external object found; Type = 0x%02x\n",
- program_name, The_Type);
- inconsistency();
+ fprintf (stderr,
+ "%s: Unknown external object found; Type = 0x%02x\n",
+ program_name, The_Type);
+ inconsistency ();
/*NOTREACHED*/
}
}
#if false
void
-Move_Memory(From, N, To)
- fast SCHEME_OBJECT *From, *To;
- long N;
+DEFUN (Move_Memory, (From, N, To),
+ fast SCHEME_OBJECT *From AND
+ long N AND
+ SCHEME_OBJECT *To)
+
{
fast SCHEME_OBJECT *Until;
#endif
void
-Relocate_Objects(from, how_many, disp)
- fast SCHEME_OBJECT *from;
- fast long disp;
- long how_many;
+DEFUN (Relocate_Objects, (from, how_many, disp),
+ fast SCHEME_OBJECT *from AND
+ long how_many AND
+ fast long disp)
{
fast SCHEME_OBJECT *Until;
Until = &from[how_many];
while (from < Until)
{
- switch(OBJECT_TYPE (*from))
+ switch (OBJECT_TYPE (*from))
{
case TC_FIXNUM:
case TC_CHARACTER:
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
*from++ ==
- (OBJECT_NEW_DATUM ((*from), (disp + OBJECT_DATUM (*from))));
+ (OBJECT_NEW_DATUM ((*from), (disp + (OBJECT_DATUM (*from)))));
break;
default:
- fprintf(stderr,
- "%s: Unknown External Object Reference with Type 0x%02x",
- program_name,
- OBJECT_TYPE (*from));
- inconsistency();
+ fprintf (stderr,
+ "%s: Unknown External Object Reference with Type 0x%02x",
+ program_name,
+ (OBJECT_TYPE (*from)));
+ inconsistency ();
}
}
return;
static SCHEME_OBJECT *Relocate_Temp;
#define Relocate(Addr) \
- (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
+ (Relocate_Into (Relocate_Temp, Addr), Relocate_Temp)
#endif
\f
SCHEME_OBJECT *
-Read_Pointers_and_Relocate(how_many, to)
- fast long how_many;
- fast SCHEME_OBJECT *to;
+DEFUN (Read_Pointers_and_Relocate, (how_many, to),
+ fast long how_many AND
+ fast SCHEME_OBJECT *to)
{
int The_Type;
long The_Datum;
ALIGN_FLOAT (to);
#endif
- while (--how_many >= 0)
+ while ((--how_many) >= 0)
{
- VMS_BUG(The_Type = 0);
- VMS_BUG(The_Datum = 0);
- fscanf(portable_file, "%2x %lx", &The_Type, &The_Datum);
- switch(The_Type)
+ VMS_BUG (The_Type = 0);
+ VMS_BUG (The_Datum = 0);
+ fscanf (portable_file, "%2x %lx", &The_Type, &The_Datum);
+ switch (The_Type)
{
case CONSTANT_CODE:
*to++ = Constant_Table[The_Datum];
continue;
case TC_MANIFEST_NM_VECTOR:
- *to++ = MAKE_OBJECT (The_Type, The_Datum);
+ *to++ = (MAKE_OBJECT (The_Type, The_Datum));
{
fast long count;
how_many -= count;
while (--count >= 0)
{
- VMS_BUG(*to = 0);
- fscanf(portable_file, "%lx", to++);
+ VMS_BUG (*to = 0);
+ fscanf (portable_file, "%lx", to++);
}
}
continue;
SCHEME_OBJECT *temp;
long base_type, base_datum;
- fscanf(portable_file, "%02x %lx", &base_type, &base_datum);
- temp = Relocate(base_datum);
+ fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
+ temp = (Relocate (base_datum));
*to++ =
(MAKE_POINTER_OBJECT
(base_type, ((SCHEME_OBJECT *) (&(((char *) temp)[The_Datum])))));
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
- fprintf(stderr, "%s: Broken Heart found.\n", program_name);
- inconsistency();
+ fprintf (stderr, "%s: Broken Heart found.\n", program_name);
+ inconsistency ();
}
/* fall through */
case TC_PRIMITIVE:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_simple_Non_Pointer:
- *to++ = MAKE_OBJECT (The_Type, The_Datum);
+ *to++ = (MAKE_OBJECT (The_Type, The_Datum));
continue;
case TC_MANIFEST_CLOSURE:
case TC_LINKAGE_SECTION:
{
- fprintf(stderr, "%s: File contains linked compiled code.\n",
- program_name);
- inconsistency();
+ fprintf (stderr, "%s: File contains linked compiled code.\n",
+ program_name);
+ inconsistency ();
}
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
- *to++ = MAKE_OBJECT (The_Type, The_Datum);
+ *to++ = (MAKE_OBJECT (The_Type, The_Datum));
continue;
}
/* It is a pointer, fall through. */
default:
/* Should be stricter */
- *to++ = MAKE_POINTER_OBJECT (The_Type, Relocate(The_Datum));
+ *to++ = (MAKE_POINTER_OBJECT (The_Type, Relocate (The_Datum)));
continue;
}
}
static Boolean primitive_warn = false;
SCHEME_OBJECT *
-read_primitives(how_many, where)
- fast long how_many;
- fast SCHEME_OBJECT *where;
+DEFUN (read_primitives, (how_many, where),
+ fast long how_many AND
+ fast SCHEME_OBJECT *where)
{
long arity;
while (--how_many >= 0)
{
- fscanf(portable_file, "%ld", &arity);
+ fscanf (portable_file, "%ld", &arity);
if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
{
primitive_warn = true;
}
- *where++ = LONG_TO_FIXNUM(arity);
- where = read_a_string_internal(where, ((long) -1));
+ *where++ = (LONG_TO_FIXNUM (arity));
+ where = (read_a_string_internal (where, ((long) -1)));
}
return (where);
}
#ifdef DEBUG
void
-print_external_objects(area_name, Table, N)
- char *area_name;
- fast SCHEME_OBJECT *Table;
- fast long N;
+DEFUN (print_external_objects, (area_name, Table, N),
+ char *area_name AND
+ fast SCHEME_OBJECT *Table AND
+ fast long N)
{
fast SCHEME_OBJECT *Table_End = &Table[N];
- fprintf(stderr, "%s External Objects:\n", area_name);
- fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
+ fprintf (stderr, "%s External Objects:\n", area_name);
+ fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
- for( ; Table < Table_End; Table++)
+ for ( ; Table < Table_End; Table++)
{
switch (OBJECT_TYPE (*Table))
{
case TC_FIXNUM:
{
- fprintf(stderr,
- "Table[%6d] = Fixnum %d\n",
- (N - (Table_End - Table)),
- (FIXNUM_TO_LONG (*Table)));
+ fprintf (stderr,
+ "Table[%6d] = Fixnum %d\n",
+ (N - (Table_End - Table)),
+ (FIXNUM_TO_LONG (*Table)));
break;
}
case TC_CHARACTER:
- fprintf(stderr,
- "Table[%6d] = Character %c = 0x%02x\n",
- (N - (Table_End - Table)),
- (OBJECT_DATUM (*Table)),
- (OBJECT_DATUM (*Table)));
+ fprintf (stderr,
+ "Table[%6d] = Character %c = 0x%02x\n",
+ (N - (Table_End - Table)),
+ (OBJECT_DATUM (*Table)),
+ (OBJECT_DATUM (*Table)));
break;
case TC_CHARACTER_STRING:
- fprintf(stderr,
- "Table[%6d] = string \"%s\"\n",
- (N - (Table_End - Table)),
- ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
+ fprintf (stderr,
+ "Table[%6d] = string \"%s\"\n",
+ (N - (Table_End - Table)),
+ ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
break;
\f
case TC_BIG_FIXNUM:
- fprintf(stderr,
- "Table[%6d] = Bignum\n",
- (N - (Table_End - Table)));
+ fprintf (stderr,
+ "Table[%6d] = Bignum\n",
+ (N - (Table_End - Table)));
break;
case TC_BIG_FLONUM:
- fprintf(stderr,
- "Table[%6d] = Flonum %lf\n",
- (N - (Table_End - Table)),
- (* ((double *) MEMORY_LOC (*Table, 1))));
+ fprintf (stderr,
+ "Table[%6d] = Flonum %lf\n",
+ (N - (Table_End - Table)),
+ (* ((double *) MEMORY_LOC (*Table, 1))));
break;
default:
- fprintf(stderr,
- "Table[%6d] = Unknown External Object 0x%8x\n",
- (N - (Table_End - Table)),
- *Table);
+ fprintf (stderr,
+ "Table[%6d] = Unknown External Object 0x%8x\n",
+ (N - (Table_End - Table)),
+ *Table);
break;
}
}
#define DEBUGGING(action) action
-#define WHEN(condition, message) when(condition, message)
+#define WHEN(condition, message) when (condition, message)
void
-when(what, message)
- Boolean what;
- char *message;
+DEFUN (when, (what, message),
+ Boolean what AND
+ char *message)
{
if (what)
{
- fprintf(stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- quit(1);
+ fprintf (stderr, "%s: Inconsistency: %s!\n",
+ program_name, (message));
+ quit (1);
}
return;
}
#define READ_HEADER(string, format, value) \
{ \
- fscanf(portable_file, format, &(value)); \
- fprintf(stderr, "%s: ", (string)); \
- fprintf(stderr, (format), (value)); \
- fprintf(stderr, "\n"); \
+ fscanf (portable_file, format, &(value)); \
+ fprintf (stderr, "%s: ", (string)); \
+ fprintf (stderr, (format), (value)); \
+ fprintf (stderr, "\n"); \
}
\f
#else /* not DEBUG */
#define READ_HEADER(string, format, value) \
{ \
- if (fscanf(portable_file, format, &(value)) == EOF) \
+ if (fscanf (portable_file, format, &(value)) == EOF) \
{ \
- short_header_read(); \
+ short_header_read (); \
} \
}
#endif /* DEBUG */
\f
void
-short_header_read()
+DEFUN_VOID (short_header_read)
{
- fprintf(stderr, "%s: Header is not complete!\n", program_name);
- quit(1);
+ fprintf (stderr, "%s: Header is not complete!\n", program_name);
+ quit (1);
}
+static SCHEME_OBJECT *Storage;
+
long
-Read_Header_and_Allocate()
+DEFUN_VOID (Read_Header_and_Allocate)
{
long
Portable_Version, Machine,
NPChars,
Size;
- READ_HEADER("Portable Version", "%ld", Portable_Version);
+#if 0
+ READ_HEADER ("Portable Version", "%ld", Portable_Version);
+#else
+ if (fscanf (portable_file, "%ld", &Portable_Version) == EOF)
+ {
+ return (-1);
+ }
+#endif
if (Portable_Version != PORTABLE_VERSION)
{
- fprintf(stderr, "%s: Portable version mismatch:\n", program_name);
- fprintf(stderr, "Portable File Version %4d\n", Portable_Version);
- fprintf(stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
- quit(1);
+ fprintf (stderr, "%s: Portable version mismatch:\n", program_name);
+ fprintf (stderr, "Portable File Version %4d\n", Portable_Version);
+ fprintf (stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
+ quit (1);
}
- READ_HEADER("Machine", "%ld", Machine);
- READ_HEADER("Version", "%ld", Version);
- READ_HEADER("Sub Version", "%ld", Sub_Version);
+ READ_HEADER ("Machine", "%ld", Machine);
+ READ_HEADER ("Version", "%ld", Version);
+ READ_HEADER ("Sub Version", "%ld", Sub_Version);
if ((Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
- fprintf(stderr, "%s: Binary version mismatch:\n", program_name);
- fprintf(stderr,
- "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
- Portable_Version, Version, Sub_Version);
- fprintf(stderr,
- "Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
- PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
- quit(1);
+ fprintf (stderr, "%s: Binary version mismatch:\n", program_name);
+ fprintf (stderr,
+ "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
+ Portable_Version, Version, Sub_Version);
+ fprintf (stderr,
+ "Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
+ PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
+ quit (1);
}
\f
- READ_HEADER("Flags", "%ld", Flags);
- READ_FLAGS(Flags);
+ READ_HEADER ("Flags", "%ld", Flags);
+ READ_FLAGS (Flags);
if (((compiled_p && (! allow_compiled_p)) ||
(nmv_p && (! allow_nmv_p))) &&
{
if (compiled_p)
{
- fprintf(stderr, "%s: %s\n", program_name,
- "Portable file contains \"non-portable\" compiled code.");
+ fprintf (stderr, "%s: %s\n", program_name,
+ "Portable file contains \"non-portable\" compiled code.");
}
else
{
- fprintf(stderr, "%s: %s\n", program_name,
- "Portable file contains \"unexpected\" non-marked vectors.");
+ fprintf (stderr, "%s: %s\n", program_name,
+ "Portable file contains \"unexpected\" non-marked vectors.");
}
- fprintf(stderr, "Machine specified in the portable file: %4d\n",
- Machine);
- fprintf(stderr, "Machine Expected: %4d\n",
- FASL_INTERNAL_FORMAT);
- quit(1);
+ fprintf (stderr, "Machine specified in the portable file: %4d\n",
+ Machine);
+ fprintf (stderr, "Machine Expected: %4d\n",
+ FASL_INTERNAL_FORMAT);
+ quit (1);
}
\f
- READ_HEADER("Heap Count", "%ld", Heap_Count);
- READ_HEADER("Dumped Heap Base", "%ld", Dumped_Heap_Base);
- READ_HEADER("Heap Objects", "%ld", Heap_Objects);
-
- READ_HEADER("Constant Count", "%ld", Constant_Count);
- READ_HEADER("Dumped Constant Base", "%ld", Dumped_Constant_Base);
- READ_HEADER("Constant Objects", "%ld", Constant_Objects);
-
- READ_HEADER("Pure Count", "%ld", Pure_Count);
- READ_HEADER("Dumped Pure Base", "%ld", Dumped_Pure_Base);
- READ_HEADER("Pure Objects", "%ld", Pure_Objects);
-
- READ_HEADER("& Dumped Object", "%ld", Dumped_Object_Addr);
-
- READ_HEADER("Number of flonums", "%ld", NFlonums);
- READ_HEADER("Number of integers", "%ld", NIntegers);
- READ_HEADER("Number of bits in integers", "%ld", NBits);
- READ_HEADER("Number of bit strings", "%ld", NBitstrs);
- READ_HEADER("Number of bits in bit strings", "%ld", NBBits);
- READ_HEADER("Number of character strings", "%ld", NStrings);
- READ_HEADER("Number of characters in strings", "%ld", NChars);
-
- READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
- READ_HEADER("Number of characters in primitives", "%ld", NPChars);
-
- READ_HEADER("CPU type", "%ld", compiler_processor_type);
- READ_HEADER("Compiled code interface version", "%ld",
- compiler_interface_version);
+ READ_HEADER ("Heap Count", "%ld", Heap_Count);
+ READ_HEADER ("Dumped Heap Base", "%ld", Dumped_Heap_Base);
+ READ_HEADER ("Heap Objects", "%ld", Heap_Objects);
+
+ READ_HEADER ("Constant Count", "%ld", Constant_Count);
+ READ_HEADER ("Dumped Constant Base", "%ld", Dumped_Constant_Base);
+ READ_HEADER ("Constant Objects", "%ld", Constant_Objects);
+
+ READ_HEADER ("Pure Count", "%ld", Pure_Count);
+ READ_HEADER ("Dumped Pure Base", "%ld", Dumped_Pure_Base);
+ READ_HEADER ("Pure Objects", "%ld", Pure_Objects);
+
+ READ_HEADER ("& Dumped Object", "%ld", Dumped_Object_Addr);
+
+ READ_HEADER ("Number of flonums", "%ld", NFlonums);
+ READ_HEADER ("Number of integers", "%ld", NIntegers);
+ READ_HEADER ("Number of bits in integers", "%ld", NBits);
+ READ_HEADER ("Number of bit strings", "%ld", NBitstrs);
+ READ_HEADER ("Number of bits in bit strings", "%ld", NBBits);
+ READ_HEADER ("Number of character strings", "%ld", NStrings);
+ READ_HEADER ("Number of characters in strings", "%ld", NChars);
+
+ READ_HEADER ("Primitive Table Length", "%ld", Primitive_Table_Length);
+ READ_HEADER ("Number of characters in primitives", "%ld", NPChars);
+
+ READ_HEADER ("CPU type", "%ld", compiler_processor_type);
+ READ_HEADER ("Compiled code interface version", "%ld",
+ compiler_interface_version);
#if false
- READ_HEADER("Compiler utilities vector", "%ld", compiler_utilities);
+ READ_HEADER ("Compiler utilities vector", "%ld", compiler_utilities);
#endif
Size = (6 + /* SNMV */
Heap_Count + Heap_Objects +
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
- flonum_to_pointer(NFlonums) +
+ flonum_to_pointer (NFlonums) +
((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type))))) +
(BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits)))) +
((NStrings * (1 + STRING_CHARS)) +
- (char_to_pointer(NChars))) +
+ (char_to_pointer (NChars))) +
((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (BIT_STRING_LENGTH_TO_GC_LENGTH(NBBits))) +
+ (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits))) +
((Primitive_Table_Length * (2 + STRING_CHARS)) +
- (char_to_pointer(NPChars))));
+ (char_to_pointer (NPChars))));
ALLOCATE_HEAP_SPACE (Size);
if (Heap == NULL)
{
- fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
- program_name, Size);
- quit(1);
+ fprintf (stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
+ program_name, Size);
+ quit (1);
}
+ Storage = Heap;
Heap += (TRAP_MAX_IMMEDIATE + 1);
return (Size - (TRAP_MAX_IMMEDIATE + 1));
}
\f
void
-do_it()
+DEFUN_VOID (do_it)
{
- SCHEME_OBJECT *primitive_table_end;
- Boolean result;
- long Size;
+ while (1)
+ {
+ SCHEME_OBJECT *primitive_table_end;
+ Boolean result;
+ long Size;
- allow_nmv_p = (allow_nmv_p || allow_compiled_p);
- Size = Read_Header_and_Allocate();
+ Size = (Read_Header_and_Allocate ());
+ if (Size < 0)
+ {
+ return;
+ }
- Stack_Top = &Heap[Size];
+ Stack_Top = &Heap[Size];
- Heap_Table = &Heap[0];
- Heap_Base = &Heap_Table[Heap_Objects];
- ALIGN_FLOAT (Heap_Base);
- Heap_Object_Base =
- Read_External(Heap_Objects, Heap_Table, Heap_Base);
+ Heap_Table = &Heap[0];
+ Heap_Base = &Heap_Table[Heap_Objects];
+ ALIGN_FLOAT (Heap_Base);
+ Heap_Object_Base =
+ Read_External (Heap_Objects, Heap_Table, Heap_Base);
- /* The various 2s below are for SNMV headers. */
+ /* The various 2s below are for SNMV headers. */
- Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2];
- Pure_Object_Base =
- Read_External(Pure_Objects, Pure_Table, Pure_Base);
+ Pure_Table = &Heap_Object_Base[Heap_Count];
+ Pure_Base = &Pure_Table[Pure_Objects + 2];
+ Pure_Object_Base =
+ Read_External (Pure_Objects, Pure_Table, Pure_Base);
- Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2];
- Constant_Object_Base =
- Read_External(Constant_Objects, Constant_Table, Constant_Base);
+ Constant_Table = &Heap[Size - Constant_Objects];
+ Constant_Base = &Pure_Object_Base[Pure_Count + 2];
+ Constant_Object_Base =
+ Read_External (Constant_Objects, Constant_Table, Constant_Base);
- primitive_table = &Constant_Object_Base[Constant_Count + 2];
+ primitive_table = &Constant_Object_Base[Constant_Count + 2];
- WHEN((primitive_table > Constant_Table),
- "primitive_table overran Constant_Table");
+ WHEN ((primitive_table > Constant_Table),
+ "primitive_table overran Constant_Table");
- DEBUGGING(print_external_objects("Heap", Heap_Table, Heap_Objects));
- DEBUGGING(print_external_objects("Pure", Pure_Table, Pure_Objects));
- DEBUGGING(print_external_objects("Constant",
- Constant_Table,
- Constant_Objects));
+ DEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
+ DEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
+ DEBUGGING (print_external_objects ("Constant",
+ Constant_Table,
+ Constant_Objects));
\f
- /* Read the normal objects */
+ /* Read the normal objects */
- Free =
- Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
+ Free =
+ Read_Pointers_and_Relocate (Heap_Count, Heap_Object_Base);
- WHEN((Free > Pure_Table),
- "Free overran Pure_Table");
- WHEN((Free < Pure_Table),
- "Free did not reach Pure_Table");
+ WHEN ((Free > Pure_Table),
+ "Free overran Pure_Table");
+ WHEN ((Free < Pure_Table),
+ "Free did not reach Pure_Table");
- Free_Pure =
- Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
+ Free_Pure =
+ Read_Pointers_and_Relocate (Pure_Count, Pure_Object_Base);
- WHEN((Free_Pure > (Constant_Base - 2)),
- "Free_Pure overran Constant_Base");
- WHEN((Free_Pure < (Constant_Base - 2)),
- "Free_Pure did not reach Constant_Base");
+ WHEN ((Free_Pure > (Constant_Base - 2)),
+ "Free_Pure overran Constant_Base");
+ WHEN ((Free_Pure < (Constant_Base - 2)),
+ "Free_Pure did not reach Constant_Base");
- Free_Constant =
- Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
+ Free_Constant =
+ Read_Pointers_and_Relocate (Constant_Count, Constant_Object_Base);
- WHEN((Free_Constant > (primitive_table - 2)),
- "Free_Constant overran primitive_table");
- WHEN((Free_Constant < (primitive_table - 2)),
- "Free_Constant did not reach primitive_table");
+ WHEN ((Free_Constant > (primitive_table - 2)),
+ "Free_Constant overran primitive_table");
+ WHEN ((Free_Constant < (primitive_table - 2)),
+ "Free_Constant did not reach primitive_table");
- primitive_table_end =
- read_primitives(Primitive_Table_Length, primitive_table);
+ primitive_table_end =
+ read_primitives (Primitive_Table_Length, primitive_table);
- /*
- primitive_table_end can be well below Constant_Table, since
- the memory allocation is conservative (it rounds up), and all
- the slack ends up between them.
- */
+ /*
+ primitive_table_end can be well below Constant_Table, since
+ the memory allocation is conservative (it rounds up), and all
+ the slack ends up between them.
+ */
- WHEN((primitive_table_end > Constant_Table),
- "primitive_table_end overran Constant_Table");
+ WHEN ((primitive_table_end > Constant_Table),
+ "primitive_table_end overran Constant_Table");
- if (primitive_warn)
- {
- fprintf(stderr, "%s:\n", program_name);
- fprintf(stderr,
- "NOTE: The binary file contains primitives with unknown arity.\n");
- }
+ if (primitive_warn)
+ {
+ fprintf (stderr, "%s:\n", program_name);
+ fprintf (stderr,
+ "NOTE: The binary file contains primitives with unknown arity.\n");
+ }
\f
- /* Dump the objects */
+ /* Dump the objects */
{
SCHEME_OBJECT *Dumped_Object;
- Relocate_Into(Dumped_Object, Dumped_Object_Addr);
-
- DEBUGGING(fprintf(stderr, "Dumping:\n"));
- DEBUGGING(fprintf(stderr,
- "Heap = 0x%x; Heap Count = %d\n",
- Heap_Base, (Free - Heap_Base)));
- DEBUGGING(fprintf(stderr,
- "Pure Space = 0x%x; Pure Count = %d\n",
- Pure_Base, (Free_Pure - Pure_Base)));
- DEBUGGING(fprintf(stderr,
- "Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base)));
- DEBUGGING(fprintf(stderr,
- "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object));
- DEBUGGING(fprintf(stderr, "Primitive_Table_Length = %ld; ",
- Primitive_Table_Length));
- DEBUGGING(fprintf(stderr, "Primitive_Table_Size = %ld\n",
- (primitive_table_end - primitive_table)));
+ Relocate_Into (Dumped_Object, Dumped_Object_Addr);
+
+ DEBUGGING (fprintf (stderr, "Dumping:\n"));
+ DEBUGGING (fprintf (stderr,
+ "Heap = 0x%x; Heap Count = %d\n",
+ Heap_Base, (Free - Heap_Base)));
+ DEBUGGING (fprintf (stderr,
+ "Pure Space = 0x%x; Pure Count = %d\n",
+ Pure_Base, (Free_Pure - Pure_Base)));
+ DEBUGGING (fprintf (stderr,
+ "Constant Space = 0x%x; Constant Count = %d\n",
+ Constant_Base, (Free_Constant - Constant_Base)));
+ DEBUGGING (fprintf (stderr,
+ "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
+ Dumped_Object, *Dumped_Object));
+ DEBUGGING (fprintf (stderr, "Primitive_Table_Length = %ld; ",
+ Primitive_Table_Length));
+ DEBUGGING (fprintf (stderr, "Primitive_Table_Size = %ld\n",
+ (primitive_table_end - primitive_table)));
\f
/* Is there a Pure/Constant block? */
if ((Constant_Objects == 0) && (Constant_Count == 0) &&
(Pure_Objects == 0) && (Pure_Count == 0))
{
- result = Write_File(Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- 0, Stack_Top,
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- compiled_p, band_p);
+ result = Write_File (Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ 0, Stack_Top,
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p);
}
else
{
Free_Constant[1] =
MAKE_OBJECT (END_OF_BLOCK, Total_Length);
- result = Write_File(Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- Total_Length, (Pure_Base - 2),
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- compiled_p, band_p);
+ result = (Write_File (Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ Total_Length, (Pure_Base - 2),
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p));
}
}
- if (!result)
- {
- fprintf(stderr, "%s: Error writing the output file.\n", program_name);
- quit(1);
+ if (!result)
+ {
+ fprintf (stderr, "%s: Error writing the output file.\n", program_name);
+ quit (1);
+ }
+ free ((char *) Storage);
}
- return;
}
\f
/* Top level */
static struct keyword_struct
options[] = {
- KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
- OUTPUT_KEYWORD(),
- INPUT_KEYWORD(),
- END_KEYWORD()
+ KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
+ OUTPUT_KEYWORD (),
+ INPUT_KEYWORD (),
+ END_KEYWORD ()
};
-main(argc, argv)
- int argc;
- char *argv[];
+DEFUN (main, (argc, argv),
+ int argc AND
+ char **argv)
{
- parse_keywords(argc, argv, options, false);
+ parse_keywords (argc, argv, options, false);
if (help_sup_p && help_p)
{
- print_usage_and_exit(options, 0);
+ print_usage_and_exit (options, 0);
/*NOTREACHED*/
}
- setup_io();
- do_it();
- quit(0);
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p);
+
+ setup_io ();
+ do_it ();
+ quit (0);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.38 1990/10/03 16:49:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.39 1990/11/21 07:04:43 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
/* The following are not used in the 68000 implementation */
#define RC_POP_RETURN_ERROR 0x40
#define RC_EVAL_ERROR 0x41
-/* formerly #define RC_REPEAT_PRIMITIVE 0x42 */
+/* formerly RC_REPEAT_PRIMITIVE 0x42 */
#define RC_COMP_INTERRUPT_RESTART 0x43
/* formerly RC_COMP_RECURSION_GC 0x44 */
#define RC_RESTORE_INT_MASK 0x45
#define RC_HARDWARE_TRAP 0x5C
#define RC_INTERNAL_APPLY_VAL 0x5D
#define RC_COMP_ERROR_RESTART 0x5E
+#define RC_PRIMITIVE_CONTINUE 0x5F
/* When adding return codes, add them to the table below as well! */
-#define MAX_RETURN_CODE 0x5E
+#define MAX_RETURN_CODE 0x5F
\f
#define RETURN_NAME_TABLE \
{ \
/* 0x5B */ "COMPILER_LINK_CACHES_RESTART", \
/* 0x5C */ "HARDWARE_TRAP", \
/* 0x5D */ "INTERNAL_APPLY_VAL", \
-/* 0x5E */ "COMPILER_ERROR_RESTARRT" \
+/* 0x5E */ "COMPILER_ERROR_RESTARRT", \
+/* 0x5F */ "PRIMITIVE_CONTINUE" \
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.55 1990/11/15 23:18:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.56 1990/11/21 07:04:49 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 55
+#define SUBVERSION 56
#endif
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.46 1990/10/05 18:57:37 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.47 1990/11/21 07:03:30 jinx Rel $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
/* IO definitions */
+#include "ansidecl.h"
#include "psbmap.h"
#include "trap.h"
#include "limits.h"
#define portable_file output_file
long
-Load_Data(Count, To_Where)
- long Count;
- char *To_Where;
+DEFUN (Load_Data, (Count, To_Where),
+ long Count AND
+ SCHEME_OBJECT *To_Where)
{
- return (fread (To_Where, (sizeof (SCHEME_OBJECT)), Count, internal_file));
+ return (fread (((char *) To_Where),
+ (sizeof (SCHEME_OBJECT)),
+ Count,
+ internal_file));
}
#define INHIBIT_FASL_VERSION_CHECK
\f
/* Character macros and procedures */
-extern int strlen();
+extern int strlen ();
#ifndef isalpha
punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!";
Boolean
-ispunct(c)
- fast char c;
+DEFUN (ispunct, (c),
+ fast char c)
{
fast char *;
allow_compiled_p = false,
allow_nmv_p = false,
shuffle_bytes_p = false,
+ swap_bytes_p = false,
upgrade_compiled_p = false,
upgrade_lengths_p = false,
upgrade_primitives_p = false,
}
void
-print_a_char(c, name)
- fast char c;
- char *name;
+DEFUN (print_a_char, (c, name),
+ fast char c AND
+ char *name)
{
switch(c)
{
do_flonum_kernel (Code, Scn, Obj, FObj))
\f
void
-print_a_fixnum(val)
- long val;
+DEFUN (print_a_fixnum, (val),
+ long val)
{
fast long size_in_bits;
fast unsigned long temp;
}
\f
void
-print_a_string_internal(len, str)
- fast long len;
- fast char *str;
+DEFUN (print_a_string_internal, (len, str),
+ fast long len AND
+ fast char *str)
{
fprintf(portable_file, "%ld ", len);
if (shuffle_bytes_p)
}
\f
void
-print_a_string(from)
- SCHEME_OBJECT *from;
+DEFUN (print_a_string, (from),
+ SCHEME_OBJECT *from)
{
long len;
long maxlen;
- maxlen = pointer_to_char((OBJECT_DATUM (*from++)) - 1);
- len = STRING_LENGTH_TO_LONG(*from++);
+ maxlen = (pointer_to_char ((OBJECT_DATUM (*from++)) - 1));
+ len = (STRING_LENGTH_TO_LONG (*from++));
- fprintf(portable_file,
- "%02x %ld ",
- TC_CHARACTER_STRING,
- (compact_p ? len : maxlen));
+ fprintf (portable_file,
+ "%02x %ld ",
+ TC_CHARACTER_STRING,
+ (compact_p ? len : maxlen));
- print_a_string_internal(len, ((char *) from));
+ print_a_string_internal (len, ((char *) from));
return;
}
void
-print_a_primitive(arity, length, name)
- long arity, length;
- char *name;
+DEFUN (print_a_primitive, (arity, length, name),
+ long arity AND
+ long length AND
+ char *name)
{
- fprintf(portable_file, "%ld ", arity);
- print_a_string_internal(length, name);
+ fprintf (portable_file, "%ld ", arity);
+ print_a_string_internal (length, name);
return;
}
\f
static long
-bignum_length (bignum)
- SCHEME_OBJECT bignum;
+DEFUN (bignum_length, (bignum),
+ SCHEME_OBJECT bignum)
{
if (BIGNUM_ZERO_P (bignum))
return (0);
}
\f
void
-print_a_bignum (bignum)
- SCHEME_OBJECT bignum;
+DEFUN (print_a_bignum, (bignum_ptr),
+ SCHEME_OBJECT *bignum_ptr)
{
+ SCHEME_OBJECT bignum;
+
+ bignum = (MAKE_POINTER_OBJECT (TC_BIG_FIXNUM, bignum_ptr));
+
if (BIGNUM_ZERO_P (bignum))
{
fprintf (portable_file, "%02x + 0\n",
/* The following procedure assumes that a C long is at least 4 bits. */
void
-print_a_bit_string(from)
- SCHEME_OBJECT *from;
+DEFUN (print_a_bit_string, (from),
+ SCHEME_OBJECT *from)
{
SCHEME_OBJECT the_bit_string;
fast long bits_remaining, leftover_bits;
}
\f
void
-print_a_flonum(val)
- double val;
+DEFUN (print_a_flonum, (val),
+ double val)
{
fast long size_in_bits;
fast double mant, temp;
}
\f
void
-out_of_range_pointer(ptr)
- SCHEME_OBJECT ptr;
+DEFUN (out_of_range_pointer, (ptr),
+ SCHEME_OBJECT ptr)
{
fprintf(stderr,
"%s: The input file is not portable: Out of range pointer.\n",
}
SCHEME_OBJECT *
-relocate(object)
- SCHEME_OBJECT object;
+DEFUN (relocate, (object),
+ SCHEME_OBJECT object)
{
long the_datum;
SCHEME_OBJECT *result;
found_ext_prims = false;
SCHEME_OBJECT
-upgrade_primitive(prim)
- SCHEME_OBJECT prim;
+DEFUN (upgrade_primitive, (prim),
+ SCHEME_OBJECT prim)
{
long the_datum, the_type, new_type, code;
SCHEME_OBJECT new;
}
\f
SCHEME_OBJECT *
-setup_primitive_upgrade(Heap)
- SCHEME_OBJECT *Heap;
+DEFUN (setup_primitive_upgrade, (Heap),
+ SCHEME_OBJECT *Heap)
{
fast long count, length;
SCHEME_OBJECT *old_prims_vector;
\f
/* Processing of a single area */
-#define Do_Area(Code, Area, Bound, Obj, FObj) \
- Process_Area(Code, &Area, &Bound, &Obj, &FObj)
+#define Do_Area(Code, Area, Bound, Obj, FObj) \
+ Process_Area (Code, &Area, &Bound, &Obj, &FObj)
-Process_Area(Code, Area, Bound, Obj, FObj)
- int Code;
- fast long *Area, *Bound;
- fast long *Obj;
- fast SCHEME_OBJECT **FObj;
+void
+DEFUN (Process_Area, (Code, Area, Bound, Obj, FObj),
+ int Code AND
+ fast long *Area AND
+ fast long *Bound AND
+ fast long *Obj AND
+ fast SCHEME_OBJECT **FObj)
{
fast SCHEME_OBJECT This, *Old_Address, Old_Contents;
/* Output procedures */
void
-print_external_objects(from, count)
- fast SCHEME_OBJECT *from;
- fast long count;
+DEFUN (print_external_objects, (from, count),
+ fast SCHEME_OBJECT *from AND
+ fast long count)
{
while (--count >= 0)
{
break;
case TC_BIT_STRING:
- print_a_bit_string(++from);
- from += (1 + OBJECT_DATUM (*from));
+ print_a_bit_string (++from);
+ from += (1 + (OBJECT_DATUM (*from)));
break;
case TC_BIG_FIXNUM:
print_a_bignum (++from);
- from += (1 + OBJECT_DATUM (*from));
+ from += (1 + (OBJECT_DATUM (*from)));
break;
case TC_CHARACTER_STRING:
- print_a_string(++from);
- from += (1 + OBJECT_DATUM (*from));
+ print_a_string (++from);
+ from += (1 + (OBJECT_DATUM (*from)));
break;
case TC_BIG_FLONUM:
- print_a_flonum(*((double *) (from + 1)));
+ print_a_flonum (*((double *) (from + 1)));
from += (1 + float_to_pointer);
break;
case TC_CHARACTER:
- fprintf(portable_file, "%02x %03x\n",
- TC_CHARACTER, (*from & MASK_MIT_ASCII));
+ fprintf (portable_file, "%02x %03x\n",
+ TC_CHARACTER, ((*from) & MASK_MIT_ASCII));
from += 1;
break;
}
\f
void
-print_objects(from, to)
- fast SCHEME_OBJECT *from, *to;
+DEFUN (print_objects, (from, to),
+ fast SCHEME_OBJECT *from AND
+ fast SCHEME_OBJECT *to)
{
fast long the_datum, the_type;
#define WHEN(condition, message) when(condition, message)
void
-when(what, message)
- Boolean what;
- char *message;
+DEFUN (when, (what, message),
+ Boolean what AND
+ char *message)
{
if (what)
{
/* The main program */
void
-do_it()
+DEFUN_VOID (do_it)
{
- SCHEME_OBJECT *Heap;
- long Initial_Free;
+ while (true)
+ {
+ /* Load the Data */
- /* Load the Data */
+ SCHEME_OBJECT *Heap, *Storage;
+ long Initial_Free;
- if (Read_Header() != FASL_FILE_FINE)
- {
- fprintf(stderr,
- "%s: Input file does not appear to be in an appropriate format.\n",
- program_name);
- quit(1);
- }
+ switch (Read_Header ())
+ {
+ /* There should really be a difference between no header
+ and a short header.
+ */
- if ((Version > FASL_READ_VERSION) ||
- (Version < FASL_OLDEST_VERSION) ||
- (Sub_Version > FASL_READ_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUBVERSION) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) &&
- (!shuffle_bytes_p)))
- {
- fprintf(stderr, "%s:\n", program_name);
- fprintf(stderr,
- "FASL File Version %ld Subversion %ld Machine Type %ld\n",
- Version, Sub_Version , Machine_Type);
- fprintf(stderr,
- "Expected: Version %d Subversion %d Machine Type %d\n",
- FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
- quit(1);
- }
+ case FASL_FILE_TOO_SHORT:
+ return;
+
+ case FASL_FILE_FINE:
+ break;
+
+ default:
+ fprintf (stderr,
+ "%s: Input is not a Scheme binary file.\n",
+ program_name);
+ quit (1);
+ /* NOTREACHED */
+ }
+
+ if ((Version > FASL_READ_VERSION) ||
+ (Version < FASL_OLDEST_VERSION) ||
+ (Sub_Version > FASL_READ_SUBVERSION) ||
+ (Sub_Version < FASL_OLDEST_SUBVERSION) ||
+ ((Machine_Type != FASL_INTERNAL_FORMAT) &&
+ (!swap_bytes_p)))
+ {
+ fprintf (stderr, "%s:\n", program_name);
+ fprintf (stderr,
+ "FASL File Version %ld Subversion %ld Machine Type %ld\n",
+ Version, Sub_Version , Machine_Type);
+ fprintf (stderr,
+ "Expected: Version %d Subversion %d Machine Type %d\n",
+ FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
+ quit (1);
+ }
\f
- if ((((compiler_processor_type != 0) &&
- (dumped_processor_type != 0) &&
- (compiler_processor_type != dumped_processor_type)) ||
- ((compiler_interface_version != 0) &&
- (dumped_interface_version != 0) &&
- (compiler_interface_version != dumped_interface_version))) &&
- (!upgrade_compiled_p))
+ if ((((compiler_processor_type != 0) &&
+ (dumped_processor_type != 0) &&
+ (compiler_processor_type != dumped_processor_type)) ||
+ ((compiler_interface_version != 0) &&
+ (dumped_interface_version != 0) &&
+ (compiler_interface_version != dumped_interface_version))) &&
+ (!upgrade_compiled_p))
{
- fprintf(stderr, "\nread_file:\n");
- fprintf(stderr,
- "FASL File: compiled code interface %4d; processor %4d.\n",
- dumped_interface_version, dumped_processor_type);
- fprintf(stderr,
- "Expected: compiled code interface %4d; processor %4d.\n",
- compiler_interface_version, compiler_processor_type);
- quit(1);
+ fprintf (stderr, "\nread_file:\n");
+ fprintf (stderr,
+ "FASL File: compiled code interface %4d; processor %4d.\n",
+ dumped_interface_version, dumped_processor_type);
+ fprintf (stderr,
+ "Expected: compiled code interface %4d; processor %4d.\n",
+ compiler_interface_version, compiler_processor_type);
+ quit (1);
+ }
+ if (compiler_processor_type != 0)
+ {
+ dumped_processor_type = compiler_processor_type;
+ }
+ if (compiler_interface_version != 0)
+ {
+ dumped_interface_version = compiler_interface_version;
}
- if (compiler_processor_type != 0)
- {
- dumped_processor_type = compiler_processor_type;
- }
- if (compiler_interface_version != 0)
- {
- dumped_interface_version = compiler_interface_version;
- }
- /* Constant Space and bands not currently supported */
+ /* Constant Space and bands not currently supported */
- if (band_p)
- {
- fprintf(stderr, "%s: Input file is a band.\n", program_name);
- quit(1);
- }
+ if (band_p)
+ {
+ fprintf (stderr, "%s: Input file is a band.\n", program_name);
+ quit (1);
+ }
- if (Const_Count != 0)
- {
- fprintf(stderr,
- "%s: Input file has a constant space area.\n",
- program_name);
- quit(1);
- }
+ if (Const_Count != 0)
+ {
+ fprintf (stderr,
+ "%s: Input file has a constant space area.\n",
+ program_name);
+ quit (1);
+ }
\f
- allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
- allow_nmv_p = (allow_nmv_p || allow_compiled_p || vax_invert_p);
- if (null_nmv_p && allow_nmv_p)
- {
- fprintf(stderr,
- "%s: NMVs are both allowed and to be nulled out!\n",
- program_name);
- quit(1);
- }
-
- if (Machine_Type == FASL_INTERNAL_FORMAT)
- {
- shuffle_bytes_p = false;
- }
+ shuffle_bytes_p = swap_bytes_p;
+ if (Machine_Type == FASL_INTERNAL_FORMAT)
+ {
+ shuffle_bytes_p = false;
+ }
- upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
- upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
- upgrade_lengths_p = upgrade_primitives_p;
+ upgrade_traps_p = (Sub_Version < FASL_REFERENCE_TRAP);
+ upgrade_primitives_p = (Sub_Version < FASL_MERGED_PRIMITIVES);
+ upgrade_lengths_p = upgrade_primitives_p;
- DEBUGGING(fprintf(stderr,
- "Dumped Heap Base = 0x%08x\n",
- Heap_Base));
+ DEBUGGING (fprintf (stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Base = 0x%08x\n",
- Const_Base));
+ DEBUGGING (fprintf (stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
- DEBUGGING(fprintf(stderr,
- "Dumped Constant Top = 0x%08x\n",
- Dumped_Constant_Top));
+ DEBUGGING (fprintf (stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
- DEBUGGING(fprintf(stderr,
- "Heap Count = %6d\n",
- Heap_Count));
+ DEBUGGING (fprintf (stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
- DEBUGGING(fprintf(stderr,
- "Constant Count = %6d\n",
- Const_Count));
+ DEBUGGING (fprintf (stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
\f
- {
- long Size;
+ {
+ long Size;
- /* This is way larger than needed, but... what the hell? */
+ /* This is way larger than needed, but... what the hell? */
- Size = ((3 * (Heap_Count + Const_Count)) +
- (NROOTS + 1) +
- (upgrade_primitives_p ?
- (3 * PRIMITIVE_UPGRADE_SPACE) :
- Primitive_Table_Size) +
- (allow_compiled_p ?
- (2 * (Heap_Count + Const_Count)) :
- 0));
+ Size = ((3 * (Heap_Count + Const_Count)) +
+ (NROOTS + 1) +
+ (upgrade_primitives_p ?
+ (3 * PRIMITIVE_UPGRADE_SPACE) :
+ Primitive_Table_Size) +
+ (allow_compiled_p ?
+ (2 * (Heap_Count + Const_Count)) :
+ 0));
- ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE);
+ ALLOCATE_HEAP_SPACE (Size + HEAP_BUFFER_SPACE);
- if (Heap == ((SCHEME_OBJECT *) 0))
- {
- fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
- program_name, Size);
- quit(1);
+ if (Heap == ((SCHEME_OBJECT *) 0))
+ {
+ fprintf (stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
+ program_name, Size);
+ quit (1);
+ }
}
- }
- Heap += HEAP_BUFFER_SPACE;
- INITIAL_ALIGN_FLOAT(Heap);
- Load_Data(Heap_Count, &Heap[0]);
- Load_Data(Const_Count, &Heap[Heap_Count]);
- Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
- Constant_Relocation = ((&Heap[Heap_Count]) - (OBJECT_ADDRESS (Const_Base)));
+ Storage = Heap;
+ Heap += HEAP_BUFFER_SPACE;
+ INITIAL_ALIGN_FLOAT (Heap);
+ if ((Load_Data (Heap_Count, Heap)) != Heap_Count)
+ {
+ fprintf (stderr, "%s: Could not load the heap's contents.\n",
+ program_name);
+ quit (1);
+ }
+ if ((Load_Data (Const_Count, (Heap + Heap_Count))) != Const_Count)
+ {
+ fprintf (stderr, "%s: Could not load constant space.\n",
+ program_name);
+ quit (1);
+ }
+ Heap_Relocation = ((&Heap[0]) - (OBJECT_ADDRESS (Heap_Base)));
+ Constant_Relocation = ((&Heap[Heap_Count]) -
+ (OBJECT_ADDRESS (Const_Base)));
\f
- /* Setup compiled code and primitive tables. */
+ /* Setup compiled code and primitive tables. */
- compiled_entry_table = &Heap[Heap_Count + Const_Count];
- compiled_entry_pointer = compiled_entry_table;
- compiled_entry_table_end = compiled_entry_table;
+ compiled_entry_table = &Heap[Heap_Count + Const_Count];
+ compiled_entry_pointer = compiled_entry_table;
+ compiled_entry_table_end = compiled_entry_table;
- if (allow_compiled_p)
- {
- compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
- }
+ if (allow_compiled_p)
+ {
+ compiled_entry_table_end += (2 * (Heap_Count + Const_Count));
+ }
- primitive_table = compiled_entry_table_end;
- if (upgrade_primitives_p)
- {
- primitive_table_end = setup_primitive_upgrade(primitive_table);
- }
- else
- {
- fast SCHEME_OBJECT *table;
- fast long count, char_count;
-
- Load_Data(Primitive_Table_Size, primitive_table);
- for (char_count = 0,
- count = Primitive_Table_Length,
- table = primitive_table;
- --count >= 0;)
+ primitive_table = compiled_entry_table_end;
+ if (upgrade_primitives_p)
{
- char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH_INDEX]);
- table += (2 + OBJECT_DATUM (table[1 + STRING_HEADER]));
+ primitive_table_end = (setup_primitive_upgrade (primitive_table));
}
- NPChars = char_count;
- primitive_table_end = &primitive_table[Primitive_Table_Size];
- }
- Mem_Base = primitive_table_end;
+ else
+ {
+ fast SCHEME_OBJECT *table;
+ fast long count, char_count;
+
+ if ((Load_Data (Primitive_Table_Size, primitive_table)) !=
+ Primitive_Table_Size)
+ {
+ fprintf (stderr, "%s: Could not load the primitive table.\n",
+ program_name);
+ quit (1);
+ }
+ for (char_count = 0,
+ count = Primitive_Table_Length,
+ table = primitive_table;
+ --count >= 0;)
+ {
+ char_count += (STRING_LENGTH_TO_LONG (table[1 + STRING_LENGTH_INDEX]));
+ table += (2 + (OBJECT_DATUM (table[1 + STRING_HEADER])));
+ }
+ NPChars = char_count;
+ primitive_table_end = (&primitive_table[Primitive_Table_Size]);
+ }
+ Mem_Base = primitive_table_end;
\f
- /* Reformat the data */
+ /* Reformat the data */
- NFlonums = NIntegers = NStrings = 0;
- NBits = NBBits = NChars = 0;
+ NFlonums = NIntegers = NStrings = 0;
+ NBits = NBBits = NChars = 0;
- Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
- Initial_Free = NROOTS;
- Scan = 0;
+ Mem_Base[0] = (OBJECT_NEW_TYPE (TC_CELL, Dumped_Object));
+ Initial_Free = NROOTS;
+ Scan = 0;
- Free = Initial_Free;
- Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
- Objects = 0;
+ Free = Initial_Free;
+ Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
+ Objects = 0;
- Free_Constant = (2 * Heap_Count) + Initial_Free;
- Scan_Constant = Free_Constant;
- Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
- Constant_Objects = 0;
+ Free_Constant = (2 * Heap_Count) + Initial_Free;
+ Scan_Constant = Free_Constant;
+ Free_Cobjects = &Mem_Base[Const_Count + Free_Constant];
+ Constant_Objects = 0;
#if true
- Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+ Do_Area (HEAP_CODE, Scan, Free, Objects, Free_Objects);
#else
- /*
- When Constant Space finally becomes supported,
- something like this must be done.
- */
+ /*
+ When Constant Space finally becomes supported,
+ something like this must be done.
+ */
- while (true)
- {
- Do_Area(HEAP_CODE, Scan, Free,
- Objects, Free_Objects);
- Do_Area(CONSTANT_CODE, Scan_Constant, Free_Constant,
- Constant_Objects, Free_Cobjects);
- Do_Area(PURE_CODE, Scan_Pure, Free_Pure,
- Pure_Objects, Free_Pobjects);
- if (Scan == Free)
+ while (true)
{
- break;
+ Do_Area (HEAP_CODE, Scan, Free,
+ Objects, Free_Objects);
+ Do_Area (CONSTANT_CODE, Scan_Constant, Free_Constant,
+ Constant_Objects, Free_Cobjects);
+ Do_Area (PURE_CODE, Scan_Pure, Free_Pure,
+ Pure_Objects, Free_Pobjects);
+ if (Scan == Free)
+ {
+ break;
+ }
}
- }
#endif
\f
- /* Consistency checks */
+ /* Consistency checks */
- WHEN(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+ WHEN (((Free - Initial_Free) > Heap_Count), "Free overran Heap");
- WHEN(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
- Heap_Count),
- "Free_Objects overran Heap Object Space");
+ WHEN (((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
+ Heap_Count),
+ "Free_Objects overran Heap Object Space");
- WHEN(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
- "Free_Constant overran Constant Space");
+ WHEN (((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+ "Free_Constant overran Constant Space");
- WHEN(((Free_Cobjects - &Mem_Base[Initial_Free +
- (2 * Heap_Count) + Const_Count]) >
- Const_Count),
- "Free_Cobjects overran Constant Object Space");
+ WHEN (((Free_Cobjects - &Mem_Base[Initial_Free +
+ (2 * Heap_Count) + Const_Count]) >
+ Const_Count),
+ "Free_Cobjects overran Constant Object Space");
\f
- /* Output the data */
+ /* Output the data */
- if (found_ext_prims)
- {
- fprintf(stderr, "%s:\n", program_name);
- fprintf(stderr, "NOTE: The arity of some primitives is not known.\n");
- fprintf(stderr, " The portable file has %ld as their arity.\n",
- UNKNOWN_PRIMITIVE_ARITY);
- fprintf(stderr, " You may want to fix this by hand.\n");
- }
+ if (found_ext_prims)
+ {
+ fprintf (stderr, "%s:\n", program_name);
+ fprintf (stderr, "NOTE: The arity of some primitives is not known.\n");
+ fprintf (stderr, " The portable file has %ld as their arity.\n",
+ UNKNOWN_PRIMITIVE_ARITY);
+ fprintf (stderr, " You may want to fix this by hand.\n");
+ }
- /* Header */
+ /* Header */
- WRITE_HEADER("Portable Version", "%ld", PORTABLE_VERSION);
- WRITE_HEADER("Machine", "%ld", FASL_INTERNAL_FORMAT);
- WRITE_HEADER("Version", "%ld", FASL_FORMAT_VERSION);
- WRITE_HEADER("Sub Version", "%ld", FASL_SUBVERSION);
- WRITE_HEADER("Flags", "%ld", (MAKE_FLAGS()));
+ WRITE_HEADER ("Portable Version", "%ld", PORTABLE_VERSION);
+ WRITE_HEADER ("Machine", "%ld", FASL_INTERNAL_FORMAT);
+ WRITE_HEADER ("Version", "%ld", FASL_FORMAT_VERSION);
+ WRITE_HEADER ("Sub Version", "%ld", FASL_SUBVERSION);
+ WRITE_HEADER ("Flags", "%ld", (MAKE_FLAGS ()));
- WRITE_HEADER("Heap Count", "%ld", (Free - NROOTS));
- WRITE_HEADER("Heap Base", "%ld", NROOTS);
- WRITE_HEADER("Heap Objects", "%ld", Objects);
+ WRITE_HEADER ("Heap Count", "%ld", (Free - NROOTS));
+ WRITE_HEADER ("Heap Base", "%ld", NROOTS);
+ WRITE_HEADER ("Heap Objects", "%ld", Objects);
- /* Currently Constant and Pure not supported, but the header is ready */
+ /* Currently Constant and Pure not supported, but the header is ready */
- WRITE_HEADER("Pure Count", "%ld", 0);
- WRITE_HEADER("Pure Base", "%ld", Free_Constant);
- WRITE_HEADER("Pure Objects", "%ld", 0);
+ WRITE_HEADER ("Pure Count", "%ld", 0);
+ WRITE_HEADER ("Pure Base", "%ld", Free_Constant);
+ WRITE_HEADER ("Pure Objects", "%ld", 0);
- WRITE_HEADER("Constant Count", "%ld", 0);
- WRITE_HEADER("Constant Base", "%ld", Free_Constant);
- WRITE_HEADER("Constant Objects", "%ld", 0);
+ WRITE_HEADER ("Constant Count", "%ld", 0);
+ WRITE_HEADER ("Constant Base", "%ld", Free_Constant);
+ WRITE_HEADER ("Constant Objects", "%ld", 0);
- WRITE_HEADER("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
+ WRITE_HEADER ("& Dumped Object", "%ld", (OBJECT_DATUM (Mem_Base[0])));
- WRITE_HEADER("Number of flonums", "%ld", NFlonums);
- WRITE_HEADER("Number of integers", "%ld", NIntegers);
- WRITE_HEADER("Number of bits in integers", "%ld", NBits);
- WRITE_HEADER("Number of bit strings", "%ld", NBitstrs);
- WRITE_HEADER("Number of bits in bit strings", "%ld", NBBits);
- WRITE_HEADER("Number of character strings", "%ld", NStrings);
- WRITE_HEADER("Number of characters in strings", "%ld", NChars);
+ WRITE_HEADER ("Number of flonums", "%ld", NFlonums);
+ WRITE_HEADER ("Number of integers", "%ld", NIntegers);
+ WRITE_HEADER ("Number of bits in integers", "%ld", NBits);
+ WRITE_HEADER ("Number of bit strings", "%ld", NBitstrs);
+ WRITE_HEADER ("Number of bits in bit strings", "%ld", NBBits);
+ WRITE_HEADER ("Number of character strings", "%ld", NStrings);
+ WRITE_HEADER ("Number of characters in strings", "%ld", NChars);
- WRITE_HEADER("Number of primitives", "%ld", Primitive_Table_Length);
- WRITE_HEADER("Number of characters in primitives", "%ld", NPChars);
+ WRITE_HEADER ("Number of primitives", "%ld", Primitive_Table_Length);
+ WRITE_HEADER ("Number of characters in primitives", "%ld", NPChars);
- if (!compiled_p)
- {
- dumped_processor_type = 0;
- dumped_interface_version = 0;
- }
+ if (!compiled_p)
+ {
+ dumped_processor_type = 0;
+ dumped_interface_version = 0;
+ }
- WRITE_HEADER("CPU type", "%ld", dumped_processor_type);
- WRITE_HEADER("Compiled code interface version", "%ld",
- dumped_interface_version);
+ WRITE_HEADER ("CPU type", "%ld", dumped_processor_type);
+ WRITE_HEADER ("Compiled code interface version", "%ld",
+ dumped_interface_version);
#if false
- WRITE_HEADER("Compiler utilities vector", "%ld",
- OBJECT_DATUM (dumped_utilities));
+ WRITE_HEADER ("Compiler utilities vector", "%ld",
+ (OBJECT_DATUM (dumped_utilities)));
#endif
\f
- /* External Objects */
+ /* External Objects */
- print_external_objects(&Mem_Base[Initial_Free + Heap_Count],
- Objects);
+ print_external_objects (&Mem_Base[Initial_Free + Heap_Count],
+ Objects);
#if false
- print_external_objects(&Mem_Base[Pure_Objects_Start],
- Pure_Objects);
- print_external_objects(&Mem_Base[Constant_Objects_Start],
- Constant_Objects);
+ print_external_objects (&Mem_Base[Pure_Objects_Start],
+ Pure_Objects);
+ print_external_objects (&Mem_Base[Constant_Objects_Start],
+ Constant_Objects);
#endif
- /* Pointer Objects */
+ /* Pointer Objects */
- print_objects(&Mem_Base[NROOTS], &Mem_Base[Free]);
+ print_objects (&Mem_Base[NROOTS], &Mem_Base[Free]);
#if false
- print_objects(&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
- print_objects(&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
+ print_objects (&Mem_Base[Pure_Start], &Mem_Base[Free_Pure]);
+ print_objects (&Mem_Base[Constant_Start], &Mem_Base[Free_Constant]);
#endif
\f
- /* Primitives */
-
- if (upgrade_primitives_p)
- {
- SCHEME_OBJECT obj;
- fast SCHEME_OBJECT *table;
- fast long count, the_datum;
+ /* Primitives */
- for (count = Primitive_Table_Length,
- table = external_renumber_table;
- --count >= 0;)
+ if (upgrade_primitives_p)
{
- obj = *table++;
- the_datum = OBJECT_DATUM (obj);
- if (OBJECT_TYPE (obj) == TC_PRIMITIVE_EXTERNAL)
- {
- SCHEME_OBJECT *strobj;
+ SCHEME_OBJECT obj;
+ fast SCHEME_OBJECT *table;
+ fast long count, the_datum;
- strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
- print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
- (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH_INDEX])),
- ((char *) &strobj[STRING_CHARS]));
- }
- else
+ for (count = Primitive_Table_Length,
+ table = external_renumber_table;
+ --count >= 0;)
{
- char *str;
+ obj = *table++;
+ the_datum = (OBJECT_DATUM (obj));
+ if ((OBJECT_TYPE (obj)) == TC_PRIMITIVE_EXTERNAL)
+ {
+ SCHEME_OBJECT *strobj;
+
+ strobj = ((SCHEME_OBJECT *) (external_prim_name_table[the_datum]));
+ print_a_primitive (((long) UNKNOWN_PRIMITIVE_ARITY),
+ (STRING_LENGTH_TO_LONG
+ (strobj[STRING_LENGTH_INDEX])),
+ ((char *) &strobj[STRING_CHARS]));
+ }
+ else
+ {
+ char *str;
- str = builtin_prim_name_table[the_datum];
- print_a_primitive(((long) builtin_prim_arity_table[the_datum]),
- ((long) strlen(str)),
- str);
+ str = builtin_prim_name_table[the_datum];
+ print_a_primitive (((long) builtin_prim_arity_table[the_datum]),
+ ((long) strlen(str)),
+ str);
+ }
}
}
- }
- else
- {
- fast SCHEME_OBJECT *table;
- fast long count;
- long arity;
-
- for (count = Primitive_Table_Length, table = primitive_table;
- --count >= 0;)
+ else
{
- arity = (FIXNUM_TO_LONG (*table));
- table += 1;
- print_a_primitive(arity,
- (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
- ((char *) &table[STRING_CHARS]));
- table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
+ fast SCHEME_OBJECT *table;
+ fast long count;
+ long arity;
+
+ for (count = Primitive_Table_Length, table = primitive_table;
+ --count >= 0;)
+ {
+ arity = (FIXNUM_TO_LONG (*table));
+ table += 1;
+ print_a_primitive (arity,
+ (STRING_LENGTH_TO_LONG(table[STRING_LENGTH_INDEX])),
+ ((char *) &table[STRING_CHARS]));
+ table += (1 + OBJECT_DATUM (table[STRING_HEADER]));
+ }
}
+ fflush (portable_file);
+ free ((char *) Storage);
}
- return;
}
\f
/* Top Level */
static struct keyword_struct
options[] = {
- KEYWORD("swap_bytes", &shuffle_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
- &ci_version_sup_p),
- KEYWORD("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
- &ci_processor_sup_p),
- KEYWORD("vax_invert", &vax_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
- OUTPUT_KEYWORD(),
- INPUT_KEYWORD(),
- END_KEYWORD()
+ KEYWORD ("swap_bytes", &swap_bytes_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("compact", &compact_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("null_nmv", &null_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("upgrade_cc", &upgrade_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("ci_version", &compiler_interface_version, INT_KYWRD, "%ld",
+ &ci_version_sup_p),
+ KEYWORD ("ci_processor", &compiler_processor_type, INT_KYWRD, "%ld",
+ &ci_processor_sup_p),
+ KEYWORD ("vax_invert", &vax_invert_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
+ OUTPUT_KEYWORD (),
+ INPUT_KEYWORD (),
+ END_KEYWORD ()
};
-main(argc, argv)
- int argc;
- char *argv[];
+void
+DEFUN (main, (argc, argv),
+ int argc AND
+ char **argv)
{
- parse_keywords(argc, argv, options, false);
+ parse_keywords (argc, argv, options, false);
+
if (help_sup_p && help_p)
{
print_usage_and_exit(options, 0);
/*NOTREACHED*/
}
- setup_io();
- do_it();
- quit(0);
+
+ allow_compiled_p = (allow_compiled_p || upgrade_compiled_p);
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p || vax_invert_p);
+ if (null_nmv_p && allow_nmv_p)
+ {
+ fprintf (stderr,
+ "%s: NMVs are both allowed and to be nulled out!\n",
+ program_name);
+ quit (1);
+ }
+
+ setup_io ();
+ do_it ();
+ quit (0);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.58 1990/10/03 18:57:28 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.59 1990/11/21 07:04:25 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#include "history.h"
#include "cmpint.h"
#include "zones.h"
+#include "prmcon.h"
extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
extern void EXFUN (free, (PTR ptr));
Val = Fetch_Expression();
break;
+ case RC_PRIMITIVE_CONTINUE:
+ Export_Registers ();
+ Val = (continue_primitive ());
+ Import_Registers ();
+ break;
+
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.40 1990/11/16 21:20:15 arthur Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.41 1990/11/21 07:03:39 jinx Exp $
Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
#endif /* OS2 */
long
-DEFUN (Load_Data, (Count, To_Where), long Count AND char *To_Where)
+DEFUN (Load_Data, (Count, To_Where), long Count AND SCHEME_OBJECT *To_Where)
{
#ifdef OS2
- setmode (fileno (stdin), O_BINARY);
+ setmode ((fileno (stdin)), O_BINARY);
#endif /* OS2 */
- return (fread ((char *) To_Where, (sizeof (SCHEME_OBJECT)), Count, stdin));
+ return (fread (((char *) To_Where),
+ (sizeof (SCHEME_OBJECT)),
+ Count,
+ stdin));
}
#define INHIBIT_COMPILED_VERSION_CHECK
\f
#ifdef HEAP_IN_LOW_MEMORY
#ifdef hp9000s800
-#define File_To_Pointer(P) \
- ((((long) (P)) & DATUM_MASK) / sizeof(SCHEME_OBJECT))
+# define File_To_Pointer(P) \
+ ((((long) (P)) & DATUM_MASK) / (sizeof (SCHEME_OBJECT)))
#else
-#define File_To_Pointer(P) ((P) / sizeof(SCHEME_OBJECT))
+# define File_To_Pointer(P) ((P) / (sizeof (SCHEME_OBJECT)))
#endif /* hp9000s800 */
#else
-#define File_To_Pointer(P) (P)
+# define File_To_Pointer(P) (P)
#endif
#ifndef Conditional_Bug
-#define Relocate(P) \
+# define Relocate(P) \
(((long) (P) < Const_Base) ? \
- File_To_Pointer(((long) (P)) - Heap_Base) : \
- (Heap_Count + File_To_Pointer(((long) (P)) - Const_Base)))
+ (File_To_Pointer (((long) (P)) - Heap_Base)) : \
+ (Heap_Count + (File_To_Pointer (((long) (P)) - Const_Base))))
#else
-#define Relocate_Into(What, P) \
+# define Relocate_Into(What, P) \
if (((long) (P)) < Const_Base) \
- (What) = File_To_Pointer(((long) (P)) - Heap_Base); \
+ (What) = (File_To_Pointer (((long) (P)) - Heap_Base)); \
else \
- (What) = Heap_Count + File_To_Pointer(((long) P) - Const_Base);
+ (What) = Heap_Count + (File_To_Pointer (((long) P) - Const_Base));
static long Relocate_Temp;
-#define Relocate(P) (Relocate_Into(Relocate_Temp, P), Relocate_Temp)
+# define Relocate(P) (Relocate_Into (Relocate_Temp, P), Relocate_Temp)
#endif
static SCHEME_OBJECT *Data, *end_of_memory;
{
if (Quoted)
{
- putchar('\"');
+ putchar ('\"');
}
for (i = 0; i < Count; i++)
{
- printf("%c", *Chars++);
+ printf ("%c", *Chars++);
}
if (Quoted)
{
- putchar('\"');
+ putchar ('\"');
}
- putchar('\n');
+ putchar ('\n');
return (true);
}
}
if (Quoted)
{
- printf("String not in memory; datum = %lx\n", From);
+ printf ("String not in memory; datum = %lx\n", From);
}
return (false);
}
-#define via(File_Address) Relocate(OBJECT_DATUM (Data[File_Address]))
+#define via(File_Address) Relocate (OBJECT_DATUM (Data[File_Address]))
void
DEFUN (scheme_symbol, (From), long From)
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
- (!(scheme_string(via(From + SYMBOL_NAME), false))))
+ (!(scheme_string (via (From + SYMBOL_NAME), false))))
{
- printf("symbol not in memory; datum = %lx\n", From);
+ printf ("symbol not in memory; datum = %lx\n", From);
}
return;
}
#define PRINT_OBJECT(type, datum) \
{ \
- printf("[%s %lx]", type, datum); \
+ printf ("[%s %lx]", type, datum); \
}
#define NON_POINTER(string) \
char *the_string;
long Points_To;
- printf("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
- Points_To = Relocate((SCHEME_OBJECT *) The_Datum);
+ printf ("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
+ Points_To = Relocate ((SCHEME_OBJECT *) The_Datum);
switch (Type)
{ /* "Strange" cases */
case TC_NULL:
if (The_Datum == 0)
{
- printf("#F\n");
+ printf ("#F\n");
return;
}
- NON_POINTER("NULL");
+ NON_POINTER ("NULL");
case TC_TRUE:
if (The_Datum == 0)
{
- printf("#T\n");
+ printf ("#T\n");
return;
}
/* fall through */
case TC_PCOMB0:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case TC_MANIFEST_NM_VECTOR:
- NON_POINTER(Type_Names[Type]);
+ NON_POINTER (Type_Names[Type]);
\f
case TC_INTERNED_SYMBOL:
- PRINT_OBJECT("INTERNED-SYMBOL", Points_To);
- printf(" = ");
- scheme_symbol(Points_To);
+ PRINT_OBJECT ("INTERNED-SYMBOL", Points_To);
+ printf (" = ");
+ scheme_symbol (Points_To);
return;
case TC_UNINTERNED_SYMBOL:
- PRINT_OBJECT("UNINTERNED-SYMBOL", Points_To);
- printf(" = ");
- scheme_symbol(Points_To);
+ PRINT_OBJECT ("UNINTERNED-SYMBOL", Points_To);
+ printf (" = ");
+ scheme_symbol (Points_To);
return;
case TC_CHARACTER_STRING:
- PRINT_OBJECT("CHARACTER-STRING", Points_To);
- printf(" = ");
- scheme_string(Points_To, true);
+ PRINT_OBJECT ("CHARACTER-STRING", Points_To);
+ printf (" = ");
+ scheme_string (Points_To, true);
return;
case TC_FIXNUM:
- PRINT_OBJECT("FIXNUM", The_Datum);
+ PRINT_OBJECT ("FIXNUM", The_Datum);
Points_To = (FIXNUM_TO_LONG (The_Datum));
- printf(" = %ld\n", Points_To);
+ printf (" = %ld\n", Points_To);
return;
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
- NON_POINTER("REFERENCE-TRAP");
+ NON_POINTER ("REFERENCE-TRAP");
}
else
{
- POINTER("REFERENCE-TRAP");
+ POINTER ("REFERENCE-TRAP");
}
case TC_BROKEN_HEART:
default:
if (Type <= LAST_TYPE_CODE)
{
- POINTER(Type_Names[Type]);
+ POINTER (Type_Names[Type]);
}
else
{
- sprintf(&string_buf[0], "0x%02lx ", Type);
- POINTER(&string_buf[0]);
+ sprintf (&string_buf[0], "0x%02lx ", Type);
+ POINTER (&string_buf[0]);
}
}
- PRINT_OBJECT(the_string, Points_To);
- putchar('\n');
+ PRINT_OBJECT (the_string, Points_To);
+ putchar ('\n');
return;
}
\f
{
fast long i;
- printf("\n%s contents:\n\n", name);
+ printf ("\n%s contents:\n\n", name);
for (i = start; i < end; area++, i++)
{
if ((OBJECT_TYPE (*area) == TC_MANIFEST_NM_VECTOR) ||
((OBJECT_TYPE (*area) == TC_LINKAGE_SECTION)
? (READ_CACHE_LINKAGE_COUNT (*area))
: (OBJECT_DATUM (*area)));
- Display(i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
+ Display (i, OBJECT_TYPE (*area), OBJECT_DATUM (*area));
area += 1;
for (j = 0; j < count ; j++, area++)
{
- printf(" %02lx%06lx\n",
- (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
+ printf (" %02lx%06lx\n",
+ (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
}
i += count;
area -= 1;
}
else
{
- Display(i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
+ Display (i, (OBJECT_TYPE (*area)), (OBJECT_DATUM (*area)));
}
}
return (area);
}
\f
-main(argc, argv)
- int argc;
- char **argv;
+void
+DEFUN (main, (argc, argv),
+ int argc AND
+ char **argv)
{
- fast SCHEME_OBJECT *Next;
- long total_length, load_length;
+ int counter = 0;
- if (argc == 1)
+ while (1)
{
- if (Read_Header() != FASL_FILE_FINE)
+ fast SCHEME_OBJECT *Next;
+ long total_length, load_length;
+
+ if (argc == 1)
{
- fprintf(stderr,
- "%s: Input does not appear to be in correct FASL format.\n",
- argv[0]);
- exit(1);
+ switch (Read_Header ())
+ {
+ case FASL_FILE_FINE :
+ if (counter != 0)
+ {
+ printf ("\f\n\t*** New object ***\n\n");
+ }
+ break;
+
+ /* There should really be a difference between no header
+ and a short header.
+ */
+
+ case FASL_FILE_TOO_SHORT:
+ exit (0);
+
+ default:
+ {
+ fprintf (stderr,
+ "%s: Input does not appear to be in correct FASL format.\n",
+ argv[0]);
+ exit (1);
+ /* NOTREACHED */
+ }
+ }
+ print_fasl_information ();
+ printf ("Dumped object (relocated) at 0x%lx\n",
+ (Relocate (Dumped_Object)));
}
- print_fasl_information();
- printf("Dumped object (relocated) at 0x%lx\n", Relocate(Dumped_Object));
- }
- else
- {
- Const_Count = 0;
- Primitive_Table_Size = 0;
- sscanf(argv[1], "%lx", ((long) &Heap_Base));
- sscanf(argv[2], "%lx", ((long) &Const_Base));
- sscanf(argv[3], "%ld", ((long) &Heap_Count));
- printf("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
- Heap_Base, Const_Base, Heap_Count);
- }
-\f
- load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
- Data = ((SCHEME_OBJECT *) malloc(sizeof(SCHEME_OBJECT) * (load_length + 4)));
- if (Data == NULL)
- {
- fprintf(stderr, "Allocation of %ld words failed.\n", (load_length + 4));
- exit(1);
- }
- total_length = Load_Data (load_length, ((char *) Data));
- end_of_memory = &Data[total_length];
- if (total_length != load_length)
- {
- printf("The FASL file does not have the right length.\n");
- printf("Expected %ld objects. Obtained %ld objects.\n\n",
- ((long) load_length), ((long) total_length));
- if (total_length < Heap_Count)
+ else
{
- Heap_Count = total_length;
+ Const_Count = 0;
+ Primitive_Table_Size = 0;
+ sscanf (argv[1], "%lx", ((long) &Heap_Base));
+ sscanf (argv[2], "%lx", ((long) &Const_Base));
+ sscanf (argv[3], "%ld", ((long) &Heap_Count));
+ printf ("Heap Base = 0x%lx; Constant Base = 0x%lx; Heap Count = %ld\n",
+ Heap_Base, Const_Base, Heap_Count);
}
- total_length -= Heap_Count;
- if (total_length < Const_Count)
+\f
+ load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
+ Data = ((SCHEME_OBJECT *) malloc (sizeof (SCHEME_OBJECT) * (load_length + 4)));
+ if (Data == NULL)
{
- Const_Count = total_length;
+ fprintf (stderr, "Allocation of %ld words failed.\n", (load_length + 4));
+ exit (1);
}
- total_length -= Const_Count;
- if (total_length < Primitive_Table_Size)
+ total_length = (Load_Data (load_length, Data));
+ end_of_memory = &Data[total_length];
+ if (total_length != load_length)
{
- Primitive_Table_Size = total_length;
+ printf ("The FASL file does not have the right length.\n");
+ printf ("Expected %ld objects. Obtained %ld objects.\n\n",
+ ((long) load_length), ((long) total_length));
+ if (total_length < Heap_Count)
+ {
+ Heap_Count = total_length;
+ }
+ total_length -= Heap_Count;
+ if (total_length < Const_Count)
+ {
+ Const_Count = total_length;
+ }
+ total_length -= Const_Count;
+ if (total_length < Primitive_Table_Size)
+ {
+ Primitive_Table_Size = total_length;
+ }
}
- }
\f
- if (Heap_Count > 0)
- {
- Next = show_area(Data, 0, Heap_Count, "Heap");
- }
- if (Const_Count > 0)
- {
- Next = show_area(Next, Heap_Count, Const_Count, "Constant Space");
- }
- if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
- {
- long arity, size;
- fast long entries, count;
+ if (Heap_Count > 0)
+ {
+ Next = show_area (Data, 0, Heap_Count, "Heap");
+ }
+ if (Const_Count > 0)
+ {
+ Next = show_area (Next, Heap_Count, Const_Count, "Constant Space");
+ }
+ if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
+ {
+ long arity, size;
+ fast long entries, count;
- /* This is done in case the file is short. */
- end_of_memory[0] = ((SCHEME_OBJECT) 0);
- end_of_memory[1] = ((SCHEME_OBJECT) 0);
- end_of_memory[2] = ((SCHEME_OBJECT) 0);
- end_of_memory[3] = ((SCHEME_OBJECT) 0);
+ /* This is done in case the file is short. */
+ end_of_memory[0] = ((SCHEME_OBJECT) 0);
+ end_of_memory[1] = ((SCHEME_OBJECT) 0);
+ end_of_memory[2] = ((SCHEME_OBJECT) 0);
+ end_of_memory[3] = ((SCHEME_OBJECT) 0);
- entries = Primitive_Table_Length;
- printf("\nPrimitive table: number of entries = %ld\n\n", entries);
+ entries = Primitive_Table_Length;
+ printf ("\nPrimitive table: number of entries = %ld\n\n", entries);
- for (count = 0;
- ((count < entries) && (Next < end_of_memory));
- count += 1)
+ for (count = 0;
+ ((count < entries) && (Next < end_of_memory));
+ count += 1)
+ {
+ arity = (FIXNUM_TO_LONG (*Next));
+ Next += 1;
+ size = (OBJECT_DATUM (*Next));
+ printf ("Number = %3lx; Arity = %2ld; Name = ", count, arity);
+ scheme_string ((Next - Data), true);
+ Next += (1 + size);
+ }
+ printf ("\n");
+ }
+ if (argc != 1)
{
- arity = (FIXNUM_TO_LONG (*Next));
- Next += 1;
- size = (OBJECT_DATUM (*Next));
- printf("Number = %3lx; Arity = %2ld; Name = ", count, arity);
- scheme_string((Next - Data), true);
- Next += (1 + size);
+ exit (0);
}
- printf("\n");
+ free ((char *) Data);
+ counter = 1;
}
- exit(0);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.41 1990/04/17 21:56:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.42 1990/11/21 07:03:45 jinx Rel $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
/* Cheap renames */
+#include "ansidecl.h"
#include "psbmap.h"
#include "float.h"
#define portable_file input_file
*Stack_Top;
long
-Write_Data(Count, From_Where)
- long Count;
- SCHEME_OBJECT *From_Where;
+DEFUN (Write_Data, (Count, From_Where),
+ long Count AND
+ SCHEME_OBJECT *From_Where)
{
return (fwrite (((char *) From_Where),
(sizeof (SCHEME_OBJECT)),
#include "dump.c"
\f
void
-inconsistency()
+DEFUN_VOID (inconsistency)
{
/* Provide some context (2 lines). */
char yow[100];
- fgets(&yow[0], 100, portable_file);
- fprintf(stderr, "%s\n", &yow[0]);
- fgets(&yow[0], 100, portable_file);
- fprintf(stderr, "%s\n", &yow[0]);
+ fgets (&yow[0], 100, portable_file);
+ fprintf (stderr, "%s\n", &yow[0]);
+ fgets (&yow[0], 100, portable_file);
+ fprintf (stderr, "%s\n", &yow[0]);
- quit(1);
+ quit (1);
/*NOTREACHED*/
}
\f
#define OUT(c) return ((long) ((c) & MAX_CHAR))
long
-read_a_char()
+DEFUN_VOID (read_a_char)
{
fast char C;
- C = getc(portable_file);
+ C = getc (portable_file);
if (C != '\\')
{
- OUT(C);
+ OUT (C);
}
- C = getc(portable_file);
- switch(C)
+ C = getc (portable_file);
+ switch (C)
{
- case 'n': OUT('\n');
- case 't': OUT('\n');
- case 'r': OUT('\r');
- case 'f': OUT('\f');
- case '0': OUT('\0');
+ case 'n': OUT ('\n');
+ case 't': OUT ('\n');
+ case 'r': OUT ('\r');
+ case 'f': OUT ('\f');
+ case '0': OUT ('\0');
case 'X':
{
long Code;
- fprintf(stderr,
- "%s: File is not Portable. Character Code Found.\n",
- program_name);
- fscanf(portable_file, "%ld", &Code);
- getc(portable_file); /* Space */
- OUT(Code);
+ fprintf (stderr,
+ "%s: File is not Portable. Character Code Found.\n",
+ program_name);
+ fscanf (portable_file, "%ld", &Code);
+ getc (portable_file); /* Space */
+ OUT (Code);
}
- case '\\': OUT('\\');
- default : OUT(C);
+ case '\\': OUT ('\\');
+ default : OUT (C);
}
}
\f
SCHEME_OBJECT *
-read_a_string_internal(To, maxlen)
- SCHEME_OBJECT *To;
- long maxlen;
+DEFUN (read_a_string_internal, (To, maxlen),
+ SCHEME_OBJECT *To AND
+ long maxlen)
{
long ilen, Pointer_Count;
fast char *str;
fast long len;
str = ((char *) (&To[STRING_CHARS]));
- fscanf(portable_file, "%ld", &ilen);
+ fscanf (portable_file, "%ld", &ilen);
len = ilen;
if (maxlen == -1)
maxlen += 1;
- Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
+ Pointer_Count = STRING_CHARS + (char_to_pointer (maxlen));
To[STRING_HEADER] =
- MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
+ (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1)));
To[STRING_LENGTH_INDEX] = ((SCHEME_OBJECT) len);
/* Space */
- getc(portable_file);
+ getc (portable_file);
while (--len >= 0)
{
- *str++ = ((char) read_a_char());
+ *str++ = ((char) read_a_char ());
}
*str = '\0';
return (To + Pointer_Count);
}
SCHEME_OBJECT *
-read_a_string(To, Slot)
- SCHEME_OBJECT *To, *Slot;
+DEFUN (read_a_string, (To, Slot),
+ SCHEME_OBJECT *To AND
+ SCHEME_OBJECT *Slot)
{
long maxlen;
- *Slot = MAKE_POINTER_OBJECT(TC_CHARACTER_STRING, To);
- fscanf(portable_file, "%ld", &maxlen);
- return (read_a_string_internal(To, maxlen));
+ *Slot = (MAKE_POINTER_OBJECT (TC_CHARACTER_STRING, To));
+ fscanf (portable_file, "%ld", &maxlen);
+ return (read_a_string_internal (To, maxlen));
}
\f
/*
#define read_hex_digit(var) \
{ \
- fscanf(portable_file, "%1lx", &var); \
+ fscanf (portable_file, "%1lx", &var); \
}
#else
#define VMS_BUG(stmt) stmt
-#define read_hex_digit(var) \
+#define read_hex_digit (var) \
{ \
- var = read_hex_digit_procedure(); \
+ var = (read_hex_digit_procedure ()); \
}
long
-read_hex_digit_procedure()
+read_hex_digit_procedure ()
{
long digit;
int c;
- while ((c = fgetc(portable_file)) == ' ')
+ while ((c = fgetc (portable_file)) == ' ')
{};
digit = ((c >= 'a') ? (c - 'a' + 10)
: ((c >= 'A') ? (c - 'A' + 10)
: ((c >= '0') ? (c - '0')
- : fprintf(stderr, "Losing big: %d\n", c))));
+ : fprintf (stderr, "Losing big: %d\n", c))));
return (digit);
}
#endif
\f
SCHEME_OBJECT *
-read_an_integer(The_Type, To, Slot)
- int The_Type;
- SCHEME_OBJECT *To;
- SCHEME_OBJECT *Slot;
+DEFUN (read_an_integer, (The_Type, To, Slot),
+ int The_Type AND
+ SCHEME_OBJECT *To AND
+ SCHEME_OBJECT *Slot)
{
Boolean negative;
fast long length_in_bits;
- getc(portable_file); /* Space */
- negative = ((getc(portable_file)) == '-');
+ getc (portable_file); /* Space */
+ negative = ((getc (portable_file)) == '-');
{
long l;
fscanf (portable_file, "%ld", (&l));
if (length_in_bits != 0)
{
- for(Normalization = 0,
- ndigits = hex_digits(length_in_bits);
+ for (Normalization = 0,
+ ndigits = hex_digits (length_in_bits);
--ndigits >= 0;
Normalization += 4)
{
- read_hex_digit(digit);
+ read_hex_digit (digit);
Value += (digit << Normalization);
}
}
{
Value = -Value;
}
- *Slot = LONG_TO_FIXNUM(Value);
+ *Slot = (LONG_TO_FIXNUM (Value));
return (To);
}
else if (length_in_bits == 0)
}
\f
SCHEME_OBJECT *
-read_a_bit_string(To, Slot)
- SCHEME_OBJECT *To, *Slot;
+DEFUN (read_a_bit_string, (To, Slot),
+ SCHEME_OBJECT *To AND
+ SCHEME_OBJECT *Slot)
{
long size_in_bits, size_in_words;
SCHEME_OBJECT the_bit_string;
- fscanf(portable_file, "%ld", &size_in_bits);
+ fscanf (portable_file, "%ld", &size_in_bits);
size_in_words = (1 + (BIT_STRING_LENGTH_TO_GC_LENGTH (size_in_bits)));
- the_bit_string = MAKE_POINTER_OBJECT (TC_BIT_STRING, To);
- *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words);
+ the_bit_string = (MAKE_POINTER_OBJECT (TC_BIT_STRING, To));
+ *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, size_in_words));
*To = size_in_bits;
To += size_in_words;
accumulator = 0;
bits_accumulated = 0;
- scan = BIT_STRING_LOW_PTR(the_bit_string);
- for(bits_remaining = size_in_bits;
+ scan = (BIT_STRING_LOW_PTR (the_bit_string));
+ for (bits_remaining = size_in_bits;
bits_remaining > 0;
bits_remaining -= 4)
{
- read_hex_digit(temp);
+ read_hex_digit (temp);
if ((bits_accumulated + 4) > OBJECT_LENGTH)
{
accumulator |=
- ((temp & LOW_MASK(OBJECT_LENGTH - bits_accumulated)) <<
+ ((temp & LOW_MASK (OBJECT_LENGTH - bits_accumulated)) <<
bits_accumulated);
- *(INC_BIT_STRING_PTR(scan)) = accumulator;
+ *(INC_BIT_STRING_PTR (scan)) = accumulator;
accumulator = (temp >> (OBJECT_LENGTH - bits_accumulated));
bits_accumulated -= (OBJECT_LENGTH - 4);
- temp &= LOW_MASK(bits_accumulated);
+ temp &= LOW_MASK (bits_accumulated);
}
else
{
}
if (bits_accumulated != 0)
{
- *(INC_BIT_STRING_PTR(scan)) = accumulator;
+ *(INC_BIT_STRING_PTR (scan)) = accumulator;
}
}
*Slot = the_bit_string;
static double the_max = 0.0;
#define dflmin() 0.0 /* Cop out */
-#define dflmax() ((the_max == 0.0) ? compute_max() : the_max)
+#define dflmax() ((the_max == 0.0) ? (compute_max ()) : the_max)
double
-compute_max()
+DEFUN_VOID (compute_max)
{
fast double Result;
fast int expt;
expt != 0;
expt >>= 1)
{
- Result += ldexp(1.0, expt);
+ Result += (ldexp (1.0, expt));
}
the_max = Result;
return (Result);
}
\f
long
-read_signed_decimal (stream)
- fast FILE * stream;
+DEFUN (read_signed_decimal, (stream),
+ fast FILE *stream)
{
fast int c = (getc (stream));
fast long result = (-1);
int negative_p = 0;
while (c == ' ')
+ {
c = (getc (stream));
+ }
if (c == '-')
- {
- negative_p = 1;
- c = (getc (stream));
- }
+ {
+ negative_p = 1;
+ c = (getc (stream));
+ }
else if (c == '+')
+ {
c = (getc (stream));
+ }
if ((c >= '0') && (c <= '9'))
+ {
+ result = (c - '0');
+ c = (getc (stream));
+ while ((c >= '0') && (c <= '9'))
{
- result = (c - '0');
+ result = ((result * 10) + (c - '0'));
c = (getc (stream));
- while ((c >= '0') && (c <= '9'))
- {
- result = ((result * 10) + (c - '0'));
- c = (getc (stream));
- }
}
+ }
if (c != EOF)
+ {
ungetc (c, stream);
+ }
if (result == (-1))
- {
- fprintf (stderr, "%s: Unable to read expected decimal integer\n",
- program_name);
- inconsistency ();
- }
+ {
+ fprintf (stderr, "%s: Unable to read expected decimal integer\n",
+ program_name);
+ inconsistency ();
+ }
return (negative_p ? (-result) : result);
}
\f
double
-read_a_flonum ()
+DEFUN_VOID (read_a_flonum)
{
Boolean negative;
long exponent;
{
int c = (getc (portable_file));
if (c == '\n')
+ {
return (0);
+ }
ungetc (c, portable_file);
}
size_in_bits = (read_signed_decimal (portable_file));
if (size_in_bits == 0)
+ {
return (0);
+ }
if ((exponent > DBL_MAX_EXP) || (exponent < DBL_MIN_EXP))
{
/* Skip over mantissa */
- while (getc(portable_file) != '\n')
+ while ((getc (portable_file)) != '\n')
{};
- fprintf(stderr,
- "%s: Floating point exponent too %s!\n",
- program_name,
- ((exponent < 0) ? "small" : "large"));
- Result = ((exponent < 0) ? dflmin() : dflmax());
+ fprintf (stderr,
+ "%s: Floating point exponent too %s!\n",
+ program_name,
+ ((exponent < 0) ? "small" : "large"));
+ Result = ((exponent < 0) ? (dflmin ()) : (dflmax ()));
}
else
{
if (size_in_bits > DBL_MANT_DIG)
{
- fprintf(stderr,
- "%s: Some precision may be lost.",
- program_name);
+ fprintf (stderr,
+ "%s: Some precision may be lost.",
+ program_name);
}
- getc(portable_file); /* Space */
- for (ndigits = hex_digits(size_in_bits),
+ getc (portable_file); /* Space */
+ for (ndigits = (hex_digits (size_in_bits)),
Result = 0.0,
Normalization = (1.0 / 16.0);
--ndigits >= 0;
Normalization /= 16.0)
{
- read_hex_digit(digit);
+ read_hex_digit (digit);
Result += (((double ) digit) * Normalization);
}
- Result = ldexp(Result, ((int) exponent));
+ Result = (ldexp (Result, ((int) exponent)));
}
if (negative)
{
}
\f
SCHEME_OBJECT *
-Read_External(N, Table, To)
- long N;
- fast SCHEME_OBJECT *Table, *To;
+DEFUN (Read_External, (N, Table, To),
+ long N AND
+ fast SCHEME_OBJECT *Table AND
+ SCHEME_OBJECT *To)
{
fast SCHEME_OBJECT *Until = &Table[N];
int The_Type;
while (Table < Until)
{
- fscanf(portable_file, "%2x", &The_Type);
- switch(The_Type)
+ fscanf (portable_file, "%2x", &The_Type);
+ switch (The_Type)
{
case TC_CHARACTER_STRING:
- To = read_a_string(To, Table++);
+ To = (read_a_string (To, Table++));
continue;
case TC_BIT_STRING:
- To = read_a_bit_string(To, Table++);
+ To = (read_a_bit_string (To, Table++));
continue;
case TC_FIXNUM:
case TC_BIG_FIXNUM:
- To = read_an_integer(The_Type, To, Table++);
+ To = (read_an_integer (The_Type, To, Table++));
continue;
case TC_CHARACTER:
{
long the_char_code;
- getc(portable_file); /* Space */
- VMS_BUG(the_char_code = 0);
- fscanf( portable_file, "%3lx", &the_char_code);
- *Table++ = MAKE_OBJECT (TC_CHARACTER, the_char_code);
+ getc (portable_file); /* Space */
+ VMS_BUG (the_char_code = 0);
+ fscanf (portable_file, "%3lx", &the_char_code);
+ *Table++ = (MAKE_OBJECT (TC_CHARACTER, the_char_code));
continue;
}
\f
case TC_BIG_FLONUM:
{
- double The_Flonum = read_a_flonum();
+ double The_Flonum = (read_a_flonum ());
ALIGN_FLOAT (To);
- *Table++ = MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To);
- *To++ = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer));
+ *Table++ = (MAKE_POINTER_OBJECT (TC_BIG_FLONUM, To));
+ *To++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (float_to_pointer)));
*((double *) To) = The_Flonum;
To += float_to_pointer;
continue;
}
default:
- fprintf(stderr,
- "%s: Unknown external object found; Type = 0x%02x\n",
- program_name, The_Type);
- inconsistency();
+ fprintf (stderr,
+ "%s: Unknown external object found; Type = 0x%02x\n",
+ program_name, The_Type);
+ inconsistency ();
/*NOTREACHED*/
}
}
#if false
void
-Move_Memory(From, N, To)
- fast SCHEME_OBJECT *From, *To;
- long N;
+DEFUN (Move_Memory, (From, N, To),
+ fast SCHEME_OBJECT *From AND
+ long N AND
+ SCHEME_OBJECT *To)
+
{
fast SCHEME_OBJECT *Until;
#endif
void
-Relocate_Objects(from, how_many, disp)
- fast SCHEME_OBJECT *from;
- fast long disp;
- long how_many;
+DEFUN (Relocate_Objects, (from, how_many, disp),
+ fast SCHEME_OBJECT *from AND
+ long how_many AND
+ fast long disp)
{
fast SCHEME_OBJECT *Until;
Until = &from[how_many];
while (from < Until)
{
- switch(OBJECT_TYPE (*from))
+ switch (OBJECT_TYPE (*from))
{
case TC_FIXNUM:
case TC_CHARACTER:
case TC_BIG_FLONUM:
case TC_CHARACTER_STRING:
*from++ ==
- (OBJECT_NEW_DATUM ((*from), (disp + OBJECT_DATUM (*from))));
+ (OBJECT_NEW_DATUM ((*from), (disp + (OBJECT_DATUM (*from)))));
break;
default:
- fprintf(stderr,
- "%s: Unknown External Object Reference with Type 0x%02x",
- program_name,
- OBJECT_TYPE (*from));
- inconsistency();
+ fprintf (stderr,
+ "%s: Unknown External Object Reference with Type 0x%02x",
+ program_name,
+ (OBJECT_TYPE (*from)));
+ inconsistency ();
}
}
return;
static SCHEME_OBJECT *Relocate_Temp;
#define Relocate(Addr) \
- (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
+ (Relocate_Into (Relocate_Temp, Addr), Relocate_Temp)
#endif
\f
SCHEME_OBJECT *
-Read_Pointers_and_Relocate(how_many, to)
- fast long how_many;
- fast SCHEME_OBJECT *to;
+DEFUN (Read_Pointers_and_Relocate, (how_many, to),
+ fast long how_many AND
+ fast SCHEME_OBJECT *to)
{
int The_Type;
long The_Datum;
ALIGN_FLOAT (to);
#endif
- while (--how_many >= 0)
+ while ((--how_many) >= 0)
{
- VMS_BUG(The_Type = 0);
- VMS_BUG(The_Datum = 0);
- fscanf(portable_file, "%2x %lx", &The_Type, &The_Datum);
- switch(The_Type)
+ VMS_BUG (The_Type = 0);
+ VMS_BUG (The_Datum = 0);
+ fscanf (portable_file, "%2x %lx", &The_Type, &The_Datum);
+ switch (The_Type)
{
case CONSTANT_CODE:
*to++ = Constant_Table[The_Datum];
continue;
case TC_MANIFEST_NM_VECTOR:
- *to++ = MAKE_OBJECT (The_Type, The_Datum);
+ *to++ = (MAKE_OBJECT (The_Type, The_Datum));
{
fast long count;
how_many -= count;
while (--count >= 0)
{
- VMS_BUG(*to = 0);
- fscanf(portable_file, "%lx", to++);
+ VMS_BUG (*to = 0);
+ fscanf (portable_file, "%lx", to++);
}
}
continue;
SCHEME_OBJECT *temp;
long base_type, base_datum;
- fscanf(portable_file, "%02x %lx", &base_type, &base_datum);
- temp = Relocate(base_datum);
+ fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
+ temp = (Relocate (base_datum));
*to++ =
(MAKE_POINTER_OBJECT
(base_type, ((SCHEME_OBJECT *) (&(((char *) temp)[The_Datum])))));
case TC_BROKEN_HEART:
if (The_Datum != 0)
{
- fprintf(stderr, "%s: Broken Heart found.\n", program_name);
- inconsistency();
+ fprintf (stderr, "%s: Broken Heart found.\n", program_name);
+ inconsistency ();
}
/* fall through */
case TC_PRIMITIVE:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_simple_Non_Pointer:
- *to++ = MAKE_OBJECT (The_Type, The_Datum);
+ *to++ = (MAKE_OBJECT (The_Type, The_Datum));
continue;
case TC_MANIFEST_CLOSURE:
case TC_LINKAGE_SECTION:
{
- fprintf(stderr, "%s: File contains linked compiled code.\n",
- program_name);
- inconsistency();
+ fprintf (stderr, "%s: File contains linked compiled code.\n",
+ program_name);
+ inconsistency ();
}
case TC_REFERENCE_TRAP:
if (The_Datum <= TRAP_MAX_IMMEDIATE)
{
- *to++ = MAKE_OBJECT (The_Type, The_Datum);
+ *to++ = (MAKE_OBJECT (The_Type, The_Datum));
continue;
}
/* It is a pointer, fall through. */
default:
/* Should be stricter */
- *to++ = MAKE_POINTER_OBJECT (The_Type, Relocate(The_Datum));
+ *to++ = (MAKE_POINTER_OBJECT (The_Type, Relocate (The_Datum)));
continue;
}
}
static Boolean primitive_warn = false;
SCHEME_OBJECT *
-read_primitives(how_many, where)
- fast long how_many;
- fast SCHEME_OBJECT *where;
+DEFUN (read_primitives, (how_many, where),
+ fast long how_many AND
+ fast SCHEME_OBJECT *where)
{
long arity;
while (--how_many >= 0)
{
- fscanf(portable_file, "%ld", &arity);
+ fscanf (portable_file, "%ld", &arity);
if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
{
primitive_warn = true;
}
- *where++ = LONG_TO_FIXNUM(arity);
- where = read_a_string_internal(where, ((long) -1));
+ *where++ = (LONG_TO_FIXNUM (arity));
+ where = (read_a_string_internal (where, ((long) -1)));
}
return (where);
}
#ifdef DEBUG
void
-print_external_objects(area_name, Table, N)
- char *area_name;
- fast SCHEME_OBJECT *Table;
- fast long N;
+DEFUN (print_external_objects, (area_name, Table, N),
+ char *area_name AND
+ fast SCHEME_OBJECT *Table AND
+ fast long N)
{
fast SCHEME_OBJECT *Table_End = &Table[N];
- fprintf(stderr, "%s External Objects:\n", area_name);
- fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
+ fprintf (stderr, "%s External Objects:\n", area_name);
+ fprintf (stderr, "Table = 0x%x; N = %d\n", Table, N);
- for( ; Table < Table_End; Table++)
+ for ( ; Table < Table_End; Table++)
{
switch (OBJECT_TYPE (*Table))
{
case TC_FIXNUM:
{
- fprintf(stderr,
- "Table[%6d] = Fixnum %d\n",
- (N - (Table_End - Table)),
- (FIXNUM_TO_LONG (*Table)));
+ fprintf (stderr,
+ "Table[%6d] = Fixnum %d\n",
+ (N - (Table_End - Table)),
+ (FIXNUM_TO_LONG (*Table)));
break;
}
case TC_CHARACTER:
- fprintf(stderr,
- "Table[%6d] = Character %c = 0x%02x\n",
- (N - (Table_End - Table)),
- (OBJECT_DATUM (*Table)),
- (OBJECT_DATUM (*Table)));
+ fprintf (stderr,
+ "Table[%6d] = Character %c = 0x%02x\n",
+ (N - (Table_End - Table)),
+ (OBJECT_DATUM (*Table)),
+ (OBJECT_DATUM (*Table)));
break;
case TC_CHARACTER_STRING:
- fprintf(stderr,
- "Table[%6d] = string \"%s\"\n",
- (N - (Table_End - Table)),
- ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
+ fprintf (stderr,
+ "Table[%6d] = string \"%s\"\n",
+ (N - (Table_End - Table)),
+ ((char *) MEMORY_LOC (*Table, STRING_CHARS)));
break;
\f
case TC_BIG_FIXNUM:
- fprintf(stderr,
- "Table[%6d] = Bignum\n",
- (N - (Table_End - Table)));
+ fprintf (stderr,
+ "Table[%6d] = Bignum\n",
+ (N - (Table_End - Table)));
break;
case TC_BIG_FLONUM:
- fprintf(stderr,
- "Table[%6d] = Flonum %lf\n",
- (N - (Table_End - Table)),
- (* ((double *) MEMORY_LOC (*Table, 1))));
+ fprintf (stderr,
+ "Table[%6d] = Flonum %lf\n",
+ (N - (Table_End - Table)),
+ (* ((double *) MEMORY_LOC (*Table, 1))));
break;
default:
- fprintf(stderr,
- "Table[%6d] = Unknown External Object 0x%8x\n",
- (N - (Table_End - Table)),
- *Table);
+ fprintf (stderr,
+ "Table[%6d] = Unknown External Object 0x%8x\n",
+ (N - (Table_End - Table)),
+ *Table);
break;
}
}
#define DEBUGGING(action) action
-#define WHEN(condition, message) when(condition, message)
+#define WHEN(condition, message) when (condition, message)
void
-when(what, message)
- Boolean what;
- char *message;
+DEFUN (when, (what, message),
+ Boolean what AND
+ char *message)
{
if (what)
{
- fprintf(stderr, "%s: Inconsistency: %s!\n",
- program_name, (message));
- quit(1);
+ fprintf (stderr, "%s: Inconsistency: %s!\n",
+ program_name, (message));
+ quit (1);
}
return;
}
#define READ_HEADER(string, format, value) \
{ \
- fscanf(portable_file, format, &(value)); \
- fprintf(stderr, "%s: ", (string)); \
- fprintf(stderr, (format), (value)); \
- fprintf(stderr, "\n"); \
+ fscanf (portable_file, format, &(value)); \
+ fprintf (stderr, "%s: ", (string)); \
+ fprintf (stderr, (format), (value)); \
+ fprintf (stderr, "\n"); \
}
\f
#else /* not DEBUG */
#define READ_HEADER(string, format, value) \
{ \
- if (fscanf(portable_file, format, &(value)) == EOF) \
+ if (fscanf (portable_file, format, &(value)) == EOF) \
{ \
- short_header_read(); \
+ short_header_read (); \
} \
}
#endif /* DEBUG */
\f
void
-short_header_read()
+DEFUN_VOID (short_header_read)
{
- fprintf(stderr, "%s: Header is not complete!\n", program_name);
- quit(1);
+ fprintf (stderr, "%s: Header is not complete!\n", program_name);
+ quit (1);
}
+static SCHEME_OBJECT *Storage;
+
long
-Read_Header_and_Allocate()
+DEFUN_VOID (Read_Header_and_Allocate)
{
long
Portable_Version, Machine,
NPChars,
Size;
- READ_HEADER("Portable Version", "%ld", Portable_Version);
+#if 0
+ READ_HEADER ("Portable Version", "%ld", Portable_Version);
+#else
+ if (fscanf (portable_file, "%ld", &Portable_Version) == EOF)
+ {
+ return (-1);
+ }
+#endif
if (Portable_Version != PORTABLE_VERSION)
{
- fprintf(stderr, "%s: Portable version mismatch:\n", program_name);
- fprintf(stderr, "Portable File Version %4d\n", Portable_Version);
- fprintf(stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
- quit(1);
+ fprintf (stderr, "%s: Portable version mismatch:\n", program_name);
+ fprintf (stderr, "Portable File Version %4d\n", Portable_Version);
+ fprintf (stderr, "Expected: Version %4d\n", PORTABLE_VERSION);
+ quit (1);
}
- READ_HEADER("Machine", "%ld", Machine);
- READ_HEADER("Version", "%ld", Version);
- READ_HEADER("Sub Version", "%ld", Sub_Version);
+ READ_HEADER ("Machine", "%ld", Machine);
+ READ_HEADER ("Version", "%ld", Version);
+ READ_HEADER ("Sub Version", "%ld", Sub_Version);
if ((Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
- fprintf(stderr, "%s: Binary version mismatch:\n", program_name);
- fprintf(stderr,
- "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
- Portable_Version, Version, Sub_Version);
- fprintf(stderr,
- "Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
- PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
- quit(1);
+ fprintf (stderr, "%s: Binary version mismatch:\n", program_name);
+ fprintf (stderr,
+ "Portable File Version %4d; Binary Version %4d; Subversion %4d\n",
+ Portable_Version, Version, Sub_Version);
+ fprintf (stderr,
+ "Expected: Version %4d; Binary Version %4d; Subversion %4d\n",
+ PORTABLE_VERSION, FASL_FORMAT_VERSION, FASL_SUBVERSION);
+ quit (1);
}
\f
- READ_HEADER("Flags", "%ld", Flags);
- READ_FLAGS(Flags);
+ READ_HEADER ("Flags", "%ld", Flags);
+ READ_FLAGS (Flags);
if (((compiled_p && (! allow_compiled_p)) ||
(nmv_p && (! allow_nmv_p))) &&
{
if (compiled_p)
{
- fprintf(stderr, "%s: %s\n", program_name,
- "Portable file contains \"non-portable\" compiled code.");
+ fprintf (stderr, "%s: %s\n", program_name,
+ "Portable file contains \"non-portable\" compiled code.");
}
else
{
- fprintf(stderr, "%s: %s\n", program_name,
- "Portable file contains \"unexpected\" non-marked vectors.");
+ fprintf (stderr, "%s: %s\n", program_name,
+ "Portable file contains \"unexpected\" non-marked vectors.");
}
- fprintf(stderr, "Machine specified in the portable file: %4d\n",
- Machine);
- fprintf(stderr, "Machine Expected: %4d\n",
- FASL_INTERNAL_FORMAT);
- quit(1);
+ fprintf (stderr, "Machine specified in the portable file: %4d\n",
+ Machine);
+ fprintf (stderr, "Machine Expected: %4d\n",
+ FASL_INTERNAL_FORMAT);
+ quit (1);
}
\f
- READ_HEADER("Heap Count", "%ld", Heap_Count);
- READ_HEADER("Dumped Heap Base", "%ld", Dumped_Heap_Base);
- READ_HEADER("Heap Objects", "%ld", Heap_Objects);
-
- READ_HEADER("Constant Count", "%ld", Constant_Count);
- READ_HEADER("Dumped Constant Base", "%ld", Dumped_Constant_Base);
- READ_HEADER("Constant Objects", "%ld", Constant_Objects);
-
- READ_HEADER("Pure Count", "%ld", Pure_Count);
- READ_HEADER("Dumped Pure Base", "%ld", Dumped_Pure_Base);
- READ_HEADER("Pure Objects", "%ld", Pure_Objects);
-
- READ_HEADER("& Dumped Object", "%ld", Dumped_Object_Addr);
-
- READ_HEADER("Number of flonums", "%ld", NFlonums);
- READ_HEADER("Number of integers", "%ld", NIntegers);
- READ_HEADER("Number of bits in integers", "%ld", NBits);
- READ_HEADER("Number of bit strings", "%ld", NBitstrs);
- READ_HEADER("Number of bits in bit strings", "%ld", NBBits);
- READ_HEADER("Number of character strings", "%ld", NStrings);
- READ_HEADER("Number of characters in strings", "%ld", NChars);
-
- READ_HEADER("Primitive Table Length", "%ld", Primitive_Table_Length);
- READ_HEADER("Number of characters in primitives", "%ld", NPChars);
-
- READ_HEADER("CPU type", "%ld", compiler_processor_type);
- READ_HEADER("Compiled code interface version", "%ld",
- compiler_interface_version);
+ READ_HEADER ("Heap Count", "%ld", Heap_Count);
+ READ_HEADER ("Dumped Heap Base", "%ld", Dumped_Heap_Base);
+ READ_HEADER ("Heap Objects", "%ld", Heap_Objects);
+
+ READ_HEADER ("Constant Count", "%ld", Constant_Count);
+ READ_HEADER ("Dumped Constant Base", "%ld", Dumped_Constant_Base);
+ READ_HEADER ("Constant Objects", "%ld", Constant_Objects);
+
+ READ_HEADER ("Pure Count", "%ld", Pure_Count);
+ READ_HEADER ("Dumped Pure Base", "%ld", Dumped_Pure_Base);
+ READ_HEADER ("Pure Objects", "%ld", Pure_Objects);
+
+ READ_HEADER ("& Dumped Object", "%ld", Dumped_Object_Addr);
+
+ READ_HEADER ("Number of flonums", "%ld", NFlonums);
+ READ_HEADER ("Number of integers", "%ld", NIntegers);
+ READ_HEADER ("Number of bits in integers", "%ld", NBits);
+ READ_HEADER ("Number of bit strings", "%ld", NBitstrs);
+ READ_HEADER ("Number of bits in bit strings", "%ld", NBBits);
+ READ_HEADER ("Number of character strings", "%ld", NStrings);
+ READ_HEADER ("Number of characters in strings", "%ld", NChars);
+
+ READ_HEADER ("Primitive Table Length", "%ld", Primitive_Table_Length);
+ READ_HEADER ("Number of characters in primitives", "%ld", NPChars);
+
+ READ_HEADER ("CPU type", "%ld", compiler_processor_type);
+ READ_HEADER ("Compiled code interface version", "%ld",
+ compiler_interface_version);
#if false
- READ_HEADER("Compiler utilities vector", "%ld", compiler_utilities);
+ READ_HEADER ("Compiler utilities vector", "%ld", compiler_utilities);
#endif
Size = (6 + /* SNMV */
Heap_Count + Heap_Objects +
Constant_Count + Constant_Objects +
Pure_Count + Pure_Objects +
- flonum_to_pointer(NFlonums) +
+ flonum_to_pointer (NFlonums) +
((NIntegers * (2 + (BYTES_TO_WORDS (sizeof (bignum_digit_type))))) +
(BYTES_TO_WORDS (BIGNUM_BITS_TO_DIGITS (NBits)))) +
((NStrings * (1 + STRING_CHARS)) +
- (char_to_pointer(NChars))) +
+ (char_to_pointer (NChars))) +
((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (BIT_STRING_LENGTH_TO_GC_LENGTH(NBBits))) +
+ (BIT_STRING_LENGTH_TO_GC_LENGTH (NBBits))) +
((Primitive_Table_Length * (2 + STRING_CHARS)) +
- (char_to_pointer(NPChars))));
+ (char_to_pointer (NPChars))));
ALLOCATE_HEAP_SPACE (Size);
if (Heap == NULL)
{
- fprintf(stderr,
- "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
- program_name, Size);
- quit(1);
+ fprintf (stderr,
+ "%s: Memory Allocation Failed. Size = %ld Scheme Objects\n",
+ program_name, Size);
+ quit (1);
}
+ Storage = Heap;
Heap += (TRAP_MAX_IMMEDIATE + 1);
return (Size - (TRAP_MAX_IMMEDIATE + 1));
}
\f
void
-do_it()
+DEFUN_VOID (do_it)
{
- SCHEME_OBJECT *primitive_table_end;
- Boolean result;
- long Size;
+ while (1)
+ {
+ SCHEME_OBJECT *primitive_table_end;
+ Boolean result;
+ long Size;
- allow_nmv_p = (allow_nmv_p || allow_compiled_p);
- Size = Read_Header_and_Allocate();
+ Size = (Read_Header_and_Allocate ());
+ if (Size < 0)
+ {
+ return;
+ }
- Stack_Top = &Heap[Size];
+ Stack_Top = &Heap[Size];
- Heap_Table = &Heap[0];
- Heap_Base = &Heap_Table[Heap_Objects];
- ALIGN_FLOAT (Heap_Base);
- Heap_Object_Base =
- Read_External(Heap_Objects, Heap_Table, Heap_Base);
+ Heap_Table = &Heap[0];
+ Heap_Base = &Heap_Table[Heap_Objects];
+ ALIGN_FLOAT (Heap_Base);
+ Heap_Object_Base =
+ Read_External (Heap_Objects, Heap_Table, Heap_Base);
- /* The various 2s below are for SNMV headers. */
+ /* The various 2s below are for SNMV headers. */
- Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2];
- Pure_Object_Base =
- Read_External(Pure_Objects, Pure_Table, Pure_Base);
+ Pure_Table = &Heap_Object_Base[Heap_Count];
+ Pure_Base = &Pure_Table[Pure_Objects + 2];
+ Pure_Object_Base =
+ Read_External (Pure_Objects, Pure_Table, Pure_Base);
- Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2];
- Constant_Object_Base =
- Read_External(Constant_Objects, Constant_Table, Constant_Base);
+ Constant_Table = &Heap[Size - Constant_Objects];
+ Constant_Base = &Pure_Object_Base[Pure_Count + 2];
+ Constant_Object_Base =
+ Read_External (Constant_Objects, Constant_Table, Constant_Base);
- primitive_table = &Constant_Object_Base[Constant_Count + 2];
+ primitive_table = &Constant_Object_Base[Constant_Count + 2];
- WHEN((primitive_table > Constant_Table),
- "primitive_table overran Constant_Table");
+ WHEN ((primitive_table > Constant_Table),
+ "primitive_table overran Constant_Table");
- DEBUGGING(print_external_objects("Heap", Heap_Table, Heap_Objects));
- DEBUGGING(print_external_objects("Pure", Pure_Table, Pure_Objects));
- DEBUGGING(print_external_objects("Constant",
- Constant_Table,
- Constant_Objects));
+ DEBUGGING (print_external_objects ("Heap", Heap_Table, Heap_Objects));
+ DEBUGGING (print_external_objects ("Pure", Pure_Table, Pure_Objects));
+ DEBUGGING (print_external_objects ("Constant",
+ Constant_Table,
+ Constant_Objects));
\f
- /* Read the normal objects */
+ /* Read the normal objects */
- Free =
- Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
+ Free =
+ Read_Pointers_and_Relocate (Heap_Count, Heap_Object_Base);
- WHEN((Free > Pure_Table),
- "Free overran Pure_Table");
- WHEN((Free < Pure_Table),
- "Free did not reach Pure_Table");
+ WHEN ((Free > Pure_Table),
+ "Free overran Pure_Table");
+ WHEN ((Free < Pure_Table),
+ "Free did not reach Pure_Table");
- Free_Pure =
- Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
+ Free_Pure =
+ Read_Pointers_and_Relocate (Pure_Count, Pure_Object_Base);
- WHEN((Free_Pure > (Constant_Base - 2)),
- "Free_Pure overran Constant_Base");
- WHEN((Free_Pure < (Constant_Base - 2)),
- "Free_Pure did not reach Constant_Base");
+ WHEN ((Free_Pure > (Constant_Base - 2)),
+ "Free_Pure overran Constant_Base");
+ WHEN ((Free_Pure < (Constant_Base - 2)),
+ "Free_Pure did not reach Constant_Base");
- Free_Constant =
- Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
+ Free_Constant =
+ Read_Pointers_and_Relocate (Constant_Count, Constant_Object_Base);
- WHEN((Free_Constant > (primitive_table - 2)),
- "Free_Constant overran primitive_table");
- WHEN((Free_Constant < (primitive_table - 2)),
- "Free_Constant did not reach primitive_table");
+ WHEN ((Free_Constant > (primitive_table - 2)),
+ "Free_Constant overran primitive_table");
+ WHEN ((Free_Constant < (primitive_table - 2)),
+ "Free_Constant did not reach primitive_table");
- primitive_table_end =
- read_primitives(Primitive_Table_Length, primitive_table);
+ primitive_table_end =
+ read_primitives (Primitive_Table_Length, primitive_table);
- /*
- primitive_table_end can be well below Constant_Table, since
- the memory allocation is conservative (it rounds up), and all
- the slack ends up between them.
- */
+ /*
+ primitive_table_end can be well below Constant_Table, since
+ the memory allocation is conservative (it rounds up), and all
+ the slack ends up between them.
+ */
- WHEN((primitive_table_end > Constant_Table),
- "primitive_table_end overran Constant_Table");
+ WHEN ((primitive_table_end > Constant_Table),
+ "primitive_table_end overran Constant_Table");
- if (primitive_warn)
- {
- fprintf(stderr, "%s:\n", program_name);
- fprintf(stderr,
- "NOTE: The binary file contains primitives with unknown arity.\n");
- }
+ if (primitive_warn)
+ {
+ fprintf (stderr, "%s:\n", program_name);
+ fprintf (stderr,
+ "NOTE: The binary file contains primitives with unknown arity.\n");
+ }
\f
- /* Dump the objects */
+ /* Dump the objects */
{
SCHEME_OBJECT *Dumped_Object;
- Relocate_Into(Dumped_Object, Dumped_Object_Addr);
-
- DEBUGGING(fprintf(stderr, "Dumping:\n"));
- DEBUGGING(fprintf(stderr,
- "Heap = 0x%x; Heap Count = %d\n",
- Heap_Base, (Free - Heap_Base)));
- DEBUGGING(fprintf(stderr,
- "Pure Space = 0x%x; Pure Count = %d\n",
- Pure_Base, (Free_Pure - Pure_Base)));
- DEBUGGING(fprintf(stderr,
- "Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base)));
- DEBUGGING(fprintf(stderr,
- "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object));
- DEBUGGING(fprintf(stderr, "Primitive_Table_Length = %ld; ",
- Primitive_Table_Length));
- DEBUGGING(fprintf(stderr, "Primitive_Table_Size = %ld\n",
- (primitive_table_end - primitive_table)));
+ Relocate_Into (Dumped_Object, Dumped_Object_Addr);
+
+ DEBUGGING (fprintf (stderr, "Dumping:\n"));
+ DEBUGGING (fprintf (stderr,
+ "Heap = 0x%x; Heap Count = %d\n",
+ Heap_Base, (Free - Heap_Base)));
+ DEBUGGING (fprintf (stderr,
+ "Pure Space = 0x%x; Pure Count = %d\n",
+ Pure_Base, (Free_Pure - Pure_Base)));
+ DEBUGGING (fprintf (stderr,
+ "Constant Space = 0x%x; Constant Count = %d\n",
+ Constant_Base, (Free_Constant - Constant_Base)));
+ DEBUGGING (fprintf (stderr,
+ "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
+ Dumped_Object, *Dumped_Object));
+ DEBUGGING (fprintf (stderr, "Primitive_Table_Length = %ld; ",
+ Primitive_Table_Length));
+ DEBUGGING (fprintf (stderr, "Primitive_Table_Size = %ld\n",
+ (primitive_table_end - primitive_table)));
\f
/* Is there a Pure/Constant block? */
if ((Constant_Objects == 0) && (Constant_Count == 0) &&
(Pure_Objects == 0) && (Pure_Count == 0))
{
- result = Write_File(Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- 0, Stack_Top,
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- compiled_p, band_p);
+ result = Write_File (Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ 0, Stack_Top,
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p);
}
else
{
Free_Constant[1] =
MAKE_OBJECT (END_OF_BLOCK, Total_Length);
- result = Write_File(Dumped_Object,
- (Free - Heap_Base), Heap_Base,
- Total_Length, (Pure_Base - 2),
- primitive_table, Primitive_Table_Length,
- ((long) (primitive_table_end - primitive_table)),
- compiled_p, band_p);
+ result = (Write_File (Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ Total_Length, (Pure_Base - 2),
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)),
+ compiled_p, band_p));
}
}
- if (!result)
- {
- fprintf(stderr, "%s: Error writing the output file.\n", program_name);
- quit(1);
+ if (!result)
+ {
+ fprintf (stderr, "%s: Error writing the output file.\n", program_name);
+ quit (1);
+ }
+ free ((char *) Storage);
}
- return;
}
\f
/* Top level */
static struct keyword_struct
options[] = {
- KEYWORD("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
- KEYWORD("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
- OUTPUT_KEYWORD(),
- INPUT_KEYWORD(),
- END_KEYWORD()
+ KEYWORD ("allow_nmv", &allow_nmv_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("allow_cc", &allow_compiled_p, BOOLEAN_KYWRD, BFRMT, NULL),
+ KEYWORD ("help", &help_p, BOOLEAN_KYWRD, BFRMT, &help_sup_p),
+ OUTPUT_KEYWORD (),
+ INPUT_KEYWORD (),
+ END_KEYWORD ()
};
-main(argc, argv)
- int argc;
- char *argv[];
+DEFUN (main, (argc, argv),
+ int argc AND
+ char **argv)
{
- parse_keywords(argc, argv, options, false);
+ parse_keywords (argc, argv, options, false);
if (help_sup_p && help_p)
{
- print_usage_and_exit(options, 0);
+ print_usage_and_exit (options, 0);
/*NOTREACHED*/
}
- setup_io();
- do_it();
- quit(0);
+ allow_nmv_p = (allow_nmv_p || allow_compiled_p);
+
+ setup_io ();
+ do_it ();
+ quit (0);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.38 1990/10/03 16:49:32 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.39 1990/11/21 07:04:43 jinx Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
/* The following are not used in the 68000 implementation */
#define RC_POP_RETURN_ERROR 0x40
#define RC_EVAL_ERROR 0x41
-/* formerly #define RC_REPEAT_PRIMITIVE 0x42 */
+/* formerly RC_REPEAT_PRIMITIVE 0x42 */
#define RC_COMP_INTERRUPT_RESTART 0x43
/* formerly RC_COMP_RECURSION_GC 0x44 */
#define RC_RESTORE_INT_MASK 0x45
#define RC_HARDWARE_TRAP 0x5C
#define RC_INTERNAL_APPLY_VAL 0x5D
#define RC_COMP_ERROR_RESTART 0x5E
+#define RC_PRIMITIVE_CONTINUE 0x5F
/* When adding return codes, add them to the table below as well! */
-#define MAX_RETURN_CODE 0x5E
+#define MAX_RETURN_CODE 0x5F
\f
#define RETURN_NAME_TABLE \
{ \
/* 0x5B */ "COMPILER_LINK_CACHES_RESTART", \
/* 0x5C */ "HARDWARE_TRAP", \
/* 0x5D */ "INTERNAL_APPLY_VAL", \
-/* 0x5E */ "COMPILER_ERROR_RESTARRT" \
+/* 0x5E */ "COMPILER_ERROR_RESTARRT", \
+/* 0x5F */ "PRIMITIVE_CONTINUE" \
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.55 1990/11/15 23:18:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.56 1990/11/21 07:04:49 jinx Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 55
+#define SUBVERSION 56
#endif
projects / mit-scheme.git / commitdiff