mim/development/mim/vaxc/utread.mud

   1 <USE "FILE-INDEX">
   2
   3 <SETG WARN-PRINT T>
   4
   5 <DEFINE READIN (READ-INFO "OPTIONAL" (NXT <>) "AUX" RES LAST FROB ATM)
   6         #DECL ((READ-INFO) TUPLE (RES) <PRIMTYPE LIST>)
   7         <SET RES <READ-LIST-INTERNAL .READ-INFO END!- <>>>
   8         <COND (<OR <NOT .RES>
   9                    <EMPTY? .RES>
  10                    <NOT <TYPE? <SET LAST <NTH .RES <LENGTH .RES>>> FORM>>
  11                    <EMPTY? .LAST>
  12                    <N==? <1 .LAST> END!- >>
  13                <SETG END-READ T>)
  14               (T
  15                <COND (.NXT
  16                       <SET RES (.NXT !.RES)>)>
  17                <REPEAT ((L .RES) (LL .RES) OBJ (IFL ()) (FLUSH? <>))
  18                  #DECL ((L) LIST)
  19                  <COND (<EMPTY? .L> <RETURN>)>
  20                  <COND (<AND <TYPE? <SET OBJ <1 .L>> FORM>
  21                              <FUDGE-MIMOP .OBJ>>
  22                         <COND (<==? <SET FROB <1 .OBJ>> END!-MIMOP>
  23                                <RETURN>)>
  24                         <COND (<==? .FROB IFSYS!-MIMOP>
  25                                <COND (<MEMBER <2 .OBJ> '["VAX" "UNIX"]>
  26                                       <SET IFL (<2 .OBJ> !.IFL)>
  27                                       <SET FLUSH? T>)
  28                                      (T
  29                                       <FLUSH-TO-ENDIF <2 .OBJ> <REST .L>
  30                                                       .LL>
  31                                       <SET L <REST .LL>>
  32                                       <AGAIN>)>)
  33                               (<==? .FROB IFCAN!-MIMOP>
  34                                <COND (<AND
  35                                        <SET ATM <LOOKUP <2 .OBJ>
  36                                                         <MOBLIST MIMOP>>>
  37                                        <GASSIGNED? .ATM>>
  38                                       <SET IFL (<2 .OBJ> !.IFL)>
  39                                       <SET FLUSH? T>)
  40                                      (T
  41                                       <FLUSH-TO-ENDIF <2 .OBJ> <REST .L>
  42                                                       .LL>
  43                                       <SET L <REST .LL>>
  44                                       <AGAIN>)>)
  45                               (<==? .FROB IFCANNOT!-MIMOP>
  46                                <COND (<OR
  47                                        <NOT <SET ATM
  48                                                  <LOOKUP <2 .OBJ>
  49                                                          <MOBLIST MIMOP>>>>
  50                                       <NOT <GASSIGNED? .ATM>>>
  51                                       <SET IFL (<2 .OBJ> !.IFL)>
  52                                       <SET FLUSH? T>)
  53                                      (T
  54                                       <FLUSH-TO-ENDIF <2 .OBJ> <REST .L>
  55                                                       .LL>
  56                                       <SET L <REST .LL>>
  57                                       <AGAIN>)>)
  58                               (<==? .FROB ENDIF!-MIMOP>
  59                                <COND (<OR <EMPTY? .IFL>
  60                                           <N=? <2 .OBJ> <1 .IFL>>>
  61                                       <ERROR UNMATCHED-IFSYS!-ERRORS
  62                                              .OBJ .IFL READIN>)
  63                                      (<SET IFL <REST .IFL>>
  64                                       <SET FLUSH? T>)>)>)>
  65                  <COND (.FLUSH?
  66                         <SET FLUSH? <>>
  67                         <COND (<==? .L .LL>
  68                                <SET RES <REST .RES>>
  69                                <SET L .RES>
  70                                <SET LL .RES>)
  71                               (T
  72                                <PUTREST .LL <SET L <REST .L>>>)>)
  73                        (T
  74                         <SET LL .L>
  75                         <SET L <REST .L>>)>>
  76                .RES)>>
  77
  78 <DEFINE FLUSH-TO-ENDIF (FLG L LL "AUX" THING (CT 1))
  79   #DECL ((L LL) LIST)
  80   <REPEAT ()
  81     <COND (<EMPTY? .L>
  82            <ERROR MISSING-ENDIF!-ERRORS .FLG>
  83            <RETURN>)>
  84     <SET THING <1 .L>>
  85     <COND (<AND <TYPE? .THING FORM>
  86                 <FUDGE-MIMOP .THING>>
  87            <COND (<==? <1 .THING> ENDIF!-MIMOP>
  88                   <COND (<0? <SET CT <- .CT 1>>>
  89                          <PUTREST .LL <REST .L>>
  90                          <RETURN>)>)
  91                  (<OR <==? <1 .THING> IFSYS!-MIMOP>
  92                       <==? <1 .THING> IFCAN!-MIMOP>
  93                       <==? <1 .THING> IFCANNOT!-MIMOP>>
  94                   <SET CT <+ .CT 1>>)>)>
  95     <SET L <REST .L>>>>
  96
  97 <DEFINE FUDGE-MIMOP (FRM "AUX" NATM)
  98         #DECL ((FRM) FORM)
  99         <COND (<SET NATM <LOOKUP <SPNAME <1 .FRM>> ,MIMOP-OBLIST>>
 100                <PUT .FRM 1 .NATM>)>>
 101
 102 <DEFINE PRE-HACK (L "AUX" LR)
 103    #DECL ((L LR) LIST)
 104    <REPEAT (WIN)
 105      #DECL ((WIN) <OR ATOM FALSE>)
 106      <SET WIN <>>
 107      <SET LR
 108       <MAPR ,LIST
 109             <FUNCTION (LL "AUX" (FRM <1 .LL>) M N I LBL)
 110                     #DECL ((FRM) <OR FORM ATOM> (M) <OR FALSE LIST> (LBL) ATOM
 111                            (N) <OR FALSE LIST> (I) FORM (LL) LIST)
 112                     <COND (<TYPE? .FRM ATOM> <MAPRET>)
 113                           (<==? <1 .FRM> OPT-DISPATCH!-MIMOP>
 114                            <MAPRET !<REST .FRM 3>>)
 115                           (<OR <SET M <MEMQ + .FRM>> <SET M <MEMQ - .FRM>>>
 116                            <COND (<SET N <MEMQ <SET LBL <2 .M>> .L>>)
 117                                  (T <MIMOCERR BAD-LABEL!-ERRORS .LBL>)>
 118                            <COND (<==? <1 <SET I <NEXTINS .N>>> JUMP!-MIMOP>
 119                                   <PUT .M 2 <3 .I>>
 120                                   <MAPRET <3 .I>>)
 121                                  (<AND <==? <1 .FRM> JUMP!-MIMOP>
 122                                        <==? <1 .I> RETURN>>
 123                                   <PUT .LL 1 .I>
 124                                   <MAPRET>)
 125                                  (T <MAPRET .LBL>)>)
 126                           (<==? <1 .FRM> ICALL!-MIMOP> <MAPRET <2 .FRM>>)
 127                           (T <MAPRET>)>>
 128             .L>>
 129      <REPEAT ((L .L) (OL .L) ITM)
 130              #DECL ((L OL) LIST (ITM) ANY)
 131              <COND (<EMPTY? .L> <RETURN>)
 132                    (<AND <TYPE? <1 .L> ATOM> <NOT <MEMQ <1 .L> .LR>>>
 133                     <PUTREST .OL <REST .L>>
 134                     <SET WIN T>)
 135                    (<AND <TYPE? <SET ITM <1 .L>> FORM>
 136                          <==? <1 .ITM> JUMP>
 137                          <TYPE? <SET ITM <1 .OL>> FORM>
 138                          <==? <1 .ITM> JUMP>>
 139                     <PUTREST .OL <REST .L>>
 140                     <SET WIN T>)
 141                    (<AND <TYPE? <SET ITM <1 .L>> FORM>
 142                          <==? <1 .ITM> JUMP>
 143                          <NOT <LENGTH? .L 1>>
 144                          <==? <2 .L> <3 .ITM>>>
 145                     <PUTREST .OL <REST .L>>
 146                     <SET WIN T>)
 147                    (<AND <TYPE? <SET ITM <1 .L>> FORM>
 148                          <==? <1 .ITM> JUMP>
 149                          <NOT <LENGTH? .L 1>>
 150                          <NOT <TYPE? <2 .L> ATOM>>>
 151                     <PUTREST .L <REST .L 2>>
 152                     <SET WIN T>)
 153                    (T <SET OL .L>)>
 154              <SET L <REST .L>>>
 155      <OR .WIN <RETURN>>>>
 156
 157 <SETG USE-PRE <>>
 158
 159 <DEFINE FIXIT (LST "AUX" LABS)
 160         #DECL ((LST) LIST)
 161         <SETG COMPERR-FLAG <>>
 162         <SETG UNWCNT-FLAG <>>
 163         <AND ,USE-PRE <PRE-HACK .LST>>
 164         <REPLACE-LOOP-BRANCHES .LST>
 165         <SET LABS <FIND-DUAL-LABELS .LST>>
 166         <SET LABS (UNWCONT TUNWCNT COMPERR TCOMPERR !.LABS)>
 167         <FLUSH-DUAL-LABELS .LST .LABS>
 168         <COND (,COMPERR-FLAG
 169                <PUTREST <REST .LST <- <LENGTH .LST> 1>>
 170                         (TCOMPERR '<COMPERR!-MIMOP>)>)>
 171         <COND (,UNWCNT-FLAG
 172                <PUTREST <REST .LST <- <LENGTH .LST> 1>>
 173                         (TUNWCNT '<UNWCNT!-MIMOP>)>)>
 174         T>
 175
 176 <DEFINE NEXTINS (L)
 177         #DECL ((L) LIST)
 178         <MAPF <>
 179               <FUNCTION (ITM)
 180                       #DECL ((ITM) <OR ATOM FORM>)
 181                       <COND (<TYPE? .ITM FORM> <MAPLEAVE .ITM>)>>
 182               .L>>
 183
 184 <DEFINE FIND-DUAL-LABELS (LST "AUX" (PPTR .LST) (NPTR <REST .LST>))
 185         #DECL ((LST) LIST)
 186         <MAPF ,LIST
 187               <FCN ("AUX" L1 L2)
 188                    <COND (<AND <TYPE? <SET L1 <1 .PPTR>> ATOM>
 189                                <TYPE? <SET L2 <1 .NPTR>> ATOM>>
 190                           <PUTREST .PPTR <REST .NPTR>>
 191                           <COND (<EMPTY? <SET NPTR <REST .PPTR>>>
 192                                  <MAPSTOP .L2 .L1>)>
 193                           <MAPRET .L2 .L1>)>
 194                    <SET PPTR .NPTR>
 195                    <COND (<EMPTY? <SET NPTR <REST .PPTR>>> <MAPSTOP>)>
 196                    <MAPRET>>>>
 197
 198 <DEFINE FLUSH-DUAL-LABELS (LST LABS "AUX" PITEM FLAB PLAB)
 199         #DECL ((LST) LIST (LABS) <LIST [REST ATOM]>
 200                (PITEM) <OR ATOM <PRIMTYPE LIST>>)
 201         <MAPF <>
 202               <FCN (ITEM)
 203                    <COND (<AND <TYPE? .ITEM FORM>
 204                                <OR <SET PITEM <MEMQ + .ITEM>>
 205                                    <SET PITEM <MEMQ - .ITEM>>
 206                                    <AND <NOT <EMPTY? .ITEM>>
 207                                         <TYPE? <SET PITEM
 208                                                     <NTH .ITEM <LENGTH .ITEM>>>
 209                                                LIST>
 210                                         <OR <SET PITEM <MEMQ + .PITEM>>
 211                                             <SET PITEM <MEMQ - .PITEM>>>>>
 212                                <SET FLAB <DMEMQ <2 .PITEM> .LABS>>>
 213                           <SET PLAB <2 .FLAB>>
 214                           <COND (<==? .PLAB TCOMPERR> <SETG COMPERR-FLAG T>)>
 215                           <COND (<==? .PLAB TUNWCNT> <SETG UNWCNT-FLAG T>)>
 216                           <PUT .PITEM 2 <2 .FLAB>>)>>
 217               .LST>>
 218
 219 <DEFINE REPLACE-LOOP-BRANCHES (CODE "AUX" (LOOPS ()))
 220         #DECL ((CODE) LIST)
 221         <REPEAT ((PTR .CODE) ITM RBRANCH LAB NLAB RPTR)
 222                 <COND (<EMPTY? .PTR> <RETURN>)>
 223                 <COND (<TYPE? <SET ITM <1 .PTR>> FORM>
 224                        <COND (<AND <==? <1 .ITM> LOOP!-MIMOP>
 225                                    <G? <LENGTH .ITM> 1>>
 226                               <SET LOOPS (<2 .PTR> !.LOOPS)>
 227                               <SET PTR <REST .PTR 2>>)
 228                              (<==? <1 .ITM> DISPATCH!-MIMOP>
 229                               <HACK-DISPATCH-LABELS .PTR .LOOPS>
 230                               <SET PTR <REST .PTR>>)
 231                              (<AND <OR <SET RBRANCH <MEMQ + .ITM>>
 232                                        <SET RBRANCH <MEMQ - .ITM>>
 233                                        <AND <TYPE? <SET RBRANCH
 234                                                         <NTH .ITM
 235                                                              <LENGTH .ITM>>>
 236                                                    LIST>
 237                                             <OR <SET RBRANCH <MEMQ + .RBRANCH>>
 238                                                 <SET RBRANCH
 239                                                      <MEMQ - .RBRANCH>>>>>
 240                                    <MEMQ <SET LAB <2 .RBRANCH>> .LOOPS>
 241                                    <N==? <1 .ITM> JUMP!-MIMOP>>
 242                               <SET NLAB <MAKE-LABEL "UNLOOP">>
 243                               <PUT .RBRANCH 2 .NLAB>
 244                               <COND (<==? <1 .RBRANCH> -> <PUT .RBRANCH 1 +>)
 245                                     (<PUT .RBRANCH 1 ->)>
 246                               <SET RPTR <REST .PTR>>
 247                               <PUTREST .PTR (<FORM JUMP!-MIMOP + .LAB> .NLAB)>
 248                               <PUTREST <REST .PTR 2> .RPTR>
 249                               <SET PTR <REST .PTR 3>>)
 250                              (<SET PTR <REST .PTR>>)>)
 251                       (<SET PTR <REST .PTR>>)>>>
 252
 253 <DEFINE HACK-DISPATCH-LABELS (PTR LOOPS "AUX" (DEFLBL <>) (ANY? <>))
 254   #DECL ((PTR LOOPS) LIST (DEFLBL) <OR ATOM FALSE> (ANY?) <OR LIST FALSE>)
 255   <COND (<TYPE? <2 .PTR> ATOM>
 256          <SET DEFLBL <2 .PTR>>)>
 257   <MAPR <>
 258     <FUNCTION (NP "AUX" (LBL <1 .NP>) NL)
 259       #DECL ((NP) LIST (NL LBL) ATOM)
 260       <COND (<MEMQ .LBL .LOOPS>
 261              ; "We have to put in funny jumps, so the default case must become
 262                 JUMP label..."
 263              <COND (<NOT .ANY?>
 264                     <COND (<NOT .DEFLBL>
 265                            ; "Make sure we have a label to jump to"
 266                            <PUTREST .PTR (<SET DEFLBL <MAKE-LABEL "DEFCASE">>
 267                                           !<REST .PTR>)>)>
 268                     ; "Put in the jump"
 269                     <PUTREST .PTR
 270                              <SET ANY? (<FORM JUMP!-MIMOP + .DEFLBL>
 271                                         !<REST .PTR>)>>)>
 272              <SET NL <MAKE-LABEL "LCASE">>
 273              <PUTREST .ANY?
 274                       (.NL <FORM JUMP!-MIMOP + .LBL> !<REST .ANY?>)>
 275              <1 .NP .NL>
 276              ; "Find any other frobs to same place"
 277              <REPEAT ((L <REST .NP>))
 278                <COND (<SET L <MEMQ .LBL .L>>
 279                       <1 .L .NL>)
 280                      (<RETURN>)>>)>>
 281     <REST <1 .PTR> 3>>>
 282
 283 <DEFINE DMEMQ (X L)
 284         #DECL ((X) ATOM (L) <LIST [REST ATOM]>)
 285         <REPEAT ()
 286                 <COND (<EMPTY? .L> <RETURN <>>)
 287                       (<==? .X <1 .L>> <RETURN .L>)
 288                       (<SET L <REST .L 2>>)>>>
 289
 290 <DEFINE PRINT-MIM-CODE (LST
 291                         "OPTIONAL" (OUTCHAN .OUTCHAN)
 292                         "AUX" (OBLIST (,MIMOP-OBLIST !.OBLIST)))
 293         #DECL ((LST) LIST (OBLIST) <SPECIAL LIST> (OUTCHAN) <SPECIAL CHANNEL>)
 294         <CRLF>
 295         <CRLF>
 296         <MAPF <>
 297               <FCN (X)
 298                    <COND (<TYPE? .X ATOM> <PRIN1 .X>)
 299                          (ELSE <PRINC "   "> <PRIN1 .X>)>
 300                    <CRLF>>
 301               .LST>>
 302
 303 <GDECL (GLUE-FCNS) <LIST [REST ATOM]>>
 304
 305 <GDECL (INCHANS) <LIST [REST CHANNEL]>>
 306
 307 <DEFINE FINISH-FILE (READ-INFO OUTCHAN EXPFLOAD "AUX" (IND '(1))
 308                      (EXPSPLICE <AND <ASSIGNED? EXPSPLICE> .EXPSPLICE>) TMP
 309                      (INCHAN <RI-CHANNEL .READ-INFO>) ST)
 310   #DECL ((READ-INFO) TUPLE (OUTCHAN) <SPECIAL <OR CHANNEL FALSE>>
 311          (EXPSPLICE EXPFLOAD) <OR ATOM FALSE> (INCHAN) <SPECIAL CHANNEL>)
 312   <REPEAT (ITM NCH)
 313     <COND (<==? <SET ITM <READ-INTERNAL .READ-INFO '.IND>> .IND>
 314            <COND (<EMPTY? <SETG INCHANS <REST ,INCHANS>>>
 315                   <CLOSE .INCHAN>
 316                   <RETURN <>>)>
 317            <CLOSE <SET-RI-CHANNEL .READ-INFO <SET INCHAN <1 ,INCHANS>>>>
 318            <AGAIN>)>
 319     <COND (<NOT <OR <TYPE? .ITM STRING CHARACTER FIX>
 320                     <AND <TYPE? .ITM ATOM>
 321                          <=? <SPNAME .ITM> "\f">>>>
 322            <COND (<AND <TYPE? .ITM FORM>
 323                        <NOT <LENGTH? .ITM 2>>
 324                        <MEMBER <SPNAME <1 .ITM>> '["FCN" "GFCN"]>>
 325                   <RETURN .ITM>)>
 326            <COND (<TYPE? .ITM WORD>
 327                   ; "Copy the new hash code over to the msubr file."
 328                   <COND (<NOT ,GLUE>
 329                          <SETG LAST-HASH .ITM>
 330                          <COND (<NOT ,INT-MODE>
 331                                 <SET ST <UNPARSE .ITM>>
 332                                 <PRINC "#WORD \1a*" .OUTCHAN>
 333                                 <PRINTSTRING <REST .ST 7> .OUTCHAN
 334                                              <- <LENGTH .ST> 8>>
 335                                 <PRINC !\* .OUTCHAN>
 336                                 <CRLF .OUTCHAN>)>)>)
 337                  (<AND .EXPFLOAD
 338                        <TYPE? .ITM FORM>
 339                        <NOT <EMPTY? .ITM>>
 340                        <COND (<==? <1 .ITM> FLOAD>
 341                               <SET NCH <OPEN "READ" !<REST .ITM>>>)
 342                              (<==? <1 .ITM> L-FLOAD>
 343                               <SET NCH <L-OPEN <2 .ITM>>>)>>
 344                   <PRINFILE .NCH>
 345                   <SET-RI-CHANNEL .READ-INFO <SET INCHAN .NCH>>
 346                   <SETG INCHANS (.NCH !,INCHANS)>)
 347                  (T
 348                   <COND (<AND <TYPE? .ITM FORM>
 349                               <NOT <EMPTY? .ITM>>>
 350                          <COND (<==? <1 .ITM> NEW-CHANNEL-TYPE>
 351                                 <SET TMP <EVAL <FORM NCT-NEW !<REST .ITM>>>>)
 352                                (<AND <MEMQ <1 .ITM> '[INCLUDE-WHEN USE-WHEN]>
 353                                      <NOT <LENGTH? .ITM 1>>
 354                                      <TYPE? <2 .ITM> FORM>
 355                                      <NOT <EMPTY? <2 .ITM>>>
 356                                      <==? <1 <2 .ITM>> COMPILING?>>
 357                                 <SET TMP <EVAL .ITM>>
 358                                 <1 <2 .ITM> DEBUGGING?>)
 359                                (T
 360                                 <SET TMP <EVAL .ITM>>)>)
 361                         (T
 362                          <SET TMP <EVAL .ITM>>)>
 363                   <COND (.OUTCHAN
 364                          <COND (,INT-MODE
 365                                 <PRINTTYPE ATOM ,ATOM-PRINT>
 366                                 <PRINTTYPE LVAL ,ATOM-PRINT>
 367                                 <PRINTTYPE GVAL ,ATOM-PRINT>)>
 368                          <COND (<AND .EXPSPLICE <TYPE? .TMP SPLICE>>
 369                                 <MAPF <>
 370                                   <FUNCTION (X)
 371                                     <PRIN1 .X>
 372                                     <CRLF>>
 373                                   .TMP>)
 374                                (T
 375                                 <PRIN1 .ITM>
 376                                 <CRLF>)>
 377                          <COND (,INT-MODE
 378                                 <PRINTTYPE ATOM ,PRINT>
 379                                 <PRINTTYPE LVAL ,PRINT>
 380                                 <PRINTTYPE GVAL ,PRINT>)>)>)>)>>>
 381
 382 <GDECL (LAST-HASH) <OR FALSE WORD>>
 383
 384 <DEFINE FILE-PASS1 (NAMES READ-INFO OCH PMCH AMCH AACH EXPFLOAD
 385                     "AUX" LST NOFF ITM (STARCPU 0.0000000) (NM2 "MIMA")
 386                           (PRE-CH <>) (INDEX ()) (RREDO ()))
 387         #DECL ((OCH) CHANNEL (PMCH AMCH AACH) <OR FALSE CHANNEL>
 388                (LST) <LIST [REST <OR ATOM FORM>]> (NM2) <SPECIAL STRING>
 389                (NAMES) <<PRIMTYPE VECTOR> [REST STRING]> (READ-INFO) TUPLE
 390                (INDEX RREDO) LIST)
 391         <SETG END-READ T>
 392         <SETG GLUE-FCNS ()>
 393         <SETG FCN-COUNT 0>
 394         <COND (<AND <NOT ,GLUE>
 395                     <ASSIGNED? PRECOMPILED>
 396                     .PRECOMPILED
 397                     ,PRE-CH>
 398                <SET PRE-CH ,PRE-CH>
 399                <CRLF .OUTCHAN>
 400                <PRINT-MANY .OUTCHAN PRINC "Precompilation from "
 401                            <CHANNEL-OP .PRE-CH NAME>>
 402                <SET INDEX <BUILD-INDEX .PRE-CH ,FCN-OBL>>
 403                <COND (<AND <ASSIGNED? REDO>
 404                            .REDO>
 405                       <SET RREDO
 406                            <MAPF ,LIST
 407                                  <FUNCTION (X) <SPNAME .X>>
 408                                  .REDO>>)>)>
 409         <REPEAT READIT (NAME ITM (CH <>) COMPILER-INPUT OLD-FCN)
 410                 #DECL ((COMPILER-INPUT) <SPECIAL CHANNEL>
 411                        (OLD-FCN) <OR FALSE LIST>)
 412                 <SETG LAST-HASH <>>
 413                 <COND (,END-READ
 414                        <AND .CH <CLOSE .CH>>
 415                        <COND (<EMPTY? .NAMES> <RETURN>)>
 416                        <COND (<NOT <SET CH <OPEN "READ" <1 .NAMES>>>>
 417                               <ERROR .CH>)>
 418                        <PRINFILE .CH>
 419                        <SETG INCHANS (.CH)>
 420                        <SET COMPILER-INPUT .CH>
 421                        <SET-RI-CHANNEL .READ-INFO .CH>
 422                        <SET NAMES <REST .NAMES>>
 423                        <SETG END-READ <>>)>
 424                 <COND (<NOT <SET ITM
 425                                  <IO-TIMER
 426                                   <FINISH-FILE .READ-INFO
 427                                                <COND (<NOT ,GLUE> .OCH)>
 428                                               .EXPFLOAD>>>>
 429                        <SETG END-READ T>
 430                        <AGAIN .READIT>)
 431                       (T
 432                        <SET CH <1 ,INCHANS>>
 433                        <SETG FCN-COUNT <+ ,FCN-COUNT 1>>
 434                        <COND (<=? <SPNAME <1 .ITM>> "FCN">
 435                               <PUT .ITM 1 FCN!-MIMOP>)
 436                              (<PUT .ITM 1 GFCN!-MIMOP>)>
 437                        <SET NAME <2 .ITM>>
 438                        <COND (,GLUE
 439                               <IO-TIMER <SKIP .READ-INFO>>
 440                               <COND (<==? <1 .ITM> GFCN!-MIMOP>
 441                                      <SETG GLUE-FCNS (.NAME !,GLUE-FCNS)>)>)
 442                              (ELSE
 443                               <COND
 444                                (<AND .PRE-CH
 445                                      <NOT <MEMBER <SPNAME .NAME> .RREDO>>
 446                                      <SET OLD-FCN
 447                                           <FIND-OLD-FCN .NAME .INDEX>>
 448                                      <OR <L? <LENGTH .OLD-FCN> 4>
 449                                          <==? <4 .OLD-FCN> ,LAST-HASH>>>
 450                                 ; "Skip if have precompiled, fcn is not
 451                                    in redo list, is in index (--> in precompiled),
 452                                    and either doesn't have hash or has right
 453                                    hash"
 454                                 <COND (,VERBOSE?
 455                                        <CRLF .OUTCHAN>
 456                                        <PRINC "Skipping function " .OUTCHAN>
 457                                        <PRIN1 .NAME .OUTCHAN>)>
 458                                 <IO-TIMER
 459                                  <BIND ()
 460                                        <COPY-OLD-FCN .OLD-FCN .PRE-CH .OCH>
 461                                        <SET-RI-CHANNEL .READ-INFO <>>
 462                                        <SKIP-MIMA .CH .NAME>
 463                                        <SET-RI-CHANNEL .READ-INFO .CH>>>)
 464                                (T
 465                                 <COND (<AND ,WARN-PRINT ,VERBOSE?>
 466                                        <CRLF>
 467                                        <PRINC "Compiling: ">
 468                                        <PRIN1 <2 .ITM>>)>
 469                                 <IO-TIMER <SET LST <READIN .READ-INFO .ITM>>>
 470                                 <SET STARCPU <TIME>>
 471                                 <FIXIT .LST>
 472                                 <AND .PMCH <PRINT-MIM-CODE .LST .PMCH>>
 473                                 <MIMOC .LST T>
 474                                 <AND .AMCH <PRINT-GEN-INST .AMCH>>
 475                                 <SET NAME ,FUNCTION-NAME>
 476                                 <ASSEMBLE-CODE 0 .NAME>
 477                                 <IO-TIMER
 478                                  <COND (.AACH
 479                                         <CRLF .AACH>
 480                                         <CRLF .AACH>
 481                                         <PRIN1 .NAME .AACH>
 482                                         <CRLF .AACH>
 483                                         <CRLF .AACH>
 484                                         <PRINT-FINAL-INST .AACH>)>>
 485                                 <SETG INTERNAL-MSUBR-NAME
 486                                       <GEN-NAME ,FUNCTION-NAME>>
 487                                 <COND (,INT-MODE
 488                                        <PRINTTYPE ATOM ,ATOM-PRINT>
 489                                        <PRINTTYPE LVAL ,ATOM-PRINT>
 490                                        <PRINTTYPE GVAL ,ATOM-PRINT>)>
 491                                 <IO-TIMER <BIND ()
 492                                                 <PRINT-IMSUBR .OCH>
 493                                                 <PRINT-MSUBR 0 .OCH>>>
 494                                 <AND ,VERBOSE?
 495                                      ,WARN-PRINT
 496                                      <PRINT-RSUBR-STATS .STARCPU 0>>
 497                                 <COND (,INT-MODE
 498                                        <PRINTTYPE ATOM ,PRINT>
 499                                        <PRINTTYPE LVAL ,PRINT>
 500                                        <PRINTTYPE GVAL ,PRINT>)>)>)>)>>>
 501
 502 <DEFMAC IO-TIMER ('THING)
 503   <FORM BIND ((STARCPU '<TIME>) VAL)
 504     <FORM SET VAL .THING>
 505     '<SETG IO-TIME <+ ,IO-TIME <- <TIME> .STARCPU>>>
 506     '.VAL>>
 507
 508
 509 <DEFINE FILE-PASS2 (NAMES READ-INFO OCH PMCH AMCH AACH EXPFLOAD
 510                       "AUX" LST NOFF ITM (STARCPU 0.0000000) (NM2 "MIMA")
 511                       (REDEFINE T) (PASS2? T))
 512    #DECL ((OCH) CHANNEL (PMCH AMCH AACH) <OR FALSE CHANNEL>
 513           (LST) <LIST [REST <OR ATOM FORM>]> (READ-INFO) TUPLE
 514           (NM2) <SPECIAL STRING> (NAMES) <<PRIMTYPE VECTOR> [REST STRING]>
 515           (PASS2? REDEFINE) <SPECIAL ATOM>)
 516    <SETG END-READ T>
 517    <SETG FIRST-FCN-ACCESS <>>
 518    <SETG FIRST-FCN-OBLIST ()>
 519    <REPEAT READIT (NAME (FIRST T) (OFF 0) (CH <>) (END T) ARES
 520                    COMPILER-INPUT CH2)
 521        #DECL ((ARES) <LIST [2 FIX]> (COMPILER-INPUT) <SPECIAL CHANNEL>)
 522        <COND (<0? ,FCN-COUNT>
 523               <COND (<SET CH2 <OPEN "PRINT" ""
 524                                     <CHANNEL-OP .OCH NM1>
 525                                     <IFSYS ("TOPS20" "VSUBR")
 526                                            ("VAX" "GSUBR")>
 527                                     <CHANNEL-OP .OCH DEV>
 528                                     <CHANNEL-OP .OCH SNM>>>
 529                      <PROG ((OBLIST ,FIRST-FCN-OBLIST))
 530                        #DECL ((OBLIST) <SPECIAL OBLIST>)
 531                        <BUFOUT .OCH>
 532                        <ACCESS .OCH 0>
 533                        <COND (,FIRST-FCN-ACCESS
 534                               <IO-TIMER
 535                                <DO-FILE-COPY .OCH .CH2 ,FIRST-FCN-ACCESS>>)>
 536                        <COND (,INT-MODE
 537                               <PRINTTYPE ATOM ,ATOM-PRINT>
 538                               <PRINTTYPE LVAL ,ATOM-PRINT>
 539                               <PRINTTYPE GVAL ,ATOM-PRINT>)>
 540                        <IO-TIMER <PRINT-IMSUBR .CH2>>
 541                        <COND (.AACH <IO-TIMER <PRINT-FINAL-INST .AACH>>)>
 542                        <COND (,INT-MODE
 543                               <PRINTTYPE ATOM ,PRINT>
 544                               <PRINTTYPE LVAL ,PRINT>
 545                               <PRINTTYPE GVAL ,PRINT>)>
 546                        <IO-TIMER <DO-FILE-COPY .OCH .CH2 -1>>>
 547                      <SET OCH .CH2>
 548                      <SETG FCN-COUNT -1>)
 549                     (<ERROR CANT-OPEN-MSUBR-FILE .CH2 FILE-PASS2>)>)>
 550        <COND (,END-READ
 551               <AND .CH <CLOSE .CH>>
 552               <COND (<EMPTY? .NAMES>
 553                      <CLOSE .CH2>
 554                      <RETURN>)>
 555               <COND (<NOT <SET CH <OPEN "READ" <1 .NAMES>>>>
 556                      <ERROR .CH>)>
 557               <PRINFILE .CH>
 558               <SETG INCHANS (.CH)>
 559               <SET COMPILER-INPUT .CH>
 560               <SET-RI-CHANNEL .READ-INFO .CH>
 561               <SET NAMES <REST .NAMES>>
 562               <SETG END-READ <>>)>
 563        <COND (<NOT <SET ITM <IO-TIMER <FINISH-FILE .READ-INFO .OCH .EXPFLOAD>>>>
 564               <SETG END-READ T>
 565               <AGAIN .READIT>)
 566              (T
 567               <SET CH <1 ,INCHANS>>
 568               <SETG FCN-COUNT <- ,FCN-COUNT 1>>
 569               <COND (.FIRST
 570                      <SETG FIRST-FCN-ACCESS <ACCESS .OCH>>
 571                      <SETG FIRST-FCN-OBLIST .OBLIST>)>
 572               <COND (<=? <SPNAME <1 .ITM>> "FCN">
 573                      <PUT .ITM 1 FCN!-MIMOP>)
 574                     (<PUT .ITM 1 GFCN!-MIMOP>)>
 575               <COND (<AND ,VERBOSE? ,WARN-PRINT>
 576                      <CRLF>
 577                      <PRINC "Compiling:  ">
 578                      <PRIN1 <2 .ITM>>)>
 579               <IO-TIMER <SET LST <READIN .READ-INFO .ITM>>>
 580               <SET STARCPU <TIME>>
 581               <FIXIT .LST>
 582               <MIMOC .LST .FIRST>
 583               <AND .AMCH <PRINT-GEN-INST .AMCH>>
 584               <SET NAME ,FUNCTION-NAME>
 585               <AND .FIRST
 586                    <SETG INTERNAL-MSUBR-NAME <GEN-NAME .NAME>>>
 587               <SET ARES <ASSEMBLE-CODE .OFF .NAME>>
 588               <SET OFF <1 .ARES>>
 589               <SET NOFF <2 .ARES>>
 590               <COND (,INT-MODE
 591                      <PRINTTYPE ATOM ,ATOM-PRINT>
 592                      <PRINTTYPE LVAL ,ATOM-PRINT>
 593                      <PRINTTYPE GVAL ,ATOM-PRINT>)>
 594               <IO-TIMER <PRINT-MSUBR .OFF .OCH>>
 595               <COND (,INT-MODE
 596                      <PRINTTYPE ATOM  ,PRINT>
 597                      <PRINTTYPE LVAL ,PRINT>
 598                      <PRINTTYPE GVAL ,PRINT>)>
 599               <SET FIRST <>>
 600               <AND ,WARN-PRINT ,VERBOSE?
 601                    <PRINT-RSUBR-STATS .STARCPU .OFF>>
 602               <SET OFF .NOFF>)>>>
 603
 604 <DEFINE PRINT-RSUBR-STATS (STARCPU OFF "AUX" (OUTCHAN .OUTCHAN))
 605         #DECL ((STARCPU) FLOAT (OFF) FIX)
 606         <PRINT-MANY .OUTCHAN PRINC "    " <- <TIME> .STARCPU>
 607                     " / " <- <* ,FBYTE-OFFSET 4> .OFF>>>
 608
 609 <DEFINE GEN-NAME (NAME "AUX" ISTR)
 610         #DECL ((NAME) ATOM)
 611         <SET ISTR
 612              <MAPF ,STRING
 613                    <FCN (X "AUX" (VAL <ASCII .X>))
 614                         <COND (<AND <G=? .VAL <ASCII !\A>>
 615                                     <L=? .VAL <ASCII !\Z>>>
 616                                <ASCII <+ .VAL <- <ASCII !\a> <ASCII !\A>>>>)
 617                               (.X)>>
 618                    <SPNAME .NAME>>>
 619         <PARSE <STRING .ISTR "-IMSUBR">>>
 620
 621 <DEFINE ATOM-PRINT (ATM "AUX" (SPN <SPNAME <CHTYPE .ATM ATOM>>)
 622                     (OUTCHAN .OUTCHAN))
 623         #DECL ((ATM) <OR ATOM LVAL GVAL> (SPN) STRING)
 624         <COND (<AND <NOT <LENGTH? .SPN 2>>
 625                     <==? <1 .SPN> !\T>
 626                     <==? <2 .SPN> !\$>>
 627                <IPRINC <REST .SPN 2> .OUTCHAN <NOT ,BOOT-MODE> <TYPE .ATM>>)
 628               (<AND <OR <==? <OBLIST? .ATM> <ROOT>>
 629                         <MEMBER .SPN ,ROOT-ATOMS>
 630                         <AND <==? <OBLIST? .ATM> ,MIMOP-OBLIST>
 631                              <LOOKUP .SPN <ROOT>>>>
 632                     <NOT ,BOOT-MODE>>
 633                <IPRINC .SPN .OUTCHAN T <TYPE .ATM>>)
 634               (T <IPRINC .SPN .OUTCHAN <> <TYPE .ATM>>)>
 635         <PRINC " ">>
 636
 637 <SETG FOOSTR "$">
 638
 639 <GDECL (FOOSTR) STRING>
 640
 641 <GDECL (GC-COUNT) FIX (IO-TIME) FLOAT>
 642
 643 <DEFINE FILE-MIMOC (OUTNAME PML AML AAL
 644                     "TUPLE" NAMES
 645                     "AUX" CH OCH (PMCH <>) (AMCH <>) (AACH <>)
 646                           (GC-HANDLER <>)
 647                           (READ-INFO <ITUPLE 9 <>>)
 648                           SAVED-OBLIST)
 649         #DECL ((NAME) STRING)
 650         <SETG PRE-CH <>>
 651         <SETUP-READ-TABLE>
 652         <INIT-RI .READ-INFO <> 2560 ,MIMOC-READ-TABLE>
 653         <PROG (NM2)
 654               #DECL ((NM2) <SPECIAL STRING>)
 655               <COND (<AND <ASSIGNED? PRECOMPILED>
 656                           .PRECOMPILED>
 657                      <IFSYS ("TOPS20"
 658                              <SET NM2 "VSUBR">)
 659                             ("UNIX"
 660                              <SET NM2 "MSUBR">)>
 661                      <COND (<NOT <TYPE? .PRECOMPILED STRING>>
 662                             <SETG PRE-CH <OPEN "READ" .OUTNAME>>)
 663                            (T
 664                             <SETG PRE-CH <OPEN "READ" .PRECOMPILED>>)>)>
 665               <COND (<AND <ASSIGNED? AUTO-PRECOMP>
 666                           .AUTO-PRECOMP
 667                           ,PRE-CH>
 668                      ; "Have precompiled, and don't necessarily want to
 669                         do anything"
 670                      <SET NM2 "MIMA">
 671                      <COND (<AND <SET OCH <OPEN "READ" .OUTNAME>>
 672                                  <L=? <CHANNEL-OP .OCH WRITE-DATE>
 673                                       <CHANNEL-OP ,PRE-CH WRITE-DATE>>>
 674                             ; "Have existing msubr, and it's later"
 675                               <PRINT-MANY ,OUTCHAN PRINC
 676                                           "Not recompiling "
 677                                           <CHANNEL-OP .OCH NAME>
 678                                           ".">
 679                               <CRLF ,OUTCHAN>
 680                               <EXIT>)
 681                            (.OCH
 682                             <CLOSE .OCH>)>)>
 683               <SET NM2 "MUD">
 684               ; "Do things to do"
 685               <COND (,GLUE
 686                      <SET NM2 "TMSUBR">)
 687                     (T
 688                      <IFSYS ("TOPS20"
 689                              <SET NM2 "VSUBR">)
 690                             ("VAX"
 691                              <SET NM2 "MSUBR">)>)>
 692               <OR <SET OCH <OPEN "PRINT" .OUTNAME>>
 693                   <ERROR .OCH OUTPUT FILE-MIMOC>>
 694               <SET NM2 "BMIM">
 695               <AND .PML
 696                    <OR <SET PMCH <OPEN "PRINT" .OUTNAME>>
 697                        <ERROR .PMCH PRINT-MIM FILE-MIMOC>>>
 698               <SET NM2 "AMIM">
 699               <AND .AML
 700                    <OR <SET AMCH <OPEN "PRINT" .OUTNAME>>
 701                        <ERROR .AMCH PRINT-MIM FILE-MIMOC>>>
 702               <SET NM2 "ASSEMBLY">
 703               <AND .AAL
 704                    <OR <SET AACH <OPEN "PRINT" .OUTNAME>>
 705                        <ERROR .AACH PRINT-MIM FILE-MIMOC>>>>
 706         <SETG DO-CLOSE T>
 707         <UNWIND <PROG ((STARCPU <FIX <+ <TIME> 0.5>>) (GCTIME 0.0000000)
 708                        (EXPFLOAD <AND <ASSIGNED? EXPFLOAD> .EXPFLOAD>))
 709                       #DECL ((STARCPU) <SPECIAL FIX> (GCTIME) <SPECIAL FLOAT>)
 710                       <COND (,WARN-PRINT
 711                              <SET GC-HANDLER
 712                                   <ON <HANDLER "GC" ,COUNT-GCS 10>>>)>
 713                       <SETG GC-COUNT 0>
 714                       <SETG IO-TIME 0.0>
 715                       <SET SAVED-OBLIST <LIST !.OBLIST>>
 716                       <FILE-PASS1 .NAMES .READ-INFO
 717                                   .OCH .PMCH .AMCH .AACH .EXPFLOAD>
 718                       <BLOCK .SAVED-OBLIST>
 719                       <AND ,GLUE <FILE-PASS2 .NAMES .READ-INFO
 720                                              .OCH .PMCH .AMCH .AACH
 721                                              .EXPFLOAD>>
 722                       <ENDBLOCK>
 723                       <CLOSE .OCH>
 724                       <COND (,GLUE
 725                              <SET NM2 "TMSUBR">
 726                              <DELFILE .OUTNAME>)>
 727                       <AND .PMCH <CLOSE .PMCH>>
 728                       <AND .AMCH <CLOSE .AMCH>>
 729                       <AND .AACH <CLOSE .AACH>>
 730                       <SETG DO-CLOSE <>>
 731                       <AND .GC-HANDLER <OFF .GC-HANDLER>>
 732                       <COND (,WARN-PRINT <PRINTSTATS>)>
 733                       <RETURN T>>
 734                 <PROG ()
 735                       <COND (,DO-CLOSE
 736                              <COND
 737                               (<AND <RI-CHANNEL .READ-INFO>
 738                                     <CHANNEL-OPEN? <RI-CHANNEL .READ-INFO>>>
 739                                <CLOSE <RI-CHANNEL .READ-INFO>>)>
 740                              <COND
 741                               (<GASSIGNED? INCHANS>
 742                                <MAPF <>
 743                                  <FUNCTION (X)
 744                                    #DECL ((X) CHANNEL)
 745                                    <COND (<CHANNEL-OPEN? .X>
 746                                           <CLOSE .X>)>>
 747                                  ,INCHANS>)>
 748                              <CLOSE .OCH>
 749                              <AND .PMCH <CLOSE .PMCH>>
 750                              <AND .AMCH <CLOSE .AMCH>>
 751                              <AND .AACH <CLOSE .AACH>>)>
 752                       <AND .GC-HANDLER <OFF .GC-HANDLER>>>>>
 753
 754 <DEFINE PRINFILE (CH "AUX" (OUTCHAN ,OUTCHAN))
 755   #DECL ((CH) CHANNEL)
 756   <COND
 757    (,VERBOSE?
 758     <CRLF .OUTCHAN>
 759     <PRINT-MANY .OUTCHAN PRINC <COND (<NOT ,GLUE>
 760                                       "Reading file ")
 761                                      (<AND <ASSIGNED? PASS2?> .PASS2?>
 762                                       "Pass 2:  ")
 763                                      (T
 764                                       "Pass 1:  ")>
 765                 <CHANNEL-OP .CH NAME>>)>>
 766
 767 <DEFINE PRINTSTATS ("AUX" (ECPU <FIX <+ <TIME> 0.5>>) (OUTCHAN .OUTCHAN))
 768         #DECL ((STARCPU) FIX (GCTIME) FLOAT)
 769         <CRLF .OUTCHAN>
 770         <PRINT-MANY .OUTCHAN PRINC  "Total time Used: " <- .ECPU .STARCPU>
 771                     " Gc Time Used: " <FIX .GCTIME> "
 772 IO time: " <FIX <+ ,IO-TIME 0.5>>
 773            <COND (,GLUE
 774                   " Total Glue Code Length: ")
 775                  ("")>
 776            <COND (,GLUE
 777                   <* ,FBYTE-OFFSET 4>)
 778                  ("")>>
 779         <CRLF .OUTCHAN>>
 780
 781
 782 <SETG ROOT-ATOMS ["M$$BINDID" "M$$INT-LEVEL"]>
 783
 784 <GDECL (ROOT-ATOMS) <VECTOR [REST STRING]>>
 785
 786 <DEFINE SKIP (READ-INFO)
 787         #DECL ((N) FIX (READ-INFO) TUPLE)
 788         <REPEAT EREAD (E)
 789                 <SET E
 790                      <READ-INTERNAL .READ-INFO '<PROG ()
 791                                       <SETG END-READ T>
 792                                       <RETURN T .EREAD>>>>
 793                 <COND (<AND <TYPE? .E FORM>
 794                             <FUDGE-MIMOP .E>
 795                             <==? <1 .E> END!-MIMOP>>
 796                        <RETURN>)>>>
 797
 798 <SETG IP-BUFSTR <ISTRING 100>>
 799
 800 <GDECL (IP-BUFSTR) STRING>
 801
 802 <DEFINE IPRINC (X OUTCHAN
 803                 "OPTIONAL" (PRINT-TRAIL <>) (TYPE ATOM)
 804                 "AUX" (CNT 1) (STR ,IP-BUFSTR))
 805         #DECL ((X) STRING (OUTCHAN) <SPECIAL CHANNEL>)
 806         <COND (<==? .TYPE GVAL>
 807                <1 .STR !\,>
 808                <SET CNT 2>)
 809               (<==? .TYPE LVAL>
 810                <1 .STR !\.>
 811                <SET CNT 2>)>
 812         <MAPF <>
 813               <FCN (CH)
 814                    <COND (<==? .CH !\ >
 815                           <COND (<NOT ,INT-MODE>
 816                                  <PUT .STR .CNT <ASCII 92>>
 817                                  <PUT .STR <+ .CNT 1> !\ >
 818                                  <SET CNT <+ .CNT 2>>)>)
 819                          (ELSE <PUT .STR .CNT .CH> <SET CNT <+ .CNT 1>>)>>
 820               .X>
 821         <COND (.PRINT-TRAIL
 822                <PUT .STR .CNT !\!>
 823                <PUT .STR <+ .CNT 1> !\->
 824                <SET CNT <+ .CNT 2>>)>
 825         <SET STR <SUBSTRUC .STR 0 <- .CNT 1> <REST .STR <- 101 .CNT>>>>
 826         <PRINC .STR>>
 827
 828 <DEFINE COUNT-GCS (IGN TI "TUPLE" X)
 829         #DECL ((TI GCTIME) FLOAT)
 830         <SETG GC-COUNT <+ ,GC-COUNT 1>>
 831         <AND <ASSIGNED? GCTIME> <SET GCTIME <+ .GCTIME .TI>>>>
 832
 833 <DEFINE DO-FILE-COPY (INCH OUCH AMT "AUX" (BUF <ISTRING 512>))
 834   #DECL ((INCH OUCH) <CHANNEL 'DISK> (AMT) FIX (BUF) STRING)
 835   <COND (<==? .AMT -1> <SET AMT <MIN>>)>
 836   <REPEAT (CT RAMT)
 837     <COND (<SET CT <CHANNEL-OP .INCH READ-BUFFER .BUF <MIN 512 .AMT>>>
 838            <CHANNEL-OP .OUCH WRITE-BUFFER .BUF .CT>
 839            <COND (<OR <L? .CT 512>
 840                       <L=? <SET AMT <- .AMT .CT>> 0>>
 841                   <RETURN>)>)
 842           (<ERROR READ-FAILED <SYS-ERR <CHANNEL-OP .INCH NAME> .CT <>>
 843                   DO-FILE-COPY>)>>>
 844 \\f
 845 <SETG CTLZ+1 <+ <SETG CTLZ 26> 1>>
 846
 847 <COND (<==? <PRIMTYPE FIX> FIX>
 848        <SETG PKG-OBL <CHTYPE PACKAGE OBLIST>>)
 849       (T
 850        <SETG PKG-OBL <GETPROP PACKAGE OBLIST>>)>
 851
 852 <DEFINE SETUP-READ-TABLE ("AUX" RT)
 853   #DECL ((RT) VECTOR)
 854   <SETG FCN-OBL <MOBLIST FOO>>
 855   <SETG FCN-OBL-L (,FCN-OBL)>
 856   <COND (<GASSIGNED? MIMOC-READ-TABLE>
 857          <SET RT ,MIMOC-READ-TABLE>)
 858         (T
 859          <SETG MIMOC-READ-TABLE <SET RT <IVECTOR ,CTLZ+1 <>>>>)>
 860   <PUT .RT ,CTLZ+1 [<ASCII ,CTLZ> ,CTLZ T ,CTLZ-RD <>]>>
 861
 862 <SETG FIRST-PASS-SURVIVOR-GLUE <>>
 863
 864 <DEFINE CTLZ-RD (X "OPT" Y "AUX" (O .OBLIST) (OBLIST ,FCN-OBL-L))
 865         #DECL ((OBLIST) <SPECIAL ANY>)
 866         <COND (<NOT ,FIRST-PASS-SURVIVOR-GLUE>
 867                <SET OBLIST .O>)>
 868         <COND (<NOT <TYPE? <SET X <READ .X>> ATOM>>
 869                <PROG ((OBLIST .O))
 870                      #DECL ((OBLIST) <SPECIAL ANY>)
 871                      <ERROR BAD-CTRL-Z-USAGE-BY-MIMC .X>>)
 872               (<==? .OBLIST .O> .X)
 873               (ELSE
 874                <SET X (.X <LIST !.O>)>
 875                <COND (<NOT <MEMBER .X ,LIST-OF-FCNS>>
 876                       <SETG LIST-OF-FCNS (.X !,LIST-OF-FCNS)>)>
 877                <1 .X>)>>
 878
 879 <DEFINE FIND-OLD-FCN (NAME INDEX "AUX" (SPN <SPNAME .NAME>))
 880   #DECL ((NAME) ATOM (INDEX) <LIST [REST LIST]>)
 881   <MAPF <>
 882     <FUNCTION (L)
 883       <COND (<=? .SPN <SPNAME <1 .L>>>
 884              <MAPLEAVE .L>)>>
 885     .INDEX>>
 886
 887 <DEFINE COPY-OLD-FCN (LIST INCH OUCH)
 888   #DECL ((LIST) <LIST ATOM FIX FIX> (INCH OUCH) <CHANNEL 'DISK>)
 889   <COND (<NOT <GASSIGNED? COPY-BUF>>
 890          <SETG COPY-BUF <ISTRING 1024>>)>
 891   <ACCESS .INCH <2 .LIST>>
 892   <CRLF .OUCH>
 893   <REPEAT ((LEN <- <3 .LIST> <2 .LIST>>) CT)
 894     #DECL ((LEN CT) FIX)
 895     <SET CT <CHANNEL-OP .INCH READ-BUFFER ,COPY-BUF <MIN .LEN 1024>>>
 896     <CHANNEL-OP .OUCH WRITE-BUFFER ,COPY-BUF .CT>
 897     <COND (<L=? <SET LEN <- .LEN .CT>> 0>
 898            <RETURN>)>>
 899   <CRLF .OUCH>>