--- /dev/null
+<PACKAGE "GC-DUMP-R">
+
+<ENTRY GC-READ>
+
+<INCLUDE-WHEN <FEATURE? "COMPILER"> "GC-DUMP-DEFS" "STORAGE-DEFS">
+
+<DEFINE GC-READ ("OPT" (CHAN:<CHANNEL 'DISK> .INCHAN)
+ (EOF '<ERROR END-OF-FILE!-ERRORS GC-READ>)
+ "AUX" BLOCK:UVECTOR HEADER:LIST OFFSET:FIX STOP:FIX
+ BLOCK-LENGTH:<OR FALSE FIX> WORDS-NEEDED:<OR FALSE FIX>
+ NUMBER-OF-NEWTYPES:<OR FALSE FIX> FLAG)
+ <COND
+ (<S=? <CHANNEL-OP .CHAN GET-BYTE-SIZE> "BINARY">
+ <COND (<SET NUMBER-OF-NEWTYPES <CHANNEL-OP .CHAN READ-BYTE>>
+ <COND (<OR <L? .NUMBER-OF-NEWTYPES 0>
+ <NOT <SET WORDS-NEEDED <CHANNEL-OP .CHAN READ-BYTE>>>
+ <L? .WORDS-NEEDED 0>
+ <NOT <SET BLOCK-LENGTH <CHANNEL-OP .CHAN READ-BYTE>>>
+ <L? .BLOCK-LENGTH 3>>
+ <ERROR BAD-GC-READ-FILE!-ERRORS GC-READ>)
+ (ELSE
+ <COND (<G=? .WORDS-NEEDED 2>
+ <CALL RELU <IUVECTOR <- .WORDS-NEEDED 2>>>)>
+ <SET BLOCK <IUVECTOR .BLOCK-LENGTH>>
+ <COND (<==? <CHANNEL-OP .CHAN READ-BUFFER .BLOCK>
+ .BLOCK-LENGTH>
+ <IFSYS ("TOPS20" <SET OFFSET 3>)
+ ("VAX" <SET OFFSET 2>)>
+ <SET HEADER
+ <CALL OBJECT
+ ,TYPE-C-LIST
+ 0
+ <CALL VALUE
+ <REST .BLOCK
+ <- .BLOCK-LENGTH .OFFSET>>>>>
+ <SET OFFSET
+ <- <CALL VALUE .HEADER>
+ <CALL VALUE <REST .HEADER>>>>
+ <SET STOP <CALL VALUE .BLOCK>>
+ <BIND ((OLD-CODES <ITUPLE .NUMBER-OF-NEWTYPES 0>)
+ (NEW-CODES <ITUPLE .NUMBER-OF-NEWTYPES 0>)
+ (GCP:<PRIMTYPE UVECTOR>
+ <STACK <IUVECTOR 13 0>>))
+ <SET GCP <CHTYPE .GCP GC-PARAMS>>
+ <GCSMIN .GCP <CALL VALUE .BLOCK>>
+ <SETG OLD-CODES .OLD-CODES>
+ <SETG NEW-CODES .NEW-CODES>
+ <SET FLAG
+ <PROG READ-FRAME ()
+ #DECL ((READ-FRAME) <SPECIAL FRAME>)
+ <FIXUP-TOUGHIES .HEADER .OFFSET .STOP
+ .GCP>
+ %<>>>
+ <COND (.FLAG
+ <ERROR TYPE-ALREADY-EXISTS!-ERRORS
+ .FLAG
+ GC-READ>)
+ (ELSE
+ <FIXUP-EASIES .HEADER
+ .OFFSET
+ .STOP
+ .OLD-CODES
+ .NEW-CODES
+ .GCP>
+ <SWEEPING-UNMARK .HEADER .STOP .GCP>
+ <1 .HEADER>)>>)
+ (ELSE <ERROR BAD-GC-READ-FILE!-ERRORS GC-READ>)>)>)
+ (ELSE <EVAL .EOF>)>)
+ (ELSE <ERROR CHANNEL-HAS-WRONG-BYTE-SIZE!-ERRORS GC-READ>)>>
+
+<DEFINE FIXUP-TOUGHIES (OBJ OFF:FIX STOP:FIX GCP:GC-PARAMS)
+ <REPEAT ()
+ ;"Unfortunately we cannot fixup strings in this pass because swnext
+ only returns the length of the string to the nearest multiple of
+ four."
+ <COND ;(<TYPE? .OBJ STRING> <FIXUP-STRING .OBJ .OFF>)
+ (<TYPE? .OBJ ATOM> <FIXUP-ATOM .OBJ .OFF>)
+ (<TYPE? .OBJ GBIND> <FIXUP-GBIND .OBJ .OFF>)>
+ <SET OBJ <CALL SWNEXT .OBJ .GCP>>
+ <COND (<OR <TYPE? .OBJ FIX>
+ <L? <COND (<OR <TYPE? .OBJ BYTES>
+ <TYPE? .OBJ STRING>>
+ <ADDR-S <CALL VALUE .OBJ>>)
+ (ELSE <CALL VALUE .OBJ>)>
+ .STOP>>
+ <RETURN>)>>>
+
+<SETG STRING-OBLIST <STRINGS> OBLIST>
+
+<DEFINE FIXUP-STRING (STR:STRING OFF:FIX)
+ <BIND (STR-ATM:<OR ATOM FALSE> FX:<OR STRING FIX> CORR-STR:STRING)
+ <COND (<TYPE? <SET FX <CALL MARKUS? .STR 1>> FIX>
+ <SET STR-ATM <LOOKUP .STR ,STRING-OBLIST>>
+ <COND (.STR-ATM
+ <SET CORR-STR <M$$PNAM .STR-ATM>>
+ <CALL MARKUS .STR .CORR-STR>
+ .CORR-STR)
+ (ELSE <CALL MARKUS .STR .STR> .STR)>)
+ (ELSE .FX)>>>
+
+;"The function RIGHT-ATOM has been replaced by the corresponding MACRO in
+ GC-DUMP-DEFS"
+
+;<DEFINE RIGHT-ATOM (ATM OFF "AUX" (VAL <CALL VALUE .ATM>))
+ #DECL ((ATM) <PRIMTYPE ATOM> (OFF VAL) FIX)
+ <COND (<==? .VAL -1>
+ <CHTYPE ROOT <TYPE .ATM>>)
+ (ELSE
+ <CHTYPE <FIXUP-ATOM <CALL OBJECT
+ ,TYPE-C-ATOM
+ ,LENUU-ATOM
+ <+ .VAL .OFF>>
+ .OFF>
+ <TYPE .ATM>>)>>
+
+<DEFINE FIXUP-ATOM (ATM OFF
+ "AUX" OBL PNAM CORR-ATM BNUM FX TYPE-C NEWTYPE? CORR-TYPE-C
+ PTYP GB)
+ #DECL ((OBL) <OR FALSE OBLIST> (PNAM) STRING (OFF BNUM) FIX (ATM PTYP) ATOM
+ (CORR-ATM) <OR FALSE ATOM> (FX) <OR ATOM FIX>
+ (TYPE-C CORR-TYPE-C) <OR TYPE-C FALSE> (GB) <OR FALSE GBIND>)
+ <COND
+ (<TYPE? <SET FX <CALL MARKR? .ATM 1>> FIX>
+ <CALL MARKR .ATM .ATM>
+ <SET OBL <M$$OBLS .ATM>>
+ <COND (.OBL
+ <M$$OBLS .ATM <SET OBL <RIGHT-ATOM <M$$OBLS .ATM> .OFF>>>)>
+ <SET PNAM <M$$PNAM .ATM>>
+ <M$$PNAM .ATM
+ <SET PNAM
+ <FIXUP-STRING <CALL OBJECT
+ ,TYPE-C-STRING
+ <CALL LENUU .PNAM>
+ <+ <CALL VALUE .PNAM> .OFF>>
+ .OFF>>>
+ <SET TYPE-C <VALID-TYPE? .ATM>>
+ <SET GB <M$$GVAL .ATM>>
+ <SET NEWTYPE? <AND .TYPE-C <G? <LSH .TYPE-C -6> ,OLD-TYPES> .GB>>
+ <COND (.NEWTYPE?
+ <SET PTYP
+ <FIXUP-ATOM <CALL OBJECT
+ ,TYPE-C-ATOM
+ ,LENUU-ATOM
+ <+ <CALL VALUE .GB> .OFF>>
+ .OFF>>
+ <M$$GVAL .ATM %<>>)>
+ <COND
+ (.OBL
+ <SET CORR-ATM <LOOKUP .PNAM .OBL>>
+ <COND (.CORR-ATM
+ <COND (.NEWTYPE?
+ <SET CORR-TYPE-C <VALID-TYPE? .CORR-ATM>>
+ <COND (.CORR-TYPE-C
+ <COND (<==? .PTYP <TYPEPRIM .CORR-ATM>>
+ <PAIR-UP .TYPE-C .CORR-TYPE-C>)
+ (ELSE <RETURN .CORR-ATM .READ-FRAME>)>)
+ (ELSE
+ <PAIR-UP .TYPE-C
+ <CREATE-NEWTYPE .CORR-ATM .PTYP>>)>)>
+ <CALL MARKR .ATM .CORR-ATM>
+ .CORR-ATM)
+ (ELSE
+ <M$$OBLS .ATM .OBL>
+ <SET BNUM <HASH-NAME <M$$PNAM .ATM> <LENGTH ,ATOM-TABLE>>>
+ <PUT ,ATOM-TABLE .BNUM (.ATM !<NTH ,ATOM-TABLE .BNUM>)>
+ <COND (.NEWTYPE? <PAIR-UP .TYPE-C <CREATE-NEWTYPE .ATM .PTYP>>)>
+ .ATM)>)
+ (ELSE
+ <COND (.NEWTYPE? <PAIR-UP .TYPE-C <CREATE-NEWTYPE .ATM .PTYP>>)>
+ .ATM)>)
+ (ELSE .FX)>>
+
+;"The function PAIR-UP has been replaced by the corresponding MACRO in
+ GC-DUMP-DEFS."
+
+;<DEFINE PAIR-UP (OC NC "AUX" (OLD-CODES ,OLD-CODES) (NEW-CODES ,NEW-CODES))
+ #DECL ((OC NC) TYPE-C
+ (OLD-CODES NEW-CODES) <<PRIMTYPE VECTOR> <PRIMTYPE FIX>>)
+ <1 .OLD-CODES .OC>
+ <SETG OLD-CODES <REST .OLD-CODES>>
+ <1 .NEW-CODES .NC>
+ <SETG NEW-CODES <REST .NEW-CODES>>>
+
+<DEFINE CREATE-NEWTYPE (TYP-ATM PTYP-ATM "AUX" TYPE-C ENTRY SAT TYP)
+ #DECL ((TYP-ATM PTYP-ATM) ATOM (ENTRY) TYPE-ENTRY (TYP SAT) FIX
+ (TYPE-C) TYPE-C)
+ <SET ENTRY
+ <NTH ,M$$TYPE-INFO!-INTERNAL
+ <+ <LSH <VALID-TYPE? .PTYP-ATM> -6> 1>>>
+ <SET SAT <ANDB ,M$$TYSAT <M$$TYWRD .ENTRY>>>
+ <SET TYP <LSH <CALL NEWTYPE .SAT> -6>>
+ <SET TYPE-C <CHTYPE <ORB <LSH .TYP ,M$$TYOFF> .SAT> TYPE-C>>
+ <SETG M$$NEWTYPE? T>
+ <PUT ,M$$TYPE-INFO!-INTERNAL
+ <+ .TYP 1>
+ <CHTYPE [.TYP-ATM <M$$PTYPE .ENTRY> %<> %<> %<> .TYPE-C %<>]
+ T$TYPE-ENTRY>>
+ <M$$TYPE .TYP-ATM .TYPE-C>
+ .TYPE-C>
+
+<DEFINE FIXUP-GBIND (GB OFF "AUX" ATM CORR-GB)
+ #DECL ((GB) GBIND (OFF) FIX (ATM) ATOM (CORR-GB) <OR FALSE GBIND>)
+ <COND (<TYPE? <CALL MARKR? .GB 1> FIX>
+ <M$$ATOM .GB <SET ATM <RIGHT-ATOM <M$$ATOM .GB> .OFF>>>
+ <SET CORR-GB <M$$GVAL .ATM>>
+ <COND (.CORR-GB <CALL MARKR .GB .CORR-GB>)
+ (ELSE <CALL MARKR .GB .GB> <M$$GVAL .ATM .GB>)>)>
+ T>
+
+<DEFINE FIXUP-EASIES (OBJ OFF STOP OLD-CODES NEW-CODES GCP:GC-PARAMS)
+ #DECL ((OBJ) ANY (OFF STOP) FIX
+ (OLD-CODES NEW-CODES) <<PRIMTYPE VECTOR> [REST TYPE-C]>)
+ <REPEAT ()
+ <COND (<TYPE? .OBJ VECTOR>
+ <MAPR %<>
+ <FUNCTION (R-OBJ:VECTOR)
+ <PUT .R-OBJ
+ 1
+ <CORRECT-POINTER <1 .R-OBJ> .OFF
+ .OLD-CODES .NEW-CODES>>>
+ .OBJ>)
+ (<TYPE? .OBJ LIST>
+ <PUT .OBJ
+ 1
+ <CORRECT-POINTER <1 .OBJ> .OFF .OLD-CODES .NEW-CODES>>
+ <PUTREST .OBJ
+ <CORRECT-POINTER <REST .OBJ>
+ .OFF
+ .OLD-CODES
+ .NEW-CODES>>)>
+ <SET OBJ <CALL SWNEXT .OBJ .GCP>>
+ <COND (<OR <TYPE? .OBJ FIX>
+ <L? <COND (<OR <TYPE? .OBJ BYTES> <TYPE? .OBJ STRING>>
+ <ADDR-S <CALL VALUE .OBJ>>)
+ (ELSE <CALL VALUE .OBJ>)>
+ .STOP>>
+ <RETURN>)>>>
+
+<DEFINE CORRECT-POINTER (OBJ OFF OLD-CODES NEW-CODES
+ "AUX" (TYPE-C <CHTYPE <CALL TYPE .OBJ> TYPE-C>)
+ (TYP <LSH .TYPE-C -6>) PTYP RC)
+ #DECL ((OBJ) ANY (OFF) FIX (PTYP) ATOM (TYP) FIX (TYPE-C) TYPE-C
+ (OLD-CODES NEW-CODES RC) <<PRIMTYPE VECTOR> [REST TYPE-C]>)
+ <COND (<G? .TYP ,OLD-TYPES>
+ <SET RC <MEMQ .TYPE-C .OLD-CODES>>
+ <SET OBJ
+ <CALL OBJECT
+ <NTH .NEW-CODES
+ <- <LENGTH .OLD-CODES> <LENGTH .RC> -1>>
+ <CALL LENUU .OBJ>
+ <CALL VALUE .OBJ>>>)>
+ <SET PTYP <PRIMTYPE .OBJ>>
+ <COND (<NOT <OR <==? .PTYP FIX> <AND <==? .PTYP LIST> <EMPTY? .OBJ>>>>
+ <COND (<==? .PTYP ATOM> <SET OBJ <RIGHT-ATOM .OBJ .OFF>>)
+ (ELSE
+ <SET OBJ
+ <CALL OBJECT
+ <CALL TYPE .OBJ>
+ <CALL LENUU .OBJ>
+ <+ <CALL VALUE .OBJ> .OFF>>>
+ <COND (<==? .PTYP STRING>
+ ;<SET OBJ
+ <CHTYPE <CALL MARKUS? .OBJ 1> <TYPE .OBJ>>>
+ <SET OBJ
+ <CHTYPE <FIXUP-STRING .OBJ .OFF> <TYPE .OBJ>>>)
+ (<==? .PTYP GBIND>
+ <SET OBJ
+ <CHTYPE <CALL MARKR? .OBJ 1>
+ <TYPE .OBJ>>>)>)>)>
+ .OBJ>
+
+<DEFINE SWEEPING-UNMARK (OBJ STOP GCP:GC-PARAMS "AUX" (PTYP <PRIMTYPE .OBJ>))
+ #DECL ((OBJ) ANY (STOP) FIX (PTYP) ATOM)
+ <REPEAT ()
+ <COND (<==? .PTYP STRING> <CALL MARKUS .OBJ 0>)
+ (<==? .PTYP ATOM> <CALL MARKR .OBJ 0>)
+ (<==? .PTYP GBIND> <CALL MARKR .OBJ 0>)>
+ <SET OBJ <CALL SWNEXT .OBJ .GCP>>
+ <SET PTYP <PRIMTYPE .OBJ>>
+ <COND (<OR <TYPE? .OBJ FIX>
+ <L? <COND (<OR <==? .PTYP BYTES> <==? .PTYP STRING>>
+ <ADDR-S <CALL VALUE .OBJ>>)
+ (ELSE <CALL VALUE .OBJ>)>
+ .STOP>>
+ <RETURN>)>>>
+
+<ENDPACKAGE>
projects / pdp10-muddle.git / blobdiff