From: Guillermo J. Rozas Date: Wed, 21 Nov 1990 07:04:49 +0000 (+0000) Subject: Fasload and Fasdump now handle channels as well as files. X-Git-Tag: 20090517-FFI~11027 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=0da83a974e109bf8a486722d867f5b3fede76e85;p=mit-scheme.git Fasload and Fasdump now handle channels as well as files. A primitive suspension mechanism has been implemented (prmcon.[ch]) and is used by fasload to continue if a GC is needed, rather than aborting and starting from scratch. --- diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index 3839fede6..1a33efb19 100644 --- a/v7/src/microcode/bchdmp.c +++ b/v7/src/microcode/bchdmp.c @@ -1,6 +1,6 @@ /* -*-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 @@ -38,7 +38,7 @@ MIT in each case. */ #include "scheme.h" #include "prims.h" -#include "osio.h" +#include "uxio.h" #include "osfile.h" #include "trap.h" #include "lookup.h" /* UNCOMPILED_VARIABLE */ @@ -50,16 +50,18 @@ static Tchannel dump_channel; #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; @@ -74,7 +76,7 @@ static Boolean compiled_code_present_p; #define fasdump_remember_to_fix(location, contents) \ { \ - if ((fixup == fixup_buffer) && (!reset_fixes())) \ + if ((fixup == fixup_buffer) && (!(reset_fixes ()))) \ { \ return (PRIM_INTERRUPT); \ } \ @@ -84,34 +86,34 @@ static Boolean compiled_code_present_p; #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 */ @@ -120,7 +122,8 @@ static Boolean compiled_code_present_p; 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); \ @@ -131,21 +134,21 @@ static Boolean compiled_code_present_p; #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 (); \ } #define fasdump_typeless_setup() \ @@ -157,7 +160,7 @@ static Boolean compiled_code_present_p; continue; \ } \ New_Address = ((SCHEME_OBJECT) To_Address); \ - fasdump_remember_to_fix(Old, *Old); \ + fasdump_remember_to_fix (Old, *Old); \ } #define fasdump_typeless_end() \ @@ -169,29 +172,29 @@ static Boolean compiled_code_present_p; #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) @@ -200,7 +203,7 @@ do { \ { \ Scan = ((SCHEME_OBJECT *) (word_ptr)); \ EXTRACT_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); \ - fasdump_compiled_entry(); \ + fasdump_compiled_entry (); \ STORE_OPERATOR_LINKAGE_ADDRESS (Temp, Scan); \ } @@ -208,44 +211,45 @@ do { \ { \ Scan = ((SCHEME_OBJECT *) (word_ptr)); \ EXTRACT_CLOSURE_ENTRY_ADDRESS (Temp, Scan); \ - fasdump_compiled_entry(); \ + fasdump_compiled_entry (); \ STORE_CLOSURE_ENTRY_ADDRESS (Temp, Scan); \ } 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; - + next_buffer: while (fixes != fixup_buffer_end) @@ -256,13 +260,13 @@ next_buffer: 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; @@ -271,16 +275,16 @@ next_buffer: } 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); } @@ -291,9 +295,10 @@ reset_fixes() /* 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; @@ -305,19 +310,19 @@ dumploop(Scan, To_ptr, To_Address_ptr) 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) @@ -327,7 +332,7 @@ dumploop(Scan, To_ptr, To_Address_ptr) /* 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); @@ -338,7 +343,7 @@ dumploop(Scan, To_ptr, To_Address_ptr) 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; @@ -348,10 +353,10 @@ dumploop(Scan, To_ptr, To_Address_ptr) 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) { @@ -362,17 +367,17 @@ dumploop(Scan, To_ptr, To_Address_ptr) case TC_PRIMITIVE: case TC_PCOMB0: - *Scan = dump_renumber_primitive(*Scan); + *Scan = (dump_renumber_primitive (*Scan)); break; 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. */ @@ -381,7 +386,7 @@ dumploop(Scan, To_ptr, To_Address_ptr) 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); @@ -389,12 +394,12 @@ dumploop(Scan, To_ptr, To_Address_ptr) 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; } } @@ -499,10 +504,10 @@ dumploop(Scan, To_ptr, To_Address_ptr) } 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; @@ -511,73 +516,73 @@ dumploop(Scan, To_ptr, To_Address_ptr) 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 (); } 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: @@ -592,26 +597,18 @@ end_dumploop: return (PRIM_DONE); } -/* (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); @@ -624,83 +621,151 @@ DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0) 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); } - + #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); + + 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); +} + +/* (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); } /* (DUMP-BAND PROCEDURE FILE-NAME) @@ -715,22 +780,23 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) 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; @@ -740,17 +806,21 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) 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; diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c index b4b9aa8d7..17ea1d754 100644 --- a/v7/src/microcode/bintopsb.c +++ b/v7/src/microcode/bintopsb.c @@ -1,8 +1,8 @@ /* -*-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 @@ -37,6 +37,7 @@ MIT in each case. */ /* IO definitions */ +#include "ansidecl.h" #include "psbmap.h" #include "trap.h" #include "limits.h" @@ -44,11 +45,14 @@ MIT in each case. */ #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 @@ -59,7 +63,7 @@ Load_Data(Count, To_Where) /* Character macros and procedures */ -extern int strlen(); +extern int strlen (); #ifndef isalpha @@ -78,8 +82,8 @@ static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!"; Boolean -ispunct(c) - fast char c; +DEFUN (ispunct, (c), + fast char c) { fast char *; @@ -108,6 +112,7 @@ static Boolean 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, @@ -140,9 +145,9 @@ static long } 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) { @@ -257,8 +262,8 @@ print_a_char(c, name) do_flonum_kernel (Code, Scn, Obj, FObj)) void -print_a_fixnum(val) - long val; +DEFUN (print_a_fixnum, (val), + long val) { fast long size_in_bits; fast unsigned long temp; @@ -290,9 +295,9 @@ print_a_fixnum(val) } 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) @@ -328,37 +333,38 @@ print_a_string_internal(len, str) } 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; } static long -bignum_length (bignum) - SCHEME_OBJECT bignum; +DEFUN (bignum_length, (bignum), + SCHEME_OBJECT bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); @@ -386,9 +392,13 @@ bignum_length (bignum) } 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", @@ -469,8 +479,8 @@ print_a_bignum (bignum) /* 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; @@ -527,8 +537,8 @@ print_a_bit_string(from) } void -print_a_flonum(val) - double val; +DEFUN (print_a_flonum, (val), + double val) { fast long size_in_bits; fast double mant, temp; @@ -781,8 +791,8 @@ print_a_flonum(val) } 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", @@ -797,8 +807,8 @@ out_of_range_pointer(ptr) } SCHEME_OBJECT * -relocate(object) - SCHEME_OBJECT object; +DEFUN (relocate, (object), + SCHEME_OBJECT object) { long the_datum; SCHEME_OBJECT *result; @@ -844,8 +854,8 @@ static Boolean 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; @@ -896,8 +906,8 @@ upgrade_primitive(prim) } 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; @@ -948,14 +958,16 @@ setup_primitive_upgrade(Heap) /* 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; @@ -1176,9 +1188,9 @@ Process_Area(Code, Area, Bound, Obj, FObj) /* 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) { @@ -1190,28 +1202,28 @@ print_external_objects(from, count) 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; @@ -1239,8 +1251,9 @@ print_external_objects(from, count) } 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; @@ -1288,9 +1301,9 @@ print_objects(from, to) #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) { @@ -1327,382 +1340,408 @@ when(what, message) /* 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); + } - 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); + } - 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)); - { - 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))); - /* 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; - /* 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 - /* 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"); - /* 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 - /* 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 - /* 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; } /* Top Level */ @@ -1717,34 +1756,47 @@ static Boolean 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); } diff --git a/v7/src/microcode/dump.c b/v7/src/microcode/dump.c index 768d3af7e..c350e48fb 100644 --- a/v7/src/microcode/dump.c +++ b/v7/src/microcode/dump.c @@ -1,8 +1,8 @@ /* -*-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 @@ -38,18 +38,22 @@ extern SCHEME_OBJECT compiler_utilities; 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; @@ -111,6 +115,7 @@ prepare_dump_header (Buffer, Dumped_Object, 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; @@ -119,18 +124,21 @@ prepare_dump_header (Buffer, Dumped_Object, } 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 (); @@ -165,14 +173,14 @@ Write_File (Dumped_Object, Heap_Count, Heap_Relocation, 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); @@ -180,7 +188,7 @@ Write_File (Dumped_Object, Heap_Count, Heap_Relocation, } if (Constant_Count != 0) { - if (Write_Data(Constant_Count, ((char *) Constant_Relocation)) != + if ((Write_Data (Constant_Count, Constant_Relocation)) != Constant_Count) { return (false); @@ -188,7 +196,8 @@ Write_File (Dumped_Object, Heap_Count, Heap_Relocation, } 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); } @@ -199,10 +208,10 @@ Write_File (Dumped_Object, Heap_Count, Heap_Relocation, 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; @@ -213,4 +222,4 @@ checksum_area (start, count, initial_value) } return (value); } - + diff --git a/v7/src/microcode/errors.h b/v7/src/microcode/errors.h index bdde6a679..65f0b6ff3 100644 --- a/v7/src/microcode/errors.h +++ b/v7/src/microcode/errors.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ -/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/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. * @@ -104,13 +104,14 @@ MIT in each case. */ #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 #define ERROR_NAME_TABLE \ { \ @@ -173,7 +174,8 @@ MIT in each case. */ /* 0x37 */ "IO-ERROR", \ /* 0x38 */ "FASDUMP-ENVIRONMENT", \ /* 0x39 */ "FASLOAD-BAND", \ -/* 0x3A */ "FASLOAD-COMPILED-MISMATCH" \ +/* 0x3A */ "FASLOAD-COMPILED-MISMATCH", \ +/* 0x3B */ "UNKNOWN-PRIMITIVE-CONTINUATION" \ } /* Termination codes: the interpreter halts on these */ diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index 9665448b2..83e4c9f92 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -1,6 +1,6 @@ /* -*-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 @@ -49,22 +49,24 @@ static Tchannel dump_channel; #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 (); /* 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: @@ -82,10 +84,7 @@ static CONST char * dump_file_name = 0; 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. */ /* @@ -96,16 +95,16 @@ static CONST char * dump_file_name = 0; */ #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. */ @@ -121,9 +120,9 @@ Code #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; @@ -135,7 +134,7 @@ DumpLoop(Scan, Dump_Mode) { Temp = *Scan; - Switch_by_GC_Type(Temp) + Switch_by_GC_Type (Temp) { case TC_PRIMITIVE: case TC_PCOMB0: @@ -145,24 +144,24 @@ DumpLoop(Scan, Dump_Mode) 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; @@ -195,7 +194,7 @@ DumpLoop(Scan, Dump_Mode) 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. @@ -204,12 +203,12 @@ DumpLoop(Scan, Dump_Mode) 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; @@ -239,11 +238,11 @@ DumpLoop(Scan, Dump_Mode) } 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; @@ -252,7 +251,7 @@ DumpLoop(Scan, Dump_Mode) case TC_WEAK_CONS: case_Fasdump_Pair: - Setup_Pointer_for_Dump(Transport_Pair()); + Setup_Pointer_for_Dump (Transport_Pair ()); break; case TC_INTERNED_SYMBOL: @@ -264,26 +263,26 @@ DumpLoop(Scan, Dump_Mode) 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; 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: @@ -292,11 +291,11 @@ DumpLoop(Scan, Dump_Mode) 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: @@ -316,41 +315,45 @@ exit_dumploop: { \ 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) { @@ -372,124 +375,90 @@ Fasdump_Exit(code, close_p) } } -/* (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; - -#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 */ - + + 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)); } /* (DUMP-BAND PROCEDURE FILE-NAME) diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index f5cf088df..2434975ca 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-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 @@ -39,17 +39,21 @@ MIT in each case. */ #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" @@ -69,26 +73,26 @@ extern void compiler_reset (); 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. */ @@ -107,61 +111,151 @@ DEFUN (read_file_start, (file_name, from_band_load), } } - 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); - + 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; } +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; +} + 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 = @@ -173,7 +267,10 @@ DEFUN_VOID (read_file_end) 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 = @@ -187,7 +284,10 @@ DEFUN_VOID (read_file_end) 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 = @@ -197,7 +297,10 @@ DEFUN_VOID (read_file_end) 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)) @@ -225,8 +328,7 @@ relocation_type static Boolean Warned = false; SCHEME_OBJECT * -Relocate(P) - long P; +DEFUN (Relocate, (P), long P) { SCHEME_OBJECT *Result; @@ -244,19 +346,20 @@ Relocate(P) } 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); } @@ -306,23 +409,24 @@ static SCHEME_OBJECT *Relocate_Temp; */ 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: @@ -362,12 +466,12 @@ Relocate_Block(Scan, Stop_At) 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; } @@ -387,7 +491,7 @@ Relocate_Block(Scan, Stop_At) 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]; @@ -423,12 +527,12 @@ Relocate_Block(Scan, Stop_At) #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; @@ -442,8 +546,9 @@ Relocate_Block(Scan, Stop_At) #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; } } @@ -451,20 +556,24 @@ Relocate_Block(Scan, Stop_At) } 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 @@ -472,11 +581,15 @@ check_primitive_numbers(table, length) 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); } @@ -492,12 +605,13 @@ DEFUN (get_band_parameters, (heap_size, const_size), } 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) @@ -505,11 +619,11 @@ Intern_Block(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); @@ -526,7 +640,7 @@ Intern_Block(Next_Pointer, Stop_At) } } } - 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 = @@ -544,7 +658,7 @@ Intern_Block(Next_Pointer, Stop_At) } if (Reloc_Debug) { - printf("Done interning block.\n"); + printf ("Done interning block.\n"); } return; } @@ -556,8 +670,7 @@ Intern_Block(Next_Pointer, Stop_At) #endif SCHEME_OBJECT -load_file (from_band_load) - Boolean from_band_load; +DEFUN (load_file, (mode), int mode) { SCHEME_OBJECT *Orig_Heap, @@ -575,7 +688,7 @@ load_file (from_band_load) 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)); @@ -617,16 +730,16 @@ load_file (from_band_load) stack_relocation = (COMPUTE_RELOCATION (Stack_Top, Dumped_Stack_Top)); #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)) || @@ -636,9 +749,9 @@ load_file (from_band_load) /* 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)); } /* @@ -648,44 +761,71 @@ load_file (from_band_load) 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); } #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); } -/* (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)); +} + /* Band loading. */ static char *reload_band_name = 0; @@ -784,12 +924,12 @@ DEFUN (terminate_band_load, (ap), PTR ap) { 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); @@ -842,17 +982,21 @@ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) 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; } } @@ -890,7 +1034,7 @@ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) 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*/ } @@ -900,14 +1044,14 @@ DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0) 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) { @@ -917,11 +1061,12 @@ Finish_String_Inversion() 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); @@ -931,10 +1076,10 @@ Finish_String_Inversion() return; } -#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; @@ -951,23 +1096,23 @@ String_Inversion(Orig_Pointer) { 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; @@ -983,15 +1128,15 @@ String_Inversion(Orig_Pointer) { FAST_MEMORY_SET (Last_String, STRING_LENGTH_INDEX, - MAKE_POINTER_OBJECT (Count + MAGIC_OFFSET, Orig_Pointer)); + (MAKE_POINTER_OBJECT ((Count + MAGIC_OFFSET), Orig_Pointer))); } - 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; @@ -1018,7 +1163,7 @@ String_Inversion(Orig_Pointer) } if (Reloc_Debug) { - printf("\n"); + printf ("\n"); } return; } diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index c19bb49fd..03d1bdfd8 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-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 @@ -43,6 +43,7 @@ MIT in each case. */ #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)); @@ -1971,6 +1972,12 @@ Primitive_Internal_Apply: Val = Fetch_Expression(); break; + case RC_PRIMITIVE_CONTINUE: + Export_Registers (); + Val = (continue_primitive ()); + Import_Registers (); + break; + /* Interpret() continues on the next page */ /* Interpret(), continued */ diff --git a/v7/src/microcode/load.c b/v7/src/microcode/load.c index 79e673cbb..aeb9a4872 100644 --- a/v7/src/microcode/load.c +++ b/v7/src/microcode/load.c @@ -1,8 +1,8 @@ /* -*-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 @@ -82,7 +82,7 @@ static SCHEME_OBJECT dumped_utilities; void -print_fasl_information () +DEFUN_VOID (print_fasl_information) { printf ("FASL File Information:\n\n"); printf ("Machine = %ld; Version = %ld; Subversion = %ld\n", @@ -120,35 +120,30 @@ print_fasl_information () } 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 = @@ -159,12 +154,12 @@ Read_Header () 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; } @@ -180,12 +175,12 @@ Read_Header () { 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]; } #ifndef INHIBIT_FASL_VERSION_CHECK @@ -243,7 +238,7 @@ Read_Header () #endif /* INHIBIT_COMPILED_VERSION_CHECK */ - dumped_checksum = (Buffer [FASL_Offset_Check_Sum]); + dumped_checksum = (buffer [FASL_Offset_Check_Sum]); #ifndef INHIBIT_CHECKSUMS @@ -251,7 +246,7 @@ Read_Header () 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))); @@ -261,14 +256,30 @@ Read_Header () 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])); +} #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; @@ -284,8 +295,9 @@ Byte_Invert_Header(Header, Headsize, Test1, Test2) } void -Byte_Invert_Region(Region, Size) - long *Region, Size; +DEFUN (Byte_Invert_Region, (Region, Size), + long *Region AND + long Size) { register long word, size; @@ -302,4 +314,3 @@ Byte_Invert_Region(Region, Size) } #endif /* BYTE_INVERSION */ - diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c index 051e5829c..5e5e3fdb0 100644 --- a/v7/src/microcode/ppband.c +++ b/v7/src/microcode/ppband.c @@ -1,6 +1,6 @@ /* -*-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 @@ -65,13 +65,16 @@ extern off_t EXFUN (OS2_fwrite, (char *, unsigned int, off_t, FILE *)); #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 @@ -80,29 +83,29 @@ DEFUN (Load_Data, (Count, To_Where), long Count AND char *To_Where) #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; @@ -122,28 +125,28 @@ DEFUN (scheme_string, (From, Quoted), long From AND Boolean Quoted) { 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) @@ -152,9 +155,9 @@ 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; } @@ -163,7 +166,7 @@ static char string_buffer[10]; #define PRINT_OBJECT(type, datum) \ { \ - printf("[%s %lx]", type, datum); \ + printf ("[%s %lx]", type, datum); \ } #define NON_POINTER(string) \ @@ -191,23 +194,23 @@ DEFUN (Display, (Location, Type, The_Datum), 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 */ @@ -220,40 +223,40 @@ DEFUN (Display, (Location, Type, The_Datum), case TC_PCOMB0: case TC_MANIFEST_SPECIAL_NM_VECTOR: case TC_MANIFEST_NM_VECTOR: - NON_POINTER(Type_Names[Type]); + NON_POINTER (Type_Names[Type]); 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: @@ -264,16 +267,16 @@ DEFUN (Display, (Location, Type, The_Datum), 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; } @@ -286,7 +289,7 @@ DEFUN (show_area, (area, start, end, name), { 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) || @@ -299,118 +302,148 @@ DEFUN (show_area, (area, start, end, name), ((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); } -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); - } - - 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) + + 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; + } } - } - 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); } diff --git a/v7/src/microcode/prosfs.c b/v7/src/microcode/prosfs.c index 82db3a7c5..36e5529fd 100644 --- a/v7/src/microcode/prosfs.c +++ b/v7/src/microcode/prosfs.c @@ -1,6 +1,6 @@ /* -*-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 @@ -155,33 +155,63 @@ If third arg HARD? is #F, a soft link is created;\n\ #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, diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c index 103979cc2..104c7acad 100644 --- a/v7/src/microcode/psbtobin.c +++ b/v7/src/microcode/psbtobin.c @@ -1,8 +1,8 @@ /* -*-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 @@ -37,6 +37,7 @@ MIT in each case. */ /* Cheap renames */ +#include "ansidecl.h" #include "psbmap.h" #include "float.h" #define portable_file input_file @@ -64,9 +65,9 @@ static SCHEME_OBJECT *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)), @@ -78,67 +79,67 @@ Write_Data(Count, From_Where) #include "dump.c" 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*/ } #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); } } 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) @@ -150,31 +151,32 @@ read_a_string_internal(To, maxlen) 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)); } /* @@ -190,46 +192,46 @@ read_a_string(To, Slot) #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 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)); @@ -245,12 +247,12 @@ read_an_integer(The_Type, To, Slot) 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); } } @@ -258,7 +260,7 @@ read_an_integer(The_Type, To, Slot) { Value = -Value; } - *Slot = LONG_TO_FIXNUM(Value); + *Slot = (LONG_TO_FIXNUM (Value)); return (To); } else if (length_in_bits == 0) @@ -331,17 +333,18 @@ read_an_integer(The_Type, To, Slot) } 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; @@ -354,21 +357,21 @@ read_a_bit_string(To, Slot) 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 { @@ -378,7 +381,7 @@ read_a_bit_string(To, Slot) } if (bits_accumulated != 0) { - *(INC_BIT_STRING_PTR(scan)) = accumulator; + *(INC_BIT_STRING_PTR (scan)) = accumulator; } } *Slot = the_bit_string; @@ -392,10 +395,10 @@ read_a_bit_string(To, Slot) 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; @@ -405,51 +408,57 @@ compute_max() expt != 0; expt >>= 1) { - Result += ldexp(1.0, expt); + Result += (ldexp (1.0, expt)); } the_max = Result; return (Result); } 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); } double -read_a_flonum () +DEFUN_VOID (read_a_flonum) { Boolean negative; long exponent; @@ -464,23 +473,27 @@ read_a_flonum () { 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 { @@ -490,21 +503,21 @@ read_a_flonum () 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) { @@ -514,59 +527,60 @@ read_a_flonum () } 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; } 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*/ } } @@ -576,9 +590,11 @@ Read_External(N, Table, To) #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; @@ -593,17 +609,17 @@ Move_Memory(From, N, To) #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: @@ -614,15 +630,15 @@ Relocate_Objects(from, how_many, disp) 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; @@ -658,14 +674,14 @@ Relocate_Objects(from, how_many, disp) static SCHEME_OBJECT *Relocate_Temp; #define Relocate(Addr) \ - (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp) + (Relocate_Into (Relocate_Temp, Addr), Relocate_Temp) #endif 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; @@ -674,12 +690,12 @@ Read_Pointers_and_Relocate(how_many, to) 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]; @@ -690,7 +706,7 @@ Read_Pointers_and_Relocate(how_many, to) continue; case TC_MANIFEST_NM_VECTOR: - *to++ = MAKE_OBJECT (The_Type, The_Datum); + *to++ = (MAKE_OBJECT (The_Type, The_Datum)); { fast long count; @@ -698,8 +714,8 @@ Read_Pointers_and_Relocate(how_many, to) 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; @@ -709,8 +725,8 @@ Read_Pointers_and_Relocate(how_many, to) 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]))))); @@ -720,8 +736,8 @@ Read_Pointers_and_Relocate(how_many, to) 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 */ @@ -729,28 +745,28 @@ Read_Pointers_and_Relocate(how_many, to) 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; } } @@ -763,21 +779,21 @@ Read_Pointers_and_Relocate(how_many, to) 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); } @@ -785,61 +801,61 @@ read_primitives(how_many, 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; 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; } } @@ -848,28 +864,28 @@ print_external_objects(area_name, Table, N) #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"); \ } #else /* not DEBUG */ @@ -880,23 +896,25 @@ when(what, message) #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 */ 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, @@ -906,35 +924,42 @@ Read_Header_and_Allocate() 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); } - 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))) && @@ -942,51 +967,51 @@ Read_Header_and_Allocate() { 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); } - 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 */ @@ -994,150 +1019,156 @@ Read_Header_and_Allocate() 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)); } 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)); - /* 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"); + } - /* 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))); /* 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 { @@ -1158,20 +1189,21 @@ do_it() 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; } /* Top level */ @@ -1182,25 +1214,27 @@ static Boolean 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); } diff --git a/v7/src/microcode/returns.h b/v7/src/microcode/returns.h index bcd94a3c1..afa9e3120 100644 --- a/v7/src/microcode/returns.h +++ b/v7/src/microcode/returns.h @@ -1,6 +1,6 @@ /* -*-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 @@ -92,7 +92,7 @@ MIT in each case. */ /* 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 @@ -121,10 +121,11 @@ MIT in each case. */ #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 #define RETURN_NAME_TABLE \ { \ @@ -222,5 +223,6 @@ MIT in each case. */ /* 0x5B */ "COMPILER_LINK_CACHES_RESTART", \ /* 0x5C */ "HARDWARE_TRAP", \ /* 0x5D */ "INTERNAL_APPLY_VAL", \ -/* 0x5E */ "COMPILER_ERROR_RESTARRT" \ +/* 0x5E */ "COMPILER_ERROR_RESTARRT", \ +/* 0x5F */ "PRIMITIVE_CONTINUE" \ } diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index f8f5dd13f..01f221ade 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-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 @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 55 +#define SUBVERSION 56 #endif diff --git a/v8/src/microcode/bintopsb.c b/v8/src/microcode/bintopsb.c index ca07972e9..0b326066a 100644 --- a/v8/src/microcode/bintopsb.c +++ b/v8/src/microcode/bintopsb.c @@ -1,8 +1,8 @@ /* -*-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 @@ -37,6 +37,7 @@ MIT in each case. */ /* IO definitions */ +#include "ansidecl.h" #include "psbmap.h" #include "trap.h" #include "limits.h" @@ -44,11 +45,14 @@ MIT in each case. */ #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 @@ -59,7 +63,7 @@ Load_Data(Count, To_Where) /* Character macros and procedures */ -extern int strlen(); +extern int strlen (); #ifndef isalpha @@ -78,8 +82,8 @@ static char punctuation[] = "'\",<.>/?;:{}[]|`~=+-_()*&^%$#@!"; Boolean -ispunct(c) - fast char c; +DEFUN (ispunct, (c), + fast char c) { fast char *; @@ -108,6 +112,7 @@ static Boolean 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, @@ -140,9 +145,9 @@ static long } 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) { @@ -257,8 +262,8 @@ print_a_char(c, name) do_flonum_kernel (Code, Scn, Obj, FObj)) void -print_a_fixnum(val) - long val; +DEFUN (print_a_fixnum, (val), + long val) { fast long size_in_bits; fast unsigned long temp; @@ -290,9 +295,9 @@ print_a_fixnum(val) } 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) @@ -328,37 +333,38 @@ print_a_string_internal(len, str) } 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; } static long -bignum_length (bignum) - SCHEME_OBJECT bignum; +DEFUN (bignum_length, (bignum), + SCHEME_OBJECT bignum) { if (BIGNUM_ZERO_P (bignum)) return (0); @@ -386,9 +392,13 @@ bignum_length (bignum) } 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", @@ -469,8 +479,8 @@ print_a_bignum (bignum) /* 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; @@ -527,8 +537,8 @@ print_a_bit_string(from) } void -print_a_flonum(val) - double val; +DEFUN (print_a_flonum, (val), + double val) { fast long size_in_bits; fast double mant, temp; @@ -781,8 +791,8 @@ print_a_flonum(val) } 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", @@ -797,8 +807,8 @@ out_of_range_pointer(ptr) } SCHEME_OBJECT * -relocate(object) - SCHEME_OBJECT object; +DEFUN (relocate, (object), + SCHEME_OBJECT object) { long the_datum; SCHEME_OBJECT *result; @@ -844,8 +854,8 @@ static Boolean 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; @@ -896,8 +906,8 @@ upgrade_primitive(prim) } 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; @@ -948,14 +958,16 @@ setup_primitive_upgrade(Heap) /* 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; @@ -1176,9 +1188,9 @@ Process_Area(Code, Area, Bound, Obj, FObj) /* 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) { @@ -1190,28 +1202,28 @@ print_external_objects(from, count) 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; @@ -1239,8 +1251,9 @@ print_external_objects(from, count) } 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; @@ -1288,9 +1301,9 @@ print_objects(from, to) #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) { @@ -1327,382 +1340,408 @@ when(what, message) /* 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); + } - 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); + } - 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)); - { - 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))); - /* 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; - /* 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 - /* 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"); - /* 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 - /* 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 - /* 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; } /* Top Level */ @@ -1717,34 +1756,47 @@ static Boolean 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); } diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index ccf064f66..dd5d9201d 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -1,6 +1,6 @@ /* -*-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 @@ -43,6 +43,7 @@ MIT in each case. */ #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)); @@ -1971,6 +1972,12 @@ Primitive_Internal_Apply: Val = Fetch_Expression(); break; + case RC_PRIMITIVE_CONTINUE: + Export_Registers (); + Val = (continue_primitive ()); + Import_Registers (); + break; + /* Interpret() continues on the next page */ /* Interpret(), continued */ diff --git a/v8/src/microcode/ppband.c b/v8/src/microcode/ppband.c index 3ea34c8f8..8755e5d30 100644 --- a/v8/src/microcode/ppband.c +++ b/v8/src/microcode/ppband.c @@ -1,6 +1,6 @@ /* -*-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 @@ -65,13 +65,16 @@ extern off_t EXFUN (OS2_fwrite, (char *, unsigned int, off_t, FILE *)); #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 @@ -80,29 +83,29 @@ DEFUN (Load_Data, (Count, To_Where), long Count AND char *To_Where) #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; @@ -122,28 +125,28 @@ DEFUN (scheme_string, (From, Quoted), long From AND Boolean Quoted) { 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) @@ -152,9 +155,9 @@ 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; } @@ -163,7 +166,7 @@ static char string_buffer[10]; #define PRINT_OBJECT(type, datum) \ { \ - printf("[%s %lx]", type, datum); \ + printf ("[%s %lx]", type, datum); \ } #define NON_POINTER(string) \ @@ -191,23 +194,23 @@ DEFUN (Display, (Location, Type, The_Datum), 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 */ @@ -220,40 +223,40 @@ DEFUN (Display, (Location, Type, The_Datum), case TC_PCOMB0: case TC_MANIFEST_SPECIAL_NM_VECTOR: case TC_MANIFEST_NM_VECTOR: - NON_POINTER(Type_Names[Type]); + NON_POINTER (Type_Names[Type]); 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: @@ -264,16 +267,16 @@ DEFUN (Display, (Location, Type, The_Datum), 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; } @@ -286,7 +289,7 @@ DEFUN (show_area, (area, start, end, name), { 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) || @@ -299,118 +302,148 @@ DEFUN (show_area, (area, start, end, name), ((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); } -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); - } - - 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) + + 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; + } } - } - 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); } diff --git a/v8/src/microcode/psbtobin.c b/v8/src/microcode/psbtobin.c index 17f2d932e..c78358de4 100644 --- a/v8/src/microcode/psbtobin.c +++ b/v8/src/microcode/psbtobin.c @@ -1,8 +1,8 @@ /* -*-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 @@ -37,6 +37,7 @@ MIT in each case. */ /* Cheap renames */ +#include "ansidecl.h" #include "psbmap.h" #include "float.h" #define portable_file input_file @@ -64,9 +65,9 @@ static SCHEME_OBJECT *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)), @@ -78,67 +79,67 @@ Write_Data(Count, From_Where) #include "dump.c" 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*/ } #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); } } 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) @@ -150,31 +151,32 @@ read_a_string_internal(To, maxlen) 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)); } /* @@ -190,46 +192,46 @@ read_a_string(To, Slot) #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 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)); @@ -245,12 +247,12 @@ read_an_integer(The_Type, To, Slot) 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); } } @@ -258,7 +260,7 @@ read_an_integer(The_Type, To, Slot) { Value = -Value; } - *Slot = LONG_TO_FIXNUM(Value); + *Slot = (LONG_TO_FIXNUM (Value)); return (To); } else if (length_in_bits == 0) @@ -331,17 +333,18 @@ read_an_integer(The_Type, To, Slot) } 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; @@ -354,21 +357,21 @@ read_a_bit_string(To, Slot) 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 { @@ -378,7 +381,7 @@ read_a_bit_string(To, Slot) } if (bits_accumulated != 0) { - *(INC_BIT_STRING_PTR(scan)) = accumulator; + *(INC_BIT_STRING_PTR (scan)) = accumulator; } } *Slot = the_bit_string; @@ -392,10 +395,10 @@ read_a_bit_string(To, Slot) 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; @@ -405,51 +408,57 @@ compute_max() expt != 0; expt >>= 1) { - Result += ldexp(1.0, expt); + Result += (ldexp (1.0, expt)); } the_max = Result; return (Result); } 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); } double -read_a_flonum () +DEFUN_VOID (read_a_flonum) { Boolean negative; long exponent; @@ -464,23 +473,27 @@ read_a_flonum () { 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 { @@ -490,21 +503,21 @@ read_a_flonum () 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) { @@ -514,59 +527,60 @@ read_a_flonum () } 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; } 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*/ } } @@ -576,9 +590,11 @@ Read_External(N, Table, To) #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; @@ -593,17 +609,17 @@ Move_Memory(From, N, To) #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: @@ -614,15 +630,15 @@ Relocate_Objects(from, how_many, disp) 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; @@ -658,14 +674,14 @@ Relocate_Objects(from, how_many, disp) static SCHEME_OBJECT *Relocate_Temp; #define Relocate(Addr) \ - (Relocate_Into(Relocate_Temp, Addr), Relocate_Temp) + (Relocate_Into (Relocate_Temp, Addr), Relocate_Temp) #endif 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; @@ -674,12 +690,12 @@ Read_Pointers_and_Relocate(how_many, to) 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]; @@ -690,7 +706,7 @@ Read_Pointers_and_Relocate(how_many, to) continue; case TC_MANIFEST_NM_VECTOR: - *to++ = MAKE_OBJECT (The_Type, The_Datum); + *to++ = (MAKE_OBJECT (The_Type, The_Datum)); { fast long count; @@ -698,8 +714,8 @@ Read_Pointers_and_Relocate(how_many, to) 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; @@ -709,8 +725,8 @@ Read_Pointers_and_Relocate(how_many, to) 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]))))); @@ -720,8 +736,8 @@ Read_Pointers_and_Relocate(how_many, to) 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 */ @@ -729,28 +745,28 @@ Read_Pointers_and_Relocate(how_many, to) 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; } } @@ -763,21 +779,21 @@ Read_Pointers_and_Relocate(how_many, to) 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); } @@ -785,61 +801,61 @@ read_primitives(how_many, 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; 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; } } @@ -848,28 +864,28 @@ print_external_objects(area_name, Table, N) #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"); \ } #else /* not DEBUG */ @@ -880,23 +896,25 @@ when(what, message) #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 */ 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, @@ -906,35 +924,42 @@ Read_Header_and_Allocate() 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); } - 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))) && @@ -942,51 +967,51 @@ Read_Header_and_Allocate() { 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); } - 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 */ @@ -994,150 +1019,156 @@ Read_Header_and_Allocate() 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)); } 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)); - /* 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"); + } - /* 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))); /* 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 { @@ -1158,20 +1189,21 @@ do_it() 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; } /* Top level */ @@ -1182,25 +1214,27 @@ static Boolean 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); } diff --git a/v8/src/microcode/returns.h b/v8/src/microcode/returns.h index 24e700ee1..cd2467936 100644 --- a/v8/src/microcode/returns.h +++ b/v8/src/microcode/returns.h @@ -1,6 +1,6 @@ /* -*-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 @@ -92,7 +92,7 @@ MIT in each case. */ /* 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 @@ -121,10 +121,11 @@ MIT in each case. */ #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 #define RETURN_NAME_TABLE \ { \ @@ -222,5 +223,6 @@ MIT in each case. */ /* 0x5B */ "COMPILER_LINK_CACHES_RESTART", \ /* 0x5C */ "HARDWARE_TRAP", \ /* 0x5D */ "INTERNAL_APPLY_VAL", \ -/* 0x5E */ "COMPILER_ERROR_RESTARRT" \ +/* 0x5E */ "COMPILER_ERROR_RESTARRT", \ +/* 0x5F */ "PRIMITIVE_CONTINUE" \ } diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index fc7c97d24..5b115ce68 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-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 @@ -46,5 +46,5 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 55 +#define SUBVERSION 56 #endif