mim/development/mim/mimc/mapgen.mud

   1
   2 <PACKAGE "MAPGEN">
   3
   4 <ENTRY MAPFR-GEN
   5        MAPRET-STOP-GEN
   6        MAPLEAVE-GEN
   7        MTUPLE-GEN
   8        MBINDERS
   9        MPARGS-GEN
  10        MOPTG
  11        MOPTG2>
  12
  13 <USE "COMPDEC" "CODGEN" "CHKDCL" "CARGEN" "NEWREP" "STRGEN" "MIMGEN" "ADVMESS">
  14
  15 " Definitions of offsets into MAPINFO vector used by MAP hackers inferiors."
  16
  17 <SETG MAP-STRS 1>
  18
  19 <SETG MAP-FR 2>
  20
  21 <SETG MAP-TAG 3>
  22
  23 <SETG MAP-TEMPS 4>
  24
  25 <SETG MAP-F? 5>
  26
  27 <SETG MAP-FTMP 6>
  28
  29 <SETG MAP-EXTMP 7>
  30
  31 <SETG MAP-SEG? 8>
  32
  33 <MANIFEST MAP-FR
  34           MAP-TAG
  35           MAP-TGL
  36           MAP-SRC
  37           MAP-TEMPS
  38           MAP-F?
  39           MAP-FTMP
  40           MAP-EXTMP
  41           MAP-SEG?
  42           MAP-STRS>
  43
  44 <PUT-DECL MPINFO
  45           '<VECTOR <LIST [REST NODE]>
  46                    <OR FALSE ATOM>
  47                    ATOM
  48                    <LIST [REST TEMP]>
  49                    <OR FALSE ATOM>
  50                    TEMP
  51                    TEMP
  52                    <LIST [REST <OR ATOM FALSE>]>>>
  53
  54 "\f"
  55
  56 <DEFINE MAPFR-GEN (NOD WHERE "OPT" (NF <>) (BR <>) (DIR <>)
  57                              "AUX" (K <KIDS .NOD>) (COD <NODE-TYPE <2 .K>>))
  58    #DECL ((NOD) NODE (COD) FIX (K) <LIST [REST NODE]>)
  59    <COND
  60     (<==? .COD ,MFCN-CODE> <HMAPFR .NOD .WHERE .K .NF .BR .DIR>)
  61     (ELSE
  62      <PROG ((FAP <1 .K>) MPINFO (INRAP <2 .K>) W (STACKED 0) F? FF?
  63             (MAYBE-FALSE <>) (NARG <LENGTH <SET K <REST .K 2>>>)
  64             (R? <==? <NODE-SUBR .NOD> ,MAPR>) (MAPEND <MAKE-TAG "MAP">)
  65             (MAPLP <MAKE-TAG "MAP">) (SUBRC <AP? .FAP>) (FOONARG .NARG)
  66             (STMPS <MAPF ,LIST
  67                          <FUNCTION () <COND (<L? <SET FOONARG <- .FOONARG 1>>
  68                                                  0> <MAPSTOP>)
  69                                             (ELSE <GEN-TEMP <>>)>>>)
  70             (FTMP <GEN-TEMP <>>)
  71             (EXTMP <GEN-TEMP <>>) (APTMP <>) (FLS <==? .WHERE FLUSHED>) TMP
  72             (SEG? <MAPF ,LIST <FUNCTION (X) #FALSE ()> .STMPS>) (SEGCNT <>))
  73        #DECL ((FAP INRAP) NODE (NARG POFF) FIX (MAPLP MAPEND) ATOM
  74               (MPINFO) <SPECIAL MPINFO> (STACKED) <SPECIAL FIX>
  75               (SEG?) <LIST [REST <OR ATOM FALSE>]> (SEGCNT) <OR FALSE TEMP>)
  76        <SET WHERE
  77             <COND (<==? .WHERE FLUSHED> FLUSHED)
  78                   (<==? .WHERE DONT-CARE> .FTMP)
  79                   (ELSE .WHERE)>>
  80        <SET F? <DO-FIRST-SETUP .FAP .WHERE .FTMP .EXTMP .FLS>>
  81        <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
  82        <PUSH-STRUCS .K .STMPS .SEG?>
  83        <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC .FTMP .EXTMP>>)>
  84        <COND (<N==? .COD ,MPSBR-CODE> <SET APTMP <GEN .INRAP>>)>
  85        <COND (<AND .F?
  86                    <OR <NOT .SUBRC>
  87                        <NOT <MEMQ .SUBRC
  88                                   '[VECTOR UVECTOR TUPLE STRING BYTES]>>>>
  89               <START-FRAME <COND (.SUBRC) (ELSE APPLY)>>
  90               <COND (<NOT .SUBRC> <PUSH .EXTMP>)>)>
  91        <IEMIT `LOOP>
  92        <LABEL-TAG .MAPLP>
  93        <IEMIT `INTGO>
  94        <EMPTY-MAPF-CHECK .K .STMPS .MAPEND .SEG?>
  95        <SET MPINFO [.K .R? .MAPEND .STMPS .F? .FTMP .EXTMP .SEG?]>
  96        <COND (<AND <==? .COD ,MPSBR-CODE> <NOT <OR? !.SEG?>>>
  97               <COND (.F?
  98                      <GEN <1 <KIDS .INRAP>> ,POP-STACK>
  99                      <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>)
 100                     (.FF?
 101                      <DO-FUNNY-HACK <GEN <1 <KIDS .INRAP>> DONT-CARE>
 102                                     .NOD
 103                                     .FAP
 104                                     <1 <KIDS .INRAP>>
 105                                     .FTMP
 106                                     .EXTMP>)
 107                     (<NOT .FLS> <GEN <1 <KIDS .INRAP>> .FTMP>)
 108                     (ELSE <GEN <1 <KIDS .INRAP>> FLUSHED>)>)
 109              (ELSE
 110               <COND (<OR? !.SEG?>
 111                      <SET SEGCNT <GEN-TEMP>>
 112                      <IEMIT `SET
 113                             .SEGCNT
 114                             <+ <MAPF ,+
 115                                      <FUNCTION (SG) <COND (.SG 0) (ELSE 1)>>
 116                                      .SEG?>
 117                                <COND (.APTMP 1) (ELSE 0)>>>)>
 118               <START-FRAME <COND (.APTMP APPLY)
 119                                  (ELSE <NODE-NAME <1 <KIDS .INRAP>>>)>>
 120               <COND (.APTMP <PUSH .APTMP>)>
 121               <REPEAT ((I .NARG))
 122                       #DECL ((I) FIX)
 123                       <MPARGS-GEN .NOD ,POP-STACK .SEGCNT>
 124                       <AND <0? <SET I <- .I 1>>> <RETURN>>>
 125               <MSUBR-CALL <COND (.APTMP APPLY)
 126                                 (ELSE <NODE-NAME <1 <KIDS .INRAP>>>)>
 127                           <COND (.SEGCNT) (ELSE <+ .NARG 1>)>
 128                           <COND (<OR .F? .FF?> <SET TMP <GEN-TEMP>>)
 129                                 (ELSE .WHERE)>>
 130               <COND (.F? <DO-STACK-ARGS .MAYBE-FALSE .TMP .EXTMP .FTMP>)
 131                     (.FF?
 132                      <DO-FUNNY-HACK .TMP .NOD .FAP .INRAP .FTMP .EXTMP>)>)>
 133        <REST-STRUCS .STMPS .K .SEG?>
 134        <BRANCH-TAG .MAPLP>
 135        <LABEL-TAG .MAPEND>
 136        <MAPF <> ,FREE-TEMP .STMPS>
 137        <COND (<ASSIGNED? APTMP> <FREE-TEMP .APTMP>)>
 138        <COND (.F?
 139               <SET WHERE <DO-LAST .SUBRC .MAYBE-FALSE .WHERE .EXTMP .FTMP>>
 140               <FREE-TEMP .FTMP>
 141               <FREE-TEMP .EXTMP>)
 142              (.FF? <FREE-TEMP .EXTMP> <SET WHERE <MOVE-ARG .FTMP .WHERE>>)
 143              (<NOT .FLS>
 144               <SET WHERE <MOVE-ARG .FTMP .WHERE>>
 145               <FREE-TEMP .EXTMP>)
 146              (ELSE <FREE-TEMP .FTMP> <FREE-TEMP .EXTMP>)>
 147        <FLUSH-TUPLES .STMPS .SEG?>
 148        .WHERE>)>>
 149
 150 \\f
 151
 152 <DEFINE PUSH-STRUCS (K STMPS SEG?
 153                      "AUX" COUNTMP (SEGLABEL <MAKE-TAG>) (SEGCALLED <>))
 154    #DECL ((K) <LIST [REST NODE]> (STMPS) <LIST [REST TEMP]>
 155           (SEG?) <LIST [REST <OR ATOM FALSE>]>
 156           (SEGCALLED COUNTMP SEGLABEL) <SPECIAL ANY>)
 157    <MAPR <>
 158     <FUNCTION (NP TMPP SEG "AUX" (N <1 .NP>) (TMP <1 .TMPP>) TT CT TTT TY STY)
 159             #DECL ((N) NODE (SEG) LIST)
 160             <COND
 161              (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
 162                   <==? <NODE-TYPE .N> ,SEG-CODE>>
 163               <SET N <1 <KIDS .N>>>
 164               <IEMIT `SET <SET CT <SET COUNTMP <GEN-TEMP>>> 0>
 165               <SET TT <GEN .N DONT-CARE>>
 166               <COND (<NOT <OR <==? .TT ,NO-DATUM>
 167                               <AND <TYPE? .TT TEMP> <L=? <TEMP-REFS .TT> 1>>>>
 168                      <IEMIT `SET <SET TTT <GEN-TEMP>> .TT>
 169                      <FREE-TEMP .TT>
 170                      <SET TT .TTT>)>
 171               <PUT .SEG 1 T>
 172               <COND (<N==? .TT ,NO-DATUM>
 173                      <SEGMENT-STACK .TT
 174                                     .CT
 175                                     <STRUCTYP <RESULT-TYPE .N>>
 176                                     <ISTYPE? <RESULT-TYPE .N>>
 177                                     .SEGLABEL>)
 178                     (.SEGCALLED <LABEL-TAG .SEGLABEL>)>
 179               <SET SEGLABEL <MAKE-TAG>>
 180               <FREE-TEMP .TT>
 181               <USE-TEMP .TMP>
 182               <IEMIT `TUPLE .CT = .TMP '(`TYPE TUPLE)>
 183               <FREE-TEMP .CT>)
 184              (ELSE
 185               <SET TT <GEN .N DONT-CARE>>
 186               <SET STY <STRUCTYP <SET TY <RESULT-TYPE .N>>>>
 187               <SET TY <ISTYPE? .TY>>
 188               <COND (<AND <TYPE? .TT TEMP> <L=? <TEMP-REFS .TT> 1>>
 189                      <PUT .TMPP 1 <SET TMP .TT>>
 190                      <COND (<AND .STY <N==? .TY .STY>>
 191                             <IEMIT `CHTYPE
 192                                    .TMP
 193                                    <FORM `TYPE-CODE .STY>
 194                                    =
 195                                    .TMP>)>)
 196                     (<AND .STY <N==? .STY .TY>>
 197                      <USE-TEMP .TMP .STY>
 198                      <IEMIT `CHTYPE .TT <FORM `TYPE-CODE .STY> = .TMP>)
 199                     (.STY <MOVE-ARG .TT .TMP (`TYPE .TY)>)
 200                     (ELSE <MOVE-ARG .TT .TMP>)>)>>
 201     .K
 202     .STMPS
 203     .SEG?>
 204    T>
 205
 206 <DEFINE REST-STRUCS (STMPS K SEG?)
 207    #DECL ((K) <LIST [REST NODE]> (STMPS) <LIST [REST TEMP]>
 208           (SEG?) <LIST [REST <OR ATOM FALSE>]>)
 209    <MAPF <>
 210     <FUNCTION (TMP NOD SEG
 211                "AUX" (ST <STRUCTYP <RESULT-TYPE .NOD>>) ETYP STMP LBL1 LBL2
 212                      ETMP)
 213        #DECL ((NOD) NODE (TMP) TEMP)
 214        <COND
 215         (.SEG
 216          <IEMIT `SET <SET STMP <GEN-TEMP>> .TMP>
 217          <SET ETYP <STRUCTYP <GET-ELE-TYPE <RESULT-TYPE <1 <KIDS .NOD>>> ALL>>>
 218          <COND (.ETYP <IEMIT `LOOP (<TEMP-NAME .STMP> LENGTH VALUE)>)
 219                (ELSE <IEMIT `LOOP>)>
 220          <LABEL-TAG <SET LBL1 <MAKE-TAG>>>
 221          <IEMIT `INTGO>
 222          <EMPTY-CHECK TUPLE .STMP TUPLE T <SET LBL2 <MAKE-TAG>>>
 223          <NTH-DO TUPLE .STMP <SET ETMP <GEN-TEMP>> 1>
 224          <COND (.ETYP <REST-DO .ETYP .ETMP .ETMP 1>)
 225                (ELSE <IEMIT `REST1 .ETMP = .ETMP>)>
 226          <PUT-VECTOR .STMP 1 .ETMP>
 227          <REST-DO TUPLE .STMP .STMP 1>
 228          <BRANCH-TAG .LBL1>
 229          <LABEL-TAG .LBL2>
 230          <FREE-TEMP .STMP>
 231          <FREE-TEMP .ETMP>)
 232         (.ST <REST-DO .ST .TMP .TMP 1>)
 233         (ELSE <IEMIT `REST1 .TMP = .TMP>)>>
 234     .STMPS
 235     .K
 236     .SEG?>>
 237
 238 <DEFINE DO-FINAL-SETUP (FAP SUBRC FTMP EXTMP
 239                         "AUX" (MBYF <AND <NOT .SUBRC>
 240                                          <OR <NOT .REASONABLE>
 241                                              <N==? <NODE-TYPE .FAP>
 242                                                    ,GVAL-CODE>>
 243                                          <TYPE-OK? <RESULT-TYPE .FAP>
 244                                                    FALSE>>)
 245                               TG1 TG2)
 246         #DECL ((FAP) NODE)
 247         <COND (<NOT .SUBRC>
 248                <GEN .FAP .EXTMP>)>
 249         <COND (.MBYF
 250                <GEN-TYPE? .EXTMP FALSE <SET TG1 <MAKE-TAG>> T>)>
 251         <SET-TEMP .FTMP <COND (.SUBRC 0) (ELSE 1)> '(`TYPE FIX)>
 252         <COND (.MBYF
 253                <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
 254                <LABEL-TAG .TG1>
 255                <SET-TEMP .FTMP <> '(`TYPE FALSE)>
 256                <LABEL-TAG .TG2>)>
 257         .MBYF>
 258
 259 <DEFINE DO-STACK-ARGS (MAYBE-FALSE ARG SW COUNT "AUX" TG1 TG2)
 260         <COND (.MAYBE-FALSE
 261                <GEN-TYPE? .SW FALSE <SET TG1 <MAKE-TAG>> T>
 262                <PUSH .ARG>
 263                <IEMIT `ADD .COUNT 1 = .COUNT '(`TYPE FIX)>
 264                <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
 265                <LABEL-TAG .TG1>
 266                <MOVE-ARG .ARG .COUNT>
 267                <LABEL-TAG .TG2>)
 268               (ELSE <PUSH .ARG> <IEMIT `ADD .COUNT 1 = .COUNT '(`TYPE FIX)>)>>
 269
 270 <DEFINE DO-STACK-TUPLE (MAYBE-FALSE NEW-COUNT SW COUNT "AUX" TG1 TG2)
 271         <COND (.MAYBE-FALSE
 272                <LENGTH-VECTOR .NEW-COUNT .NEW-COUNT>
 273                <GEN-TYPE? .SW FALSE <SET TG1 <MAKE-TAG>> T>
 274                <IEMIT `ADD .COUNT .NEW-COUNT = .COUNT '(`TYPE FIX)>
 275                <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
 276                <LABEL-TAG .TG1>
 277                <POP .COUNT>
 278                <IEMIT `SUB 1 .NEW-COUNT = .NEW-COUNT '(`TYPE FIX)>
 279                <IEMIT `MUL .NEW-COUNT 2 = .NEW-COUNT '(`TYPE FIX)>
 280                <IEMIT `ADJ .NEW-COUNT>
 281                <LABEL-TAG .TG2>)
 282               (ELSE
 283                <LENGTH-VECTOR .NEW-COUNT .NEW-COUNT>
 284                <IEMIT `ADD .COUNT .NEW-COUNT = .COUNT '(`TYPE FIX)>)>>
 285
 286 \\f
 287
 288 <SETG MINS '[[`LESS? `GRTR? `MUL `ADD] [`LESS? `GRTR? `MULF `ADDF]]>
 289
 290 <GDECL (MINS) !<VECTOR [2 !<VECTOR [4 ATOM]>]>>
 291
 292 <DEFINE DO-FUNNY-HACK (DAT N FAP NN FTMP EXTMP
 293                        "AUX" (COD <NODE-SUBR .FAP>)
 294                              (LMOD <ISTYPE? <RESULT-TYPE .NN>>)
 295                              (MOD <ISTYPE? <RESULT-TYPE .N>>) T1 T2 TMP INS)
 296         #DECL ((COD) FIX (N FAP NN) NODE)
 297         <COND (<==? .COD 5>
 298                <FREE-TEMP .DAT <>>
 299                <SET TMP <GEN-TEMP>>
 300                <IEMIT `CONS .DAT () = .TMP '(`TYPE LIST)>
 301                <EMPTY-LIST .FTMP <SET T1 <MAKE-TAG>> <>>
 302                <SET-TEMP .FTMP .TMP '(`TYPE LIST)>
 303                <BRANCH-TAG <SET T2 <MAKE-TAG>>>
 304                <LABEL-TAG .T1>
 305                <IEMIT `PUTREST .EXTMP .TMP>
 306                <LABEL-TAG .T2>
 307                <FREE-TEMP .TMP <>>
 308                <SET-TEMP .EXTMP .TMP '(`TYPE LIST)>)
 309               (ELSE
 310                <SET MOD <OR <AND <==? .MOD FIX> 1> 2>>
 311                <COND (<AND <==? .MOD 2> <==? .LMOD FIX>>
 312                       <SET TMP <GEN-FLOAT .DAT <GEN-TEMP>>>
 313                       <FREE-TEMP .DAT>
 314                       <SET DAT .TMP>)>
 315                <SET INS <NTH <NTH ,MINS .MOD> .COD>>
 316                <COND (<L? .COD 3>
 317                       <IEMIT .INS .DAT .FTMP - <SET T1 <MAKE-TAG>>
 318                              (`TYPE <COND (<==? .MOD 1> FIX)
 319                                           (ELSE FLOAT)>)>
 320                       <MOVE-ARG .DAT .FTMP>
 321                       <LABEL-TAG .T1>)
 322                      (ELSE
 323                       <FREE-TEMP .DAT <>>
 324                       <IEMIT .INS .FTMP .DAT = .FTMP>)>)>
 325         T>
 326
 327 <DEFINE DO-LAST (SUBRC MAYBE-FALSE WHERE EXTMP COUNT "AUX" TG TG2)
 328         <COND (.MAYBE-FALSE
 329                <GEN-TYPE? .EXTMP FALSE <SET TG <MAKE-TAG>> T>
 330                <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP>>)
 331                      (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE>)>
 332                <COND (.SUBRC <XMSUBR-CALL .SUBRC .COUNT .WHERE>)
 333                      (ELSE <MSUBR-CALL APPLY .COUNT .WHERE>)>
 334                <BRANCH-TAG <SET TG2 <MAKE-TAG>>>
 335                <LABEL-TAG .TG>
 336                <MOVE-ARG .COUNT .WHERE>
 337                <LABEL-TAG .TG2>)
 338               (ELSE
 339                <COND (<==? .WHERE DONT-CARE> <SET WHERE <GEN-TEMP>>)
 340                      (<TYPE? .WHERE TEMP> <USE-TEMP .WHERE>)>
 341                <COND (.SUBRC <XMSUBR-CALL .SUBRC .COUNT .WHERE>)
 342                      (ELSE <MSUBR-CALL APPLY .COUNT .WHERE>)>)>
 343         .WHERE>
 344
 345 <DEFINE XMSUBR-CALL (SUBRC NARGS WHERE)
 346         <COND (<MEMQ .SUBRC '[VECTOR UVECTOR STRING BYTES]>
 347                <IEMIT `UBLOCK <FORM `TYPE-CODE .SUBRC> .NARGS = .WHERE
 348                       (`TYPE .SUBRC)>)
 349               (<==? .SUBRC LIST>
 350                <IEMIT `LIST .NARGS = .WHERE '(`TYPE LIST)>)
 351               (<==? .SUBRC TUPLE>
 352                <IEMIT `TUPLE .NARGS = .WHERE>
 353                <COND (<ASSIGNED? LIST-TUPLE>
 354                       <SET LIST-TUPLE (.WHERE !.LIST-TUPLE)>)>)
 355               (ELSE <MSUBR-CALL .SUBRC .NARGS .WHERE>)>>
 356
 357 <SETG SLOT-FIRST [<CHTYPE <MIN> FIX> <CHTYPE <MAX> FIX> 1 0]>
 358
 359 <COND (<GASSIGNED? MINFL> <SETG FSLOT-FIRST [,MINFL ,MAXFL 1.0 0.0]>)>
 360
 361 <GDECL (SLOT-FIRST) <VECTOR [REST FIX]> (FSLOT-FIRST) <VECTOR [REST FLOAT]>>
 362
 363 \\f
 364
 365 <DEFINE DO-FIRST-SETUP (FAP W FTMP EXTMP FLS
 366                         "AUX" (COD 0)
 367                               (TYP <ISTYPE? <RESULT-TYPE <PARENT .FAP>>>))
 368    #DECL ((FAP) NODE (COD) FIX)
 369    <COND
 370     (<==? <NODE-TYPE .FAP> ,MFIRST-CODE>
 371      <SET COD <NODE-SUBR .FAP>>
 372      <COND (<==? .COD 5>
 373             <MOVE-ARG <REFERENCE <COND (.TYP <CHTYPE () .TYP>) (ELSE ())>>
 374                       .FTMP>
 375             <MOVE-ARG <REFERENCE ()> .EXTMP>
 376             <>)
 377            (ELSE
 378             <MOVE-ARG <REFERENCE <COND (<==? .TYP FLOAT>
 379                                         <NTH ,FSLOT-FIRST .COD>)
 380                                        (ELSE <NTH ,SLOT-FIRST .COD>)>>
 381                       .FTMP>
 382             <>)>)
 383     (<NODE-NAME .FAP> T)
 384     (<NOT .FLS> <DEALLOCATE-TEMP <MOVE-ARG <REFERENCE <>> .FTMP>> <>)>>
 385
 386 \\f
 387
 388 <DEFINE MPARGS-GEN (N W "OPT" (CNT <>) "AUX" (MP .MPINFO))
 389         #DECL ((MP) MPINFO (ETAG) ATOM)
 390         <SET W
 391              <STACKM <1 <MAP-STRS .MP>>
 392                      <1 <MAP-TEMPS .MP>>
 393                      <MAP-FR .MP>
 394                      <MAP-TAG .MP>
 395                      .W
 396                      <1 <MAP-SEG? .MP>>
 397                      .CNT>>
 398         <PUT .MP ,MAP-STRS <REST <MAP-STRS .MP>>>
 399         <PUT .MP ,MAP-TEMPS <REST <MAP-TEMPS .MP>>>
 400         <PUT .MP ,MAP-SEG? <REST <MAP-SEG? .MP>>>
 401         .W>
 402
 403 \\f
 404
 405 <DEFINE STACKM (N SRC R? LBL W SEG CNT
 406                 "AUX" (STY <STRUCTYP <RESULT-TYPE .N>>) STMP ETMP LBL1 LBL2
 407                       (ETY
 408                        <GET-ELE-TYPE <RESULT-TYPE .N>
 409                                      ALL
 410                                      <AND .R? <NOT .SEG>>>))
 411         #DECL ((N) NODE)
 412         <COND (<==? .W DONT-CARE>
 413                <SET W <GEN-TEMP <COND (<ISTYPE? .ETY>)(T)>>>)
 414               (<TYPE? .W TEMP> <USE-TEMP .W <ISTYPE? .ETY>>)>
 415         <COND (.SEG                             ;"Note this implies W is STACK"
 416                <IEMIT `SET <SET STMP <GEN-TEMP>> .SRC>
 417                <IEMIT `LOOP (<TEMP-NAME .STMP> LENGTH VALUE)>
 418                <LABEL-TAG <SET LBL1 <MAKE-TAG>>>
 419                <IEMIT `INTGO>
 420                <EMPTY-CHECK TUPLE .STMP TUPLE T <SET LBL2 <MAKE-TAG>>>
 421                <NTH-DO TUPLE .STMP <SET ETMP <GEN-TEMP>> 1>
 422                <SET ETY <GET-ELE-TYPE <RESULT-TYPE <1 <KIDS .N>>> ALL>>
 423                <COND (.R? <PUSH .ETMP>)
 424                      (<SET ETY <STRUCTYP .ETY>>
 425                       <NTH-DO .ETY .ETMP ,POP-STACK 1>)
 426                      (ELSE <IEMIT `NTH1 .ETMP = ,POP-STACK>)>
 427                <IEMIT `ADD .CNT 1 = .CNT '(`TYPE FIX)>
 428                <REST-DO TUPLE .STMP .STMP 1>
 429                <BRANCH-TAG .LBL1>
 430                <LABEL-TAG .LBL2>
 431                <FREE-TEMP .ETMP>
 432                <FREE-TEMP .STMP>)
 433               (ELSE
 434                <SET ETY <ISTYPE? .ETY>>
 435                <COND (.R? <IEMIT `SET .W .SRC>)
 436                      (.STY <NTH-DO .STY .SRC .W 1> .W)
 437                      (ELSE <IEMIT `NTH1 .SRC = .W>)>)>
 438         .W>
 439
 440 <DEFINE EMPTY-MAPF-CHECK (K STMPS LBL SEG? "AUX" STMP ETMP LBL1 LBL2 ETYP)
 441    #DECL ((K) <LIST [REST NODE]> (STMPS) <LIST [REST TEMP]>
 442           (SEG?) <LIST [REST <OR ATOM FALSE>]>)
 443    <MAPF <>
 444     <FUNCTION (N TMP SEG "AUX" (STYP <STRUCTYP <RESULT-TYPE .N>>))
 445        #DECL ((N) NODE)
 446        <COND
 447         (.SEG
 448          <IEMIT `SET <SET STMP <GEN-TEMP>> .TMP>
 449          <IEMIT `LOOP (<TEMP-NAME .STMP> VALUE LENGTH)>
 450          <LABEL-TAG <SET LBL1 <MAKE-TAG>>>
 451          <IEMIT `INTGO>
 452          <EMPTY-CHECK TUPLE .STMP TUPLE T <SET LBL2 <MAKE-TAG>>>
 453          <SET ETYP <STRUCTYP <GET-ELE-TYPE <RESULT-TYPE <1 <KIDS .N>>> ALL>>>
 454          <NTH-DO TUPLE .STMP <SET ETMP <GEN-TEMP>> 1>
 455          <COND (.ETYP <EMPTY-CHECK .ETYP .ETMP .ETYP T .LBL>)
 456                (ELSE
 457                 <IEMIT `EMPTY? .ETMP + .LBL>)>
 458          <REST-DO TUPLE .STMP .STMP 1>
 459          <BRANCH-TAG .LBL1>
 460          <LABEL-TAG .LBL2>
 461          <FREE-TEMP .STMP>
 462          <FREE-TEMP .ETMP>)
 463         (.STYP <EMPTY-CHECK .STYP .TMP .STYP T .LBL>)
 464         (ELSE
 465          <IEMIT `EMPTY? .TMP + .LBL>)>>
 466     .K
 467     .STMPS
 468     .SEG?>>
 469
 470 <DEFINE REM-TUPS ()
 471         #DECL ((STK-CHARS8 STK-CHARS7 STK) FIX)
 472         <COND (<N==? .STK-CHARS8 0>
 473                <SET STK-CHARS8 <+ .STK-CHARS8 .STK>>
 474                <SET STK-CHARS7 <+ .STK-CHARS7 .STK>>
 475                <SET STK 0>)>
 476         <COND (<ASSIGNED? STKTMP>
 477                <COND (<N==? .STK 0>
 478                       <IEMIT `SUB .STKTMP .STK = .STKTMP (`TYPE FIX)>)
 479                      (<N==? .STK-CHARS7 0>
 480                       <IEMIT `IFSYS "TOPS20">
 481                       <IEMIT `SUB .STKTMP .STK-CHARS7 = .STKTMP>
 482                       <IEMIT `ENDIF "TOPS20">
 483                       <IEMIT `IFSYS "UNIX">
 484                       <IEMIT `SUB .STKTMP .STK-CHARS8 = .STKTMP>
 485                       <IEMIT `ENDIF "UNIX">)>
 486                <IEMIT `ADJ .STKTMP>
 487                <FREE-TEMP .STKTMP>)
 488               (<N==? .STK 0>
 489                <IEMIT `ADJ <- .STK>>)
 490               (<N==? .STK-CHARS8 0>
 491                <IEMIT `IFSYS "TOPS20">
 492                <IEMIT `ADJ <- .STK-CHARS7>>
 493                <IEMIT `ENDIF "TOPS20">
 494                <IEMIT `IFSYS "UNIX">
 495                <IEMIT `ADJ <- .STK-CHARS8>>
 496                <IEMIT `ENDIF "UNIX">)>>
 497
 498 <DEFINE FLUSH-TUPLES (STMPS SEG?)
 499         #DECL ((SEG? STMPS) LIST)
 500         <MAPF <>
 501               <FUNCTION (TMP SEGF)
 502                       #DECL ((TMP) TEMP (SEGF) <OR ATOM FALSE>)
 503                       <COND (.SEGF
 504                              <LENGTH-VECTOR .TMP .TMP>
 505                              <IEMIT `SUB 0 .TMP = .TMP '(`TYPE FIX)>
 506                              <IEMIT `MUL .TMP 2 = .TMP '(`TYPE FIX)>
 507                              <IEMIT `ADJ .TMP>)>
 508                       <FREE-TEMP .TMP>>
 509               .STMPS
 510               .SEG?>>
 511
 512 \\f
 513
 514 <DEFINE HMAPFR (MNOD MWHERE K NF BR DIR
 515                 "AUX" (SPECD <>) (FAP <1 .K>) (INRAP <2 .K>) F?
 516                       (NARG <LENGTH <SET K <REST .K 2>>>)
 517                       (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (FF? <>)
 518                       (MAPEND <MAKE-TAG "MAP">) (MAPLP <MAKE-TAG "MAP">)
 519                       (REST-TAG <MAKE-TAG "MAP">) (SUBRC <AP? .FAP>)
 520                       (BASEF .BASEF) (MAYBE-FALSE <>) (EXIT <MAKE-TAG "MAPEX">)
 521                       (APPLTAG <MAKE-TAG "MAPAP">) (FLS <==? .MWHERE FLUSHED>)
 522                       (RTAG <MAKE-TAG "MAP">) TEM (FOONARG .NARG)
 523                       (STMPS
 524                        <MAPF ,LIST
 525                              <FUNCTION ()
 526                                      <COND (<L? <SET FOONARG <- .FOONARG 1>> 0>
 527                                             <MAPSTOP>)
 528                                            (ELSE <GEN-TEMP <>>)>>>) FTMP FEXIT
 529                       (EXTMP <GEN-TEMP <>>) (BNDTMP <GEN-TEMP <>>)
 530                       (SEG? <MAPF ,LIST <FUNCTION (X) %<>> .STMPS>) SEGCNT
 531                       MYFRAME (INRTYP <ISTYPE? <RESULT-TYPE .INRAP>>)
 532                       (FWHERE <>) LEAVE? (OFT .FREE-TEMPS) (ANY-EMPTY <>)
 533                       STKTMP (STK 0) (STK-CHARS7 0) (STK-CHARS8 0))
 534    #DECL ((STK-CHARS7 STK-CHARS8 STK) <SPECIAL FIX> (STKTMP) <SPECIAL ANY>
 535           (SPECD) <SPECIAL <OR FALSE ATOM>> (NARG) <SPECIAL FIX> (FAP) NODE
 536           (BASEF MNOD INRAP) <SPECIAL NODE> (K) <LIST [REST NODE]>
 537           (MAPEND EXIT MAPLP RTAG APPLTAG REST-TAG) <SPECIAL ATOM>
 538           (FTMP EXTMP MWHERE MAYBE-FALSE FLS) <SPECIAL ANY> (FSYM) SYMTAB
 539           (F?) <SPECIAL ANY> (BNDTMP LEAVE?) <SPECIAL TEMP>
 540           (DIR BR) <SPECIAL ANY> (SEG?) <LIST [REST <OR ATOM FALSE>]>
 541           (TMPS) <PRIMTYPE LIST>)
 542    <MAPF <>
 543          <FUNCTION (X)
 544                  #DECL ((X) NODE)
 545                  <COND (<L? <MINL <RESULT-TYPE .X>> 1>
 546                         <SET ANY-EMPTY T>
 547                         <MAPLEAVE>)>>
 548          .K>
 549    <COND (.NF <SET DIR <NOT .DIR>>)>
 550    <PROG ((TMPS .TMPS) (TMPS-NEXT .TMPS-NEXT) (FREE-TEMPS .FREE-TEMPS)
 551           (ALL-TEMPS-LIST .ALL-TEMPS-LIST))
 552      #DECL ((TMPS-NEXT FREE-TEMPS ALL-TEMPS-LIST) <SPECIAL LIST>
 553             (TMPS) <SPECIAL FORM>)
 554      <COND (<==? .MWHERE DONT-CARE> <SET FTMP <SET MWHERE <GEN-TEMP <>>>>)
 555            (ELSE <SET FTMP <GEN-TEMP <>>>)>
 556      <SET F? <DO-FIRST-SETUP .FAP .MWHERE .FTMP .EXTMP .FLS>>
 557      <OR .F? <SET FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>>>
 558      <PUSH-STRUCS .K .STMPS .SEG?>
 559      <COND (.F? <SET MAYBE-FALSE <DO-FINAL-SETUP .FAP .SUBRC .FTMP .EXTMP>>)>
 560      <COND (<AND .F?
 561                  <OR <NOT .SUBRC>
 562                      <NOT <MEMQ .SUBRC '[VECTOR
 563                                          UVECTOR
 564                                          TUPLE
 565                                          STRING
 566                                          BYTES]>>>>
 567             <START-FRAME <COND (.SUBRC) (ELSE APPLY)>>
 568             <COND (<NOT .SUBRC> <PUSH .EXTMP>)>)>
 569      <COND (<AND .ANY-EMPTY .BR <N==? .INRTYP FALSE> <NOT .DIR>>
 570             <EMPTY-MAPF-CHECK .K .STMPS .BR .SEG?>)>
 571      <IEMIT `LOOP>
 572      <LABEL-TAG .MAPLP>
 573      <IEMIT `INTGO>
 574      <EMPTY-MAPF-CHECK .K
 575                        .STMPS
 576                        <COND (<AND .BR
 577                                    <COND (.DIR <N==? .INRTYP FALSE>)
 578                                          (ELSE <==? .INRTYP FALSE>)>>
 579                               .BR)
 580                              (ELSE .APPLTAG)>
 581                        .SEG?>
 582      <COND (<AND <OR <SPCS-X .INRAP> <OR? !.SEG?>>
 583                  <ACTIVATED .INRAP>
 584                  .F?
 585                  <NOT .FF?>>
 586             <SET LEAVE? <GEN-TEMP>>
 587             <IEMIT `SET .LEAVE? 0>
 588             <IEMIT `ICALL <SET FEXIT <MAKE-TAG>> = <SET FWHERE <GEN-TEMP>>>
 589             <SET ALL-TEMPS-LIST
 590                  ((.TMPS .TMPS-NEXT .FREE-TEMPS <>) !.ALL-TEMPS-LIST)>
 591             <MIM-TEMPS-HOLD>
 592             <MIM-TEMPS-EMIT>
 593             <SET FREE-TEMPS ()>
 594             <SET MYFRAME <GEN-TEMP>>
 595             <PREV-FRAME .MYFRAME>
 596             <PUT <1 .ALL-TEMPS-LIST> 4 .MYFRAME>)>
 597      <REPEAT ((BST <BINDING-STRUCTURE .INRAP>) (K .K) TMP SYM (STMPS .STMPS)
 598               VAL (SEG? .SEG?) T-NAME TY PT)
 599        #DECL ((BS) <LIST [REST SYMTAB]> (K) <LIST [REST NODE]>
 600               (STMPS) <LIST [REST TEMP]> (TNAME) <SPECIAL ANY>
 601               (SEG?) <LIST [REST <OR ATOM FALSE>]>)
 602        <COND
 603         (<EMPTY? .STMPS>
 604          <MAPF <>
 605                <FUNCTION (SYM)
 606                        #DECL ((SYM) SYMTAB)
 607                        <COND (<AND <NOT .SPECD> <SPEC-SYM .SYM>>
 608                               <SAVE-BINDING .BNDTMP>
 609                               <SET SPECD T>)>
 610                        <COND (<NOT <SPEC-SYM .SYM>>
 611                               <SET TMP
 612                                    <GEN-TEMP <>
 613                                              <NAME-SYM .SYM>
 614                                              T
 615                                              <DECL-SYM .SYM>>>
 616                               <PUT .SYM ,TEMP-NAME-SYM .TMP>
 617                               <SET T-NAME <TEMP-NAME .TMP>>)>
 618                        <COND (<AND <MBIND-GENERATE .SYM> <NOT <SPEC-SYM .SYM>>>
 619                               <PUTREST .TMPS-NEXT <SET TMPS-NEXT (.T-NAME)>>
 620                               <USE-TEMP .TMP>
 621                               <PUT .TMP ,TEMP-REFS 1>)>>
 622                .BST>
 623          <RETURN>)
 624         (ELSE
 625          <COND (<AND <SPEC-SYM <SET SYM <1 .BST>>> <NOT .SPECD>>
 626                 <SAVE-BINDING .BNDTMP>
 627                 <SET SPECD T>)>
 628          <COND
 629           (<NOT <SPEC-SYM .SYM>>
 630            <SET TMP <GEN-TEMP <> <NAME-SYM .SYM> T T>>
 631            <PUT .SYM ,TEMP-NAME-SYM .TMP>
 632            <PUTREST
 633             .TMPS-NEXT
 634             <SET TMPS-NEXT
 635                  (<COND (<AND <NOT <ASS? .SYM>>
 636                               <SET TY <ISTYPE? <COMPOSIT-TYPE .SYM>>>
 637                               <OR <==? <SET PT <TYPEPRIM .TY>> FIX>
 638                                   <==? .PT WORD>
 639                                   <==? .PT LIST>>>
 640                          <CHTYPE [<TEMP-NAME .TMP> .TY] ADECL>)
 641                         (ELSE <TEMP-NAME .TMP>)>)>>
 642            <PUT .TMP ,TEMP-REFS 1>)>
 643          <COND (<AND <1 .SEG?> <==? <CODE-SYM .SYM> ,ARGL-TUPLE>>
 644                 <IEMIT `SET <SET SEGCNT <GEN-TEMP>> 0>
 645                 <STACKM <1 .K> <1 .STMPS> .R? .MAPEND ,POP-STACK T .SEGCNT>
 646                 <IEMIT `TUPLE
 647                        .SEGCNT
 648                        =
 649                        <COND (<SPEC-SYM .SYM> <SET VAL <GEN-TEMP>>)
 650                              (ELSE .TMP)>>)
 651                (<1 .SEG?>
 652                 <COMPILE-LOSSAGE "Not quite implemented SEGMENTS in MAPFS">)
 653                (ELSE
 654                 <SET VAL
 655                      <STACKM <1 .K>
 656                              <1 .STMPS>
 657                              .R?
 658                              .MAPEND
 659                              <COND (<SPEC-SYM .SYM> DONT-CARE) (ELSE .TMP)>
 660                              <>
 661                              <>>>)>
 662          <COND (<SPEC-SYM .SYM>
 663                 <SPECIAL-BINDING .SYM T .VAL>
 664                 <SET STK <+ .STK ,BINDING-LENGTH>>)>
 665          <SET STMPS <REST .STMPS>>
 666          <SET BST <REST .BST>>
 667          <SET K <REST .K>>
 668          <SET SEG? <REST .SEG?>>)>>
 669      <COND (.F?
 670             <SET TEM <SEQ-GEN <KIDS .INRAP> DONT-CARE>>
 671             <COND (<N==? .TEM ,NO-DATUM>
 672                    <COND (.FWHERE
 673                           <FREE-TEMP .TEM <>>
 674                           <PUSH .TEM>
 675                           <IEMIT `RTUPLE 1 <FREE-TEMP <CURRENT-FRAME> <>>>)
 676                          (ELSE
 677                           <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
 678                           <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
 679                                  <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
 680                                  <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
 681                                  <IEMIT `ADJ .SEGCNT>
 682                                  <FREE-TEMP .SEGCNT>)>
 683                           <REM-TUPS>
 684                           <DO-STACK-ARGS .MAYBE-FALSE .TEM .EXTMP .FTMP>
 685                           <FREE-TEMP .TEM>)>)>)
 686            (.FF?
 687             <SET TEM <SEQ-GEN <KIDS .INRAP> DONT-CARE>>
 688             <COND (<N==? .TEM ,NO-DATUM>
 689                    <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
 690                    <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
 691                           <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
 692                           <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
 693                           <IEMIT `ADJ .SEGCNT>
 694                           <FREE-TEMP .SEGCNT>)>
 695                    <REM-TUPS>
 696                    <DO-FUNNY-HACK .TEM .MNOD .FAP .INRAP .FTMP .EXTMP>)>)
 697            (.FLS
 698             <SEQ-GEN <KIDS .INRAP> FLUSHED>
 699             <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
 700             <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
 701                    <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
 702                    <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
 703                    <IEMIT `ADJ .SEGCNT>
 704                    <FREE-TEMP .SEGCNT>)>
 705             <REM-TUPS>)
 706            (ELSE
 707             <SEQ-GEN <KIDS .INRAP> .FTMP>
 708             <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
 709             <COND (<AND <ASSIGNED? SEGCNT> .SEGCNT>
 710                    <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
 711                    <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
 712                    <IEMIT `ADJ .SEGCNT>
 713                    <FREE-TEMP .SEGCNT>)>
 714             <REM-TUPS>)>
 715      <COND (<NOT <ASSIGNED? LEAVE?>> <SET OFT .FREE-TEMPS>)>>
 716    <SET FREE-TEMPS .OFT>
 717    <SET TMPS-NEXT <REST .TMPS <- <LENGTH .TMPS> 1>>>
 718    <COND (<AND .FWHERE .F?>
 719           <LABEL-TAG .FEXIT>
 720           <IEMIT `VEQUAL? .LEAVE? 2 + .EXIT>
 721           <DO-STACK-TUPLE .MAYBE-FALSE .FWHERE .EXTMP .FTMP>
 722           <IEMIT `VEQUAL? .LEAVE? 1 + .APPLTAG>
 723           <FREE-TEMP .LEAVE?>)>
 724    <COND (<AND <NOT .F?> <ASSIGNED? SEGCNT> .SEGCNT>
 725           <IEMIT `SUB 0 .SEGCNT = .SEGCNT '(`TYPE FIX)>
 726           <IEMIT `MUL .SEGCNT 2 = .SEGCNT '(`TYPE FIX)>
 727           <IEMIT `ADJ .SEGCNT>
 728           <FREE-TEMP .SEGCNT>)>
 729    <LABEL-TAG .REST-TAG>
 730    <REST-STRUCS .STMPS .K .SEG?>
 731    <BRANCH-TAG .MAPLP>
 732    <LABEL-TAG .APPLTAG>
 733    <COND (.F?
 734           <SET MWHERE <DO-LAST .SUBRC .MAYBE-FALSE .MWHERE .EXTMP .FTMP>>
 735           <FREE-TEMP .EXTMP>
 736           <FREE-TEMP .FTMP>)
 737          (.FF? <FREE-TEMP .EXTMP> <SET MWHERE <MOVE-ARG .FTMP .MWHERE>>)
 738          (<N==? .MWHERE FLUSHED>
 739           <FREE-TEMP .EXTMP>
 740           <COND (<N==? .FTMP .MWHERE> <MOVE-ARG .FTMP .MWHERE>)>)
 741          (ELSE <FREE-TEMP .EXTMP> <FREE-TEMP .FTMP>)>
 742    <LABEL-TAG .EXIT>
 743    <FLUSH-TUPLES .STMPS .SEG?>
 744    .MWHERE>
 745
 746 <DEFINE SAVE-BINDING (BNDTMP) <USE-TEMP .BNDTMP> <GET-BINDING .BNDTMP>>
 747
 748 <DEFINE NO-INTERFERE (N B)
 749         #DECL ((N) NODE (B) <LIST [REST SYMTAB]>)
 750         <COND (<AND <==? <NODE-TYPE .N> ,LVAL-CODE> <MEMQ <NODE-NAME .N> .B>>
 751                <>)
 752               (<MEMQ <NODE-TYPE .N> ,SNODES> T)
 753               (<AND <==? <NODE-TYPE .N> ,COND-CODE>
 754                     <NOT <NO-INTERFERE <PREDIC .N> .B>>>
 755                <>)
 756               (ELSE
 757                <MAPF <>
 758                      <FUNCTION (N)
 759                              #DECL ((N) NODE)
 760                              <COND (<NO-INTERFERE .N .B> T)
 761                                    (ELSE <MAPLEAVE <>>)>>
 762                      <KIDS .N>>)>>
 763
 764 \\f
 765
 766 <DEFINE NOTIMP (ARG) <COMPILE-ERROR "NOT IMPLEMENTED MAPF/R TUPLES">>
 767
 768 <DEFINE MENTROPY (SYM) T>
 769
 770 <DEFINE MBIND-GENERATE (SYM "AUX" (COD <CODE-SYM .SYM>))
 771         #DECL ((SYM) SYMTAB (COD) FIX)
 772         <CASE ,==?
 773               .COD
 774               (,ARGL-ACT <ACT-B .SYM>)
 775               (,ARGL-IAUX <AUX1-B .SYM T>)
 776               (,ARGL-AUX <AUX2-B .SYM T>)
 777               (,ARGL-TUPLE <NOTIMP .SYM>)
 778               (,ARGL-ARGS <MENTROPY .SYM>)
 779               (,ARGL-QIOPT <AUX1-B .SYM T>)
 780               (,ARGL-IOPT <AUX1-B .SYM T>)
 781               (,ARGL-QOPT <AUX2-B .SYM T>)
 782               (,ARGL-OPT <AUX2-B .SYM T>)
 783               (,ARGL-CALL <MENTROPY .SYM>)
 784               (,ARGL-BIND <BIND-B .SYM>)
 785               (,ARGL-QUOTE <MENTROPY .SYM>)
 786               (,ARGL-ARG <MENTROPY .SYM>)>>
 787
 788 <DEFINE MAPLEAVE-GEN (N W
 789                       "AUX" (FAP <1 <KIDS .MNOD>>) (TMP <GEN-TEMP <>>)
 790                             (BR .BR) (DIR .DIR) RT (FRAME? <ASSIGNED? LEAVE?>)
 791                             FOK TRUE-OK)
 792         #DECL ((MNOD FAP N) NODE (TMP) TEMP)
 793         <SET FOK <TYPE-AND <SET RT <RESULT-TYPE <SET N <1 <KIDS .N>>>>> FALSE>>
 794         <SET TRUE-OK <N==? <ISTYPE? .RT> FALSE>>
 795         <COND (<==? .MWHERE FLUSHED>
 796                <COND (.BR
 797                       <COND (<AND .FOK .TRUE-OK>
 798                              <PRED-BRANCH-GEN .BR .N .DIR>)
 799                             (ELSE
 800                              <GEN .N FLUSHED>
 801                              <COND (<COND (.FOK <NOT .DIR>) (ELSE .DIR)>
 802                                     <BRANCH-TAG .BR>)>)>)
 803                      (ELSE
 804                       <GEN .N FLUSHED>)>)
 805               (ELSE
 806                <COND (<AND .F? <==? .MWHERE .FTMP> <NOT .FRAME?>>
 807                       <SET-TEMP .TMP .FTMP>)
 808                      (ELSE <SET TMP .FTMP>)>
 809                <SET MWHERE <GEN .N .MWHERE>>
 810                <DEALLOCATE-TEMP .MWHERE>)>
 811         <COND (.FRAME? <SET-TEMP .LEAVE? 2>)
 812               (ELSE
 813                <REM-TUPS>
 814                <MAP-UNBIND .TMP .F? .BNDTMP .SPECD>
 815                <COND (<N==? .TMP .FTMP> <FREE-TEMP .TMP>)>
 816                <BRANCH-TAG .EXIT>)>
 817         ,NO-DATUM>
 818
 819 <DEFINE MAP-UNBIND (EXTMP F? BNDTMP SPECD)
 820         <COND (.F?
 821                <IEMIT `SUB 0 .EXTMP = .EXTMP '(`TYPE FIX)>
 822                <IEMIT `MUL .EXTMP 2 = .EXTMP '(`TYPE FIX)>
 823                <IEMIT `ADJ .EXTMP>)>
 824         <COND (.SPECD <IEMIT `UNBIND .BNDTMP>)>
 825         T>
 826
 827 \\f
 828
 829 <DEFINE MAPRET-STOP-GEN (N W
 830                          "AUX" (SG <SEGS .N>) (K <KIDS .N>) (LN <LENGTH .K>)
 831                                (FAP <1 <KIDS .MNOD>>) DAT FTG
 832                                (FF? <==? <NODE-TYPE .FAP> ,MFIRST-CODE>)
 833                                (LEAVE <==? <NODE-SUBR .N> ,MAPSTOP>)
 834                                (EXTMP .EXTMP) (FTMP .FTMP) (F? .F?)
 835                                (MAYBE-FALSE .MAYBE-FALSE) SEGTMP
 836                                (FRAME? <ASSIGNED? LEAVE?>)
 837                                (SEGLABEL <MAKE-TAG>) (COUNTMP .FTMP)
 838                                (SEGCALLED <>))
 839    #DECL ((N MNOD) NODE (K) <LIST [REST NODE]> (LN) FIX
 840           (SEGCALLED SEGLABEL COUNTMP) <SPECIAL ANY>)
 841    <COND
 842     (<AND <NOT .SG> <L? .LN 2>>
 843      <COND (<NOT <0? .LN>>
 844             <SET DAT <GEN <1 .K>>>
 845             <COND (.FF?
 846                    <REM-TUPS>
 847                    <DO-FUNNY-HACK .DAT <1 .K> .FAP .INRAP .FTMP .EXTMP>)
 848                   (.F?
 849                    <COND (.FRAME?
 850                           <PUSH .DAT>
 851                           <IEMIT `RTUPLE 1 <FREE-TEMP <CURRENT-FRAME> <>>>)
 852                          (ELSE
 853                           <REM-TUPS>
 854                           <PUSH .DAT>
 855                           <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>)>
 856                    <FREE-TEMP .DAT>)>)
 857            (ELSE <REM-TUPS>)>)
 858     (.FF? <DO-FUNNY-MAPRET .N .K .FAP> <REM-TUPS>)
 859     (ELSE
 860      <COND (.FRAME? <SET FTMP <GEN-TEMP>> <IEMIT `SET .FTMP 0>)>
 861      <MAPF <>
 862       <FUNCTION (NOD "AUX" TG STYP N TT RES)
 863          #DECL ((NOD) NODE)
 864          <COND
 865           (<==? <NODE-TYPE .NOD> ,SEGMENT-CODE>
 866            <COND (<NOT <ASSIGNED? SEGTMP>> <SET SEGTMP <GEN-TEMP <>>>)>
 867            <SET RES <GEN <SET N <1 <KIDS .NOD>>> .SEGTMP>>
 868            <COND (.MAYBE-FALSE <GEN-TYPE? .EXTMP FALSE <SET TG <MAKE-TAG>> T>)>
 869            <COND (<N==? .RES ,NO-DATUM>
 870                   <SEGMENT-STACK
 871                    .SEGTMP
 872                    .FTMP
 873                    <SET STYP <STRUCTYP <RESULT-TYPE .N>>>
 874                    <ISTYPE? <RESULT-TYPE .N>>
 875                    .SEGLABEL>)
 876                  (.SEGCALLED <LABEL-TAG .SEGLABEL>)>
 877            <SET SEGLABEL <MAKE-TAG>>
 878            <COND (.MAYBE-FALSE
 879                   <BRANCH-TAG <SET FTG <MAKE-TAG>>>
 880                   <LABEL-TAG .TG>
 881                   <COND (.STYP <EMPTY-CHECK .STYP .SEGTMP .STYP T .FTG>)
 882                         (ELSE <IEMIT `EMPTY? .SEGTMP + .FTG>)>
 883                   <STACKM .N .SEGTMP <> <> .FTMP <> <>>
 884                   <LABEL-TAG .FTG>)>)
 885           (ELSE
 886            <COND (.MAYBE-FALSE
 887                   <SET TT <GEN .NOD>>
 888                   <GEN-TYPE? .EXTMP FALSE <SET TG <MAKE-TAG>> T>
 889                   <PUSH .TT>
 890                   <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>
 891                   <BRANCH-TAG <SET FTG <MAKE-TAG>>>
 892                   <LABEL-TAG .TG>
 893                   <SET-TEMP .FTMP .TT>
 894                   <LABEL-TAG .FTG>
 895                   <FREE-TEMP .TT>)
 896                  (ELSE
 897                   <GEN .NOD ,POP-STACK>
 898                   <IEMIT `ADD .FTMP 1 = .FTMP '(`TYPE FIX)>)>)>>
 899       .K>
 900      <COND (.FRAME?
 901             <COND (.LEAVE <SET-TEMP .LEAVE? 1>)>
 902             <IEMIT `RTUPLE .FTMP <FREE-TEMP <CURRENT-FRAME> <>>>)>)>
 903    <COND (<NOT .FRAME?>
 904           <BRANCH-TAG <COND (.LEAVE .APPLTAG) (ELSE .REST-TAG)>>)>
 905    ,NO-DATUM>
 906
 907 \\f
 908
 909 <DEFINE DO-FUNNY-MAPRET (N K FAP "AUX" SEGTMP SEGLABEL COUNTMP TGX (SEGCALLED <>))
 910    #DECL ((N FAP) NODE (K) <LIST [REST NODE]>
 911           (SEGLABEL COUNTMP SEGCALLED) <SPECIAL ANY>)
 912    <MAPF <>
 913     <FUNCTION (NN "AUX" TG1 TG2 DAT STYP TMPX TEM)
 914             #DECL ((NN) NODE (TG1 TG2) ATOM)
 915             <COND (<OR <==? <NODE-TYPE .NN> ,SEG-CODE>
 916                        <==? <NODE-TYPE .NN> ,SEGMENT-CODE>>
 917                    <SET COUNTMP <GEN-TEMP>>
 918                    <SET SEGLABEL <MAKE-TAG>>
 919                    <SET TEM <GEN <SET NN <1 <KIDS .NN>>>>>
 920                    <COND (<AND <TYPE? .TEM TEMP> <L=? <TEMP-REFS .TEM> 1>>
 921                           <SET SEGTMP .TEM>)
 922                          (<N==? .TEM ,NO-DATUM>
 923                           <COND (<NOT <ASSIGNED? SEGTMP>>
 924                                  <SET SEGTMP <GEN-TEMP <>>>)>
 925                           <SET-TEMP .SEGTMP .TEM>
 926                           <FREE-TEMP .TEM>)>
 927                    <SET TG2 <MAKE-TAG>>
 928                    <COND (<N==? .TEM ,NO-DATUM>
 929                           <SET STYP <STRUCTYP <RESULT-TYPE .NN>>>
 930                           <COND (<==? .STYP LIST>
 931                                  <IEMIT `LOOP (<TEMP-NAME .SEGTMP> VALUE)>)
 932                                 (ELSE
 933                                  <IEMIT `LOOP (<TEMP-NAME .SEGTMP>
 934                                                VALUE LENGTH)>)>
 935                           <LABEL-TAG <SET TG1 <MAKE-TAG>>>
 936                           <IEMIT `INTGO>
 937                           <SET TMPX <GEN-TEMP>>
 938                           <COND (.STYP
 939                                  <EMPTY-CHECK .STYP .SEGTMP .STYP T .TG2>
 940                                  <NTH-DO .STYP .SEGTMP .TMPX 1>)
 941                                 (ELSE
 942                                  <IEMIT `EMPTY? .SEGTMP + .TG2>
 943                                  <IEMIT `NTH1 .SEGTMP = .TMPX>)>
 944                           <DO-FUNNY-HACK .TMPX .MNOD .FAP .NN .FTMP .EXTMP>
 945                           <COND (.STYP <REST-DO .STYP .SEGTMP .SEGTMP 1>)
 946                                 (ELSE <IEMIT `REST1 .SEGTMP = .SEGTMP>)>
 947                           <BRANCH-TAG .TG1>)>
 948                    <COND (.SEGCALLED
 949                           <SET TMPX <GEN-TEMP>>
 950                           <LABEL-TAG .SEGLABEL>
 951                           <IEMIT `LOOP>
 952                           <LABEL-TAG <SET TGX <MAKE-TAG>>>
 953                           <IEMIT `VEQUAL? .COUNTMP 0 + .TG2>
 954                           <POP .TMPX>
 955                           <DO-FUNNY-HACK .TMPX .MNOD .FAP .NN .FTMP .EXTMP>
 956                           <IEMIT `SUB .COUNTMP 1 = .COUNTMP>
 957                           <BRANCH-TAG .TGX>
 958                           <LABEL-TAG .TG2>
 959                           <FREE-TEMP .COUNTMP>
 960                           <FREE-TEMP .TMPX>)
 961                          (<N==? .TEM ,NO-DATUM>
 962                           <LABEL-TAG .TG2>)>)
 963                   (ELSE
 964                    <SET DAT <GEN .NN DONT-CARE>>
 965                    <DO-FUNNY-HACK .DAT .MNOD .FAP .NN .FTMP .EXTMP>)>>
 966     .K>>
 967
 968 <DEFINE AP? (N "AUX" AT)
 969         #DECL ((N) NODE)
 970         <AND <==? <NODE-TYPE .N> ,GVAL-CODE>
 971              <==? <NODE-TYPE <SET N <1 <KIDS .N>>>> ,QUOTE-CODE>
 972              <SET AT <NODE-NAME .N>>
 973              <OR .REASONABLE
 974                  <AND <GASSIGNED? .AT> <TYPE? ,.AT MSUBR>>
 975                  <AND <GASSIGNED? .AT>
 976                       <TYPE? ,.AT FUNCTION>
 977                       <OR <==? .AT .FCNS>
 978                           <AND <TYPE? .FCNS LIST> <MEMQ .AT .FCNS>>>>>
 979              .AT>>
 980
 981 <ENDPACKAGE>