mim/development/mim/mimc/pass1.mud

   1
   2 <PACKAGE "PASS1">
   3
   4 <ENTRY PASS1
   5        PCOMP
   6        PMACRO
   7        PAPPLY-OBJECT
   8        PAPPLY-TYPE
   9        PTHIS-OBJECT
  10        PTHIS-TYPE
  11        GEN-D
  12        ACT-FIX
  13        FIND_DECL
  14        SEG?
  15        PSUBR-C>
  16
  17 <RENTRY REFERENCED>
  18
  19 <USE "GC-DUMP" "CHKDCL" "COMPDEC" "MIMGEN" "ADVMESS" "CDRIVE">
  20
  21 "       This file contains the first pass of the MUDDLE compiler.
  22 The functions therein take a MUDDLE function and build a more detailed
  23 model of it.  Each entity in the function is represented by an object
  24 of type NODE.  The entire function is represented by the functions node
  25 and it points to the rest of the nodes for the function."
  26
  27 "       Nodes vary in complexity and size depending on what they represent.
  28 A function or prog/repeat node is contains more information than a node
  29 for a quoted object.  All nodes have some fields in common to allow
  30 general programs to traverse the model."
  31
  32 "       The model built by PASS1 is used by the analyzer (SYMANA), the
  33 variable allocator (VARANA) and the code generator (CODGEN).  In some
  34 cases the analyzers and generators for certain classes of SUBRs are
  35 together in their own files (e.g.  CARITH, STRUCT, ISTRUC)."
  36
  37 "       This the top level program for PASS1.  It takes a function as
  38 input and returns the data structure representing the model."
  39
  40 <COND (<NOT ,MIM> <SETG PMAX ,NUMPRI!-MUDDLE>)>
  41
  42 <SETG MAX-DENSE 2>
  43
  44 <NEWTYPE ORQ LIST>
  45
  46 <COND (<NOT ,MIM> <FLOAD "PRCOD.NBIN">)>
  47
  48 <DEFINE PASS1 (FNAME FUNC
  49                "AUX" RESULT (VARTBL ,LVARTBL) (DCL #DECL ()) (ARGL ())
  50                      (HATOM <>) (TT ()) (FCN .FUNC) TEM (RQRG 0) (TRG 0))
  51         #DECL ((FUNC) FUNCTION (VARTBL) <SPECIAL SYMTAB> (FNAME) <SPECIAL ATOM>
  52                (FCN) <PRIMTYPE LIST> (ARGL TT) LIST (RESULT) <SPECIAL NODE>
  53                (RQRG TRG) <SPECIAL FIX>)
  54         <COND (<EMPTY? .FCN> <COMPILE-ERROR "Empty function:  " .FNAME>)>
  55         <COND (<TYPE? <1 .FCN> ATOM ADECL>
  56                <SET HATOM <1 .FCN>>
  57                <SET FCN <REST .FCN>>)>
  58         <COND (<EMPTY? .FCN> <COMPILE-ERROR "Empty function:  " .FNAME>)>
  59         <SET ARGL <1 .FCN>>
  60         <SET FCN <REST .FCN>>
  61         <COND (<AND <NOT <EMPTY? .FCN>> <TYPE? <1 .FCN> DECL>>
  62                <SET DCL <1 .FCN>>
  63                <SET FCN <REST .FCN>>)>
  64         <COND (<EMPTY? .FCN> <COMPILE-ERROR "Function has no body:  " .FNAME>)>
  65         <SET RESULT
  66              <NODEF ,FUNCTION-CODE () <FIND_DECL VALUE .DCL> .FNAME ()
  67                     () () .HATOM .VARTBL 0 0>>
  68         <GEN-D .ARGL .DCL .HATOM .RESULT>
  69         <PUTPROP .FNAME .IND .RESULT>
  70         <PUT .RESULT
  71              ,RSUBR-DECLS
  72              ("VALUE" <RESULT-TYPE .RESULT> !<RSUBR-DECLS .RESULT>)>
  73         <PUT .RESULT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .RESULT>> .FCN>>
  74         <ACT-FIX .RESULT <BINDING-STRUCTURE .RESULT>>
  75         <PUTPROP .FNAME .IND>
  76         <PUTPROP .FNAME RSUB-DEC <RSUBR-DECLS .RESULT>>
  77         .RESULT>
  78
  79 "Vector of legal strings in decl list."
  80
  81 <SETG TOT-MODES
  82       ["BIND"
  83        "CALL"
  84        "OPT"
  85        "OPTIONAL"
  86        "ARGS"
  87        "TUPLE"
  88        "AUX"
  89        "EXTRA"
  90        "ACT"
  91        "NAME"
  92        "DECL"
  93        "VALUE"]>
  94
  95 <PROG ((N <LENGTH ,TOT-MODES>))
  96       <MAPF <>
  97             <FUNCTION (S "AUX" (ATM <PARSE <STRING "ACODE-" .S>>))
  98                     <SETG .ATM .N>
  99                     <MANIFEST .ATM>
 100                     <SET N <- .N 1>>>
 101             ,TOT-MODES>
 102       <SET N <+ <LENGTH ,TOT-MODES> 1>>
 103       <MAPF <>
 104             <FUNCTION (ATM) <SETG .ATM .N> <MANIFEST .ATM> <SET N <+ .N 1>>>
 105             '[ACODE-INIT ACODE-INIT1 ACODE-ERR ACODE-NORM]>>
 106
 107 "Amount to rest off decl vector after each encounter."
 108
 109 <SETG RESTS ![1 1 1 2 1 2 1 2 1 2 1 1]>
 110
 111 "       This function (and others on this page) take an arg list and
 112 decls and parses them.
 113
 114         1) An RSUBR decl list.
 115
 116         2) A machine readable binding specification.
 117
 118 Atoms are also entered into the symbol table."
 119
 120 <DEFINE GEN-D (ARGL DCL HATOM FCNNOD
 121                "AUX" (SVTBL .VARTBL) (RES_TOP (())) (RES_BOT .RES_TOP) (ARGN 1)
 122                      (BNDL_TOP (())) (BNDL_BOT .BNDL_TOP) TIX VIX
 123                      (MODE ,TOT-MODES) (ST <>) T T1 SVT (IX ,ACODE-INIT))
 124         #DECL ((BNDL_BOT RES_BOT) <SPECIAL LIST> (BNDL_TOP RES_TOP) LIST
 125                (ARGN) <SPECIAL FIX> (VIX) <VECTOR [REST STRING]>
 126                (MODE) <SPECIAL <VECTOR [REST STRING]>> (IX) <SPECIAL FIX>
 127                (ARGL) LIST (SVTBL SVT) SYMTAB (DCL) <SPECIAL <PRIMTYPE LIST>>)
 128         <REPEAT ()
 129                 <COND (<EMPTY? .ARGL> <RETURN>)>
 130                 <COND (<TYPE? <SET T <1 .ARGL>> ATOM FORM LIST ADECL>
 131                        <SET ST <>>
 132                        <RUN-ARGER .IX .T .FCNNOD>)
 133                       (<TYPE? .T STRING>
 134                        <COND (.ST
 135                               <COMPILE-ERROR "Two arg list strings in a row:  "
 136                                              .ST
 137                                              .T>)>
 138                        <SET ST .T>
 139                        <COND (<NOT <SET TIX <MEMBER .T .MODE>>>
 140                               <COMPILE-ERROR "Unrecognized arg list string:  "
 141                                              .T>)>
 142                        <SET VIX .TIX>
 143                        <SET MODE
 144                             <REST .MODE <NTH ,RESTS <SET IX <LENGTH .VIX>>>>>
 145                        <COND (<NOT <OR <L? .IX 7> <G? .IX 11>>>
 146                               <PUT-RES (<COND (<=? <1 .ARGL> "OPT"> "OPTIONAL")
 147                                               (ELSE <1 .ARGL>)>)>)>)
 148                       (ELSE
 149                        <COMPILE-ERROR "Unknown type of object in arglist "
 150                                       .T>)>
 151                 <SET ARGL <REST .ARGL>>>
 152         <COND (.HATOM <ACT-D .HATOM>)>
 153         <REPEAT (DC DC1)
 154                 #DECL ((DC1) FORM (DC) ANY (VARTBL) <SPECIAL SYMTAB>)
 155                 <COND (<EMPTY? .DCL> <RETURN>)
 156                       (<EMPTY? <REST .DCL>>
 157                        <COMPILE-ERROR "DECL in bad format (no DECL for):  "
 158                                       <1 .DCL>>)>
 159                 <SET DC <2 .DCL>>
 160                 <COND (<AND <TYPE? .DC FORM>
 161                             <SET DC1 .DC>
 162                             <==? <LENGTH .DC1> 2>
 163                             <OR <==? <1 .DC1> SPECIAL>
 164                                 <==? <1 .DC1> UNSPECIAL>>>
 165                        <SET DC <2 .DC1>>)>
 166                 <MAPF <>
 167                       <FUNCTION (ATM)
 168                               <COND (<NOT <OR <==? .ATM VALUE>
 169                                               <SRCH-SYM .ATM>>>
 170                                      <ADDVAR .ATM T -1 0 T .DC <> <>>)>>
 171                       <CHTYPE <1 .DCL> LIST>>
 172                 <SET DCL <REST .DCL 2>>>
 173         <SET SVT .VARTBL>
 174         <SET VARTBL .SVTBL>
 175         <COND (<N==? .SVTBL .SVT>
 176                <REPEAT ((SV .SVT))
 177                        #DECL ((SV) SYMTAB)
 178                        <COND (<==? <NEXT-SYM .SV> .SVTBL>
 179                               <PUT .SV ,NEXT-SYM .VARTBL>
 180                               <SET VARTBL .SVT>
 181                               <RETURN>)
 182                              (ELSE <SET SV <NEXT-SYM .SV>>)>>)>
 183         <AND <L? <SET TRG <- .ARGN 1>> 0> <SET RQRG -1>>
 184         <PUT .FCNNOD ,BINDING-STRUCTURE <REST .BNDL_TOP>>
 185         <COND (<==? <NODE-TYPE .FCNNOD> ,FUNCTION-CODE>
 186                <PUT <PUT <PUT .FCNNOD ,REQARGS .RQRG> ,TOTARGS .TRG>
 187                     ,RSUBR-DECLS
 188                     <REST .RES_TOP>>)>
 189         <PUT .FCNNOD ,SYMTAB .VARTBL>>
 190
 191 "RUN-ARGER dispatches to different arg handlers"
 192
 193 <DEFINE RUN-ARGER (INDX ARG N)
 194         #DECL ((INDX) FIX)
 195         <CASE ,==?
 196               .INDX
 197               (,ACODE-BIND <BIND-D .ARG>)
 198               (,ACODE-CALL <CALL-D .ARG>)
 199               (,ACODE-OPT <OPT-D .ARG>)
 200               (,ACODE-OPTIONAL <OPT-D .ARG>)
 201               (,ACODE-ARGS <ARGS-D .ARG>)
 202               (,ACODE-TUPLE <TUPL-D .ARG>)
 203               (,ACODE-AUX <AUX-D .ARG>)
 204               (,ACODE-EXTRA <AUX-D .ARG>)
 205               (,ACODE-ACT <ACT-D .ARG>)
 206               (,ACODE-NAME <ACT-D .ARG>)
 207               (,ACODE-INIT <INIT-D .ARG>)
 208               (,ACODE-INIT1 <INIT1-D .ARG>)
 209               (,ACODE-NORM <NORM-D .ARG>)
 210               (,ACODE-DECL <DECL-D .ARG>)
 211               (,ACODE-VALUE <VDECL-D .ARG .N>)
 212               (,ACODE-ERR <ERR-D .ARG>)>>
 213
 214 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
 215         #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
 216         <REPEAT ()
 217                 <COND (<EMPTY? .TB> <RETURN <>>)>
 218                 <COND (<==? .ATM <NAME-SYM .TB>> <RETURN .TB>)>
 219                 <SET TB <NEXT-SYM .TB>>>>
 220
 221 "This function used for normal args when \"BIND\" and \"CALL\" still possible."
 222
 223 <DEFINE INIT-D (OBJ)
 224         #DECL ((MODE) <VECTOR STRING>)
 225         <SET MODE <REST .MODE>>
 226         <INIT1-D .OBJ>>
 227
 228 "This function for normal args when \"CALL\" still possible."
 229
 230 <DEFINE INIT1-D (OBJ)
 231         #DECL ((MODE) <VECTOR STRING>)
 232         <SET MODE <REST .MODE>>
 233         <SET IX ,ACODE-NORM>
 234         <NORM-D .OBJ>>
 235
 236 "Handle a normal argument or quoted normal argument."
 237
 238 <DEFINE NORM-D (OBJ "OPTIONAL" DC "AUX" DC1)
 239         #DECL ((RQRG ARGN) FIX (DCL) DECL)
 240         <COND (<TYPE? .OBJ LIST>
 241                <COMPILE-ERROR "LIST not in OPT(IONAL) or AUX:  " .OBJ>)>
 242         <COND (<TYPE? .OBJ ATOM>
 243                <PUT-RES (<PUT-DCL ,ARGL-ARG
 244                                   .OBJ
 245                                   <>
 246                                   <COND (<ASSIGNED? DC> .DC)
 247                                         (ELSE <FIND_DECL .OBJ .DCL>)>
 248                                   T>)>)
 249               (<TYPE? .OBJ ADECL>
 250                <COND (<N==? <LENGTH .OBJ> 2>
 251                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 252                <NORM-D <1 .OBJ> <2 .OBJ>>)
 253               (<SET OBJ <QUOTCH .OBJ>>
 254                <COND (<TYPE? .OBJ ADECL>
 255                       <COND (<N==? <LENGTH .OBJ> 2>
 256                              <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 257                       <SET DC1 <2 .OBJ>>
 258                       <SET OBJ <1 .OBJ>>)>
 259                <PUT-RES ("QUOTE"
 260                          <PUT-DCL ,ARGL-QUOTE
 261                                   .OBJ
 262                                   <>
 263                                   <COND (<ASSIGNED? DC> .DC)
 264                                         (<ASSIGNED? DC1> .DC1)
 265                                         (ELSE <FIND_DECL .OBJ .DCL>)>
 266                                   T>)>)>
 267         <COND (<NOT <ASSIGNED? DC>>
 268                <SET ARGN <+ .ARGN 1>>
 269                <SET RQRG <+ .RQRG 1>>)>>
 270
 271 "Handle \"BIND\" decl."
 272
 273 <DEFINE BIND-D (OBJ "AUX" DC)
 274         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 275         <COND (<TYPE? .OBJ ADECL>
 276                <COND (<N==? <LENGTH .OBJ> 2>
 277                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 278                <SET OBJ <1 .OBJ>>
 279                <SET DC <2 .OBJ>>)>
 280         <COND (<NOT <TYPE? .OBJ ATOM>>
 281                <COMPILE-ERROR "Bad object after \"BIND\":  " .OBJ>)>
 282         <SET DC
 283              <PUT-DCL ,ARGL-BIND
 284                       .OBJ
 285                       <>
 286                       <COND (<ASSIGNED? DC> .DC) (ELSE <FIND_DECL .OBJ .DCL>)>
 287                       T>>
 288         <TYPE-ATOM-OK? .DC FRAME .OBJ>
 289         <SET IX ,ACODE-INIT1>>
 290
 291 "Handle \"CALL\" decl."
 292
 293 <DEFINE CALL-D (OBJ "AUX" DC)
 294         #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
 295         <SET RQRG <+ .RQRG 1>>
 296         <COND (<TYPE? .OBJ ADECL>
 297                <COND (<N==? <LENGTH .OBJ> 2>
 298                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 299                <SET DC <2 .OBJ>>
 300                <SET OBJ <1 .OBJ>>)>
 301         <COND (<NOT <TYPE? .OBJ ATOM>>
 302                <COMPILE-ERROR "Bad object after \"CALL\":  " .OBJ>)>
 303         <PUT-RES (<SET DC
 304                        <PUT-DCL ,ARGL-CALL
 305                                 .OBJ
 306                                 <>
 307                                 <COND (<ASSIGNED? DC> .DC)
 308                                       (ELSE <FIND_DECL .OBJ .DCL>)>
 309                                 T>>)>
 310         <TYPE-ATOM-OK? .DC FORM .OBJ>
 311         <SET ARGN <+ .ARGN 1>>
 312         <SET IX ,ACODE-ERR>>
 313
 314 "Flush on extra atoms after \"CALL\", \"ARGS\" etc."
 315
 316 <DEFINE ERR-D (OBJ) <COMPILE-ERROR "Bad DECL syntax:  " .OBJ>>
 317
 318 "Handle \"OPTIONAL\" decl."
 319
 320 <DEFINE OPT-D (OBJ "AUX" DC OBJ1)
 321         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 322         <COND (<TYPE? .OBJ ADECL>
 323                <COND (<N==? <LENGTH .OBJ> 2>
 324                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 325                <SET DC <2 .OBJ>>
 326                <SET OBJ <1 .OBJ>>)>
 327         <COND (<TYPE? .OBJ ATOM>
 328                <PUT-RES (<PUT-DCL ,ARGL-OPT
 329                                   .OBJ
 330                                   <>
 331                                   <COND (<ASSIGNED? DC> .DC)
 332                                         (ELSE <FIND_DECL .OBJ .DCL>)>
 333                                   <>>)>)
 334               (<TYPE? .OBJ FORM>
 335                <SET OBJ <QUOTCH .OBJ>>
 336                <COND (<TYPE? .OBJ ADECL>
 337                       <COND (<N==? <LENGTH .OBJ> 2>
 338                              <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 339                       <SET DC <2 .OBJ>>
 340                       <SET OBJ <1 .OBJ>>)>
 341                <PUT-RES ("QUOTE"
 342                          <PUT-DCL ,ARGL-QOPT
 343                                   .OBJ
 344                                   <>
 345                                   <COND (<ASSIGNED? DC> .DC)
 346                                         (ELSE <FIND_DECL .OBJ .DCL>)>
 347                                   <>>)>)
 348               (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM ADECL>
 349                <COND (<TYPE? .OBJ1 ADECL>
 350                       <COND (<N==? <LENGTH .OBJ1> 2>
 351                              <COMPILE-ERROR "Bad ADECL:  " .OBJ1>)>
 352                       <SET DC <2 .OBJ1>>
 353                       <SET OBJ1 <1 .OBJ1>>)>
 354                <PUT-RES (<PAUX .OBJ1
 355                                <2 <CHTYPE .OBJ LIST>>
 356                                <COND (<ASSIGNED? DC> .DC)
 357                                      (ELSE <FIND_DECL .OBJ1 .DCL>)>
 358                                ,ARGL-IOPT>)>)
 359               (<TYPE? .OBJ1 FORM>
 360                <SET OBJ1 <QUOTCH .OBJ1>>
 361                <COND (<TYPE? .OBJ1 ADECL>
 362                       <COND (<N==? <LENGTH .OBJ1> 2>
 363                              <COMPILE-ERROR "Bad ADECL:  " .OBJ1>)>
 364                       <SET DC <2 .OBJ1>>
 365                       <SET OBJ1 <1 .OBJ1>>)>
 366                <PUT-RES ("QUOTE"
 367                          <PAUX .OBJ1
 368                                <2 <CHTYPE .OBJ LIST>>
 369                                <COND (<ASSIGNED? DC> .DC)
 370                                      (ELSE <FIND_DECL .OBJ1 .DCL>)>
 371                                ,ARGL-QIOPT>)>)
 372               (ELSE <COMPILE-ERROR "Bad use of \"OPT(IONAL)\":  " .OBJ>)>
 373         <SET ARGN <+ .ARGN 1>>>
 374
 375 "Handle \"ARGS\" decl."
 376
 377 <DEFINE ARGS-D (OBJ "AUX" DC)
 378         #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL (BNDL_BOT) <LIST SYMTAB>)
 379         <COND (<TYPE? .OBJ ADECL>
 380                <COND (<N==? <LENGTH .OBJ> 2>
 381                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 382                <SET DC <2 .OBJ>>
 383                <SET OBJ <1 .OBJ>>)>
 384         <COND (<NOT <TYPE? .OBJ ATOM>>
 385                <COMPILE-ERROR "Bad use of \"ARGS\":  " .OBJ>)>
 386         <PUT-RES (<SET DC
 387                        <PUT-DCL ,ARGL-ARGS
 388                                 .OBJ
 389                                 <>
 390                                 <COND (<ASSIGNED? DC> .DC)
 391                                       (ELSE <FIND_DECL .OBJ .DCL>)>
 392                                 <>>>)>
 393         <TYPE-ATOM-OK? .DC LIST .OBJ>
 394         <SET IX ,ACODE-ERR>
 395         <SET ARGN <+ .ARGN 1>>>
 396
 397 "Handle \"TUPLE\" decl."
 398
 399 <DEFINE TUPL-D (OBJ "AUX" DC)
 400         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 401         <COND (<TYPE? .OBJ ADECL>
 402                <COND (<N==? <LENGTH .OBJ> 2>
 403                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 404                <SET DC <2 .OBJ>>
 405                <SET OBJ <1 .OBJ>>)>
 406         <COND (<NOT <TYPE? .OBJ ATOM>>
 407                <COMPILE-ERROR "Bad use of \"TUPLE\":  " .OBJ>)>
 408         <PUT-RES (<SET DC
 409                        <PUT-DCL ,ARGL-TUPLE
 410                                 .OBJ
 411                                 <>
 412                                 <COND (<ASSIGNED? DC> .DC)
 413                                       (ELSE <FIND_DECL .OBJ .DCL>)>
 414                                 <>>>)>
 415         <TYPE-ATOM-OK? .DC TUPLE .OBJ>
 416         <SET IX ,ACODE-ERR>>
 417
 418 "Handle \"AUX\" decl."
 419
 420 <DEFINE AUX-D (OBJ "AUX" DC OBJ1)
 421         #DECL ((ARGN) FIX (DCL) DECL)
 422         <COND (<TYPE? .OBJ ADECL>
 423                <COND (<N==? <LENGTH .OBJ> 2>
 424                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 425                <SET DC <2 .OBJ>>
 426                <SET OBJ <1 .OBJ>>)>
 427         <COND (<TYPE? .OBJ ATOM>
 428                <PUT-DCL ,ARGL-AUX
 429                         .OBJ
 430                         <>
 431                         <COND (<ASSIGNED? DC> .DC)
 432                               (ELSE <FIND_DECL .OBJ .DCL>)>
 433                         <>>)
 434               (<AND <TYPE? .OBJ LIST> <TYPE? <SET OBJ1 <LISTCH .OBJ>> ADECL ATOM>>
 435                <COND (<TYPE? .OBJ1 ADECL>
 436                       <COND (<N==? <LENGTH .OBJ1> 2>
 437                              <COMPILE-ERROR "Bad ADECL:  " .OBJ1>)>
 438                       <SET DC <2 .OBJ1>>
 439                       <SET OBJ1 <1 .OBJ1>>)>
 440                <PAUX .OBJ1
 441                      <2 .OBJ>
 442                      <COND (<ASSIGNED? DC> .DC) (ELSE <FIND_DECL .OBJ1 .DCL>)>
 443                      ,ARGL-IAUX>)
 444               (ELSE <COMPILE-ERROR "Bad usage of \"AUX\" :  " .OBJ>)>>
 445
 446 "Handle \"NAME\" and \"ACT\" decl."
 447
 448 <DEFINE ACT-D (OBJ "AUX" DC)
 449         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 450         <COND (<TYPE? .OBJ ADECL>
 451                <COND (<N==? <LENGTH .OBJ> 2>
 452                       <COMPILE-ERROR "Bad ADECL:  " .OBJ>)>
 453                <SET DC <2 .OBJ>>
 454                <SET OBJ <1 .OBJ>>)>
 455         <COND (<NOT <TYPE? .OBJ ATOM>>
 456                <COMPILE-ERROR "Bad use of \"ACT\":  " .OBJ>)>
 457         <SET DC
 458              <PUT-DCL ,ARGL-ACT
 459                       .OBJ
 460                       <>
 461                       <COND (<ASSIGNED? DC> .DC) (ELSE <FIND_DECL .OBJ .DCL>)>
 462                       <>>>
 463         <TYPE-ATOM-OK? .DC FRAME .OBJ>>
 464
 465 "Fixup activation atoms after node generated."
 466
 467 <DEFINE ACT-FIX (N L "AUX" (FLG <>))
 468         #DECL ((N) NODE (L) <LIST [REST SYMTAB]>)
 469         <REPEAT (SYM)
 470                 #DECL ((SYM) SYMTAB)
 471                 <COND (<EMPTY? .L> <RETURN .FLG>)>
 472                 <COND (<AND <==? <CODE-SYM <SET SYM <1 .L>>> ,ARGL-ACT>
 473                             <SET FLG T>
 474                             <NOT <SPEC-SYM .SYM>>>
 475                        <PUT .SYM ,RET-AGAIN-ONLY .N>)>
 476                 <SET L <REST .L>>>>
 477
 478 <DEFINE DECL-D (ARG)
 479         <COND (<TYPE? .ARG ADECL>
 480                <COND (<NOT <SRCH-SYM <1 .ARG>>>
 481                       <ADDVAR <1 .ARG> T -1 0 T <2 .ARG> <> <>>)>)
 482               (ELSE
 483                <COMPILE-ERROR "DECL in bad format (no DECL for):  " .ARG>)>>
 484
 485 <DEFINE VDECL-D (ARG N)
 486         #DECL ((N) NODE)
 487         <PUT .N ,RESULT-TYPE .ARG>
 488         <PUT .N ,INIT-DECL-TYPE .ARG>>
 489
 490 <GDECL (TOT-MODES) <VECTOR [REST STRING]> (RESTS) <UVECTOR [REST FIX]>>
 491
 492 "Check for quoted arguments."
 493
 494 <DEFINE QUOTCH (OB)
 495         #DECL ((OB) FORM (VALUE) <OR ATOM ADECL>)
 496         <COND (<AND <==? <LENGTH .OB> 2>
 497                     <==? <1 .OB> QUOTE>
 498                     <TYPE? <2 .OB> ATOM ADECL>>
 499                <2 .OB>)
 500               (ELSE <COMPILE-ERROR "Bad form in argument list" .OB> T)>>
 501
 502 "Chech for (arg init) or ('arg init)."
 503
 504 <DEFINE LISTCH (OB)
 505         #DECL ((OB) LIST)
 506         <COND (<AND <==? <LENGTH .OB> 2>
 507                     <OR <TYPE? <1 .OB> ATOM ADECL>
 508                         <AND <TYPE? <1 .OB> FORM> <QUOTCH <1 .OB>>>>>
 509                <1 .OB>)
 510               (ELSE <COMPILE-ERROR "Bad list in arg list:  " .OB> T)>>
 511
 512 "Add a decl to RSUBR decls and update AC call spec."
 513
 514 <DEFINE PUT-RES (L)
 515         #DECL ((L) LIST (RES_BOT) LIST)
 516         <SET RES_BOT <REST <PUTREST .RES_BOT .L> <LENGTH .L>>>
 517         T>
 518
 519 "Add code to set up a certain kind of argument."
 520
 521 <DEFINE PUT-DCL (COD ATM VAL DC COM "AUX" SPC DC1 TT SYM)
 522         #DECL ((DC1) FORM (ATM) ATOM (BNDL_BOT BNDL_TOP TT) LIST (COD) FIX
 523                (SYM) SYMTAB)
 524         <COND (<AND <TYPE? .DC FORM>
 525                     <SET DC1 .DC>
 526                     <==? <LENGTH .DC1> 2>
 527                     <OR <SET SPC <==? <1 .DC1> SPECIAL>>
 528                         <==? <1 .DC1> UNSPECIAL>>>
 529                <SET DC <2 .DC1>>)
 530               (ELSE <SET SPC .GLOSP>)>
 531         <SET SYM <ADDVAR .ATM .SPC .COD .ARGN T .DC <> .VAL>>
 532         <SET BNDL_BOT <REST <PUTREST .BNDL_BOT (.SYM)>>>
 533         .DC>
 534
 535 "Find decl associated with a variable, if none, use ANY."
 536
 537 <DEFINE FIND_DECL (ATM "OPTIONAL" (DC .DECLS))
 538         #DECL ((DC) <PRIMTYPE LIST> (ATM) ATOM)
 539         <REPEAT (TT)
 540                 #DECL ((TT) LIST)
 541                 <COND (<OR <EMPTY? .DC> <EMPTY? <SET TT <REST .DC>>>>
 542                        <RETURN ANY>)>
 543                 <COND (<NOT <TYPE? <1 .DC> LIST>>
 544                        <COMPILE-ERROR "Malformed DECL:  " .DC>)>
 545                 <COND (<MEMQ .ATM <CHTYPE <1 .DC> LIST>> <RETURN <1 .TT>>)>
 546                 <SET DC <REST .TT>>>>
 547
 548 "Add an AUX variable spec to structure."
 549
 550 <SETG OBJ-BUILDERS
 551       '[VECTOR UVECTOR STRING BYTES ISTRING IBYTES IVECTOR IUVECTOR]>
 552
 553 <GDECL (OBJ-BUILDERS) <VECTOR [REST ATOM]>>
 554
 555 <DEFINE PAUX (ATM OBJ DC NTUP "AUX" EV TT AP OBJ2 AP2)
 556         #DECL ((EV TT) NODE (TUP NTUP) FIX (ATM) ATOM)
 557         <COND (<PROG ((OBJ .OBJ))
 558                  <AND <TYPE? .OBJ FORM>
 559                       <NOT <EMPTY? .OBJ>>
 560                       <COND (<OR <AND <==? <SET AP <1 .OBJ>> STACK>
 561                                       <==? <LENGTH .OBJ> 2>
 562                                       <OR <AND <TYPE? <SET OBJ2 <2 .OBJ>> FORM>
 563                                                <NOT <EMPTY? .OBJ2>>
 564                                                <MEMQ <1 .OBJ2> ,OBJ-BUILDERS>>
 565                                           <TYPE? .OBJ2 VECTOR UVECTOR>>>
 566                                  <AND <==? .AP CHTYPE>
 567                                       <==? <LENGTH .OBJ> 3>
 568                                       <TYPE? <SET OBJ2 <2 .OBJ>> FORM>
 569                                       <==? <LENGTH .OBJ2> 2>
 570                                       <==? <1 .OBJ2> STACK>
 571                                       <OR <AND <TYPE? <SET OBJ2 <2 .OBJ2>> FORM>
 572                                                <NOT <EMPTY? .OBJ2>>
 573                                                <MEMQ <1 .OBJ2> ,OBJ-BUILDERS>>
 574                                           <TYPE? .OBJ2 VECTOR UVECTOR>>
 575                                       <SET OBJ2 <CHTYPE (CHTYPE .OBJ2 <3 .OBJ>)
 576                                                         FORM>>>>
 577                              <SET TT <NODEFM ,STACK-CODE () <> STACK () STACK>>
 578                              <PUT .TT ,KIDS (<PCOMP .OBJ2 .TT>)>)
 579                             (<==? .AP TUPLE>
 580                              <SET TT
 581                                   <NODEFM ,COPY-CODE
 582                                           ()
 583                                           TUPLE
 584                                           .AP
 585                                           ()
 586                                           .AP>>
 587                              <PUT .TT
 588                                   ,KIDS
 589                                   <MAPF ,LIST
 590                                         <FUNCTION (O) <PCOMP .O .TT>>
 591                                         <REST .OBJ>>>)
 592                             (<==? .AP ITUPLE>
 593                              <PROG ((PARENT ()))
 594                                    #DECL ((PARENT) <SPECIAL ANY>)
 595                                    <SET TT
 596                                         <PSTRUC .OBJ ITUPLE ITUPLE TUPLE>>>)
 597                             (<AND <TYPE? .AP ATOM>
 598                                   <GASSIGNED? .AP>
 599                                   <TYPE? ,.AP MACRO>>
 600                              <SET OBJ <EXPAND .OBJ>>
 601                              <AGAIN>)>>>)
 602               (ELSE <SET TT <PCOMP .OBJ ()>>)>
 603         <PUT-DCL .NTUP .ATM .TT .DC <>>>
 604
 605 "Main dispatch function during pass1."
 606
 607 <DEFINE PCOMP (OBJ PARENT)
 608         #DECL ((PARENT) <SPECIAL ANY> (VALUE) NODE)
 609         <APPLY <OR <GETPROP .OBJ PTHIS-OBJECT>
 610                    <GETPROP <TYPE .OBJ> PTHIS-TYPE>
 611                    ,PDEFAULT>
 612                .OBJ>>
 613
 614 "Build a node for <> or #FALSE ()."
 615
 616 <DEFINE FALSE-QT (O)
 617         #DECL ((VALUE) NODE)
 618         <NODE1 ,QUOTE-CODE .PARENT BOOL-FALSE <> ()>>
 619
 620 <COND (<GASSIGNED? FALSE-QT> <PUTPROP '<> PTHIS-OBJECT ,FALSE-QT>)>
 621
 622 "Build a node for ()."
 623
 624 <DEFINE NIL-QT (O) #DECL ((VALUE) NODE) <NODE1 ,QUOTE-CODE .PARENT LIST () ()>>
 625
 626 <COND (<GASSIGNED? NIL-QT> <PUTPROP () PTHIS-OBJECT ,NIL-QT>)>
 627
 628 "Build a node for a LIST, VECTOR or UVECTOR."
 629
 630 <DEFINE PCOPY (OBJ
 631                "AUX" (TT
 632                       <NODEFM ,COPY-CODE
 633                               .PARENT
 634                               <TYPE .OBJ>
 635                               <TYPE .OBJ>
 636                               ()
 637                               <>>))
 638         #DECL ((VALUE) NODE (TT) NODE)
 639         <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>>
 640
 641 <COND (<GASSIGNED? PCOPY>
 642        <PUTPROP VECTOR PTHIS-TYPE ,PCOPY>
 643        <PUTPROP UVECTOR PTHIS-TYPE ,PCOPY>
 644        <PUTPROP LIST PTHIS-TYPE ,PCOPY>)>
 645
 646 "Build a node for unknown things."
 647
 648 <DEFINE PDEFAULT (OBJ)
 649         #DECL ((VALUE) NODE)
 650         <NODE1 ,QUOTE-CODE .PARENT <TYPE .OBJ> .OBJ ()>>
 651
 652 "Further analyze a FORM and build appropriate node."
 653
 654 <DEFINE PFORM (OBJ)
 655         #DECL ((OBJ) <FORM ANY> (VALUE) NODE)
 656         <PROG APPLICATION ((APPLY <1 .OBJ>))
 657               #DECL ((APPLICATION) <SPECIAL ANY> (APPLY) <SPECIAL ANY>)
 658               <APPLY <OR <GETPROP .APPLY PAPPLY-OBJECT>
 659                          <AND <GETPROP .APPLY ANALYSIS> ,PSUBR-C>
 660                          <GETPROP <TYPE .APPLY> PAPPLY-TYPE>
 661                          ,PAPDEF>
 662                      .OBJ
 663                      .APPLY>>>
 664
 665 <COND (<GASSIGNED? PFORM> <PUTPROP FORM PTHIS-TYPE ,PFORM>)>
 666
 667 "Build a SEGMENT node."
 668
 669 <DEFINE SEG-FCN (OBJ "AUX" (TT <NODE1 ,SEGMENT-CODE .PARENT <> <> ()>))
 670         #DECL ((TT VALUE PARENT) NODE)
 671         <PROG ((PARENT .TT)) #DECL ((PARENT) <SPECIAL NODE>)
 672               <PUT .TT ,KIDS (<PFORM <CHTYPE .OBJ FORM>>)>>>
 673
 674 <COND (<GASSIGNED? SEG-FCN> <PUTPROP SEGMENT PTHIS-TYPE ,SEG-FCN>)>
 675
 676 "Analyze a form or the form <ATM .....>"
 677
 678 <DEFINE ATOM-FCN (OB AP:ATOM "AUX" L:<PRIMTYPE LIST>)
 679         #DECL ((AP) ATOM (VALUE) NODE)
 680         <COND (<GASSIGNED? .AP> <SET APPLY ,.AP> <AGAIN .APPLICATION>)
 681               (.REASONABLE
 682                <COND (<NOT <GASSIGNED? REFERENCED>>
 683                       <SETG REFERENCED (.AP 1)>)
 684                      (<NOT <SET L <MEMQ .AP ,REFERENCED:LIST>>>
 685                       <SETG REFERENCED (.AP 1 !,REFERENCED)>)
 686                      (T
 687                       <2 .L <+ <2 .L>:FIX 1>>)>
 688                <PSUBR-C .OB DUMMY>)
 689               (ELSE
 690                <COMPILE-WARNING "No value for:  " .AP " using EVAL">
 691                <PAPDEF .OB .AP>)>>
 692
 693 <COND (<GASSIGNED? ATOM-FCN> <PUTPROP ATOM PAPPLY-TYPE ,ATOM-FCN>)>
 694
 695 "Expand MACRO and process result."
 696
 697 <NEWTYPE FUNNY VECTOR>
 698
 699 <DEFINE PMACRO (OBJ AP "AUX" ERR TEM)
 700         <ON <SET ERR <HANDLER "ERROR" ,MACROERR 100>>>     ;"Turn On new Error"
 701         <SET TEM
 702              <PROG MACACT ()
 703                    #DECL ((MACACT) <SPECIAL ANY>)
 704                    <SETG ERR .ERR>
 705                    <SETG MACACT .MACACT>
 706                    <EXPAND .OBJ>>>
 707         <OFF .ERR>                                        ;"Turn OFF new Error"
 708         <COND (<TYPE? .TEM FUNNY>
 709                <COMPILE-ERROR "ERROR during macro expansion" ,CR !.TEM>)
 710               (ELSE <PCOMP .TEM .PARENT>)>>
 711
 712 <COND (<GASSIGNED? PMACRO> <PUTPROP MACRO PAPPLY-TYPE ,PMACRO>)>
 713
 714 <DEFINE MACROERR (IGN FR "TUPLE" T)
 715         #DECL ((T) TUPLE)
 716         <COND (<AND <NOT <EMPTY? .T>> <==? <1 .T> CONTROL-G!-ERRORS>>
 717                <INT-LEVEL 0>
 718                <OFF ,ERR>
 719                <ERROR !.T>
 720                <ON ,ERR>
 721                <ERRET T .FR>)
 722               (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
 723                <DISMISS <CHTYPE [!.T] FUNNY> ,MACACT>)
 724               (ELSE
 725                <OFF ,ERR>
 726                <ERROR INTERNAL-COMPILER-LOSSAGE!-ERRORS>)>>
 727
 728 "Build a node for a form whose 1st element is a form (could be NTH)."
 729
 730 <DEFINE PFORM-FORM (OBJ AP "AUX" TT)
 731         #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
 732         <COND (<AND <==? <LENGTH .OBJ> 2> <NOT <SEG? .OBJ>>>
 733                <SET TT <NODEFM ,FORM-F-CODE .PARENT <> .OBJ () .AP>>
 734                <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>)
 735               (ELSE <PAPDEF .OBJ .AP>)>>
 736
 737 <COND (<GASSIGNED? PFORM-FORM> <PUTPROP FORM PAPPLY-TYPE ,PFORM-FORM>)>
 738
 739 "Build a node for strange forms."
 740
 741 <DEFINE PAPDEF (OBJ AP)
 742         #DECL ((VALUE) NODE)
 743         <COMPILE-WARNING "Form not being compiled:  " .OBJ>
 744         <SPECIALIZE .OBJ>
 745         <NODEFM ,FORM-CODE .PARENT <> .OBJ () .AP>>
 746
 747 "For objects that require EVAL, make sure all atoms used are special."
 748
 749 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
 750         #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
 751         <COND (<AND <TYPE? .OBJ FORM SEGMENT>
 752                     <SET OB <CHTYPE .OBJ FORM>>
 753                     <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
 754                              <==? <1 .OB> LVAL>
 755                              <TYPE? <SET SYM <2 .OB>> ATOM>>
 756                         <AND <==? .T1 3>
 757                              <==? <1 .OB> SET>
 758                              <TYPE? <SET SYM <2 .OB>> ATOM>>>
 759                     <SET T2 <SRCH-SYM .SYM>>>
 760                <COND (<NOT <SPEC-SYM .T2>>
 761                       <COMPILE-NOTE "Redclared special:  " .SYM>
 762                       <PUT .T2 ,SPEC-SYM T>)>)>
 763         <COND (<MEMQ <PRIMTYPE .OBJ> '[FORM LIST UVECTOR VECTOR]>
 764                <MAPF <> ,SPECIALIZE .OBJ>)>>
 765
 766 "Build a MSUBR call node."
 767
 768 <DEFINE PSUBR-C (OBJ AP
 769                  "AUX" (TT
 770                         <NODEFM ,SUBR-CODE
 771                                 .PARENT
 772                                 <>
 773                                 <COND (<TYPE? .AP MSUBR> <2 .AP>)
 774                                       (ELSE <1 .OBJ>)>
 775                                 ()
 776                                 .AP>))
 777         #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
 778         <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ>>>>
 779
 780 <DEFINE LVAL-FCN (OBJ "AUX" (TT <NODEFM ,SUBR-CODE .PARENT <> LVAL () ,LVAL>))
 781         #DECL ((TT VALUE) NODE)
 782         <PUT .TT ,KIDS (<PCOMP <CHTYPE .OBJ ATOM> .TT>)>>
 783
 784 <DEFINE GVAL-FCN (OBJ "AUX" (TT <NODEFM ,SUBR-CODE .PARENT <> GVAL () ,GVAL>))
 785         #DECL ((TT VALUE) NODE)
 786         <PUT .TT ,KIDS (<PCOMP <CHTYPE .OBJ ATOM> .TT>)>>
 787
 788 <COND (<GASSIGNED? LVAL-FCN>
 789        <PUTPROP LVAL PTHIS-TYPE ,LVAL-FCN>
 790        <PUTPROP GVAL PTHIS-TYPE ,GVAL-FCN>)>
 791
 792 <DEFINE FIX-FCN (OBJ AP "AUX" TT (LN <LENGTH .OBJ>))
 793         #DECL ((TT VALUE) NODE (OBJ) FORM)
 794         <COND (<NOT <OR <==? .LN 2> <==? .LN 3>>>
 795                <COMPILE-ERROR
 796 "Number (FIX) applied to other than 2 or 3 args:  "
 797                               .OBJ>)>
 798         <SET TT
 799              <NODEFM ,SUBR-CODE
 800                      .PARENT
 801                      <>
 802                      <COND (<==? .LN 2> INTH) (ELSE IPUT)>
 803                      ()
 804                      <COND (<==? .LN 2> ,NTH) (ELSE ,PUT)>>>
 805         <PUT .TT
 806              ,KIDS
 807              (<PCOMP <2 .OBJ> .TT>
 808               <PCOMP .AP .TT>
 809               !<COND (<==? .LN 2> ()) (ELSE (<PCOMP <3 .OBJ> .TT>))>)>>
 810
 811 <COND (<GASSIGNED? FIX-FCN>
 812        <PUTPROP FIX PAPPLY-TYPE ,FIX-FCN>
 813        <PUTPROP OFFSET PAPPLY-TYPE ,FIX-FCN>)>
 814
 815 "PROG/REPEAT node."
 816
 817 <DEFINE PPROG-REPEAT (OBJ AP
 818                       "AUX" (NAME <1 .OBJ>) TT (DCL #DECL ()) (HATOM <>) ARGL
 819                             (VARTBL .VARTBL)
 820                             (IN-IFSYS <COND (<ASSIGNED? IN-IFSYS> .IN-IFSYS)>))
 821         #DECL ((OBJ) <PRIMTYPE LIST> (TT) NODE (VALUE) NODE (DCL) DECL
 822                (ARGL) LIST (VARTBL) <SPECIAL SYMTAB> (IN-IFSYS) <SPECIAL ANY>)
 823         <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
 824                <COMPILE-ERROR "Empty " .NAME " " .OBJ>)>
 825         <COND (<TYPE? <1 .OBJ> ATOM ADECL>
 826                <SET HATOM <1 .OBJ>>
 827                <SET OBJ <REST .OBJ>>)>
 828         <SET ARGL <1 .OBJ>>
 829         <SET OBJ <REST .OBJ>>
 830         <COND (<AND <NOT <EMPTY? .OBJ>> <TYPE? <1 .OBJ> DECL>>
 831                <SET DCL <1 .OBJ>>
 832                <SET OBJ <REST .OBJ>>)>
 833         <COND (<EMPTY? .OBJ> <COMPILE-ERROR "Empty body for " .NAME .OBJ>)>
 834         <SET TT
 835              <NODEPR ,PROG-CODE
 836                      .PARENT
 837                      <FIND_DECL VALUE .DCL>
 838                      .NAME
 839                      ()
 840                      .AP
 841                      ()
 842                      .HATOM
 843                      .VARTBL>>
 844         <GEN-D <COND (<AND <NOT <EMPTY? .ARGL>> <TYPE? <1 .ARGL> STRING>>
 845                       .ARGL)
 846                      (ELSE ("AUX" !.ARGL))>
 847                .DCL
 848                .HATOM
 849                .TT>
 850         <ACT-FIX .TT <BINDING-STRUCTURE .TT>>
 851         <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>
 852         .TT>
 853
 854 <COND (<GASSIGNED? PPROG-REPEAT>
 855        <PUTPROP ,PROG PAPPLY-OBJECT ,PPROG-REPEAT>
 856        <PUTPROP ,REPEAT PAPPLY-OBJECT ,PPROG-REPEAT>
 857        <PUTPROP ,BIND PAPPLY-OBJECT ,PPROG-REPEAT>)>
 858
 859 "Unwind compiler."
 860
 861 <DEFINE UNWIND-FCN (OBJ AP
 862                     "AUX" (TT
 863                            <NODEFM ,UNWIND-CODE .PARENT <> <1 .OBJ> () .AP>))
 864         #DECL ((PARENT VALUE TT) NODE (OBJ) FORM)
 865         <COND (<==? <LENGTH .OBJ> 3>
 866                <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> <PCOMP <3 .OBJ> .TT>)>)
 867               (ELSE <COMPILE-ERROR "Wrong number of args to UNIWND: " .OBJ>)>>
 868
 869 <COND (<AND <GASSIGNED? UNWIND-FCN> <GASSIGNED? UNWIND>>
 870        <PUTPROP ,UNWIND PAPPLY-OBJECT ,UNWIND-FCN>)>
 871
 872 "Build a node for a COND."
 873
 874 <DEFINE COND-FCN (OBJ AP
 875                   "AUX" (PARENT <NODECOND ,COND-CODE .PARENT <> COND ()>))
 876    #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
 877    <PUT .PARENT
 878         ,KIDS
 879         <MAPF ,LIST
 880               <FUNCTION (CLA "AUX" (TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>))
 881                       #DECL ((TT) NODE)
 882                       <COND (<AND <TYPE? .CLA LIST> <NOT <EMPTY? .CLA>>>
 883                              <PUT .TT ,PREDIC <PCOMP <1 .CLA> .TT>>
 884                              <PUT .TT
 885                                   ,CLAUSES
 886                                   <MAPF ,LIST
 887                                         <FUNCTION (O) <PCOMP .O .TT>>
 888                                         <REST .CLA>>>)
 889                             (ELSE
 890                              <COMPILE-ERROR
 891 "COND clause not a LIST or empty:  "
 892                                             .OBJ>)>>
 893               <REST .OBJ>>>>
 894
 895 <COND (<GASSIGNED? COND-FCN>
 896        <PUTPROP ,COND PAPPLY-OBJECT ,COND-FCN>
 897        <PUTPROP ,AND PAPPLY-OBJECT ,PSUBR-C>
 898        <PUTPROP ,OR PAPPLY-OBJECT ,PSUBR-C>)>
 899
 900 "Build a node for '<\b-object>\b-."
 901
 902 <DEFINE QUOTE-FCN (OBJ AP "AUX" (TT <NODE1 ,QUOTE-CODE .PARENT <> () ()>))
 903         #DECL ((TT VALUE) NODE (OBJ) FORM)
 904         <COND (<NOT <EMPTY? <REST .OBJ>>>
 905                <PUT .TT ,RESULT-TYPE <COND (<==? <2 .OBJ> #FALSE()>
 906                                             BOOL-FALSE)
 907                                            (ELSE <TYPE <2 .OBJ>>)>>
 908                <PUT .TT ,NODE-NAME <2 .OBJ>>)>>
 909
 910 <COND (<GASSIGNED? QUOTE-FCN> <PUTPROP ,QUOTE PAPPLY-OBJECT ,QUOTE-FCN>)>
 911
 912 "Build a node for a call to an RSUBR."
 913
 914 <DEFINE RSUBR-FCN (OBJ AP
 915                    "AUX" (PARENT
 916                           <NODEFM ,RSUBR-CODE .PARENT <> <1 .OBJ> () .AP>))
 917         #DECL ((OBJ) FORM (AP) MSUBR (PARENT) <SPECIAL NODE>
 918                (VALUE) NODE)
 919         <COND (<AND <G? <LENGTH .AP> 2> <TYPE? <3 .AP> DECL LIST>>
 920                <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <3 .AP>>>
 921                <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL <3 .AP>>>)
 922               (ELSE <PSUBR-C .OBJ .AP>)>>
 923
 924 <COND (<GASSIGNED? RSUBR-FCN> <PUTPROP MSUBR PAPPLY-TYPE ,RSUBR-FCN>)>
 925
 926 <DEFINE SANITIZE-DECL (DCL:LIST "AUX" (OPT <>) (TUPF <>))
 927         <COND (<=? <1 .DCL> "VALUE"> <SET DCL <REST .DCL 2>>)>
 928         <MAPF ,LIST <FUNCTION (EL)
 929                          <COND (<OR <=? .EL "QUOTE"> <=? .EL "ARGS">> <MAPRET>)
 930                                (<OR <=? .EL "OPT"> <=? .EL "OPTIONAL">>
 931                                 <SET OPT T>
 932                                 <MAPRET>)
 933                                (<=? .EL "TUPLE"> <SET TUPF T> <MAPRET>)>
 934                          <COND (.TUPF (TUPLE .EL))
 935                                (.OPT (OPTIONAL .EL))
 936                                (ELSE (NORMAL .EL))>>
 937               .DCL>>
 938
 939 "Predicate:  any segments in this object?"
 940
 941 <DEFINE SEG? (OB)
 942         #DECL ((OB) <PRIMTYPE LIST>)
 943         <REPEAT ()
 944                 <COND (<EMPTY? .OB> <RETURN <>>)>
 945                 <COND (<TYPE? <1 .OB> SEGMENT> <RETURN T>)>
 946                 <SET OB <REST .OB>>>>
 947
 948 "Analyze a call to an MSUBR with decls checking number of args and types wherever
 949  possible."
 950
 951 <DEFINE PRSUBR-C RSB
 952                  (NAME OBJ RDCL
 953                   "AUX" (DOIT ,INIT-R) (SEGSW <>) (SGD '<>) (SGP '(1)) SGN
 954                         (IX 0) DC (RM ,RMODES) (ARG-NUMBER 0) (KDS (()))
 955                         (TKDS .KDS) RMT (OB <REST .OBJ>) (ST <>) (ODC "FOO"))
 956    #DECL ((TKDS KDS) <SPECIAL LIST> (OB) LIST (OBJ) <SPECIAL <PRIMTYPE LIST>>
 957           (RM) <SPECIAL <VECTOR [REST STRING]>> (ARG-NUMBER) FIX
 958           (RDCL) <SPECIAL <PRIMTYPE LIST>> (DOIT SEGSW) <SPECIAL ANY> (IX) FIX
 959           (RSB NAME) <SPECIAL ANY> (SGD) FORM (SGP) <LIST ANY> (SGN) NODE)
 960    <REPEAT ()
 961      <COND
 962       (<NOT <EMPTY? .RDCL>>
 963        <COND (<NOT <EMPTY? .RM>> <SET DC <1 .RDCL>> <SET RDCL <REST .RDCL>>)>
 964        <COND
 965         (<TYPE? .DC STRING>
 966          <COND (<=? .DC "OPT"> <SET DC "OPTIONAL">)>
 967          <COND (<NOT <SET RMT <MEMBER .DC .RM>>>
 968                 <COMPILE-ERROR "Unknown string in MSUBR decl: "
 969                                .DC
 970                                " "
 971                                .NAME>)>
 972          <SET RM .RMT>
 973          <SET DOIT <NTH ,RDOIT <SET IX <LENGTH .RM>>>>
 974          <SET ST <APPLY <NTH ,SDOIT .IX> .ST .DC .ODC>>
 975          <SET ODC .DC>
 976          <COND (<EMPTY? .RM>                                     ;"TUPLE seen."
 977                 <SET DC <GET-ELE-TYPE <1 .RDCL> ALL>>)>)
 978         (<COND
 979           (<EMPTY? .OB>
 980            <AND <L? <LENGTH .RM> 4> <RETURN <REST .TKDS>>>
 981            <COMPILE-ERROR "Too few arguments to:  " .NAME " " .OBJ>)
 982           (.SEGSW
 983            <SET ST <>>
 984            <COND (<EMPTY? .RM>
 985                   <PUTREST .SGP ([REST .DC])>
 986                   <PUT .SGN ,RESULT-TYPE <TYPE-AND <RESULT-TYPE .SGN> .SGD>>
 987                   <RETURN <REST .TKDS>>)
 988                  (ELSE <SET SGP <REST <PUTREST .SGP (.DC)>>>)>)
 989           (<TYPE? <1 .OB> SEGMENT>
 990            <SET KDS <REST <PUTREST .KDS (<SET SGN <SEGCHK <1 .OB>>>)>>>
 991            <COND
 992             (<EMPTY? <REST .OB>>
 993              <COND (<EMPTY? .RM>
 994                     <PUT .SGN
 995                          ,RESULT-TYPE
 996                          <SEGCH1 .DC <RESULT-TYPE .SGN> <1 .OB>>>
 997                     <RETURN <REST .TKDS>>)
 998                    (ELSE <SET SEGSW T>)>)
 999             (ELSE
1000              <PUTREST
1001               .KDS
1002               <MAPF ,LIST
1003                <FUNCTION (O "AUX" TT)
1004                   <SET TT <PCOMP .O .PARENT>>
1005                   <COND
1006                    (<EMPTY? .RM>
1007                     <COND
1008                      (<==? <NODE-TYPE .TT> ,SEGMENT-CODE>
1009                       <COND
1010                        (<NOT <TYPE-OK? <RESULT-TYPE <1 <KIDS .TT>>>
1011                                        <FORM '<OR MULTI STRUCTURED> [REST .DC]>>>
1012                         <COMPILE-ERROR "Argument wrong type to:  "
1013                                        .NAME
1014                                        .OB>)>)
1015                      (ELSE
1016                       <COND (<NOT <TYPE-OK? <RESULT-TYPE .TT> .DC>>
1017                              <COMPILE-ERROR "Argument wrong type to:  "
1018                                             .NAME
1019                                             .OB>)>
1020                       <COND (<NOT <RESULT-TYPE .TT>>
1021                              <PUT .TT ,RESULT-TYPE .DC>)>)>)>
1022                   .TT>
1023                <REST .OB>>>
1024              <RETURN <REST .TKDS>>)>
1025            <SET SGP <REST <CHTYPE <SET SGD <FORM STRUCTURED .DC>> LIST>>>
1026            <SET ST <>>
1027            <AGAIN>)
1028           (<SET KDS <REST <PUTREST .KDS (<APPLY .DOIT .DC .OB>)>>>
1029            <SET OB <REST .OB>>
1030            <SET ARG-NUMBER <+ .ARG-NUMBER 1>>
1031            <SET ST <>>)>)>)
1032       (<EMPTY? .OB> <RETURN <REST .TKDS>>)
1033       (.SEGSW
1034        <PUT .SGN
1035             ,RESULT-TYPE
1036             <COND (<RESULT-TYPE .SGN> <TYPE-AND <RESULT-TYPE .SGN> .SGD>)
1037                   (ELSE .SGD)>>
1038        <RETURN <REST .TKDS>>)
1039       (<MAPF <>
1040              <FUNCTION (X) <COND (<NOT <TYPE? .X SEGMENT>> <MAPLEAVE <>>)> T>
1041              .OB>
1042        <SET KDS <REST <PUTREST .KDS (<SET SGN <SEGCHK <1 .OB>>>)>>>
1043        <RETURN <REST .TKDS>>)
1044       (ELSE <COMPILE-ERROR "Too many arguments too: " .NAME " " .OBJ>)>>>
1045
1046 <DEFINE SQUOT (F S1 S2) T>
1047
1048 "Flush one possible decl away."
1049
1050 <DEFINE CHOPPER (F S1 S2)
1051         #DECL ((RM) <VECTOR [REST STRING]>)
1052         <COND (.F
1053                <COMPILE-ERROR "Two DECL strings in a row in:  " .S1 " " .S2>)>
1054         <SET RM <REST .RM>>
1055         T>
1056
1057 "Handle Normal arg when \"VALUE\" still possible."
1058
1059 <DEFINE INIT-R (DC OB)
1060         #DECL ((RM) <VECTOR [REST STRING]>)
1061         <SET RM <REST .RM 2>>
1062         <SET DOIT ,INIT1-R>
1063         <INIT1-R .DC .OB>>
1064
1065 "Handle Normal arg when \"CALL\" still possible."
1066
1067 <DEFINE INIT2-R (DC OB)
1068         #DECL ((RM) <VECTOR [REST STRING]>)
1069         <SET RM <REST .RM>>
1070         <SET DOIT ,INIT1-R>
1071         <INIT1-R .DC .OB>>
1072
1073 "Handle normal arg."
1074
1075 <DEFINE INIT1-R (DC OB "AUX" TT)
1076         #DECL ((TT) NODE (OB) LIST)
1077         <COND (<NOT <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP <1 .OB> .PARENT>>>
1078                               .DC>>
1079                <COMPILE-ERROR "Argument wrong type to:  " .NAME " " <1 .OB>>)>
1080         <COND (<NOT <RESULT-TYPE .TT>> <PUT .TT ,RESULT-TYPE .DC>)>
1081         .TT>
1082
1083 "Handle \"QUOTE\" arg."
1084
1085 <DEFINE QINIT-R (DC OB "AUX" TT)
1086         #DECL ((TT) NODE (OB) LIST)
1087         <COND (<NOT <TYPE-OK?
1088                      <RESULT-TYPE <SET TT
1089                                        <NODE1 ,QUOTE-CODE
1090                                               .PARENT
1091                                               <TYPE <1 .OB>>
1092                                               <1 .OB>
1093                                               ()>>>
1094                      .DC>>
1095                <COMPILE-ERROR "Argument wrong type to:  " .NAME " " <1 .OB>>)>
1096         <SET DOIT ,INIT1-R>
1097         .TT>
1098
1099 "Handle \"CALL\" decl."
1100
1101 <DEFINE CAL-R (DC OB "AUX" TT)
1102         #DECL ((TKDS KDS) LIST (TT) NODE)
1103         <COND (<NOT <TYPE-OK?
1104                      <RESULT-TYPE <SET TT
1105                                        <NODE1 ,QUOTE-CODE
1106                                               .PARENT
1107                                               FORM
1108                                               .OBJ
1109                                               ()>>>
1110                      .DC>>
1111                <COMPILE-ERROR "Argument wrong type to:  " .NAME " " <1 .OB>>)>
1112         <PUTREST .KDS (.TT)>
1113         <RETURN <REST .TKDS> .RSB>>
1114
1115 "Handle \"ARGS\" decl."
1116
1117 <DEFINE ARGS-R (DC OB "AUX" TT)
1118         #DECL ((TT) NODE (KDS TKDS) LIST)
1119         <COND (<NOT <TYPE-OK?
1120                      <RESULT-TYPE <SET TT
1121                                        <NODE1 ,QUOTE-CODE
1122                                               .PARENT
1123                                               LIST
1124                                               .OB
1125                                               ()>>>
1126                      .DC>>
1127                <COMPILE-ERROR "Argument wrong type to:  " .NAME " " <1 .OB>>)>
1128         <PUTREST .KDS (.TT)>
1129         <RETURN <REST .TKDS> .RSB>>
1130
1131 "Handle \"TUPLE\" decl."
1132
1133 <DEFINE TUPL-R (DC OB "AUX" TT)
1134         #DECL ((OB) LIST (TT) NODE)
1135         <COND (<NOT <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP <1 .OB> .PARENT>>>
1136                               .DC>>
1137                <COMPILE-ERROR "Argument wrong type to:  " .NAME " " <1 .OB>>)>
1138         <COND (<NOT <RESULT-TYPE .TT>> <PUT .TT ,RESULT-TYPE .DC>)>
1139         .TT>
1140
1141 "Handle stuff with segments in arguments."
1142
1143 <DEFINE SEGCHK (OB "AUX" TT)
1144         #DECL ((TT) NODE)
1145         <COND (<NOT <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP .OB .PARENT>>>
1146                               '<OR MULTI STRUCTURED>>>
1147                <COMPILE-ERROR "Non-structured segment?  " .OB>)>
1148         .TT>
1149
1150 <DEFINE SEGCH1 (DC RT OB)
1151         <COND (<NOT <TYPE-AND .RT <FORM '<OR MULTI STRUCTURED> [REST .DC]>>>
1152                <COMPILE-ERROR "Argument wrong type to:  " .NAME " " .OB>)>>
1153
1154 "Handle \"VALUE\" chop decl and do the rest."
1155
1156 <DEFINE VAL-R (F S1 S2)
1157         #DECL ((RDCL) <PRIMTYPE LIST> (PARENT) NODE)
1158         <CHOPPER .F .S1 .S2>
1159         <PUT .PARENT ,RESULT-TYPE <1 .RDCL>>
1160         <SET DOIT ,INIT2-R>
1161         <SET F <TYPE? <1 .RDCL> STRING>>
1162         <SET RDCL <REST .RDCL>>
1163         .F>
1164
1165 <DEFINE ERR-R (DC OB)
1166         <COMPILE-LOSSAGE "Entered MSUBR application illegal state" .DC .OB>>
1167
1168 <SETG RMODES ["VALUE" "CALL" "QUOTE" "OPTIONAL" "QUOTE" "ARGS" "TUPLE"]>
1169
1170 <COND (<GASSIGNED? TUPL-R>
1171        <SETG RDOIT [,TUPL-R ,ARGS-R ,QINIT-R ,INIT1-R ,QINIT-R ,CAL-R ,ERR-R]>
1172        <SETG SDOIT
1173              [,CHOPPER ,CHOPPER ,SQUOT ,CHOPPER ,SQUOT ,CHOPPER ,VAL-R]>)>
1174
1175 <GDECL (RMODES) <VECTOR [REST STRING]> (RDOIT SDOIT) VECTOR>
1176
1177 "Create a node for a call to a function."
1178
1179 <DEFINE PFUNC (OB AP "AUX" TEM NAME)
1180         #DECL ((OB) <PRIMTYPE LIST> (VALUE) NODE)
1181         <COND (<TYPE? <1 .OB> ATOM>
1182                <COND (<==? <1 .OB> .FNAME> <RSUBR-CALL2 ,<1 .OB> <1 .OB> .OB>)
1183                      (<SET TEM <GETPROP <1 .OB> RSUB-DEC>>
1184                       <RSUBR-CALL3 .TEM <1 .OB> .OB>)
1185                      (.REASONABLE <PSUBR-C .OB DUMMY>)
1186                      (ELSE
1187                       <COMPILE-WARNING "Uncompiled function called:  "
1188                                         <1 .OB>>
1189                       <PAPDEF .OB ,<1 .OB>>)>)
1190               (<TYPE? <1 .OB> FUNCTION>
1191                <SET NAME <MAKE-TAG <STRING "ANONF" <SPNAME .FNAME>>>>
1192                <ANONF .NAME <1 .OB>>
1193                <RSUBR-CALL1 ,.NAME .NAME .OB>)>>
1194
1195 "Call compiler recursively to compile anonymous function."
1196
1197 <DEFINE ANONF (NAME BODY "AUX" (INT? <>) T GROUP-NAME)
1198         #DECL ((EXTRA-CODE) <LIST ANY> (VALUE) NODE)
1199         <COMPILE-NOTE "Compiling anonymous function">
1200         <SETG .NAME .BODY>
1201         <PUTREST .EXTRA-CODE <APPLY ,COMPILE .NAME>>
1202         <SET EXTRA-CODE <REST .EXTRA-CODE <- <LENGTH .EXTRA-CODE> 1>>>
1203         <GUNASSIGN .NAME>
1204         <COMPILE-NOTE "Finished anonymous function">
1205         <PCOMP <FORM GVAL .NAME> .PARENT>>
1206
1207 "#FUNCTION (....) compiler -- call ANONF."
1208
1209 <DEFINE FCN-FCN (OB "AUX" (NAME <MAKE-TAG <STRING "ANONF" <SPNAME .FNAME>>>))
1210         <ANONF .NAME .OB>>
1211
1212 <COND (<GASSIGNED? FCN-FCN>
1213        <PUTPROP FUNCTION PTHIS-TYPE ,FCN-FCN>
1214        <PUTPROP FUNCTION PAPPLY-TYPE ,PFUNC>)>
1215
1216 "<FUNCTION (..) ....> compiler -- call ANONF."
1217
1218 <DEFINE FCN-FCN1 (OB AP "AUX"
1219                         (NAME <MAKE-TAG <STRING "ANONF" <SPNAME .FNAME>>>))
1220         #DECL ((OB) <PRIMTYPE LIST>)
1221         <ANONF .NAME <CHTYPE <REST .OB> FUNCTION>>>
1222
1223 <COND (<GASSIGNED? FCN-FCN1> <PUTPROP ,FUNCTION PAPPLY-OBJECT ,FCN-FCN1>)>
1224
1225 "Handle RSUBR that is really a function."
1226
1227 <DEFINE RSUBR-CALL2 (BODY NAME OBJ
1228                      "AUX" ACF DCL
1229                            (PARENT
1230                             <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
1231         #DECL ((PARENT) <SPECIAL NODE> (VALUE) NODE)
1232         <PUT .PARENT
1233              ,KIDS
1234              <PRSUBR-C .NAME
1235                        .OBJ
1236                        <SET DCL <RSUBR-DECLS <SET ACF <GETPROP .NAME .IND>>>>>>
1237         <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL .DCL>>>
1238
1239 "Handle an RSUBR that is already an RSUBR."
1240
1241 <DEFINE RSUBR-CALL1 (BODY NAME OBJ
1242                      "AUX" (PARENT
1243                             <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
1244         #DECL ((BODY) <PRIMTYPE LIST> (PARENT) <SPECIAL NODE> (VALUE) NODE)
1245         <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ <3 .BODY>>>
1246         <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL <2 .BODY>>>>
1247
1248 <DEFINE RSUBR-CALL3 (DC NAME OBJ
1249                      "AUX" (PARENT
1250                             <NODEFM ,RSUBR-CODE .PARENT <> .NAME () FOO>))
1251         #DECL ((PARENT) <SPECIAL NODE> (VALUE) NODE)
1252         <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ .DC>>
1253         <PUT .PARENT ,TYPE-INFO <SANITIZE-DECL .DC>>>
1254
1255 ;"ILIST, ISTRING, IVECTOR AND IUVECTOR"
1256
1257 <DEFINE PLIST (O A) <PSTRUC .O .A ILIST LIST>>
1258
1259 <DEFINE PIVECTOR (O A) <PSTRUC .O .A IVECTOR VECTOR>>
1260
1261 <DEFINE PISTRING (O A) <PSTRUC .O .A ISTRING STRING>>
1262
1263 <DEFINE PIUVECTOR (O A) <PSTRUC .O .A IUVECTOR UVECTOR>>
1264
1265 <DEFINE PIFORM (O A) <PSTRUC .O .A IFORM FORM>>
1266
1267 <DEFINE PIBYTES (O A) <PSTRUC .O .A IBYTES BYTES>>
1268
1269 <COND (<GASSIGNED? PLIST>
1270        <PUTPROP ,ILIST PAPPLY-OBJECT ,PLIST>
1271        <PUTPROP ,IUVECTOR PAPPLY-OBJECT ,PIUVECTOR>
1272        <COND (<NOT ,MIM> <PUTPROP ,IFORM PAPPLY-OBJECT ,PIFORM>)>
1273        <PUTPROP ,IBYTES PAPPLY-OBJECT ,PIBYTES>
1274        <PUTPROP ,IVECTOR PAPPLY-OBJECT ,PIVECTOR>
1275        <PUTPROP ,ISTRING PAPPLY-OBJECT ,PISTRING>)>
1276
1277 <DEFINE PSTRUC (OBJ AP NAME TYP
1278                 "AUX" (TT <NODEFM ,ISTRUC-CODE .PARENT .TYP .NAME () ,.NAME>)
1279                       (LN <LENGTH .OBJ>) N EV SIZ)
1280         #DECL ((VALUE N EV TT) NODE (LN) FIX (OBJ) <PRIMTYPE LIST>)
1281         <COND (<SEG? .OBJ> <RSUBR-FCN .OBJ .AP>)
1282               (ELSE
1283                <COND (<==? .LN 1>
1284                       <COMPILE-ERROR "Too few args: " <1 .OBJ>>)
1285                      (<G? .LN 3> <COMPILE-ERROR "Too many args: "
1286                                                 <1 .OBJ>>)>
1287                <SET N <PCOMP <2 .OBJ> .TT>>
1288                <COND (<==? .LN 3>
1289                       <SET EV <PCOMP <3 .OBJ> .PARENT>>
1290                       <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1291                              <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1292                              <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>)
1293                      (ELSE <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
1294                <PUT .TT ,RESULT-TYPE .TYP>
1295                <COND (<ASSIGNED? EV> <PUT .TT ,KIDS (.N .EV)>)
1296                      (ELSE <PUT .TT ,KIDS (.N)>)>)>>
1297
1298 "READ, READCHR, READSTRING, NEXTCHR, READB, GET, GETL, GETPROP, GETPL"
1299
1300 <PUTPROP ,READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READ 2 ANY>>>
1301
1302 <COND (<NOT <GASSIGNED? READ-INTERNAL>> <SETG READ-INTERNAL (1)>)>
1303
1304 <PUTPROP ,READ-INTERNAL
1305          PAPPLY-OBJECT
1306          <FUNCTION (O A) <CHANFCNS .O .A READ-INTERNAL 2 ANY>>>
1307
1308 <COND (<GASSIGNED? GC-READ>
1309        <PUTPROP ,GC-READ
1310                 PAPPLY-OBJECT
1311                 <FUNCTION (O A) <CHANFCNS .O .A GC-READ 2 ANY>>>)>
1312
1313 <PUTPROP ,READCHR
1314          PAPPLY-OBJECT
1315          <FUNCTION (O A) <CHANFCNS .O .A READCHR 2 ANY>>>
1316
1317 <PUTPROP ,NEXTCHR
1318           PAPPLY-OBJECT
1319           <FUNCTION (O A) <CHANFCNS .O .A NEXTCHR 2 ANY>>>
1320
1321 <PUTPROP ,READB PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READB 4 ANY>>>
1322
1323 <PUTPROP ,READSTRING
1324          PAPPLY-OBJECT
1325          <FUNCTION (O A) <CHANFCNS .O .A READSTRING 4 ANY>>>
1326
1327 <DEFINE CHANFCNS (OBJ AP NAME ARGN TYP "AUX" TT (LN <LENGTH .OBJ>) N (TEM 0))
1328    #DECL ((VALUE) NODE (TT) NODE (N) <LIST [REST NODE]> (LN) FIX (TEM ARGN) FIX
1329           (OBJ) <PRIMTYPE LIST>)
1330    <COND
1331     (<OR <SEG? .OBJ> <L? <- .LN 1> .ARGN>> <RSUBR-FCN .OBJ .AP>)
1332     (ELSE
1333      <SET TT <NODEFM ,READ-EOF-CODE .PARENT .TYP .NAME () ,.NAME>>
1334      <SET N
1335       <MAPF ,LIST
1336             <FUNCTION (OB "AUX" (EV <PCOMP .OB .TT>))
1337                     #DECL ((EV) NODE)
1338                     <COND (<==? <SET TEM <+ .TEM 1>> .ARGN>
1339                            <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1340                                   <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1341                                   <PUT .TT ,NODE-TYPE ,READ-EOF2-CODE>)>
1342                            <SET EV
1343                                 <NODE1 ,EOF-CODE
1344                                        .TT
1345                                        <RESULT-TYPE .EV>
1346                                        <>
1347                                        (.EV)>>)>
1348                     .EV>
1349             <REST .OBJ>>>
1350      <PUT .TT ,KIDS .N>)>>
1351
1352 <PUTPROP ,GETPROP PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPROP>>>
1353
1354 '<PUTPROP ,GETPL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPL>>>
1355
1356 <DEFINE GETFCNS (OBJ AP NAME "AUX" EV TEM T2 (LN <LENGTH .OBJ>) TT)
1357         #DECL ((OBJ) FORM (LN) FIX (TT VALUE TEM T2 EV) NODE)
1358         <COND (<OR <AND <N==? .LN 4> <N==? .LN 3>> <SEG? .OBJ>>
1359                <RSUBR-FCN .OBJ .AP>)
1360               (ELSE
1361                <SET TT <NODEFM ,GET-CODE .PARENT ANY .NAME () ,.NAME>>
1362                <SET TEM <PCOMP <2 .OBJ> .TT>>
1363                <SET T2 <PCOMP <3 .OBJ> .TT>>
1364                <COND (<==? .LN 3>
1365                       <PUT .TT ,NODE-TYPE ,GET2-CODE>
1366                       <PUT .TT ,KIDS (.TEM .T2)>)
1367                      (ELSE
1368                       <SET EV <PCOMP <4 .OBJ> .TT>>
1369                       <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1370                              <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1371                              <PUT .TT ,NODE-TYPE ,GET2-CODE>)>
1372                       <PUT .TT ,KIDS (.TEM .T2 .EV)>)>
1373                .TT)>>
1374
1375 <DEFINE ARGCHK (GIV REQ NAME OBJ "AUX" (HI .REQ) (LO .REQ))
1376         #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
1377         <COND (<TYPE? .REQ LIST> <SET HI <2 .REQ>> <SET LO <1 .REQ>>)>
1378         <COND (<L? .GIV .LO>
1379                <COMPILE-ERROR "Too few arguments to: " .NAME .OBJ>)
1380               (<G? .GIV .HI>
1381                <COMPILE-ERROR "Too many arguments to: " .NAME .OBJ>)>
1382         T>
1383
1384 "\f"
1385
1386 <DEFINE PMAPF-R (OB AP
1387                  "AUX" (NAME <1 .OB>) TT ITRF OBJ (RQRG 0)
1388                        (LN <LENGTH <SET OBJ <REST .OB>>>) FINALF TAPL (APL ())
1389                        (DCL #DECL ()) (ARGL ()) (HATOM <>) (NN 0) TEM L2 L3
1390                        (TRG 0))
1391    #DECL ((OBJ OB) <PRIMTYPE LIST> (LN NN) FIX (DCL) DECL (ARGL APL) LIST
1392           (ITRF FINALF TT) NODE (TRG RQRG) <SPECIAL FIX>)
1393    <PROG ()
1394      <COND (<L? .LN 2> <COMPILE-ERROR "Too few arguments:  " .NAME .OBJ>)>
1395      <SET TT <NODEFM ,MAP-CODE .PARENT <> .NAME () .AP>>
1396      <SET FINALF <PCOMP <1 .OBJ> .TT>>
1397      <COND
1398       (<OR <TYPE? <SET TAPL <2 .OBJ>> FUNCTION>
1399            <AND <TYPE? .TAPL FORM>
1400                 <NOT <EMPTY? <SET APL <CHTYPE .TAPL LIST>>>>
1401                 <TYPE? <SET TEM <1 .APL>> ATOM>
1402                 <GASSIGNED? .TEM>
1403                 <==? ,.TEM ,FUNCTION>
1404                 <SET TAPL <REST .APL>>>>
1405        <COND (<EMPTY? <SET APL <CHTYPE .TAPL LIST>>>
1406               <COMPILE-ERROR "MAPF/R function is empty:  " .OBJ>)>
1407        <COND (<TYPE? <1 .APL> ATOM ADECL>
1408               <SET HATOM <1 .APL>>
1409               <SET APL <REST .APL>>)>
1410        <COND (<OR <EMPTY? .APL> <NOT <TYPE? <1 .APL> LIST>>>
1411               <COMPILE-ERROR "MAPF/R function lacks arg list:  " .OBJ>)>
1412        <SET ARGL <1 .APL>>
1413        <SET APL <REST .APL>>
1414        <COND (<AND <NOT <EMPTY? .APL>> <TYPE? <1 .APL> DECL>>
1415               <SET DCL <1 .APL>>
1416               <SET APL <REST .APL>>)>
1417        <COND (<EMPTY? .APL>
1418               <COMPILE-ERROR "MAPF/R function has no body:  " .OBJ>)>
1419        <PROG ((VARTBL .VARTBL))
1420          #DECL ((VARTBL) <SPECIAL SYMTAB>)
1421          <SET ITRF
1422               <NODEPR ,MFCN-CODE
1423                       .TT
1424                       <OR <FIND_DECL VALUE .DCL> ANY>
1425                       <>
1426                       ()
1427                       <>
1428                       ()
1429                       .HATOM
1430                       .VARTBL>>
1431          <GEN-D .ARGL .DCL .HATOM .ITRF>
1432          <COND
1433           (<ACT-FIX .ITRF <BINDING-STRUCTURE .ITRF>>
1434            <SET L3 <SET L2 ()>>
1435            <PUT
1436             .ITRF
1437             ,BINDING-STRUCTURE
1438             <REPEAT ((L <BINDING-STRUCTURE .ITRF>) (LL .L) (L1 .L) SYM)
1439                     #DECL ((L L1 LL) <LIST [REST SYMTAB]>)
1440                     <AND <EMPTY? .L> <RETURN .L1>>
1441                     <COND
1442                      (<==? <CODE-SYM <SET SYM <1 .L>>> 1>
1443                       <SET L2 ("ACT" <NAME-SYM .SYM> !.L2)>
1444                       <SET L3
1445                            ((<NAME-SYM .SYM>)
1446                             <COND (<SPEC-SYM .SYM>
1447                                    <FORM SPECIAL <DECL-SYM .SYM>>)
1448                                   (ELSE <FORM UNSPECIAL <DECL-SYM .SYM>>)>
1449                             !.L3)>
1450                       <COND (<==? .L .L1> <SET L1 <REST .L1>>)
1451                             (ELSE <PUTREST .LL <REST .L>>)>)>
1452                     <SET L <REST <SET LL .L>>>>>
1453            <SET APL (<FORM PROG .L2 <CHTYPE .L3 DECL> !.APL>)>)>
1454          <PUT .ITRF ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .ITRF>> .APL>>>)
1455       (<OR <AND <TYPE? .TAPL FIX> <==? .LN 3>>
1456            <AND <OR <AND <TYPE? .TAPL FORM>
1457                          <==? <LENGTH <SET APL <CHTYPE .TAPL LIST>>> 2>
1458                          <TYPE? <SET TEM <1 .APL>> ATOM>
1459                          <GASSIGNED? .TEM>
1460                          <==? ,.TEM ,GVAL>
1461                          <TYPE? <SET TEM <2 .APL>> ATOM>>
1462                     <AND <TYPE? .TAPL GVAL>
1463                          <SET TEM <CHTYPE .TAPL ATOM>>>>
1464                 <OR .REASONABLE
1465                     <AND <GASSIGNED? .TEM>
1466                          <OR <NOT <TYPE? ,.TEM FUNCTION>>
1467                              <==? .TEM .FNAME>>>>>>
1468        <PUTPROP .IND PTHIS-OBJECT ,PMARGS>
1469        <SET ITRF
1470             <COND (<TYPE? .TAPL FIX> <PCOMP <FORM NTH .IND .TAPL> .TT>)
1471                   (ELSE
1472                    <PCOMP <FORM .TEM
1473                                 !<MAPF ,LIST
1474                                        <FUNCTION () <COND (<==? .LN 2> <MAPSTOP>)
1475                                                           (ELSE
1476                                                            <SET LN <- .LN 1>>
1477                                                            .IND)>>>> .TT>)>>
1478        <PUTPROP .IND PTHIS-OBJECT>
1479        <MAPF <>
1480              <FUNCTION (N)
1481                      #DECL ((N) NODE)
1482                      <AND <==? <NODE-TYPE .N> ,MARGS-CODE>
1483                           <PUT .N ,NODE-NAME <SET NN <+ .NN 1>>>>>
1484              <KIDS .ITRF>>
1485        <SET ITRF <NODEFM ,MPSBR-CODE .TT <> <> (.ITRF) <>>>)
1486       (ELSE <SET ITRF <PCOMP .TAPL .TT>>)>
1487      <PUT .TT
1488           ,KIDS
1489           (.FINALF
1490            .ITRF
1491            !<MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ 2>>)>
1492      .TT>>
1493
1494 \\f
1495
1496 <DEFINE PMARGS (O)
1497         #DECL ((VALUE) NODE)
1498         <NODEFM ,MARGS-CODE .PARENT <> <> () <>>>
1499
1500 <COND (<GASSIGNED? PMAPF-R>
1501        <PUTPROP ,MAPF PAPPLY-OBJECT ,PMAPF-R>
1502        <PUTPROP ,MAPR PAPPLY-OBJECT ,PMAPF-R>)>
1503
1504 <DEFINE ADECL-FCN (OBJ "AUX" (TT <NODEFM ,ADECL-CODE .PARENT <> ADECL () <>>)
1505                              OBJ1)
1506         #DECL ((TT VALUE) NODE (OBJ) ADECL)
1507         <COND (<==? <LENGTH .OBJ> 2>
1508                <COND (<TYPE? <SET OBJ1 <1 .OBJ>> SEGMENT>
1509                       <PUT .TT ,NODE-TYPE ,SEGMENT-CODE>
1510                       <PUT .TT ,NODE-NAME <>>
1511                       <PUT .TT ,KIDS (<ADECL-FCN <CHTYPE [<CHTYPE .OBJ1 FORM>
1512                                                           <2 .OBJ>] ADECL>>)>)
1513                      (ELSE
1514                       <PUT .TT ,NODE-NAME <2 .OBJ>>
1515                       <PUT .TT ,KIDS (<PCOMP <1 .OBJ> .TT>)>)>)
1516               (ELSE
1517                <COMPILE-ERROR "ADECL has an incorrect number of elements: "
1518                               .OBJ>)>>
1519
1520 <COND (<GASSIGNED? ADECL-FCN> <PUTPROP ADECL PTHIS-TYPE ,ADECL-FCN>)>
1521
1522 <DEFINE CASE-FCN (OBJ AP
1523                   "AUX" (OP .PARENT) (PARENT .PARENT) (FLG T) (WIN T) TYP
1524                         (DF <>) P TEM X)
1525    #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
1526    <COND
1527     (<AND
1528       <G? <LENGTH .OBJ> 3>
1529       <PROG ()
1530             <COND (<OR <AND <==? <TYPE <SET X <2 .OBJ>>> GVAL>
1531                             <==? <SET P <CHTYPE .X ATOM>> ==?>>
1532                        <AND <TYPE? <SET X <2 .OBJ>> FORM>
1533                             <==? <LENGTH .X> 2>
1534                             <==? <1 .X> GVAL>
1535                             <==? <SET P <2 .X>> ==?>
1536                             ;<MEMQ <SET P <2 .X>> '[==? TYPE? PRIMTYPE?]>>>)
1537                   (ELSE <SET WIN <>>)>
1538             1>
1539       <MAPF <>
1540        <FUNCTION (O)
1541           <COND
1542            (<AND .FLG <==? .O DEFAULT>> <SET DF T>)
1543            (<AND .DF <TYPE? .O LIST>> <SET DF <>> <SET FLG <>>)
1544            (<AND <NOT .DF> <TYPE? .O LIST> <NOT <EMPTY? .O>>>
1545             <COND
1546              (<SET TEM <VAL-CHK <1 .O>>>
1547               <COND (<ASSIGNED? TYP> <OR <==? .TYP <TYPE .TEM>> <SET WIN <>>>)
1548                     (ELSE <SET TYP <TYPE .TEM>>)>)
1549              (<AND <TYPE? <SET TEM <1 .O>> SEGMENT>
1550                    <==? <LENGTH .TEM> 2>
1551                    <==? <1 .TEM> QUOTE>
1552                    <NOT <MONAD? <SET TEM <2 .TEM>>>>>
1553               <MAPF <>
1554                     <FUNCTION (TY)
1555                             <COND (<NOT <SET TY <VAL-CHK .TY>>> <SET WIN <>>)
1556                                   (ELSE
1557                                    <COND (<ASSIGNED? TYP>
1558                                           <OR <==? .TYP <TYPE .TY>>
1559                                               <SET WIN <>>>)
1560                                          (ELSE <SET TYP <TYPE .TY>>)>)>>
1561                     .TEM>)
1562              (ELSE <SET WIN <>>)>)
1563            (ELSE <MAPLEAVE <>>)>
1564           T>
1565        <REST .OBJ 3>>
1566       <NOT .DF>>
1567      <COND (<AND .WIN
1568                  <NOT <OR <AND <MEMQ <TYPEPRIM .TYP> '[WORD FIX]>
1569                                <==? .P ==?>>
1570                           <AND <N==? .P ==?> <==? .TYP ATOM>>>>>
1571             <SET WIN <>>)>
1572      <COND
1573       (.WIN
1574        <SET PARENT <NODECOND ,CASE-CODE .OP <> CASE ()>>
1575        <PUT
1576         .PARENT
1577         ,KIDS
1578         (<PCOMP <2 .OBJ> .PARENT>
1579          <PCOMP <3 .OBJ> .PARENT>
1580          !<MAPF ,LIST
1581            <FUNCTION (CLA "AUX" TT)
1582                    #DECL ((CLA) <OR ATOM LIST> (TT) NODE)
1583                    <COND (.DF <SET CLA (ELSE !.CLA)>)>
1584                    <COND
1585                     (<NOT <TYPE? .CLA ATOM>>
1586                      <PUT <SET TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>>
1587                           ,PREDIC
1588                           <PCOMP <COND (<TYPE? <SET TEM <1 .CLA>> SEGMENT>
1589                                         <FORM QUOTE
1590                                               <MAPF ,LIST ,VAL-CHK <2 .TEM>>>)
1591                                        (<TYPE? .TEM ORQ>
1592                                         <FORM QUOTE
1593                                               <MAPF ,LIST ,VAL-CHK .TEM>>)
1594                                        (ELSE <VAL-CHK .TEM>)>
1595                                  .TT>>
1596                      <PUT .TT
1597                           ,CLAUSES
1598                           <MAPF ,LIST
1599                                 <FUNCTION (O) <PCOMP .O .TT>>
1600                                 <REST .CLA>>>
1601                      <SET DF <>>
1602                      .TT)
1603                     (ELSE <SET DF T> <PCOMP .CLA .PARENT>)>>
1604            <REST .OBJ 3>>)>)
1605       (ELSE <PMACRO .OBJ .OP>)>)
1606     (ELSE <COMPILE-ERROR "CASE in incorrect format " .OBJ>)>>
1607
1608 <DEFINE VAL-CHK (TEM "AUX" TT)
1609         <OR <AND <OR <TYPE? .TEM ATOM>
1610                      <==? <PRIMTYPE .TEM> WORD>
1611                      <==? <PRIMTYPE .TEM> FIX>> .TEM>
1612             <AND <==? <TYPE .TEM> GVAL>
1613                  <MANIFESTQ <SET TEM <CHTYPE .TEM ATOM>>>
1614                  ,.TEM>
1615             <AND <TYPE? .TEM FORM>
1616                  <==? <LENGTH .TEM> 2>
1617                  <OR <AND <==? <1 .TEM> QUOTE> <2 .TEM>>
1618                      <AND <==? <1 .TEM> GVAL> <MANIFESTQ <2 .TEM>> ,<2 .TEM>>
1619                      <AND <==? <1 .TEM> ASCII>
1620                           <TYPE? <2 .TEM> CHARACTER FIX>
1621                           <EVAL .TEM>>>>
1622             <AND <TYPE? .TEM FORM>
1623                  <==? <LENGTH .TEM> 3>
1624                  <==? <1 .TEM> CHTYPE>
1625                  <TYPE? <3 .TEM> ATOM>
1626                  <NOT <TYPE? <2 .TEM> FORM LIST VECTOR UVECTOR SEGMENT>>
1627                  <EVAL .TEM>>
1628             <AND <TYPE? .TEM FORM>
1629                  <NOT <EMPTY? .TEM>>
1630                  <TYPE? <SET TT <1 .TEM>> ATOM>
1631                  <GASSIGNED? .TT>
1632                  <TYPE? ,.TT MACRO>
1633                  <VAL-CHK <EMACRO .TEM>>>>>
1634
1635 <DEFINE MANIFESTQ (ATM)
1636         #DECL ((ATM) ATOM)
1637         <AND <MANIFEST? .ATM>
1638              <GASSIGNED? .ATM>
1639              <NOT <TYPE? ,.ATM MSUBR>>>>
1640
1641 <DEFINE EMACRO (OBJ "AUX" (ERR <HANDLER ,MACROERR 100>) TEM)
1642         <ON .ERR>
1643         <COND (<TYPE? <SET TEM
1644                            <PROG MACACT ()
1645                                  #DECL ((MACACT) <SPECIAL ANY>)
1646                                  <SETG ERR .ERR>
1647                                  <SETG MACACT .MACACT>
1648                                  <EXPAND .OBJ>>>
1649                       FUNNY>
1650                <OFF .ERR>
1651                <COMPILE-ERROR "Macro expansion lossage " ,CR !.TEM>)
1652               (ELSE <OFF .ERR> .TEM)>>
1653
1654 <COND (<AND <GASSIGNED? CASE> <GASSIGNED? CASE-FCN>>
1655        <PUTPROP ,CASE PAPPLY-OBJECT ,CASE-FCN>)>
1656
1657 <DEFINE P-CALL (OBJ AP
1658                  "AUX" (TT
1659                         <NODEFM ,CALL-CODE
1660                                 .PARENT
1661                                 <>
1662                                 CALL
1663                                 ()
1664                                 .AP>))
1665         #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
1666         <COND (<AND <NOT <EMPTY? <REST .OBJ>>>
1667                     <TYPE? <SET CALLED <2 .OBJ>> ATOM>>
1668                <COND (<==? .CALLED IFSYS>
1669                       <SET IN-IFSYS <3 .OBJ>>)
1670                      (<==? .CALLED ENDIF>
1671                       <SET IN-IFSYS <>>)>)>
1672         <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ>>>>
1673
1674 <DEFINE P-APPLY PAP (OBJ AP "AUX" TT ITM TEM V)
1675         #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
1676         <COND (<AND <NOT <EMPTY? <REST .OBJ>>>
1677                     <TYPE? <SET ITM <2 .OBJ>> SEGMENT>>
1678                <COND (<AND <==? <LENGTH .ITM> 2>
1679                            <OR <==? <SET TEM <1 .ITM>> GVAL> <==? .TEM LVAL>>>
1680                       <SET OBJ <CHTYPE (<FORM 1 .ITM>
1681                                         <CHTYPE (REST .ITM) SEGMENT>
1682                                         !<REST .OBJ 2>) FORM>>)
1683                      (ELSE
1684                       <RETURN <PCOMP <FORM BIND ((<SET V <MAKE-TAG "A">> .ITM))
1685                                            <CHTYPE (APPLY <FORM 1
1686                                                                 <FORM LVAL .V>>
1687                                                  <CHTYPE (REST <FORM LVAL .V>)
1688                                                           SEGMENT>
1689                                                  !<REST .OBJ 2>) FORM>>
1690                                      .PARENT> .PAP>)>)
1691               (ELSE <SET OBJ <CHTYPE <REST .OBJ> FORM>>)>
1692         <SET TT <NODEFM ,APPLY-CODE .PARENT <> APPLY () .AP>>
1693         <PUT .TT ,KIDS <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>>  .OBJ>>>
1694
1695 <COND (<GASSIGNED? P-CALL> <PUTPROP `CALL PAPPLY-OBJECT ,P-CALL>)>
1696
1697 <DEFINE PRINT-HACKERS (OBJ AP "AUX" (LEN <COND (<==? <1 .OBJ> CRLF> 1)
1698                                                (ELSE 2)>))
1699         #DECL ((OBJ) FORM (LEN) FIX)
1700         <COND (<==? <LENGTH .OBJ> .LEN>
1701                <COND (<==? .LEN 1>
1702                       <SET OBJ <CHTYPE (<1 .OBJ> '.OUTCHAN) FORM>>)
1703                      (ELSE <SET OBJ <CHTYPE (<1 .OBJ> <2 .OBJ> '.OUTCHAN)
1704                                             FORM>>)>)>
1705         <RSUBR-FCN .OBJ .AP>>
1706
1707 <COND (<GASSIGNED? PRINT-HACKERS>
1708        <PUTPROP ,PRINT PAPPLY-OBJECT ,PRINT-HACKERS>
1709        <PUTPROP ,PRIN1 PAPPLY-OBJECT ,PRINT-HACKERS>
1710        <PUTPROP ,PRINC PAPPLY-OBJECT ,PRINT-HACKERS>
1711        <PUTPROP ,CRLF PAPPLY-OBJECT ,PRINT-HACKERS>)>
1712
1713 <DEFINE P-MULTI-SET (OBJ:FORM AP
1714                      "AUX" (TT <NODEFM ,MULTI-SET-CODE .PARENT <> MULTI-SET
1715                                        () ,MULTI-SET>) L)
1716         <COND (<L? <LENGTH .OBJ> 2>
1717                <COMPILE-ERROR "Too few args to MULTI-SET:  " .OBJ>)>
1718         <COND (<OR <NOT <TYPE? <SET L <2 .OBJ>> LIST>>
1719                    <EMPTY? .L>
1720                    <MAPF <>
1721                          <FUNCTION (X)
1722                               <COND (<NOT <OR <TYPE? .X ATOM>
1723                                               <AND <TYPE? .X ADECL>
1724                                                    <TYPE? <1 .X> ATOM>>>>
1725                                      <MAPLEAVE T>)>
1726                               <>>
1727                          .L>>
1728                <COMPILE-ERROR "Arg wrong type to MULTI-SET:  " .OBJ>)>
1729         <PUT .TT ,KIDS (<PCOMP <FORM QUOTE .L> .TT>
1730                         !<MAPF ,LIST
1731                                <FUNCTION (O) <PCOMP .O .TT>>
1732                                <REST .OBJ 2>>)>>
1733
1734 <COND (<AND <GASSIGNED? MULTI-SET> <GASSIGNED? P-MULTI-SET>>
1735        <PUTPROP ,MULTI-SET PAPPLY-OBJECT ,P-MULTI-SET>)>
1736
1737 <DEFINE PIFSYS (OBJ AP "AUX" L SYS) #DECL ((OBJ) <OR FORM LIST>)
1738         <COND (<AND <ASSIGNED? IN-IFSYS> .IN-IFSYS>
1739                <REPEAT ((STUFF ()))
1740                        <COND (<EMPTY? <SET OBJ <REST .OBJ>>>
1741                               <RETURN <COND (<EMPTY? .STUFF>
1742                                              <PDEFAULT <>>)
1743                                             (<PPROG-REPEAT
1744                                               <CHTYPE (BIND () !.STUFF) FORM>
1745                                               BIND>)>>)>
1746                        <COND (<OR <NOT <TYPE? <SET L <1 .OBJ>> LIST>>
1747                                   <EMPTY? .L>
1748                                   <NOT <TYPE? <SET SYS <1 .L>> STRING ATOM>>>
1749                               <ERROR ARG-WRONG-TYPE <1 .OBJ> IFSYS>)
1750                              (ELSE
1751                               <COND (<TYPE? .SYS ATOM> <SET SYS <SPNAME .SYS>>)>
1752                               <COND (<OR <=? .SYS .IN-IFSYS>
1753                                          <AND <=? .SYS "UNIX">
1754                                               <OR <=? .IN-IFSYS "VAX">
1755                                                   <=? .IN-IFSYS "MAC">>>
1756                                          <AND <OR <=? .SYS "VAX">
1757                                                   <=? .SYS "MAC">>
1758                                               <=? .IN-IFSYS "UNIX">>>
1759                                      ; "Allow for UNIX/VAX/MAC..."
1760                                      <SET STUFF (!<REST .L> !.STUFF)>)>)>>)
1761               (ELSE
1762                <PMACRO <CHTYPE (IFSYS-MIMC !<REST .OBJ>) FORM>
1763                        .AP>)>>
1764
1765 <COND (<AND <GASSIGNED? IFSYS> <GASSIGNED? PIFSYS>>
1766        <PUTPROP ,IFSYS PAPPLY-OBJECT ,PIFSYS>)>
1767
1768 <DEFMAC IFSYS-MIMC ("ARGS" ARGS "AUX" (STUFF ()))
1769   #DECL ((ARGS) LIST)
1770   <REPEAT (L)
1771     <COND (<EMPTY? .ARGS> <RETURN .STUFF>)>
1772     <COND (<OR <NOT <TYPE? <SET L  <1 .ARGS>> LIST>>
1773                <EMPTY? .L>
1774                <NOT <TYPE? <1 .L> STRING ATOM>>>
1775            <ERROR ARG-WRONG-TYPE <1 .ARGS> IFSYS>)
1776           (T
1777            <COND (<TYPE? <1 .L> ATOM>
1778                   <1 .L <SPNAME <1 .L>>>)>
1779            <SET STUFF (<FORM CALL!- IFSYS <1 .L>> !<REST .L>
1780                        <FORM CALL!- ENDIF <1 .L>> !.STUFF)>)>
1781     <SET ARGS <REST .ARGS>>>
1782   <CHTYPE (BIND () !.STUFF) FORM>>
1783
1784 <ENDPACKAGE>