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/Attic/bchdmp.c,v 9.30 1987/06/02 00:16:04 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.31 1987/06/05 04:12:14 jinx Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
*--fixup = ((Pointer) location); \
}
\f
-void
+Boolean
fasdump_exit(length)
long length;
{
extern int ftruncate(), unlink();
fast Pointer *fixes, *fix_address;
+ Boolean result;
Free = saved_free;
gc_file = real_gc_file;
ftruncate(dump_file, length);
- close(dump_file);
+ result = (close(dump_file) == 0);
if (length == 0)
unlink(dump_file_name);
dump_file_name = ((char *) NULL);
if (fixup_count >= 0)
{
- lseek(real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0);
- 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))
+ {
+ fprintf(stderr,
+ "\nCould not read back the fasdump fixup information.\n");
+ Microcode_Termination(TERM_EXIT);
+ }
fixup_count -= 1;
fixes = fixup_buffer;
goto next_buffer;
fixup = fixes;
Fasdump_Exit_Hook();
- return;
+ return result;
}
Boolean
fasdump_exit(0);
PRIMITIVE_RETURN(NIL);
}
- fasdump_exit((sizeof(Pointer) * length) + hlength);
- PRIMITIVE_RETURN(TRUTH);
+ PRIMITIVE_RETURN(fasdump_exit((sizeof(Pointer) * length) + hlength) ?
+ TRUTH : NIL);
}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
extern Pointer compiler_utilities;
Pointer Combination, Ext_Prims;
long Arg1Type;
+ Boolean result;
Primitive_2_Args();
Band_Dump_Permitted();
/* Aligning here confuses some of the counts computed.
Align_Float(Free);
*/
- Write_File(((long) (Free-Heap_Bottom)), Heap_Bottom, Free-2,
- ((long) (Free_Constant-Constant_Space)),
- Constant_Space, Free-1);
- fclose(File_Handle);
- PRIMITIVE_RETURN(TRUTH);
+ result = Write_File(((long) (Free - Heap_Bottom)), Heap_Bottom, (Free - 2),
+ ((long) (Free_Constant - Constant_Space)),
+ Constant_Space, (Free - 1));
+ result = (result && Close_Dump_File());
+ if (result)
+ PRIMITIVE_RETURN(TRUTH);
+ else
+ {
+ extern int unlink();
+
+ unlink(Scheme_String_To_C_String(Arg2));
+ PRIMITIVE_RETURN(NIL);
+ }
}
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/Attic/bintopsb.c,v 9.25 1987/04/16 15:30:25 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.26 1987/06/05 04:10:41 jinx Rel $
*
* This File contains the code to translate internal format binary
* files to portable format.
static long NBits, NChars;
static Pointer *Free_Objects, *Free_Cobjects;
+long
Load_Data(Count, To_Where)
-long Count;
-char *To_Where;
-{ fread(To_Where, sizeof(Pointer), Count, Internal_File);
+ long Count;
+ char *To_Where;
+{
+ extern int fread();
+
+ return (fread(To_Where, sizeof(Pointer), Count, Internal_File));
}
#define Reloc_or_Load_Debug false
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.35 1987/05/31 16:32:57 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.36 1987/06/05 04:12:40 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
printf("Mismatch between compiled code and compiled code support.\n");
break;
case TERM_DISK_RESTORE:
- printf("DISK restore.\n"); break;
+ printf("Unrecoverable error while loading a band.\n");
+ break;
case TERM_EOF:
printf("\nEnd of input stream reached.\n"); break;
case TERM_END_OF_COMPUTATION:
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/Attic/config.h,v 9.25 1987/05/30 23:04:34 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.26 1987/06/05 04:13:17 jinx Exp $
*
* This file contains the configuration information and the information
* given on the command line on Unix.
#ifndef STACK_SIZE
#ifndef USE_STACKLETS
-#define STACK_SIZE 30 /* Default Kcells for stack */
+#define STACK_SIZE 100 /* Default Kcells for stack */
#else
#define STACK_SIZE 256 /* Default stacklet size */
#endif
#endif
#ifndef CONSTANT_SIZE
-#define CONSTANT_SIZE 180 /* Default Kcells for constant */
+#define CONSTANT_SIZE 300 /* Default Kcells for constant */
#endif
#ifndef HEAP_SIZE
#define HEAP_SIZE 250 /* Default Kcells for each heap */
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/Attic/dump.c,v 9.23 1987/06/02 00:17:13 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.24 1987/06/05 04:13:39 jinx Rel $
*
* This file contains common code for dumping internal format binary files.
*/
return;
}
+Boolean
Write_File(Heap_Count, Heap_Relocation, Dumped_Object,
Constant_Count, Constant_Relocation, Prim_Exts)
Pointer *Heap_Relocation, *Dumped_Object,
prepare_dump_header(Buffer,Heap_Count, Heap_Relocation, Dumped_Object,
Constant_Count, Constant_Relocation, Prim_Exts);
- Write_Data(FASL_HEADER_LENGTH, ((char *) Buffer));
+ if (Write_Data(FASL_HEADER_LENGTH, ((char *) Buffer)) !=
+ FASL_HEADER_LENGTH)
+ return false;
if (Heap_Count != 0)
- Write_Data(Heap_Count, ((char *) Heap_Relocation));
+ {
+ if (Write_Data(Heap_Count, ((char *) Heap_Relocation)) !=
+ Heap_Count)
+ return false;
+ }
if (Constant_Count != 0)
- Write_Data(Constant_Count, ((char *) Constant_Relocation));
+ {
+ if (Write_Data(Constant_Count, ((char *) Constant_Relocation)) !=
+ Constant_Count)
+ return false;
+ }
+ return true;
}
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/extern.h,v 9.25 1987/05/29 02:22:08 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.26 1987/06/05 04:13:51 jinx Exp $
*
* External declarations.
*
/* And file "channels" */
extern FILE *(Channels[FILE_CHANNELS]);
-extern FILE *File_Handle; /* Used by Fasload/Fasdump */
extern FILE *Photo_File_Handle; /* Used by Photo */
extern int Saved_argc;
/* Random and OS utilities */
extern int Parse_Option();
-extern Boolean Open_File(), Restore_History(), Open_Dump_File();
+extern Boolean Restore_History();
extern long NColumns(), NLines(), System_Clock();
-extern void OS_Flush_Output_Buffer();
-extern void Load_Data(), Write_Data(), OS_Re_Init();
+extern void OS_Flush_Output_Buffer(), OS_Re_Init();
/* Memory management utilities */
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/fasdump.c,v 9.27 1987/06/02 00:17:22 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.28 1987/06/05 04:14:05 jinx Exp $
This file contains code for fasdump and dump-band.
*/
return true;
} /* DumpLoop */
\f
-void
+Boolean
Fasdump_Exit()
{
+ Boolean result;
fast Pointer *Fixes;
Fixes = Fixup;
- fclose(File_Handle);
+ result = Close_Dump_File();
while (Fixes != NewMemTop)
{
fast Pointer *Fix_Address;
}
Fixup = Fixes;
Fasdump_Exit_Hook();
+ return result;
}
\f
/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
Pointer Object, File_Name, Flag, *New_Object,
*Addr_Of_New_Object, Prim_Exts;
long Pure_Length, Length;
+ Boolean result;
Primitive_3_Args();
Object = Arg1;
\f
#if false
if (Flag == TRUTH)
- { if (!DumpLoop(New_Object, PURE_COPY))
+ {
+ if (!DumpLoop(New_Object, PURE_COPY))
{
Fasdump_Exit();
PRIMITIVE_RETURN(NIL);
Fasdump_Exit();
PRIMITIVE_RETURN(NIL);
}
- Length = NewFree-New_Object+2;
+ Length = ((NewFree - New_Object) + 2);
*NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *NewFree++ = Make_Non_Pointer(END_OF_BLOCK, Length-1);
+ *NewFree++ = Make_Non_Pointer(END_OF_BLOCK, (Length - 1));
Addr_Of_New_Object = Get_Pointer(New_Object[0]);
Prim_Exts = New_Object[1];
New_Object[0] = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
Pure_Length);
- New_Object[1] = Make_Non_Pointer(PURE_PART, Length-1);
- Write_File(0, 0x000000, Addr_Of_New_Object,
- Length, New_Object, Prim_Exts);
+ New_Object[1] = Make_Non_Pointer(PURE_PART, (Length - 1));
+ result = Write_File(0, 0x000000, Addr_Of_New_Object,
+ Length, New_Object, Prim_Exts);
}
else /* Dumping for reload into heap */
#endif
- { if (!DumpLoop(New_Object, NORMAL_GC))
+ {
+ if (!DumpLoop(New_Object, NORMAL_GC))
{
Fasdump_Exit();
PRIMITIVE_RETURN(NIL);
/* Aligning might screw up some of the counters.
Align_Float(NewFree);
*/
- Length = NewFree-New_Object;
- Write_File(Length, New_Object, New_Object,
- 0, Constant_Space, New_Object+1);
+ Length = (NewFree - New_Object);
+ result = Write_File(Length, New_Object, New_Object,
+ 0, Constant_Space, (New_Object + 1));
}
- Fasdump_Exit();
- PRIMITIVE_RETURN(TRUTH);
+ result = (result && Fasdump_Exit());
+ PRIMITIVE_RETURN(result ? TRUTH : NIL);
}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
extern Pointer compiler_utilities;
Pointer Combination, Ext_Prims;
long Arg1Type;
+ Boolean result;
Primitive_2_Args();
Band_Dump_Permitted();
/* Aligning here confuses some of the counts computed.
Align_Float(Free);
*/
- Write_File(((long) (Free-Heap_Bottom)), Heap_Bottom, Free-2,
- ((long) (Free_Constant-Constant_Space)),
- Constant_Space, Free-1);
- fclose(File_Handle);
- PRIMITIVE_RETURN(TRUTH);
+ result = Write_File(((long) (Free - Heap_Bottom)), Heap_Bottom, (Free - 2),
+ ((long) (Free_Constant - Constant_Space)),
+ Constant_Space, (Free - 1));
+ result = (result && Close_Dump_File());
+ PRIMITIVE_RETURN(result ? TRUTH : NIL);
}
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/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.24 1987/06/05 04:14:25 jinx Rel $
Contains information relating to the format of FASL files.
Some information is contained in CONFIG.H.
*/
+
+extern long Load_Data(), Write_Data();
+extern Boolean Open_Dump_File(), Close_Dump_File();
\f
/* FASL Version */
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/fasload.c,v 9.26 1987/05/29 02:22:32 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.27 1987/06/05 04:14:38 jinx Exp $
The "fast loader" which reads in and relocates binary files and then
interns symbols. It is called with one argument: the (character
#include "load.c"
\f
-void
-Load_File(Name)
- Pointer Name;
+long
+read_file_start(name)
+ Pointer name;
{
- char *Char;
- long N, i;
- Boolean File_Opened;
+ Boolean file_opened;
+
+ if (Type_Code(name) != TC_CHARACTER_STRING)
+ return ERR_ARG_1_WRONG_TYPE;
+
+ file_opened = Open_Dump_File(name, OPEN_FLAG);
- File_Opened = Open_Dump_File(Name, OPEN_FLAG);
if (Per_File)
Handle_Debug_Flags();
- if (!File_Opened)
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
+
+ if (!file_opened)
+ return ERR_ARG_1_BAD_RANGE;
if (!Read_Header())
- { fprintf(stderr,
- "\nLoad_File: The file does not appear to be in FASL format.\n");
- goto CANNOT_LOAD;
- }
+ goto cannot_load;
+
if (File_Load_Debug)
printf("\nMachine type %d, Version %d, Subversion %d\n",
Machine_Type, Version, Sub_Version);
{
fprintf(stderr,
- "\nLoad_File: FASL File Version %4d Subversion %4d Machine Type %4d.\n",
+ "\nread_file: FASL File Version %4d Subversion %4d Machine Type %4d.\n",
Version, Sub_Version , Machine_Type);
fprintf(stderr,
" Expected: Version %4d Subversion %4d Machine Type %4d.\n",
FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
-CANNOT_LOAD:
- fclose(File_Handle);
- Primitive_Error(ERR_FASL_FILE_BAD_DATA);
+
+cannot_load:
+
+ Close_Dump_File();
+ return ERR_FASL_FILE_BAD_DATA;
}
- if (!Test_Pure_Space_Top(Free_Constant+Const_Count))
+
+ if (!Test_Pure_Space_Top(Free_Constant + Const_Count))
{
- fclose(File_Handle);
- Primitive_Error(ERR_FASL_FILE_TOO_BIG);
+ Close_Dump_File();
+ return ERR_FASL_FILE_TOO_BIG;
}
+
if (GC_Check(Heap_Count))
{
- fclose(File_Handle);
+ Close_Dump_File();
Request_GC(Heap_Count);
- Primitive_Interrupt();
+ return PRIM_INTERRUPT;
}
+ return PRIM_DONE;
+}
+\f
+void
+read_file_end()
+{
/* Aligning Free here confuses the counters
Align_Float(Free);
*/
- Load_Data(Heap_Count, (char *) Free);
+ if (Load_Data(Heap_Count, ((char *) Free)) != Heap_Count)
+ {
+ Close_Dump_File();
+ Primitive_Error(ERR_EXTERNAL_RETURN);
+ }
+
#ifdef BYTE_INVERSION
Byte_Invert_Region((char *) Free, Heap_Count);
#endif
+
Free += Heap_Count;
- Load_Data(Const_Count, (char *) Free_Constant);
+ if (Load_Data(Const_Count, ((char *) Free_Constant)) != Const_Count)
+ {
+ Close_Dump_File();
+ Primitive_Error(ERR_EXTERNAL_RETURN);
+ }
+
#ifdef BYTE_INVERSION
Byte_Invert_Region((char *) Free_Constant, Const_Count);
#endif
+
Free_Constant += Const_Count;
+
/* Same
Align_Float(Free);
*/
- fclose(File_Handle);
- return;
+
+ if (Close_Dump_File())
+ return;
+ else
+ Primitive_Error(ERR_EXTERNAL_RETURN);
}
\f
/* Statics used by Relocate, below */
*/
#ifdef ENABLE_DEBUGGING_TOOLS
+
static Boolean Warned = false;
+
Pointer *
Relocate(P)
long P;
*/
void
-Install_Ext_Prims(Normal_FASLoad)
- Boolean Normal_FASLoad;
+Install_Ext_Prims(normal_fasload)
+ Boolean normal_fasload;
{
long i;
Pointer *Next;
Vector_Set(Ext_Prim_Vector, 0,
Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Ext_Prim_Count));
Next = Nth_Vector_Loc(Ext_Prim_Vector, 1);
- if (Normal_FASLoad)
- for (i = 0; i < Ext_Prim_Count; i++) Intern(Next++);
- else Undefined_Externals = NIL;
+ if (normal_fasload)
+ {
+ for (i = 0; i < Ext_Prim_Count; i++)
+ Intern(Next++);
+ }
+ else
+ Undefined_Externals = NIL;
return;
}
\f
}
\f
Pointer
-Fasload(FileName, Not_From_Band_Load)
- Pointer FileName;
- Boolean Not_From_Band_Load;
+load_file(from_band_load)
+ Boolean from_band_load;
{
Pointer *Heap_End, *Constant_End, *Orig_Heap, *Orig_Constant, *Xtemp;
+ /* Read File */
+
#ifdef ENABLE_DEBUGGING_TOOLS
Warned = false;
#endif
- if (Type_Code(FileName) != TC_CHARACTER_STRING)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
-
- /* Read File */
-
Orig_Heap = Free;
Orig_Constant = Free_Constant;
- Load_File(FileName);
+ read_file_end();
Heap_End = Free;
Constant_End = Free_Constant;
Heap_Relocation = ((relocation_type) Orig_Heap) - Heap_Base;
Found_Ext_Prims = false;
Relocate_Block(Orig_Heap, Free);
Relocate_Block(Orig_Constant, Free_Constant);
-
+\f
#ifdef BYTE_INVERSION
Finish_String_Inversion();
#endif
-\f
- if (Not_From_Band_Load)
+
+ if (!from_band_load)
{
Intern_Block(Orig_Constant, Constant_End);
Intern_Block(Orig_Heap, Heap_End);
}
- /* Update External Primitives */
+ /* Update External Primitives */
if ((Ext_Prim_Vector != NIL) && Found_Ext_Prims)
{
Relocate_Into(Xtemp, Address(Ext_Prim_Vector));
Ext_Prim_Vector = *Xtemp;
Ext_Prim_Count = Vector_Length(Ext_Prim_Vector);
- Install_Ext_Prims(Not_From_Band_Load);
+ Install_Ext_Prims(!from_band_load);
Update_Ext_Prims(Orig_Heap, Free);
Update_Ext_Prims(Orig_Constant, Free_Constant);
}
}
\f
/* (BINARY-FASLOAD FILE-NAME)
- Load the contents of FILE-NAME into memory. The file was
- presumably made by a call to PRIMITIVE-FASDUMP, and may contain
- data for the heap and/or the pure area. The value returned is
- the object which was dumped. Typically (but not always) this
- will be a piece of SCode which is then evaluated to perform
- definitions in some environment.
+ 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.
*/
Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD", 0x57)
{
+ long result;
Primitive_1_Arg();
- return Fasload(Arg1, true);
+
+ result = read_file_start(Arg1);
+ if (result != PRIM_DONE)
+ {
+ if (result == PRIM_INTERRUPT)
+ {
+ Primitive_Interrupt();
+ }
+ else
+ {
+ Primitive_Error(result);
+ }
+ }
+ PRIMITIVE_RETURN(load_file(false));
}
-\f
+
/* Band loading. */
static char *reload_band_name = ((char *) NULL);
+\f
/* (RELOAD-BAND-NAME)
Returns the filename (as a Scheme string) from which the runtime system
return C_String_To_Scheme_String(reload_band_name);
}
+/* Utility for load band below. */
+
extern void compiler_reset_error();
void
"the compiled code interface in this microcode are inconsistent.\n");
Microcode_Termination(TERM_COMPILER_DEATH);
}
-
+\f
/* (LOAD-BAND FILE-NAME)
Restores the heap and pure space from the contents of FILE-NAME,
which is typically a file created by DUMP-BAND. The file can,
*/
Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND", 0xB9)
{
+ extern char *malloc();
+ extern strcpy(), free();
+ extern void compiler_reset();
extern Pointer compiler_utilities;
- Pointer Save_FO, *Save_Free, *Save_Free_Constant,
- Save_Undefined, *Save_Stack_Pointer,
- *Save_Stack_Guard, saved_utilities, Result;
- long Jump_Value;
- jmp_buf Swapped_Buf, *Saved_Buf;
- Pointer scheme_band_name;
+ jmp_buf swapped_buf, *saved_buf;
+ Pointer *saved_free, *saved_free_constant, *saved_stack_pointer;
+ long temp, length;
+ Pointer result;
char *band_name;
- int length;
Primitive_1_Arg();
- band_name = ((char *) NULL);
- Save_Fixed_Obj(Save_FO);
- Save_Undefined = Undefined_Externals;
- Undefined_Externals = NIL;
- Save_Free = Free;
+ saved_free = Free;
Free = Heap_Bottom;
- Save_Free_Constant = Free_Constant;
+ saved_free_constant = Free_Constant;
Free_Constant = Constant_Space;
- Save_Stack_Pointer = Stack_Pointer;
- Save_Stack_Guard = Stack_Guard;
- saved_utilities = compiler_utilities;
+ saved_stack_pointer = Stack_Pointer;
+ Stack_Pointer = Highest_Allocated_Address;
+
+ result = read_file_start(Arg1);
+ if (result != PRIM_DONE)
+ {
+ Free = saved_free;
+ Free_Constant = saved_free_constant;
+ Stack_Pointer = saved_stack_pointer;
-/* Prim_Band_Load continues on next page */
+ if (result == PRIM_INTERRUPT)
+ {
+ Primitive_Interrupt();
+ }
+ else
+ {
+ Primitive_Error(result);
+ }
+ }
\f
-/* Prim_Band_Load, continued */
+ /* Point of no return. */
+
+ length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
+ band_name = malloc(length);
+ if (band_name != ((char *) NULL))
+ strcpy(band_name, Scheme_String_To_C_String(Arg1));
/* There is some jiggery-pokery going on here to make sure
that all returns from Fasload (including error exits) return to
the clean-up code before returning on up the C call stack.
*/
- Saved_Buf = Back_To_Eval;
- Jump_Value = setjmp(Swapped_Buf);
- if (Jump_Value == 0)
- {
- extern char *malloc();
- extern strcpy(), free();
- extern void compiler_reset();
- length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
- band_name = malloc(length);
- if (band_name != ((char *) NULL))
- strcpy(band_name, Scheme_String_To_C_String(Arg1));
-
- Back_To_Eval = ((jmp_buf *) Swapped_Buf);
- Result = Fasload(Arg1, false);
- Back_To_Eval = Saved_Buf;
-
- if (reload_band_name != ((char *) NULL))
- free(reload_band_name);
- reload_band_name = band_name;
- History = Make_Dummy_History();
- Initialize_Stack();
- Store_Return(RC_END_OF_COMPUTATION);
- Store_Expression(NIL);
- Save_Cont();
- Store_Expression(Vector_Ref(Result,0));
- /* Primitive externals handled by Fasload */
- compiler_utilities = Vector_Ref(Result, 1);
- compiler_reset(compiler_utilities);
- Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
- Set_Pure_Top();
- Band_Load_Hook();
- PRIMITIVE_ABORT(PRIM_DO_EXPRESSION);
- }
- else
+ saved_buf = Back_To_Eval;
+ temp = setjmp(swapped_buf);
+ if (temp != 0)
{
+ fprintf(stderr,
+ "\nload-band: Error %d past the point of no return.\n",
+ temp);
if (band_name != ((char *) NULL))
- free(band_name);
- compiler_utilities = saved_utilities;
- Back_To_Eval = Saved_Buf;
- Free = Save_Free;
- Free_Constant = Save_Free_Constant;
- Stack_Pointer = Save_Stack_Pointer;
- Set_Stack_Guard(Save_Stack_Guard);
- Undefined_Externals = Save_Undefined;
- Restore_Fixed_Obj(Save_FO);
- if (Jump_Value == PRIM_INTERRUPT)
{
- fprintf(stderr, "\nFile too large for memory.\n");
- Jump_Value = ERR_FASL_FILE_BAD_DATA;
+ fprintf(stderr, "band-name = \"%s\".\n", band_name);
+ free(band_name);
}
- Primitive_Error(Jump_Value);
+ Microcode_Termination(TERM_DISK_RESTORE);
+ /*NOTREACHED*/
}
+
+ Back_To_Eval = ((jmp_buf *) swapped_buf);
+ result = load_file(true);
+ Back_To_Eval = saved_buf;
+
+ if (reload_band_name != ((char *) NULL))
+ free(reload_band_name);
+ reload_band_name = band_name;
+
+ History = Make_Dummy_History();
+ Initialize_Stack();
+ Store_Return(RC_END_OF_COMPUTATION);
+ Store_Expression(NIL);
+ Save_Cont();
+ Store_Expression(Vector_Ref(result, 0));
+
+ /* Primitive externals handled by load_file */
+
+ compiler_utilities = Vector_Ref(result, 1);
+ compiler_reset(compiler_utilities);
+ Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
+ Set_Pure_Top();
+ Band_Load_Hook();
+ PRIMITIVE_ABORT(PRIM_DO_EXPRESSION);
+ /*NOTREACHED*/
}
\f
#ifdef BYTE_INVERSION
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/Attic/load.c,v 9.22 1987/04/16 02:25:31 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.23 1987/06/05 04:15:09 jinx Rel $
*
* This file contains common code for reading internal
* format binary files.
Pointer Buffer[FASL_HEADER_LENGTH];
Pointer Pointer_Heap_Base, Pointer_Const_Base;
- Load_Data(FASL_OLD_LENGTH, (char *) Buffer);
+ if (Load_Data(FASL_OLD_LENGTH, ((char *) Buffer)) !=
+ FASL_OLD_LENGTH)
+ return false;
if (Buffer[FASL_Offset_Marker] != FASL_FILE_MARKER)
return false;
#ifdef BYTE_INVERSION
C_To_Scheme(Nth_Vector_Loc(Pointer_Heap_Base, Heap_Count));
Dumped_Constant_Top =
C_To_Scheme(Nth_Vector_Loc(Pointer_Const_Base, Const_Count));
- Load_Data((FASL_HEADER_LENGTH - FASL_OLD_LENGTH),
- ((char *) &(Buffer[FASL_OLD_LENGTH])));
+ if (Load_Data((FASL_HEADER_LENGTH - FASL_OLD_LENGTH),
+ ((char *) &(Buffer[FASL_OLD_LENGTH]))) !=
+ (FASL_HEADER_LENGTH - FASL_OLD_LENGTH))
+ return false;
#ifdef BYTE_INVERSION
Byte_Invert_Region(((char *) &(Buffer[FASL_OLD_LENGTH])),
(FASL_HEADER_LENGTH - FASL_OLD_LENGTH));
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/Attic/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.25 1987/06/05 04:11:11 jinx Exp $
*
* Dumps Scheme FASL in user-readable form .
*/
static Pointer *Memory_Base;
+extern int fread();
+
#define Load_Data(Count,To_Where) \
fread(To_Where, sizeof(Pointer), Count, stdin)
scheme_string(From, Quoted)
long From;
Boolean Quoted;
-{ fast long i, Count;
+{
+ fast long i, Count;
fast char *Chars;
+
Chars = (char *) &Data[From+STRING_CHARS];
if (Chars < ((char *) end_of_memory))
{ Count = Get_Integer(Data[From+STRING_LENGTH]);
void
scheme_symbol(From)
long From;
-{ Pointer *symbol;
+{
+ Pointer *symbol;
+
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
!scheme_string(via(From+SYMBOL_NAME), false))
\f
Display(Location, Type, The_Datum)
long Location, Type, The_Datum;
-{ long Points_To;
+{
+ long Points_To;
+
printf("%5x: %2x|%6x ", Location, Type, The_Datum);
if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer)
Points_To = Relocate((Pointer *) The_Datum);
main(argc, argv)
int argc;
char **argv;
-{ Pointer *Next;
- long i;
+{
+ Pointer *Next;
+ long i, total_length;
if (argc == 1)
- { if (!Read_Header())
+ {
+ if (!Read_Header())
{ fprintf(stderr, "Input does not appear to be in FASL format.\n");
exit(1);
}
printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
}
else
- { Const_Count = 0;
+ {
+ Const_Count = 0;
sscanf(argv[1], "%x", &Heap_Base);
sscanf(argv[2], "%x", &Const_Base);
sscanf(argv[3], "%d", &Heap_Count);
printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n",
Heap_Base, Const_Base, Heap_Count);
}
- Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count));
+ Data = ((Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count)));
end_of_memory = &Data[Heap_Count + Const_Count];
- Load_Data(Heap_Count + Const_Count, Data);
- printf("Heap contents\n\n");
- for (Next=Data, i=0; i < Heap_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
+ total_length = Load_Data(Heap_Count + Const_Count, Data);
+ if (total_length != (Heap_Count + Const_Count))
+ {
+ printf("The FASL file does not have the right length.\n");
+ printf("Expected %d objects. Obtained %d objects.\n\n",
+ (Heap_Count + Const_Count), total_length);
+ if (total_length < Heap_Count)
+ {
+ Heap_Count = total_length;
+ }
+ total_length -= Heap_Count;
+ if (total_length < Const_Count)
+ Const_Count = total_length;
+ }
+ printf("Heap contents:\n\n");
+ for (Next = Data, i = 0; i < Heap_Count; Next++, i++)
+ {
+ if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR)
+ {
+ long j, count;
+
+ count = Get_Integer(*Next);
Display(i, Type_Code(*Next), Address(*Next));
Next += 1;
- for (j=0; j < count ; j++, Next++)
+ for (j = 0; j < count ; j++, Next++)
printf(" %02x%06x\n",
Type_Code(*Next), Address(*Next));
i += count;
Next -= 1;
}
- else Display(i, Type_Code(*Next), Address(*Next));
- printf("\n\nConstant space\n\n");
- for (; i < Heap_Count+Const_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
+ else
+ Display(i, Type_Code(*Next), Address(*Next));
+ }
+ printf("\n\nConstant space:\n\n");
+ for (; i < Heap_Count + Const_Count; Next++, i++)
+ {
+ if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR)
+ {
+ long j, count;
+
+ count = Get_Integer(*Next);
Display(i, Type_Code(*Next), Address(*Next));
Next += 1;
- for (j=0; j < count ; j++, Next++)
+ for (j = 0; j < count ; j++, Next++)
printf(" %02x%06x\n",
Type_Code(*Next), Address(*Next));
i += count;
Next -= 1;
}
- else Display(i, Type_Code(*Next), Address(*Next));
+ else
+ Display(i, Type_Code(*Next), Address(*Next));
+ }
}
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/Attic/psbtobin.c,v 9.24 1987/04/17 15:56:08 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.25 1987/06/05 04:11:31 jinx Rel $
*
* This File contains the code to translate portable format binary
* files to internal format.
static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
static Pointer *Stack_Top;
+long
Write_Data(Count, From_Where)
long Count;
Pointer *From_Where;
{
- fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File);
+ extern int fwrite();
+
+ return (fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File));
}
#include "dump.c"
\f
do_it()
{
+ Boolean result;
long Size;
Size = Read_Header_and_Allocate();
if ((Constant_Objects == 0) && (Constant_Count == 0) &&
(Pure_Objects == 0) && (Pure_Count == 0))
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- 0, &Heap[Size], Dumped_Ext_Prim);
+ result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ 0, &Heap[Size], Dumped_Ext_Prim);
else
{
long Pure_Length, Total_Length;
Free_Constant[1] =
Make_Non_Pointer(END_OF_BLOCK, Total_Length);
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
+ result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
}
}
+ if (!result)
+ {
+ fprintf(stderr, "Error writing the output file.\n");
+ exit(1);
+ }
return;
}
\f
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/storage.c,v 9.33 1987/05/31 16:37:51 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.34 1987/06/05 04:15:27 jinx Exp $
This file defines the storage for global variables for
the Scheme Interpreter. */
Declare_Fixed_Objects();
-FILE *(Channels[FILE_CHANNELS]), *File_Handle, *Photo_File_Handle;
+FILE *(Channels[FILE_CHANNELS]), *Photo_File_Handle;
int Saved_argc;
char **Saved_argv;
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/Attic/version.h,v 9.63 1987/06/03 19:57:42 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.64 1987/06/05 04:16:55 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 63
+#define SUBVERSION 64
#endif
#ifndef UCODE_TABLES_FILENAME
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.25 1987/04/16 15:30:25 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.26 1987/06/05 04:10:41 jinx Rel $
*
* This File contains the code to translate internal format binary
* files to portable format.
static long NBits, NChars;
static Pointer *Free_Objects, *Free_Cobjects;
+long
Load_Data(Count, To_Where)
-long Count;
-char *To_Where;
-{ fread(To_Where, sizeof(Pointer), Count, Internal_File);
+ long Count;
+ char *To_Where;
+{
+ extern int fread();
+
+ return (fread(To_Where, sizeof(Pointer), Count, Internal_File));
}
#define Reloc_or_Load_Debug false
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.23 1987/04/03 00:12:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.24 1987/06/05 04:14:25 jinx Rel $
Contains information relating to the format of FASL files.
Some information is contained in CONFIG.H.
*/
+
+extern long Load_Data(), Write_Data();
+extern Boolean Open_Dump_File(), Close_Dump_File();
\f
/* FASL Version */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.24 1987/04/03 00:06:29 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.25 1987/06/05 04:11:11 jinx Exp $
*
* Dumps Scheme FASL in user-readable form .
*/
static Pointer *Memory_Base;
+extern int fread();
+
#define Load_Data(Count,To_Where) \
fread(To_Where, sizeof(Pointer), Count, stdin)
scheme_string(From, Quoted)
long From;
Boolean Quoted;
-{ fast long i, Count;
+{
+ fast long i, Count;
fast char *Chars;
+
Chars = (char *) &Data[From+STRING_CHARS];
if (Chars < ((char *) end_of_memory))
{ Count = Get_Integer(Data[From+STRING_LENGTH]);
void
scheme_symbol(From)
long From;
-{ Pointer *symbol;
+{
+ Pointer *symbol;
+
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
!scheme_string(via(From+SYMBOL_NAME), false))
\f
Display(Location, Type, The_Datum)
long Location, Type, The_Datum;
-{ long Points_To;
+{
+ long Points_To;
+
printf("%5x: %2x|%6x ", Location, Type, The_Datum);
if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer)
Points_To = Relocate((Pointer *) The_Datum);
main(argc, argv)
int argc;
char **argv;
-{ Pointer *Next;
- long i;
+{
+ Pointer *Next;
+ long i, total_length;
if (argc == 1)
- { if (!Read_Header())
+ {
+ if (!Read_Header())
{ fprintf(stderr, "Input does not appear to be in FASL format.\n");
exit(1);
}
printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
}
else
- { Const_Count = 0;
+ {
+ Const_Count = 0;
sscanf(argv[1], "%x", &Heap_Base);
sscanf(argv[2], "%x", &Const_Base);
sscanf(argv[3], "%d", &Heap_Count);
printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n",
Heap_Base, Const_Base, Heap_Count);
}
- Data = (Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count));
+ Data = ((Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count)));
end_of_memory = &Data[Heap_Count + Const_Count];
- Load_Data(Heap_Count + Const_Count, Data);
- printf("Heap contents\n\n");
- for (Next=Data, i=0; i < Heap_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
+ total_length = Load_Data(Heap_Count + Const_Count, Data);
+ if (total_length != (Heap_Count + Const_Count))
+ {
+ printf("The FASL file does not have the right length.\n");
+ printf("Expected %d objects. Obtained %d objects.\n\n",
+ (Heap_Count + Const_Count), total_length);
+ if (total_length < Heap_Count)
+ {
+ Heap_Count = total_length;
+ }
+ total_length -= Heap_Count;
+ if (total_length < Const_Count)
+ Const_Count = total_length;
+ }
+ printf("Heap contents:\n\n");
+ for (Next = Data, i = 0; i < Heap_Count; Next++, i++)
+ {
+ if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR)
+ {
+ long j, count;
+
+ count = Get_Integer(*Next);
Display(i, Type_Code(*Next), Address(*Next));
Next += 1;
- for (j=0; j < count ; j++, Next++)
+ for (j = 0; j < count ; j++, Next++)
printf(" %02x%06x\n",
Type_Code(*Next), Address(*Next));
i += count;
Next -= 1;
}
- else Display(i, Type_Code(*Next), Address(*Next));
- printf("\n\nConstant space\n\n");
- for (; i < Heap_Count+Const_Count; Next++, i++)
- if (Safe_Type_Code(*Next)==TC_MANIFEST_NM_VECTOR)
- { long j, count = Get_Integer(*Next);
+ else
+ Display(i, Type_Code(*Next), Address(*Next));
+ }
+ printf("\n\nConstant space:\n\n");
+ for (; i < Heap_Count + Const_Count; Next++, i++)
+ {
+ if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR)
+ {
+ long j, count;
+
+ count = Get_Integer(*Next);
Display(i, Type_Code(*Next), Address(*Next));
Next += 1;
- for (j=0; j < count ; j++, Next++)
+ for (j = 0; j < count ; j++, Next++)
printf(" %02x%06x\n",
Type_Code(*Next), Address(*Next));
i += count;
Next -= 1;
}
- else Display(i, Type_Code(*Next), Address(*Next));
+ else
+ Display(i, Type_Code(*Next), Address(*Next));
+ }
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.24 1987/04/17 15:56:08 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.25 1987/06/05 04:11:31 jinx Rel $
*
* This File contains the code to translate portable format binary
* files to internal format.
static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
static Pointer *Stack_Top;
+long
Write_Data(Count, From_Where)
long Count;
Pointer *From_Where;
{
- fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File);
+ extern int fwrite();
+
+ return (fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File));
}
#include "dump.c"
\f
do_it()
{
+ Boolean result;
long Size;
Size = Read_Header_and_Allocate();
if ((Constant_Objects == 0) && (Constant_Count == 0) &&
(Pure_Objects == 0) && (Pure_Count == 0))
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- 0, &Heap[Size], Dumped_Ext_Prim);
+ result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ 0, &Heap[Size], Dumped_Ext_Prim);
else
{
long Pure_Length, Total_Length;
Free_Constant[1] =
Make_Non_Pointer(END_OF_BLOCK, Total_Length);
- Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
+ result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
+ Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
}
}
+ if (!result)
+ {
+ fprintf(stderr, "Error writing the output file.\n");
+ exit(1);
+ }
return;
}
\f
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.63 1987/06/03 19:57:42 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.64 1987/06/05 04:16:55 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 63
+#define SUBVERSION 64
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff