mim/development/mim/vax/mimlib/gc-dump-r.mud

   1 <PACKAGE "GC-DUMP-R">
   2
   3 <ENTRY GC-READ>
   4
   5 <INCLUDE-WHEN <FEATURE? "COMPILER"> "GC-DUMP-DEFS" "STORAGE-DEFS">
   6
   7 <DEFINE GC-READ ("OPT" (CHAN:<CHANNEL 'DISK> .INCHAN)
   8                        (EOF '<ERROR END-OF-FILE!-ERRORS GC-READ>)
   9                  "AUX" BLOCK:UVECTOR HEADER:LIST OFFSET:FIX STOP:FIX
  10                        BLOCK-LENGTH:<OR FALSE FIX> WORDS-NEEDED:<OR FALSE FIX>
  11                        NUMBER-OF-NEWTYPES:<OR FALSE FIX> FLAG)
  12    <COND
  13     (<S=? <CHANNEL-OP .CHAN GET-BYTE-SIZE> "BINARY">
  14      <COND (<SET NUMBER-OF-NEWTYPES <CHANNEL-OP .CHAN READ-BYTE>>
  15             <COND (<OR <L? .NUMBER-OF-NEWTYPES 0>
  16                        <NOT <SET WORDS-NEEDED <CHANNEL-OP .CHAN READ-BYTE>>>
  17                        <L? .WORDS-NEEDED 0>
  18                        <NOT <SET BLOCK-LENGTH <CHANNEL-OP .CHAN READ-BYTE>>>
  19                        <L? .BLOCK-LENGTH 3>>
  20                    <ERROR BAD-GC-READ-FILE!-ERRORS GC-READ>)
  21                   (ELSE
  22                    <COND (<G=? .WORDS-NEEDED 2>
  23                           <CALL RELU <IUVECTOR <- .WORDS-NEEDED 2>>>)>
  24                    <SET BLOCK <IUVECTOR .BLOCK-LENGTH>>
  25                    <COND (<==? <CHANNEL-OP .CHAN READ-BUFFER .BLOCK>
  26                                .BLOCK-LENGTH>
  27                           <IFSYS ("TOPS20" <SET OFFSET 3>)
  28                                  ("VAX" <SET OFFSET 2>)>
  29                           <SET HEADER
  30                                <CALL OBJECT
  31                                      ,TYPE-C-LIST
  32                                      0
  33                                      <CALL VALUE
  34                                            <REST .BLOCK
  35                                                  <- .BLOCK-LENGTH .OFFSET>>>>>
  36                           <SET OFFSET
  37                                <- <CALL VALUE .HEADER>
  38                                   <CALL VALUE <REST .HEADER>>>>
  39                           <SET STOP <CALL VALUE .BLOCK>>
  40                           <BIND ((OLD-CODES <ITUPLE .NUMBER-OF-NEWTYPES 0>)
  41                                  (NEW-CODES <ITUPLE .NUMBER-OF-NEWTYPES 0>)
  42                                  (GCP:<PRIMTYPE UVECTOR>
  43                                   <STACK <IUVECTOR 13 0>>))
  44                              <SET GCP <CHTYPE .GCP GC-PARAMS>>
  45                              <GCSMIN .GCP <CALL VALUE .BLOCK>>
  46                              <SETG OLD-CODES .OLD-CODES>
  47                              <SETG NEW-CODES .NEW-CODES>
  48                              <SET FLAG
  49                                   <PROG READ-FRAME ()
  50                                      #DECL ((READ-FRAME) <SPECIAL FRAME>)
  51                                      <FIXUP-TOUGHIES .HEADER .OFFSET .STOP
  52                                                      .GCP>
  53                                      %<>>>
  54                             <COND (.FLAG
  55                                    <ERROR TYPE-ALREADY-EXISTS!-ERRORS
  56                                           .FLAG
  57                                           GC-READ>)
  58                                   (ELSE
  59                                    <FIXUP-EASIES .HEADER
  60                                                  .OFFSET
  61                                                  .STOP
  62                                                  .OLD-CODES
  63                                                  .NEW-CODES
  64                                                  .GCP>
  65                                    <SWEEPING-UNMARK .HEADER .STOP .GCP>
  66                                    <1 .HEADER>)>>)
  67                          (ELSE <ERROR BAD-GC-READ-FILE!-ERRORS GC-READ>)>)>)
  68            (ELSE <EVAL .EOF>)>)
  69     (ELSE <ERROR CHANNEL-HAS-WRONG-BYTE-SIZE!-ERRORS GC-READ>)>>
  70
  71 <DEFINE FIXUP-TOUGHIES (OBJ OFF:FIX STOP:FIX GCP:GC-PARAMS)
  72    <REPEAT ()
  73       ;"Unfortunately we cannot fixup strings in this pass because swnext
  74         only returns the length of the string to the nearest multiple of
  75         four."
  76       <COND ;(<TYPE? .OBJ STRING> <FIXUP-STRING .OBJ .OFF>)
  77             (<TYPE? .OBJ ATOM> <FIXUP-ATOM .OBJ .OFF>)
  78             (<TYPE? .OBJ GBIND> <FIXUP-GBIND .OBJ .OFF>)>
  79       <SET OBJ <CALL SWNEXT .OBJ .GCP>>
  80       <COND (<OR <TYPE? .OBJ FIX>
  81                  <L? <COND (<OR <TYPE? .OBJ BYTES>
  82                                 <TYPE? .OBJ STRING>>
  83                             <ADDR-S <CALL VALUE .OBJ>>)
  84                            (ELSE <CALL VALUE .OBJ>)>
  85                      .STOP>>
  86              <RETURN>)>>>
  87
  88 <SETG STRING-OBLIST <STRINGS> OBLIST>
  89
  90 <DEFINE FIXUP-STRING (STR:STRING OFF:FIX)
  91    <BIND (STR-ATM:<OR ATOM FALSE> FX:<OR STRING FIX> CORR-STR:STRING)
  92       <COND (<TYPE? <SET FX <CALL MARKUS? .STR 1>> FIX>
  93              <SET STR-ATM <LOOKUP .STR ,STRING-OBLIST>>
  94              <COND (.STR-ATM
  95                     <SET CORR-STR <M$$PNAM .STR-ATM>>
  96                     <CALL MARKUS .STR .CORR-STR>
  97                     .CORR-STR)
  98                    (ELSE <CALL MARKUS .STR .STR> .STR)>)
  99             (ELSE .FX)>>>
 100
 101 ;"The function RIGHT-ATOM has been replaced by the corresponding MACRO in
 102   GC-DUMP-DEFS"
 103
 104 ;<DEFINE RIGHT-ATOM (ATM OFF "AUX" (VAL <CALL VALUE .ATM>))
 105     #DECL ((ATM) <PRIMTYPE ATOM> (OFF VAL) FIX)
 106     <COND (<==? .VAL -1>
 107            <CHTYPE ROOT <TYPE .ATM>>)
 108           (ELSE
 109            <CHTYPE <FIXUP-ATOM <CALL OBJECT
 110                                      ,TYPE-C-ATOM
 111                                      ,LENUU-ATOM
 112                                      <+ .VAL .OFF>>
 113                                .OFF>
 114                    <TYPE .ATM>>)>>
 115
 116 <DEFINE FIXUP-ATOM (ATM OFF
 117                     "AUX" OBL PNAM CORR-ATM BNUM FX TYPE-C NEWTYPE? CORR-TYPE-C
 118                           PTYP GB)
 119    #DECL ((OBL) <OR FALSE OBLIST> (PNAM) STRING (OFF BNUM) FIX (ATM PTYP) ATOM
 120           (CORR-ATM) <OR FALSE ATOM> (FX) <OR ATOM FIX>
 121           (TYPE-C CORR-TYPE-C) <OR TYPE-C FALSE> (GB) <OR FALSE GBIND>)
 122    <COND
 123     (<TYPE? <SET FX <CALL MARKR? .ATM 1>> FIX>
 124      <CALL MARKR .ATM .ATM>
 125      <SET OBL <M$$OBLS .ATM>>
 126      <COND (.OBL
 127             <M$$OBLS .ATM <SET OBL <RIGHT-ATOM <M$$OBLS .ATM> .OFF>>>)>
 128      <SET PNAM <M$$PNAM .ATM>>
 129      <M$$PNAM .ATM
 130               <SET PNAM
 131                    <FIXUP-STRING <CALL OBJECT
 132                                        ,TYPE-C-STRING
 133                                        <CALL LENUU .PNAM>
 134                                        <+ <CALL VALUE .PNAM> .OFF>>
 135                                  .OFF>>>
 136      <SET TYPE-C <VALID-TYPE? .ATM>>
 137      <SET GB <M$$GVAL .ATM>>
 138      <SET NEWTYPE? <AND .TYPE-C <G? <LSH .TYPE-C -6> ,OLD-TYPES> .GB>>
 139      <COND (.NEWTYPE?
 140             <SET PTYP
 141                  <FIXUP-ATOM <CALL OBJECT
 142                                    ,TYPE-C-ATOM
 143                                    ,LENUU-ATOM
 144                                    <+ <CALL VALUE .GB> .OFF>>
 145                              .OFF>>
 146             <M$$GVAL .ATM %<>>)>
 147      <COND
 148       (.OBL
 149        <SET CORR-ATM <LOOKUP .PNAM .OBL>>
 150        <COND (.CORR-ATM
 151               <COND (.NEWTYPE?
 152                      <SET CORR-TYPE-C <VALID-TYPE? .CORR-ATM>>
 153                      <COND (.CORR-TYPE-C
 154                             <COND (<==? .PTYP <TYPEPRIM .CORR-ATM>>
 155                                    <PAIR-UP .TYPE-C .CORR-TYPE-C>)
 156                                   (ELSE <RETURN .CORR-ATM .READ-FRAME>)>)
 157                            (ELSE
 158                             <PAIR-UP .TYPE-C
 159                                      <CREATE-NEWTYPE .CORR-ATM .PTYP>>)>)>
 160               <CALL MARKR .ATM .CORR-ATM>
 161               .CORR-ATM)
 162              (ELSE
 163               <M$$OBLS .ATM .OBL>
 164               <SET BNUM <HASH-NAME <M$$PNAM .ATM> <LENGTH ,ATOM-TABLE>>>
 165               <PUT ,ATOM-TABLE .BNUM (.ATM !<NTH ,ATOM-TABLE .BNUM>)>
 166               <COND (.NEWTYPE? <PAIR-UP .TYPE-C <CREATE-NEWTYPE .ATM .PTYP>>)>
 167               .ATM)>)
 168       (ELSE
 169        <COND (.NEWTYPE? <PAIR-UP .TYPE-C <CREATE-NEWTYPE .ATM .PTYP>>)>
 170        .ATM)>)
 171     (ELSE .FX)>>
 172
 173 ;"The function PAIR-UP has been replaced by the corresponding MACRO in
 174   GC-DUMP-DEFS."
 175
 176 ;<DEFINE PAIR-UP (OC NC "AUX" (OLD-CODES ,OLD-CODES) (NEW-CODES ,NEW-CODES))
 177     #DECL ((OC NC) TYPE-C
 178            (OLD-CODES NEW-CODES) <<PRIMTYPE VECTOR> <PRIMTYPE FIX>>)
 179     <1 .OLD-CODES .OC>
 180     <SETG OLD-CODES <REST .OLD-CODES>>
 181     <1 .NEW-CODES .NC>
 182     <SETG NEW-CODES <REST .NEW-CODES>>>
 183
 184 <DEFINE CREATE-NEWTYPE (TYP-ATM PTYP-ATM "AUX" TYPE-C ENTRY SAT TYP)
 185         #DECL ((TYP-ATM PTYP-ATM) ATOM (ENTRY) TYPE-ENTRY (TYP SAT) FIX
 186                (TYPE-C) TYPE-C)
 187         <SET ENTRY
 188              <NTH ,M$$TYPE-INFO!-INTERNAL
 189                   <+ <LSH <VALID-TYPE? .PTYP-ATM> -6> 1>>>
 190         <SET SAT <ANDB ,M$$TYSAT <M$$TYWRD .ENTRY>>>
 191         <SET TYP <LSH <CALL NEWTYPE .SAT> -6>>
 192         <SET TYPE-C <CHTYPE <ORB <LSH .TYP ,M$$TYOFF> .SAT> TYPE-C>>
 193         <SETG M$$NEWTYPE? T>
 194         <PUT ,M$$TYPE-INFO!-INTERNAL
 195              <+ .TYP 1>
 196              <CHTYPE [.TYP-ATM <M$$PTYPE .ENTRY> %<> %<> %<> .TYPE-C %<>]
 197                      T$TYPE-ENTRY>>
 198         <M$$TYPE .TYP-ATM .TYPE-C>
 199         .TYPE-C>
 200
 201 <DEFINE FIXUP-GBIND (GB OFF "AUX" ATM CORR-GB)
 202         #DECL ((GB) GBIND (OFF) FIX (ATM) ATOM (CORR-GB) <OR FALSE GBIND>)
 203         <COND (<TYPE? <CALL MARKR? .GB 1> FIX>
 204                <M$$ATOM .GB <SET ATM <RIGHT-ATOM <M$$ATOM .GB> .OFF>>>
 205                <SET CORR-GB <M$$GVAL .ATM>>
 206                <COND (.CORR-GB <CALL MARKR .GB .CORR-GB>)
 207                      (ELSE <CALL MARKR .GB .GB> <M$$GVAL .ATM .GB>)>)>
 208         T>
 209
 210 <DEFINE FIXUP-EASIES (OBJ OFF STOP OLD-CODES NEW-CODES GCP:GC-PARAMS)
 211    #DECL ((OBJ) ANY (OFF STOP) FIX
 212           (OLD-CODES NEW-CODES) <<PRIMTYPE VECTOR> [REST TYPE-C]>)
 213    <REPEAT ()
 214       <COND (<TYPE? .OBJ VECTOR>
 215              <MAPR %<>
 216                    <FUNCTION (R-OBJ:VECTOR)
 217                       <PUT .R-OBJ
 218                            1
 219                            <CORRECT-POINTER <1 .R-OBJ> .OFF
 220                                             .OLD-CODES .NEW-CODES>>>
 221                    .OBJ>)
 222             (<TYPE? .OBJ LIST>
 223              <PUT .OBJ
 224                   1
 225                   <CORRECT-POINTER <1 .OBJ> .OFF .OLD-CODES .NEW-CODES>>
 226              <PUTREST .OBJ
 227                       <CORRECT-POINTER <REST .OBJ>
 228                                        .OFF
 229                                        .OLD-CODES
 230                                        .NEW-CODES>>)>
 231       <SET OBJ <CALL SWNEXT .OBJ .GCP>>
 232       <COND (<OR <TYPE? .OBJ FIX>
 233                  <L? <COND (<OR <TYPE? .OBJ BYTES> <TYPE? .OBJ STRING>>
 234                             <ADDR-S <CALL VALUE .OBJ>>)
 235                            (ELSE <CALL VALUE .OBJ>)>
 236                      .STOP>>
 237              <RETURN>)>>>
 238
 239 <DEFINE CORRECT-POINTER (OBJ OFF OLD-CODES NEW-CODES
 240                          "AUX" (TYPE-C <CHTYPE <CALL TYPE .OBJ> TYPE-C>)
 241                                (TYP <LSH .TYPE-C -6>) PTYP RC)
 242         #DECL ((OBJ) ANY (OFF) FIX (PTYP) ATOM (TYP) FIX (TYPE-C) TYPE-C
 243                (OLD-CODES NEW-CODES RC) <<PRIMTYPE VECTOR> [REST TYPE-C]>)
 244         <COND (<G? .TYP ,OLD-TYPES>
 245                <SET RC <MEMQ .TYPE-C .OLD-CODES>>
 246                <SET OBJ
 247                     <CALL OBJECT
 248                           <NTH .NEW-CODES
 249                                <- <LENGTH .OLD-CODES> <LENGTH .RC> -1>>
 250                           <CALL LENUU .OBJ>
 251                           <CALL VALUE .OBJ>>>)>
 252         <SET PTYP <PRIMTYPE .OBJ>>
 253         <COND (<NOT <OR <==? .PTYP FIX> <AND <==? .PTYP LIST> <EMPTY? .OBJ>>>>
 254                <COND (<==? .PTYP ATOM> <SET OBJ <RIGHT-ATOM .OBJ .OFF>>)
 255                      (ELSE
 256                       <SET OBJ
 257                            <CALL OBJECT
 258                                  <CALL TYPE .OBJ>
 259                                  <CALL LENUU .OBJ>
 260                                  <+ <CALL VALUE .OBJ> .OFF>>>
 261                       <COND (<==? .PTYP STRING>
 262                              ;<SET OBJ
 263                                   <CHTYPE <CALL MARKUS? .OBJ 1> <TYPE .OBJ>>>
 264                              <SET OBJ
 265                                   <CHTYPE <FIXUP-STRING .OBJ .OFF> <TYPE .OBJ>>>)
 266                             (<==? .PTYP GBIND>
 267                              <SET OBJ
 268                                   <CHTYPE <CALL MARKR? .OBJ 1>
 269                                           <TYPE .OBJ>>>)>)>)>
 270         .OBJ>
 271
 272 <DEFINE SWEEPING-UNMARK (OBJ STOP GCP:GC-PARAMS "AUX" (PTYP <PRIMTYPE .OBJ>))
 273         #DECL ((OBJ) ANY (STOP) FIX (PTYP) ATOM)
 274         <REPEAT ()
 275                 <COND (<==? .PTYP STRING> <CALL MARKUS .OBJ 0>)
 276                       (<==? .PTYP ATOM> <CALL MARKR .OBJ 0>)
 277                       (<==? .PTYP GBIND> <CALL MARKR .OBJ 0>)>
 278                 <SET OBJ <CALL SWNEXT .OBJ .GCP>>
 279                 <SET PTYP <PRIMTYPE .OBJ>>
 280                 <COND (<OR <TYPE? .OBJ FIX>
 281                            <L? <COND (<OR <==? .PTYP BYTES> <==? .PTYP STRING>>
 282                                       <ADDR-S <CALL VALUE .OBJ>>)
 283                                      (ELSE <CALL VALUE .OBJ>)>
 284                                .STOP>>
 285                        <RETURN>)>>>
 286
 287 <ENDPACKAGE>