/* -*-C-*-
-$Id: psbmap.h,v 9.41 1993/11/11 20:20:03 cph Exp $
+$Id: psbmap.h,v 9.42 1995/07/27 00:16:08 adams Exp $
Copyright (c) 1987-1993 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* This file contains macros and declarations for "bintopsb.c"
- and "psbtobin.c".
+/* This file contains macros, declarations and some sahred code
+ for "bintopsb.c" and "psbtobin.c".
*/
#ifndef PSBMAP_H_INCLUDED
#define PSBMAP_H_INCLUDED
+/* Objects in the portable file are tagged with a values from this set.
+ There is no direct correspondence with the TC_ typecodes because we
+ wish PSB files to be portable across many representation choices. Unless
+ the TC_ code can be infered (as in +0ve and -ve fixnums), there is at least
+ one TA_ code for every TC_ code that might appear in a PSB file
+*/
+
+/* interesting constants whose representation varies: */
+#define TA_FALSE 0 /* #F */
+#define TA_TRUE 1 /* #T */
+#define TA_NIL 2 /* '() */
+#define TA_UNSPECIFIC 3
+
+#define TA_CONSTANT 4 /* other TC_CONSTANT */
+#define TA_CHARACTER 5 /* #\x etc */
+#define TA_TC_NULL 6
+
+#define TA_FIXNUM 10
+
+#define TA_BIGNUM 11
+#define TA_FLONUM 12
+#define TA_RATNUM 13
+#define TA_RECNUM 14
+
+#define TA_MANIFEST_NM_VECTOR 20
+#define TA_MANIFEST_SPECIAL_NM_VECTOR 21
+#define TA_PRIMITIVE 22
+
+#define TA_COMPILED_ENTRY 30
+#define TA_MANIFEST_CLOSURE 31
+#define TA_REFERENCE_TRAP 32
+#define TA_COMPILED_CODE_BLOCK 33
+#define TA_LINKAGE_SECTION 34
+#define TA_CONTROL_POINT 35
+#define TA_STACK_ENVIRONMENT 36
+
+#define TA_CELL 40
+#define TA_BROKEN_HEART 41
+#define TA_PAIR 42
+#define TA_WEAK_CONS 43
+#define TA_UNINTERNED_SYMBOL 44
+#define TA_INTERNED_SYMBOL 45
+#define TA_HUNK3_A 46
+#define TA_HUNK3_B 47
+#define TA_QUAD 48
+
+#define TA_NON_MARKED_VECTOR 70
+#define TA_VECTOR 71
+#define TA_RECORD 72
+#define TA_VECTOR_1B 73
+#define TA_CHARACTER_STRING 74
+#define TA_VECTOR_16B 75
+
+#define TA_CONSTANT_CODE 80
+#define TA_HEAP_CODE 81
+#define TA_PURE_CODE 82
+
+#define TA_PROCEDURE 100
+#define TA_EXTENDED_PROCEDURE 101
+#define TA_LEXPR 102
+#define TA_ENTITY 103
+#define TA_ENVIRONMENT 104
+#define TA_PROMISE 105
+#define TA_FUTURE 106
+#define TA_IN_PACKAGE 107
+#define TA_COMMENT 108
+#define TA_SCODE_QUOTE 109
+#define TA_VARIABLE 110
+#define TA_ACCESS 111
+#define TA_LAMBDA 112
+#define TA_EXTENDED_LAMBDA 113
+#define TA_SEQUENCE_2 114
+#define TA_SEQUENCE_3 115
+#define TA_CONDITIONAL 116
+#define TA_DISJUNCTION 117
+#define TA_COMBINATION 118
+#define TA_COMBINATION_1 119
+#define TA_COMBINATION_2 120
+#define TA_PCOMB0 121
+#define TA_PCOMB1 122
+#define TA_PCOMB2 123
+#define TA_PCOMB3 124
+#define TA_DEFINITION 125
+#define TA_DELAY 126
+#define TA_ASSIGNMENT 127
+#define TA_THE_ENVIRONMENT 128
+#define TA_RETURN_CODE 129
+
+#define TA_C_COMPILED_TAG 200
+\f
/* These definitions insure that the appropriate code is extracted
from the included files.
*/
#ifndef COMPILER_PROCESSOR_TYPE
#define COMPILER_PROCESSOR_TYPE COMPILER_NONE_TYPE
#endif
+
+/* compatibilty with previous version of microcode */
+#ifndef TC_CONSTANT
+#define TC_CONSTANT TC_TRUE
+#endif
+
+#ifndef EMPTY_LIST_VALUE
+#define EMPTY_LIST_VALUE EMPTY_LIST
+#endif
\f
extern double
EXFUN (frexp, (double, int *)),
EXFUN (ldexp, (double, int));
-#define PORTABLE_VERSION 6
+#define PORTABLE_VERSION 7
/* Number of objects which, when traced recursively, point at all other
objects dumped.
#define NROOTS 2
/* Types to recognize external object references. Any occurrence of these
- (which are external types and thus handled separately) means a reference
- to an external object.
+ (which are external types and thus handled separately) means a
+ reference to an external object. These values are required to be
+ TC_xxx values so that they can fit in a normal object typecode in
+ bintopsb until they are translated to TA_xxx values on output.
*/
-#define CONSTANT_CODE TC_FIXNUM
+#define CONSTANT_CODE TC_POSITIVE_FIXNUM
#define HEAP_CODE TC_CHARACTER
#define PURE_CODE TC_BIG_FIXNUM
+/*
+ The special constants #F () #T and UNSPECIFIC might appear in the
+ vector length position of a vector or record. If this happens we
+ want to translate the value for its datum field rather than
+ maintain that it represents #T or #F etc. In the original (7.3)
+ tagging scheme #F was the value 0x0, and so was the the vector
+ length of #().
+
+ We detect these unusual vector lengths and translate them to
+ ALIASED_LENGTH_xxx values when the vector/record is copied. We
+ choose MANIFEST_NM_VECTOR with very high datum fields as these can
+ never appear in a fasdump file if the datum field indicates a
+ length greater than the total heap size.
+*/
+
+#define ALIASED_LENGTH_SHARP_F \
+ (MAKE_OBJECT(TC_MANIFEST_NM_VECTOR, (DATUM_MASK & (-1))))
+
#define fixnum_to_bits FIXNUM_LENGTH
#define hex_digits(nbits) (((nbits) + 3) / 4)
static Boolean nmv_p = false;
-#define TC_C_COMPILED_TAG TC_MANIFEST_CLOSURE
#define C_COMPILED_FAKE_NMV 0
#define C_COMPILED_ENTRY_FORMAT 1
#define C_COMPILED_ENTRY_CODE 2
/* -*-C-*-
-$Id: psbtobin.c,v 9.56 1994/01/12 00:30:57 gjr Exp $
+$Id: psbtobin.c,v 9.57 1995/07/27 00:18:45 adams Exp $
Copyright (c) 1987-1994 Massachusetts Institute of Technology
#include "psbmap.h"
#include "float.h"
#include "limits.h"
+
#define portable_file input_file
#define internal_file output_file
DEFUN (read_a_string_internal, (To, maxlen),
SCHEME_OBJECT * To AND long maxlen)
{
+
long ilen, Pointer_Count;
fast char *str;
fast long len;
}
\f
static SCHEME_OBJECT *
-DEFUN (read_an_integer, (The_Type, To, Slot),
- int The_Type AND SCHEME_OBJECT * To AND 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;
length_in_bits = l;
}
if ((length_in_bits <= fixnum_to_bits)
- && (The_Type == TC_FIXNUM))
+ && (the_type == TC_POSITIVE_FIXNUM)) /* Always passed as POSITIVE! */
{
/* The most negative fixnum is handled in the bignum case */
fast long Value = 0;
low_digit = (- (BIGNUM_REF (bignum, 0)));
if (negative
- && (The_Type == TC_FIXNUM)
+ && (the_type == TC_POSITIVE_FIXNUM) /* Always passed as POSITIVE! */
&& (original_length_in_bits == (fixnum_to_bits + 1))
&& (LONG_TO_FIXNUM_P (low_digit)))
{
}
SCHEME_OBJECT *
-DEFUN (read_a_bignum, (The_Type, To, Slot),
- int The_Type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
+DEFUN (read_a_bignum, (the_type, To, Slot),
+ int the_type AND SCHEME_OBJECT * To AND SCHEME_OBJECT * Slot)
{
- return (read_an_integer (The_Type, To, Slot));
+ return (read_an_integer (the_type, To, Slot));
}
\f
static SCHEME_OBJECT *
AND SCHEME_OBJECT * To)
{
fast SCHEME_OBJECT *Until = &Table[N];
- int The_Type;
+ int the_type;
while (Table < Until)
{
- VMS_BUG (The_Type = 0);
- fscanf (portable_file, "%2x", &The_Type);
- switch (The_Type)
- {
- case TC_CHARACTER_STRING:
+ VMS_BUG (the_type = 0);
+ fscanf (portable_file, "%2x", &the_type);
+ switch (the_type)
+ {
+ case TA_CHARACTER_STRING:
To = (read_a_string (To, Table++));
continue;
- case TC_BIT_STRING:
+ case TA_VECTOR_1B:
To = (read_a_bit_string (To, Table++));
continue;
- case TC_FIXNUM:
- To = (read_an_integer (The_Type, To, Table++));
+ case TA_FIXNUM:
+ /* Choice of POSITIVE/NEGATIVE for output is independent of */
+ /* value on input, since the sign is indicated separately (for */
+ /* largely historical reasons) in the input file. The type */
+ /* here is used to determine whether a FIXNUM or BIGNUM result */
+ /* is required. */
+ To = (read_an_integer (TC_POSITIVE_FIXNUM, To, Table++));
continue;
- case TC_BIG_FIXNUM:
- To = (read_a_bignum (The_Type, To, Table++));
+ case TA_BIGNUM:
+ To = (read_a_bignum (TC_BIG_FIXNUM, To, Table++));
continue;
- case TC_CHARACTER:
+ case TA_CHARACTER:
{
long the_char_code;
continue;
}
- case TC_BIG_FLONUM:
+ case TA_FLONUM:
{
double The_Flonum = (read_a_flonum ());
default:
fprintf (stderr,
"%s: Unknown external object found; Type = 0x%02x\n",
- program_name, The_Type);
+ program_name, the_type);
inconsistency ();
/*NOTREACHED*/
}
{
switch (OBJECT_TYPE (*Table))
{
- case TC_FIXNUM:
- {
- fprintf (stderr,
+#if (TC_NEGATIVE_FIXNUM != TC_POSITIVE_FIXNUM)
+ case TC_NEGATIVE_FIXNUM:
+#endif
+ case TC_POSITIVE_FIXNUM:
+ { fprintf (stderr,
"Table[%6d] = Fixnum %d\n",
(N - (Table_End - Table)),
(FIXNUM_TO_LONG (*Table)));
#endif
\f
+#define TRANSLATE_CONSTANT(value) { \
+ *to++ = value; \
+ continue; \
+}
+
+#define TRANSLATE_NONPOINTER(typecode) { \
+ *to++ = (MAKE_OBJECT(typecode, the_datum)); \
+ continue; \
+}
+
+#define TRANSLATE_POINTER(typecode) { \
+ *to++ = (MAKE_POINTER_OBJECT(typecode, Relocate(the_datum))); \
+ continue; \
+}
+
static SCHEME_OBJECT *
DEFUN (Read_Pointers_and_Relocate, (how_many, to),
fast long how_many AND fast SCHEME_OBJECT * to)
{
- int The_Type;
- long The_Datum;
+ int the_type;
+ long the_datum;
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:
- WHEN (((The_Datum < 0) || (The_Datum >= Const_Objects)),
+ case TA_FALSE: TRANSLATE_CONSTANT(SHARP_F);
+ case TA_NIL: TRANSLATE_CONSTANT(EMPTY_LIST_VALUE);
+ case TA_TRUE: TRANSLATE_CONSTANT(SHARP_T);
+ case TA_UNSPECIFIC: TRANSLATE_CONSTANT(UNSPECIFIC);
+
+ case TA_CONSTANT_CODE:
+ WHEN (((the_datum < 0) || (the_datum >= Const_Objects)),
"CONSTANT_CODE too large");
- *to++ = Const_Table[The_Datum];
+ *to++ = Const_Table[the_datum];
continue;
- case HEAP_CODE:
- WHEN (((The_Datum < 0) || (The_Datum >= Heap_Objects)),
+ case TA_HEAP_CODE:
+ WHEN (((the_datum < 0) || (the_datum >= Heap_Objects)),
"HEAP_CODE too large");
- *to++ = Heap_Table[The_Datum];
+ *to++ = Heap_Table[the_datum];
continue;
- case PURE_CODE:
- WHEN (((The_Datum < 0) || (The_Datum >= Pure_Objects)),
+ case TA_PURE_CODE:
+ WHEN (((the_datum < 0) || (the_datum >= Pure_Objects)),
"PURE_CODE too large");
- *to++ = Pure_Table[The_Datum];
+ *to++ = Pure_Table[the_datum];
+ continue;
+
+ case TA_CHARACTER_STRING:
+ case TA_FIXNUM:
+ case TA_BIGNUM:
+ case TA_FLONUM:
+ case TA_CHARACTER:
+ fprintf (stderr,
+ "%s: Unexpected external constant in pointer area: 0x%02x\n.",
+ program_name, the_type);
+ inconsistency ();
continue;
- case TC_MANIFEST_NM_VECTOR:
- *to++ = (MAKE_OBJECT (The_Type, The_Datum));
+ case TA_MANIFEST_NM_VECTOR:
+ *to++ = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, the_datum));
{
fast long count;
- count = The_Datum;
- how_many -= count;
+ count = the_datum;
+ how_many = how_many - count;
while (--count >= 0)
{
VMS_BUG (*to = 0);
}
continue;
- case TC_BROKEN_HEART:
- if (The_Datum != 0)
+ case TA_BROKEN_HEART:
+ if (the_datum != 0)
{
fprintf (stderr, "%s: Broken Heart found.\n", program_name);
inconsistency ();
}
- /* fall through */
-
- case TC_PCOMB0:
- case TC_PRIMITIVE:
- case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case_simple_Non_Pointer:
- *to++ = (MAKE_OBJECT (The_Type, The_Datum));
- continue;
+ TRANSLATE_NONPOINTER(TC_BROKEN_HEART);
+
+ case TA_PCOMB0: TRANSLATE_NONPOINTER(TC_PCOMB0);
+ case TA_PRIMITIVE: TRANSLATE_NONPOINTER(TC_PRIMITIVE);
+ case TA_MANIFEST_SPECIAL_NM_VECTOR:
+ TRANSLATE_NONPOINTER(TC_MANIFEST_SPECIAL_NM_VECTOR);
+ case TA_THE_ENVIRONMENT: TRANSLATE_NONPOINTER(TC_THE_ENVIRONMENT);
+ case TA_RETURN_CODE: TRANSLATE_NONPOINTER(TC_RETURN_CODE);
+ case TA_TC_NULL: TRANSLATE_NONPOINTER(TC_NULL);
+ case TA_CONSTANT: TRANSLATE_NONPOINTER(TC_CONSTANT);
\f
- case TC_COMPILED_ENTRY:
+ case TA_COMPILED_ENTRY:
{
SCHEME_OBJECT * temp, * entry_addr;
- long base_type, base_datum;
+ long TA_of_base, TC_of_base, base_datum;
- VMS_BUG (base_type = 0);
+ VMS_BUG (TA_of_base = 0);
VMS_BUG (base_datum = 0);
- fscanf (portable_file, "%02x %lx", &base_type, &base_datum);
+ fscanf (portable_file, "%02x %lx", &TA_of_base, &base_datum);
temp = (Relocate (base_datum));
if (c_compiled_p)
- entry_addr = &temp[The_Datum];
+ entry_addr = &temp[the_datum];
else
- entry_addr = ((SCHEME_OBJECT *) (&(((char *) temp) [The_Datum])));
- *to++ = (MAKE_POINTER_OBJECT (base_type, entry_addr));
+ entry_addr = ((SCHEME_OBJECT *) (&(((char *) temp) [the_datum])));
+ switch (TA_of_base) /* translate base object type */
+ {
+ case TA_COMPILED_ENTRY: TC_of_base = TC_COMPILED_ENTRY; break;
+ default:
+ fprintf(stderr,
+ "%s: Unexpected base type for compiled entry: TA 0x%02x.\n",
+ program_name,
+ TA_of_base);
+ inconsistency();
+ }
+ *to++ = (MAKE_POINTER_OBJECT (TC_of_base, entry_addr));
continue;
}
- case TC_C_COMPILED_TAG:
+ case TA_C_COMPILED_TAG:
{
if (! c_compiled_p)
{
program_name);
inconsistency ();
}
- switch (The_Datum)
+ switch (the_datum)
{
case C_COMPILED_FAKE_NMV:
{
continue;
}
- case TC_STACK_ENVIRONMENT:
- *to++ = (MAKE_POINTER_OBJECT (The_Type, (Stack_Top - The_Datum)));
+ case TA_STACK_ENVIRONMENT:
+ *to++ = (MAKE_POINTER_OBJECT (TC_STACK_ENVIRONMENT, (Stack_Top - the_datum)));
continue;
- case TC_REFERENCE_TRAP:
- if (The_Datum <= TRAP_MAX_IMMEDIATE)
- {
- *to++ = (MAKE_OBJECT (The_Type, The_Datum));
+ case TA_REFERENCE_TRAP:
+ if (the_datum <= TRAP_MAX_IMMEDIATE)
+ { *to++ = (MAKE_OBJECT (TC_REFERENCE_TRAP, the_datum));
continue;
}
- /* It is a pointer, fall through. */
+ *to++ = MAKE_POINTER_OBJECT (TC_REFERENCE_TRAP, Relocate (the_datum));
+ continue;
+
+ case TA_RATNUM: TRANSLATE_POINTER(TC_RATNUM);
+ case TA_RECNUM: TRANSLATE_POINTER(TC_COMPLEX);
+
+ case TA_MANIFEST_CLOSURE: TRANSLATE_POINTER(TC_MANIFEST_CLOSURE);
+ case TA_COMPILED_CODE_BLOCK: TRANSLATE_POINTER(TC_COMPILED_CODE_BLOCK);
+ case TA_LINKAGE_SECTION: TRANSLATE_POINTER(TC_LINKAGE_SECTION);
+ case TA_CONTROL_POINT: TRANSLATE_POINTER(TC_CONTROL_POINT);
+
+ case TA_CELL: TRANSLATE_POINTER(TC_CELL);
+ case TA_PAIR: TRANSLATE_POINTER(TC_LIST);
+ case TA_WEAK_CONS: TRANSLATE_POINTER(TC_WEAK_CONS);
+ case TA_UNINTERNED_SYMBOL: TRANSLATE_POINTER(TC_UNINTERNED_SYMBOL);
+ case TA_INTERNED_SYMBOL: TRANSLATE_POINTER(TC_INTERNED_SYMBOL);
+ case TA_HUNK3_A: TRANSLATE_POINTER(TC_HUNK3_A);
+ case TA_HUNK3_B: TRANSLATE_POINTER(TC_HUNK3_B);
+ case TA_QUAD: TRANSLATE_POINTER(TC_QUAD);
+
+ case TA_NON_MARKED_VECTOR: TRANSLATE_POINTER(TC_NON_MARKED_VECTOR);
+ case TA_VECTOR: TRANSLATE_POINTER(TC_VECTOR);
+ case TA_RECORD: TRANSLATE_POINTER(TC_RECORD);
+ case TA_VECTOR_1B: TRANSLATE_POINTER(TC_VECTOR_1B);
+ case TA_VECTOR_16B: TRANSLATE_POINTER(TC_VECTOR_16B);
+
+ case TA_PROCEDURE: TRANSLATE_POINTER(TC_PROCEDURE);
+ case TA_EXTENDED_PROCEDURE: TRANSLATE_POINTER(TC_EXTENDED_PROCEDURE);
+ case TA_LEXPR: TRANSLATE_POINTER(TC_LEXPR);
+ case TA_ENTITY: TRANSLATE_POINTER(TC_ENTITY);
+ case TA_ENVIRONMENT: TRANSLATE_POINTER(TC_ENVIRONMENT);
+ case TA_PROMISE: TRANSLATE_POINTER(TC_DELAYED);
+ case TA_FUTURE: TRANSLATE_POINTER(TC_FUTURE);
+ case TA_IN_PACKAGE: TRANSLATE_POINTER(TC_IN_PACKAGE);
+ case TA_COMMENT: TRANSLATE_POINTER(TC_COMMENT);
+ case TA_SCODE_QUOTE: TRANSLATE_POINTER(TC_SCODE_QUOTE);
+ case TA_VARIABLE: TRANSLATE_POINTER(TC_VARIABLE);
+ case TA_ACCESS: TRANSLATE_POINTER(TC_ACCESS);
+ case TA_LAMBDA: TRANSLATE_POINTER(TC_LAMBDA);
+ case TA_EXTENDED_LAMBDA: TRANSLATE_POINTER(TC_EXTENDED_LAMBDA);
+ case TA_SEQUENCE_2: TRANSLATE_POINTER(TC_SEQUENCE_2);
+ case TA_SEQUENCE_3: TRANSLATE_POINTER(TC_SEQUENCE_3);
+ case TA_CONDITIONAL: TRANSLATE_POINTER(TC_CONDITIONAL);
+ case TA_DISJUNCTION: TRANSLATE_POINTER(TC_DISJUNCTION);
+ case TA_COMBINATION: TRANSLATE_POINTER(TC_COMBINATION);
+ case TA_COMBINATION_1: TRANSLATE_POINTER(TC_COMBINATION_1);
+ case TA_COMBINATION_2: TRANSLATE_POINTER(TC_COMBINATION_2);
+ case TA_PCOMB1: TRANSLATE_POINTER(TC_PCOMB1);
+ case TA_PCOMB2: TRANSLATE_POINTER(TC_PCOMB2);
+ case TA_PCOMB3: TRANSLATE_POINTER(TC_PCOMB3);
+ case TA_DEFINITION: TRANSLATE_POINTER(TC_DEFINITION);
+ case TA_DELAY: TRANSLATE_POINTER(TC_DELAY);
+ case TA_ASSIGNMENT: TRANSLATE_POINTER(TC_ASSIGNMENT);
default:
- /* Should be stricter */
- *to++ = (MAKE_POINTER_OBJECT (The_Type, (Relocate (The_Datum))));
- continue;
+ fprintf(stderr,"Unknown abstract tag (TA_* value): 0x%02x\n", the_type);
+ inconsistency();
}
}
- return (to);
+ return to;
}
\f
static Boolean primitive_warn = false;
projects / mit-scheme.git / commitdiff