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

   1 <PACKAGE "GC-DUMP-D">
   2
   3 <ENTRY GC-DUMP>
   4
   5 <INCLUDE-WHEN <FEATURE? "COMPILER"> "GC-DUMP-DEFS">
   6
   7 %%<GDECL (PURE-ZONE) <OR ZONE FALSE>>   ;"to override GDECL in compiler"
   8
   9 <DEFINE GC-DUMP (OBJ
  10                  "OPT" (CHAN .OUTCHAN)  ;"default to OUTCHAN (???)"
  11                  "AUX" GCP NEW-SIZE CZN NEW-ZONE NGCP AL BLOCK BLOCK-LENGTH
  12                        HEADER NEWOBJ FLAG PZN)
  13         #DECL ((CHAN) <CHANNEL 'DISK> (OBJ) ANY (GCP NGCP) GC-PARAMS
  14                (NEW-SIZE BLOCK-LENGTH) FIX (PZN CZN NEW-ZONE) ZONE
  15                (HEADER) LIST (BLOCK) UVECTOR)
  16         <COND
  17          (<S=? <CHANNEL-OP .CHAN GET-BYTE-SIZE> "BINARY">
  18           <IFSYS ("TOPS20"
  19                   <COND (<AND <GASSIGNED? PURE-ZONE> ,PURE-ZONE>
  20                          <SET PZN ,PURE-ZONE>
  21                          <MAPF <>
  22                                <FUNCTION (A) #DECL ((A) AREA)
  23                                     <DO-SPACS </ <AMIN .A> ,PSIZE>
  24                                               </ <ABOT .A> ,PSIZE>
  25                                               ,M$$COPY-ON-WRITE>>
  26                                <ALL-SPACES .PZN>>)>)>
  27           <SET GCP <GC-PARAMS <SET CZN ,CURRENT-ZONE>>>
  28           ;"calculate how large a zone we (could possibly) need"
  29           <SET NEW-SIZE
  30                <MAPF ,+
  31                      <FUNCTION (A)
  32                              #DECL ((A) AREA)
  33                              <COND (<==? <AMIN .A> <GCSMIN .GCP>>
  34                                     <AMAX .A <GCSMAX .GCP>>
  35                                     <ABOT .A <GCSBOT .GCP>>)>
  36                              <- <ABOT .A> <AMIN .A>>>
  37                      <ALL-SPACES .CZN>>>
  38           <IFSYS ("TOPS20"
  39                   <SET NEW-SIZE
  40                        <* 261632 </ <+ .NEW-SIZE 261632 -1> 261632>>>)>
  41           ;"create the new zone"
  42           <SETG NEW-ZONE
  43                 <SET NEW-ZONE
  44                      <CREATE-NEW-GC-SPACE  ;"change to CREATE-NEW-SPACE ???"
  45                       <LSH .NEW-SIZE <- ,ADDR-SHIFT>> <GC-CTL .CZN>>>>
  46           <SETG AL <GCSMIN <SET NGCP <GC-PARAMS .NEW-ZONE>>>>
  47           <SETG SPACE-END <GCSMAX .NGCP>>
  48           <SETG WORDS-NEEDED 0>
  49           ;"WORDS-NEEDED counts how many words of memory might be needed
  50             by GC-READ when it reads in this object."
  51           <SETG NUMBER-OF-NEWTYPES 0>
  52           <SET FLAG
  53                <PROG DUMP-FRAME ()
  54                   #DECL ((DUMP-FRAME) <SPECIAL FRAME>)
  55                   ;"Provide DUMP-FRAME as an emergency exit"
  56                   <SET NEWOBJ <DUMP .OBJ>>
  57                   %<>>>
  58           <UNMARK .OBJ>  ;"whether dump succeeded or not, clean up"
  59           <IFSYS ("TOPS20"
  60                   <COND (<ASSIGNED? PZN>
  61                          <MAPF <>
  62                                <FUNCTION (A) #DECL ((A) AREA)
  63                                     <DO-SPACS </ <AMIN .A> ,PSIZE>
  64                                               </ <ABOT .A> ,PSIZE>
  65                                               ,M$$READ-ONLY-EXECUTE>>
  66                                <ALL-SPACES .PZN>>)>)>
  67           <COND (<TYPE? .FLAG ATOM> ;"if general error occured"
  68                  <FLUSH-ZONE .NEW-ZONE>
  69                  <ERROR .FLAG GC-DUMP>)
  70                 (.FLAG ;"if he tried to dump something on the stack"
  71                  <FLUSH-ZONE .NEW-ZONE>
  72                  <ERROR UNDUMPABLE-OBJECT!-ERRORS .FLAG GC-DUMP>)
  73                 (ELSE ;"winnage"
  74                  <SET HEADER <CALL ALLOCL ,AL>>
  75                  <PUT .HEADER 1 .NEWOBJ>
  76                  <PUTREST .HEADER .HEADER>
  77                  ;"dump one more object, the `header', a circular list of one
  78                    element, the object dumped"
  79                  <SET BLOCK-LENGTH
  80                       <LSH <- <+ ,AL <LSH ,LENGTH-LIST ,ADDR-SHIFT>>
  81                               <GCSMIN .NGCP>>
  82                            <- ,ADDR-SHIFT>>>
  83                  <SET BLOCK
  84                       <CALL OBJECT
  85                             ,TYPE-C-UVECTOR
  86                             .BLOCK-LENGTH
  87                             <GCSMIN .NGCP>>>
  88                  ;"create a uvector out of the dumped object"
  89                  <CHANNEL-OP .CHAN WRITE-BYTE ,NUMBER-OF-NEWTYPES>
  90                  <CHANNEL-OP .CHAN WRITE-BYTE ,WORDS-NEEDED>
  91                  <CHANNEL-OP .CHAN WRITE-BYTE .BLOCK-LENGTH>
  92                  <CHANNEL-OP .CHAN WRITE-BUFFER .BLOCK>
  93                  ;"write the data to the file"
  94                  <FLUSH-ZONE .NEW-ZONE>
  95                  .OBJ)>)
  96          (ELSE <ERROR CHANNEL-HAS-WRONG-BYTE-SIZE!-ERRORS GC-DUMP>)>>
  97
  98 <DEFINE DUMP (X "AUX" (FTYP <ANDB <CALL TYPE .X> 7>) PTYP)
  99         #DECL ((X) ANY (FTYP) FIX (PTYP) ATOM)
 100         <CASE ,==?
 101               .FTYP
 102               (,STYPE-FIX <DUMP-NEWTYPE? .X> .X)
 103               (,STYPE-UVECTOR <DUMP-UVECTOR .X>)
 104               (,STYPE-STRING <DUMP-STRING .X>)
 105               (,STYPE-BYTES <DUMP-BYTES .X>)
 106               (,STYPE-VECTOR <DUMP-VECTOR .X>)
 107               (,STYPE-LIST <DUMP-LIST .X>)
 108               (,STYPE-RECORD
 109                <SET PTYP <PRIMTYPE .X>>
 110                <COND (<==? .PTYP ATOM> <DUMP-ATOM .X>)
 111                      (<==? .PTYP GBIND> <DUMP-GBIND .X>)
 112                      (ELSE <RETURN .X .DUMP-FRAME>)>)
 113               DEFAULT
 114               (<RETURN .X .DUMP-FRAME>)>>
 115
 116 <DEFINE DUMP-NEWTYPE? (OBJ
 117                        "AUX" (TYP <LSH <CALL TYPE .OBJ> -6>) TYP-ATM PTYP-ATM
 118                              ENTRY)
 119         #DECL ((OBJ) ANY (TYP) FIX (ENTRY) TYPE-ENTRY (TYP-ATM PTYP-ATM) ATOM)
 120         <COND (<G? .TYP ,OLD-TYPES> ;"if the object is a newtype"
 121                <SET ENTRY <NTH ,M$$TYPE-INFO!-INTERNAL <+ .TYP 1>>>
 122                <SET TYP-ATM <DUMP-ATOM <M$$NTYPE .ENTRY>>>
 123                ;"dump the atom naming the type (or get a pointer to it if it"
 124                ;"already has been dumped)"
 125                <COND (<NOT <M$$GVAL .TYP-ATM>>
 126                       ;"if the atom does not have a GVAL (which marks it as"
 127                       ;"being the name of a newtype)"
 128                       <SETG NUMBER-OF-NEWTYPES <+ ,NUMBER-OF-NEWTYPES 1>>
 129                       <SETG WORDS-NEEDED <+ ,WORDS-NEEDED ,LENGTH-TYPE-ENTRY>>
 130                       <SET PTYP-ATM <DUMP-ATOM <M$$PTYPE .ENTRY>>>
 131                       ;"then dump the atom naming the primtype"
 132                       <M$$GVAL .TYP-ATM
 133                                <CALL OBJECT
 134                                      ,TYPE-C-GBIND
 135                                      ,LENUU-GBIND
 136                                      <CALL VALUE .PTYP-ATM>>>
 137                       ;"and shove it (directly) into the GVAL slot")>
 138                T)>>
 139
 140 <DEFINE DUMP-VECTOR (V "AUX" (TOP-V <CALL TOPU .V>) FX NEW-V OLD-AL NEW-AL)
 141         ;"the classic case"
 142         #DECL ((V) <PRIMTYPE VECTOR> (TOP-V NEW-V) VECTOR
 143                (FX NEW-AL OLD-AL) <OR FIX VECTOR>)
 144         <SET FX <CALL MARKUV? .TOP-V 1>> ;"see if the object is marked"
 145         <COND (<TYPE? .FX FIX> ;"if not"
 146                <DUMP-NEWTYPE? .V> ;"take care of the object if it is a newtype"
 147                <SET OLD-AL ,AL> ;"remember where we now are in the zone"
 148                <CALL MARKUV .TOP-V <SET NEW-V <CALL ALLOCUV .OLD-AL .TOP-V>>>
 149                ;"mark the old vector to point to where the new vector will be"
 150                <SET NEW-AL
 151                     <+ .OLD-AL <LSH <+ <* <LENGTH .TOP-V> 2> 2> ,ADDR-SHIFT>>>
 152                ;"calculate where this will put us in the zone"
 153                <COND (<G? .NEW-AL ,SPACE-END>
 154                       ;"if we would run out of room, error"
 155                       <RETURN NO-MORE-ROOM!-ERRORS .DUMP-FRAME>)
 156                      (ELSE ;"otherwise, make it official"
 157                       <SETG AL .NEW-AL>)>
 158                <CALL BLT .TOP-V .NEW-V <+ <* <LENGTH .TOP-V> 2> 2>>
 159                ;"actually copy the object"
 160                <CALL MARKUV .NEW-V 0>
 161                ;"unmark it (since we copied a marked object, this is"
 162                ;"necessary)"
 163                <MAPR %<> ;"dump the elements of the old vector and shove the"
 164                          ;"results into the new vector"
 165                      <FUNCTION (RV)
 166                              #DECL ((RV) VECTOR)
 167                              <PUT .RV 1 <DUMP <1 .RV>>>>
 168                      .NEW-V>)
 169               (ELSE ;"if the object has already been dumped, return it"
 170                <SET NEW-V .FX>)>
 171         ;"return an object of the correct length and type"
 172         <CHTYPE <REST .NEW-V <- <LENGTH .TOP-V> <LENGTH .V>>> <TYPE .V>>>
 173
 174 <DEFINE DUMP-UVECTOR (UV
 175                       "AUX" (TOP-UV <CALL TOPU .UV>) FX NEW-UV OLD-AL NEW-AL)
 176         #DECL ((UV) <PRIMTYPE UVECTOR> (TOP-UV NEW-UV) UVECTOR
 177                (FX) <OR FIX UVECTOR> (NEW-AL OLD-AL) FIX)
 178         <SET FX <CALL MARKUU? .TOP-UV 1>>
 179         <COND (<TYPE? .FX FIX>
 180                <DUMP-NEWTYPE? .UV>
 181                <SET OLD-AL ,AL>
 182                <CALL MARKUU
 183                      .TOP-UV
 184                      <SET NEW-UV <CALL ALLOCUU .OLD-AL .TOP-UV>>>
 185                <SET NEW-AL
 186                     <+ .OLD-AL <LSH <+ <LENGTH .TOP-UV> 2> ,ADDR-SHIFT>>>
 187                <COND (<G? .NEW-AL ,SPACE-END>
 188                       <RETURN NO-MORE-ROOM!-ERRORS .DUMP-FRAME>)
 189                      (ELSE <SETG AL .NEW-AL>)>
 190                <CALL BLT .TOP-UV .NEW-UV <+ <LENGTH .TOP-UV> 2>>
 191                <CALL MARKUU .NEW-UV 0>)
 192               (ELSE <SET NEW-UV .FX>)>
 193         <CHTYPE <REST .NEW-UV <- <LENGTH .TOP-UV> <LENGTH .UV>>> <TYPE .UV>>>
 194
 195 <DEFINE DUMP-STRING (S "AUX" TOP-S FX NEW-S WL OLD-AL NEW-AL)
 196         #DECL ((S) <PRIMTYPE STRING> (TOP-S NEW-S) STRING (FX) <OR FIX STRING>
 197                (WL NEW-AL OLD-AL) FIX)
 198         <SET TOP-S <CALL TOPU .S>>
 199         <SET FX <CALL MARKUS? .TOP-S 1>>
 200         <COND (<TYPE? .FX FIX>
 201                <DUMP-NEWTYPE? .S>
 202                <SET OLD-AL ,AL>
 203                <SET WL <+ </ <+ <LENGTH .TOP-S> ,CHARS-WD-1> ,CHARS-WD> 2>>
 204                <CALL MARKUS .TOP-S <SET NEW-S <CALL ALLOCUS .OLD-AL .TOP-S>>>
 205                <SET NEW-AL <+ .OLD-AL <LSH .WL ,ADDR-SHIFT>>>
 206                <COND (<G? .NEW-AL ,SPACE-END>
 207                       <RETURN NO-MORE-ROOM!-ERRORS .DUMP-FRAME>)
 208                      (ELSE <SETG AL .NEW-AL>)>
 209                <CALL BLT <ADDR-S .TOP-S> <ADDR-S .NEW-S> .WL>
 210                <CALL MARKUS .NEW-S 0>)
 211               (ELSE <SET NEW-S .FX>)>
 212         <CHTYPE <REST .NEW-S <- <LENGTH .TOP-S> <LENGTH .S>>> <TYPE .S>>>
 213
 214 <DEFINE DUMP-BYTES (BS "AUX" TOP-BS NEW-BS FX WL OLD-AL NEW-AL)
 215         #DECL ((BS) <PRIMTYPE BYTES> (TOP-BS NEW-BS) BYTES (FX) <OR FIX BYTES>
 216                (WL NEW-AL OLD-AL) FIX)
 217         <SET TOP-BS <CALL TOPU .BS>>
 218         <SET FX <CALL MARKUB? .TOP-BS 1>>
 219         <COND (<TYPE? .FX FIX>
 220                <DUMP-NEWTYPE? .BS>
 221                <SET OLD-AL ,AL>
 222                <SET WL <+ </ <+ <LENGTH .TOP-BS> ,BYTES-WD-1> ,BYTES-WD> 2>>
 223                <CALL MARKUB
 224                      .TOP-BS
 225                      <SET NEW-BS <CALL ALLOCUB .OLD-AL .TOP-BS>>>
 226                <SET NEW-AL <+ .OLD-AL <LSH .WL ,ADDR-SHIFT>>>
 227                <COND (<G? .NEW-AL ,SPACE-END>
 228                       <RETURN NO-MORE-ROOM!-ERRORS .DUMP-FRAME>)
 229                      (ELSE <SETG AL .NEW-AL>)>
 230                <CALL BLT <ADDR-S .TOP-BS> <ADDR-S .NEW-BS> .WL>
 231                <CALL MARKUB .NEW-BS 0>)
 232               (ELSE <SET NEW-BS .FX>)>
 233         <CHTYPE <REST .NEW-BS <- <LENGTH .TOP-BS> <LENGTH .BS>>> <TYPE .BS>>>
 234
 235 ;"Note that the code to dump (and unmark) lists is extremely hairy because
 236   lists don't have relocation fields, which we need, yet we cannot permenantly
 237   mung the old list.
 238
 239 Solution:
 240
 241 1.  Dump the list as usual.
 242
 243 --------------------------         --------------------------
 244 | rest of old list       |         | rest of new list       |
 245 --------------------------         --------------------------
 246 | type-c     | length    |         | type-c     | length    |
 247 --------------------------         --------------------------
 248 | pointer to old element |         | pointer to new element |
 249 --------------------------         --------------------------
 250
 251 2.  Use the rest pointer of the old list as the relocation pointer (as is done
 252 in the copy-gc).  However, store the old rest pointer (which will need to be
 253 restored) in the type-c and length slots of the new list.
 254
 255 --------------------------         --------------------------
 256 | pointer to new list    |         | rest of new list       |
 257 --------------------------         --------------------------
 258 | type-c     | length    |         | rest of old list       |
 259 --------------------------         --------------------------
 260 | pointer to old element |         | pointer to new element |
 261 --------------------------         --------------------------
 262
 263 3.  During the unmarking phase, copy the old rest pointer from the new list to
 264 the old list and copy the type-c and length from the new list to the old list.
 265
 266 --------------------------         --------------------------
 267 | rest of old list       |         | rest of new list       |
 268 --------------------------         --------------------------
 269 | type-c     | length    |         | type-c     | length    |
 270 --------------------------         --------------------------
 271 | pointer to old element |         | pointer to new element |
 272 --------------------------         --------------------------"
 273
 274 <DEFINE DUMP-LIST (L "AUX" NEW-L REST-L OLD-AL NEW-AL)
 275         #DECL ((L) <PRIMTYPE LIST> (NEW-L REST-L) LIST (OLD-AL NEW-AL) FIX)
 276         <COND (<EMPTY? .L> <DUMP-NEWTYPE? .L> <SET NEW-L .L>)
 277               (<==? <CALL MARKL? .L> 0>
 278                <DUMP-NEWTYPE? .L>
 279                <SET OLD-AL ,AL>
 280                <SET NEW-L <CALL ALLOCL .OLD-AL>>
 281                <SET NEW-AL <+ .OLD-AL <LSH ,LENGTH-LIST ,ADDR-SHIFT>>>
 282                <COND (<G? .NEW-AL ,SPACE-END>
 283                       <RETURN NO-MORE-ROOM!-ERRORS .DUMP-FRAME>)
 284                      (ELSE <SETG AL .NEW-AL>)>
 285                <SET REST-L <REST .L>>
 286                <PUTREST .NEW-L .REST-L>
 287                <PUT .NEW-L 1 <1 .L>>
 288                <CALL MARKL .L 1>
 289                <PUTREST .L .NEW-L>
 290                <PUTREST .NEW-L <DUMP .REST-L>>
 291                <PUT .NEW-L
 292                     1
 293                     <CALL OBJECT
 294                           <LHW <CALL VALUE .REST-L>>
 295                           <RHW <CALL VALUE .REST-L>>
 296                           <CALL VALUE <DUMP <1 .NEW-L>>>>>)
 297               (ELSE <SET NEW-L <REST .L>>)>
 298         <CHTYPE .NEW-L <TYPE .L>>>
 299
 300 <DEFINE DUMP-ATOM (ATM "AUX" OLD-AL NEW-AL FX NEW-ATM)
 301         #DECL ((ATM NEW-ATM) <PRIMTYPE ATOM> (OLD-AL NEW-AL) FIX
 302                (FX) <OR FIX ATOM>)
 303         <COND (<==? <CHTYPE .ATM ATOM> ROOT>
 304                <SET NEW-ATM <CALL OBJECT <CALL TYPE .ATM> ,LENUU-ATOM -1>>)
 305               (<TYPE? <SET FX <CALL MARKR? .ATM 1>> FIX>
 306                <DUMP-NEWTYPE? .ATM>
 307                <SET OLD-AL ,AL>
 308                <SETG WORDS-NEEDED <+ ,WORDS-NEEDED ,LENGTH-LIST>>
 309                <CALL MARKR .ATM <SET NEW-ATM <CALL ALLOCR .OLD-AL .ATM>>>
 310                <SET NEW-AL <+ .OLD-AL <LSH ,LENGTH-ATOM ,ADDR-SHIFT>>>
 311                <COND (<G? .NEW-AL ,SPACE-END>
 312                       <RETURN NO-MORE-ROOM!-ERRORS .DUMP-FRAME>)
 313                      (ELSE <SETG AL .NEW-AL>)>
 314                <CALL BLT .ATM .NEW-ATM ,LENGTH-ATOM>
 315                <CALL MARKR .NEW-ATM 0>
 316                <M$$GVAL .NEW-ATM %<>>
 317                <M$$LVAL .NEW-ATM %<>>
 318                ;"don't dump GVALs or LVALs"
 319                ;"Note:  The gval slot IS used to store the primtypes of"
 320                ;"newtypes, but that is done by DUMP-NEWTYPE?"
 321                <M$$PNAM .NEW-ATM <DUMP-STRING <M$$PNAM .NEW-ATM>>>
 322                <M$$OBLS .NEW-ATM <DUMP <M$$OBLS .NEW-ATM>>>)
 323               (ELSE <SET NEW-ATM .FX>)>
 324         .NEW-ATM>
 325
 326 <DEFINE DUMP-GBIND (GB "AUX" NGB OLD-AL NEW-AL FX)
 327         #DECL ((GB NGB) <PRIMTYPE GBIND> (FX) <OR FIX GBIND>
 328                (OLD-AL NEW-AL) FIX)
 329         <COND (<TYPE? <SET FX <CALL MARKR? .GB 1>> FIX>
 330                <DUMP-NEWTYPE? .GB>
 331                <SET OLD-AL ,AL>
 332                <CALL MARKR .GB <SET NGB <CALL ALLOCR .OLD-AL .GB>>>
 333                <SET NEW-AL <+ .OLD-AL <LSH ,LENGTH-GBIND ,ADDR-SHIFT>>>
 334                <COND (<G? .NEW-AL ,SPACE-END>
 335                       <RETURN NO-MORE-ROOM!-ERRORS .DUMP-FRAME>)
 336                      (ELSE <SETG AL .NEW-AL>)>
 337                <CALL BLT .GB .NGB ,LENGTH-GBIND>
 338                <CALL MARKR .NGB 0>
 339                <M$$VALU .NGB ,M$$UNBOUND>
 340                <M$$ATOM .NGB <DUMP <M$$ATOM .NGB>>>
 341                <M$$DECL .NGB %<>>
 342                ;"don't dump the decl of gbinds")
 343               (ELSE <SET NGB .FX>)>
 344         .NGB>
 345
 346 <DEFINE UNMARK (OBJ "AUX" FX WEIRD FTYP PTYP)
 347         ;"unmark objects in general and repair lists in particular"
 348         #DECL ((OBJ WEIRD) ANY (FX) <OR FIX LIST> (PTYP) ATOM (FTYP) FIX)
 349         <BIND ((TYP <LSH <CALL TYPE .OBJ> -6>) ENTRY)
 350            <COND (<G? .TYP ,OLD-TYPES>
 351                   <SET ENTRY <NTH ,M$$TYPE-INFO!-INTERNAL <+ .TYP 1>>>
 352                   <UNMARK <M$$NTYPE .ENTRY>>
 353                   <UNMARK <M$$PTYPE .ENTRY>>)>>
 354         <SET FTYP <ANDB <CALL TYPE .OBJ> 7>>
 355         <CASE ,==?
 356               .FTYP
 357               (,STYPE-UVECTOR <CALL MARKUU .OBJ 0>)
 358               (,STYPE-STRING <CALL MARKUS .OBJ 0>)
 359               (,STYPE-BYTES <CALL MARKUB .OBJ 0>)
 360               (,STYPE-VECTOR
 361                <COND (<NOT <TYPE? <CALL MARKUV? .OBJ 1> FIX>>
 362                       <CALL MARKUV .OBJ 0>
 363                       <MAPF %<> ,UNMARK <CHTYPE .OBJ VECTOR>>)>)
 364               (,STYPE-LIST
 365                <COND (<N==? <CALL MARKL? .OBJ> 0>
 366                       <SET FX <REST .OBJ>>
 367                       <SET WEIRD <1 .FX>>
 368                       <PUTREST .OBJ
 369                                <CALL OBJECT
 370                                      ,TYPE-C-LIST
 371                                      0
 372                                      <PUTLHW <CALL LENUU .WEIRD>
 373                                              <CALL TYPE .WEIRD>>>>
 374                       <PUT .FX
 375                            1
 376                            <CALL OBJECT
 377                                  <CALL TYPE <1 .OBJ>>
 378                                  <CALL LENUU <1 .OBJ>>
 379                                  <CALL VALUE .WEIRD>>>
 380                       <CALL MARKL .OBJ 0>
 381                       <CALL MARKL .FX 0>
 382                       <UNMARK <1 .OBJ>>
 383                       <UNMARK <REST .OBJ>>)>)
 384               (,STYPE-RECORD
 385                <SET PTYP <PRIMTYPE .OBJ>>
 386                <COND (<==? .PTYP ATOM>
 387                       <COND (<NOT <TYPE? <CALL MARKR? .OBJ 1> FIX>>
 388                              <CALL MARKR .OBJ 0>
 389                              <UNMARK <M$$PNAM <CHTYPE .OBJ ATOM>>>
 390                              <UNMARK <M$$OBLS <CHTYPE .OBJ ATOM>>>)>)
 391                      (<==? .PTYP GBIND>
 392                       <COND (<NOT <TYPE? <CALL MARKR? .OBJ 1> FIX>>
 393                              <CALL MARKR .OBJ 0>
 394                              <UNMARK <M$$ATOM <CHTYPE .OBJ GBIND>>>)>)>)>
 395         T>
 396
 397 <DEFINE DO-SPACS (START LAST MODE)
 398    #DECL ((START LAST MODE) FIX)
 399    <REPEAT ()
 400       <IFSYS ("TOPS20"
 401               <CALL SYSOP SPACS <ORB ,M$$MY-PROC-LH .START> .MODE>)>
 402       <COND (<==? .START .LAST> <RETURN>)>
 403       <SET START <+ .START 1>>>>
 404
 405 <ENDPACKAGE>