<mdl.comp>/pass1.mud.45

   1 <PACKAGE "PASS1">
   2
   3 <ENTRY PASS1 PCOMP PMACRO PAPPLY-OBJECT PAPPLY-TYPE PTHIS-OBJECT PTHIS-TYPE
   4        GEN-D ACT-FIX FIND:DECL SEG? PSUBR-C>
   5
   6 <USE "CHKDCL" "COMPDEC" "CDRIVE">
   7
   8
   9 "       This file contains the first pass of the MUDDLE compiler.
  10 The functions therein take a MUDDLE function and build a more detailed
  11 model of it.  Each entity in the function is represented by an object
  12 of type NODE.  The entire function is represented by the functions node
  13 and it points to the rest of the nodes for the function."
  14
  15 "       Nodes vary in complexity and size depending on what they represent.
  16 A function or prog/repeat node is contains more information than a node
  17 for a quoted object.  All nodes have some fields in common to allow
  18 general programs to traverse the model."
  19
  20 "       The model built by PASS1 is used by the analyzer (SYMANA), the
  21 variable allocator (VARANA) and the code generator (CODGEN).  In some
  22 cases the analyzers and generators for certain classes of SUBRs are
  23 together in their own files (e.g.  CARITH, STRUCT, ISTRUC)."
  24
  25 "       This the top level program for PASS1.  It takes a function as
  26 input and returns the data structure representing the model."
  27
  28 <DEFINE PASS1 (FUNC
  29                "OPTIONAL" (NAME <>) (JUSTDCL <>) (RNAME .NAME)
  30                "AUX" RESULT (VARTBL ,LVARTBL) (DCL #DECL ()) (ARGL ())
  31                      (HATOM <>) (TT ()) (FCN .FUNC) TEM (RQRG 0) (TRG 0) INAME)
  32         #DECL ((FUNC) FUNCTION (VARTBL) <SPECIAL SYMTAB>
  33                (RQRG TRG) <SPECIAL FIX> (FCN) <PRIMTYPE LIST> (ARGL TT) LIST
  34                (RESULT) <SPECIAL NODE> (INAME) <UVECTOR [REST ATOM]>)
  35         <AND <EMPTY? .FCN> <MESSAGE ERROR " EMPTY FUNCTION ">>
  36         <AND <TYPE? <1 .FCN> ATOM>
  37             <SET HATOM <1 .FCN>>
  38             <SET FCN <REST .FCN>>>
  39         <AND <EMPTY? .FCN> <MESSAGE ERROR " NO ARG LIST ">>
  40         <SET ARGL <1 .FCN>>
  41         <SET FCN <REST .FCN>>
  42         <COND (<AND <NOT <EMPTY? .FCN>> <TYPE? <1 .FCN> DECL>>
  43                <SET DCL <1 .FCN>>
  44                <SET FCN <REST .FCN>>)>
  45         <AND <EMPTY? .FCN> <MESSAGE ERROR " NO BODY ">>
  46         <COND (<SET TEM <GET .RNAME .IND>>
  47                <SET RESULT .TEM>
  48                <SET VARTBL <SYMTAB .RESULT>>)
  49               (ELSE
  50                <SET TT <GEN-D .ARGL .DCL .HATOM>>
  51                <SET INAME
  52                     <IUVECTOR <- .TRG .RQRG -1> '<MAKE:TAG <PNAME .NAME>>>>
  53                <SET RESULT
  54                     <NODEF ,FUNCTION-CODE
  55                            ()
  56                            <FIND:DECL VALUE .DCL>
  57                            .INAME
  58                            ()
  59                            <1 .TT>
  60                            <2 .TT>
  61                            .HATOM
  62                            .VARTBL
  63                            <COND (<==? <LENGTH .TT> 3> <3 .TT>)>
  64                            .TRG
  65                            .RQRG>>
  66                <ACT-FIX .RESULT <2 .TT>>
  67                <PUT .RNAME .IND .RESULT>
  68                <PUT .RESULT
  69                     ,RSUBR-DECLS
  70                     ("VALUE" <RESULT-TYPE .RESULT> !<RSUBR-DECLS .RESULT>)>)>
  71         <OR .JUSTDCL
  72                 <PUT .RESULT
  73                      ,KIDS
  74                      <MAPF ,LIST <FUNCTION (O) <PCOMP .O .RESULT>> .FCN>>>
  75         .RESULT>
  76
  77 "       This function (and others on this page) take an arg list and
  78 decls and parses them producing 3 things.
  79
  80         1) An RSUBR decl list.
  81
  82         2) A machine readable binding specification.
  83
  84         3) Possibly an AC call spec.
  85
  86 Atoms are also entered into the symbol table."
  87
  88 <DEFINE GEN-D (ARGL DCL HATOM "OPTIONAL" (ACS:TOP <COND (.GLUE '(() STACK)) (T (()))>)
  89                "AUX" (SVTBL .VARTBL) (ACS:BOT <CHTYPE .ACS:TOP LIST>) (NACS 1)
  90                      (RES:TOP (())) (RES:BOT .RES:TOP) (ARGN 1) (BNDL:TOP (()))
  91                      (BNDL:BOT .BNDL:TOP) (MODE ,TOT-MODES) (DOIT ,INIT-D)
  92                      (ST <>) T T1 SVT (IX 0) TIX VIX)
  93    #DECL ((ACS:BOT RES:BOT BNDL:TOP BNDL:BOT) <SPECIAL LIST> (RES:TOP) LIST
  94           (ACS:TOP) <SPECIAL <PRIMTYPE LIST>> (NACS ARGN) <SPECIAL FIX>
  95           (VIX) <VECTOR [REST STRING]> (MODE) <SPECIAL <VECTOR [REST STRING]>>
  96           (IX) FIX (DOIT) <SPECIAL ANY> (ARGL) LIST (SVTBL SVT) SYMTAB
  97           (DCL) <SPECIAL <PRIMTYPE LIST>>)
  98    <REPEAT ()
  99            <AND <EMPTY? .ARGL> <RETURN>>
 100            <COND (<SET T1 <TYPE? <SET T <1 .ARGL>> ATOM FORM LIST>>
 101                   <SET ST <>>
 102                   <APPLY .DOIT .T .T1>)
 103                  (<TYPE? .T STRING>
 104                   <AND .ST <MESSAGE ERROR " TWO DECL STRINGS IN A ROW ">>
 105                   <SET ST T>
 106                   <OR <SET TIX <MEMBER .T .MODE>>
 107                           <MESSAGE ERROR " UNRECOGNIZED STRING IN DECL " .T>>
 108                   <SET VIX .TIX>
 109                   <SET MODE <REST .MODE <NTH ,RESTS <SET IX <LENGTH .VIX>>>>>
 110                   <SET DOIT <NTH ,DOITS .IX>>
 111                   <COND (<OR <L? .IX 5> <G? .IX 8>>)
 112                         (ELSE <PUT-RES (<COND (<=? <1 .ARGL> "OPT">
 113                                                "OPTIONAL")
 114                                               (ELSE <1 .ARGL>)>)>)>)
 115                  (ELSE <MESSAGE ERROR " BAD THING IN DECL " .T>)>
 116            <SET ARGL <REST .ARGL>>>
 117    <AND .HATOM <ACT-D .HATOM <TYPE .HATOM>>>
 118    <REPEAT (DC DC1)
 119            #DECL ((DC1) FORM (DC) ANY (VARTBL) <SPECIAL SYMTAB>)
 120            <COND (<EMPTY? .DCL> <RETURN>)
 121                  (<EMPTY? <REST .DCL>> <MESSAGE ERROR  "DECL LIST AT END OF DECL">)>
 122            <SET DC <2 .DCL>>
 123            <COND (<AND <TYPE? .DC FORM>
 124                        <SET DC1 .DC>
 125                        <==? <LENGTH .DC1> 2>
 126                        <OR <==? <1 .DC1> SPECIAL> <==? <1 .DC1> UNSPECIAL>>>
 127                   <SET DC <2 .DC1>>)>
 128            <MAPF <>
 129                  <FUNCTION (ATM)
 130                          <OR <==? .ATM VALUE>
 131                              <SRCH-SYM .ATM>
 132                              <ADDVAR .ATM T -1 0 T (.DC) <> <>>>>
 133                  <CHTYPE <1 .DCL> LIST>>
 134            <SET DCL <REST .DCL 2>>>
 135    <SET SVT .VARTBL>
 136    <SET VARTBL .SVTBL>
 137    <COND (<N==? .SVTBL .SVT>
 138       <REPEAT ((SV .SVT))
 139            #DECL ((SV) SYMTAB)
 140            <COND (<==? <NEXT-SYM .SV> .SVTBL>
 141                   <PUT .SV ,NEXT-SYM .VARTBL>
 142                   <SET VARTBL .SVT>
 143                   <RETURN>)
 144                  (ELSE <SET SV <NEXT-SYM .SV>>)>>)>
 145    <AND <L? <SET TRG <- .ARGN 1>> 0> <SET RQRG -1>>
 146    <COND (<OR <NOT .ACS:TOP> <=? .ACS:TOP '(() STACK)>>
 147           <REPEAT ((BB ()) B (CHNG T) (N1 0) (N2 0) TEM)
 148                   #DECL ((BB B) <LIST [REST SYMTAB]> (N1 N2) FIX (TEM) SYMTAB)
 149                   <COND (<EMPTY? .BB>
 150                          <OR .CHNG <RETURN>>
 151                          <SET CHNG <>>
 152                          <SET N1 0>
 153                          <SET B .BNDL:TOP>
 154                          <SET BB <REST .B>>
 155                          <AGAIN>)>
 156                   <COND (<NOT <0? <SET N2 <ARGNUM-SYM <SET TEM <1 .BB>>>>>>
 157                          <COND (<G? .N1 .N2>
 158                                 <PUT .BB 1 <1 .B>>
 159                                 <PUT .B 1 .TEM>
 160                                 <SET CHNG T>)
 161                                (ELSE <SET N1 .N2>)>)
 162                         (ELSE <SET BB ()> <AGAIN>)>
 163                   <SET B <REST .B>>
 164                   <SET BB <REST .BB>>>)>
 165    (<REST .RES:TOP>
 166     <REST .BNDL:TOP>
 167     !<COND (.ACS:TOP (<REST .ACS:TOP>)) (ELSE ())!>)>
 168
 169
 170 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
 171         #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
 172         <REPEAT ()
 173                 <AND <EMPTY? .TB> <RETURN <>>>
 174                 <AND <==? .ATM <NAME-SYM .TB>> <RETURN .TB>>
 175                 <SET TB <NEXT-SYM .TB>>>>
 176
 177 "Vector of legal strings in decl list."
 178
 179 <SETG TOT-MODES
 180       ["BIND"
 181        "CALL"
 182        "OPT"
 183        "OPTIONAL"
 184        "ARGS"
 185        "TUPLE"
 186        "AUX"
 187        "EXTRA"
 188        "ACT"
 189        "NAME"]>
 190
 191 "Amount to rest off decl vector after each encounter."
 192
 193 <SETG RESTS ![1 2 1 2 1 2 1 2 1 1!]>
 194
 195 "This function used for normal args when \"BIND\" and \"CALL\" still possible."
 196
 197 <DEFINE INIT-D (OBJ TYP) #DECL ((MODE) <VECTOR STRING>)
 198         <SET MODE <REST .MODE>> <INIT1-D .OBJ .TYP>>
 199
 200 "This function for normal args when \"CALL\" still possible."
 201
 202 <DEFINE INIT1-D (OBJ TYP)
 203         #DECL ((MODE) <VECTOR STRING>)
 204         <SET MODE <REST .MODE>>
 205         <SET DOIT ,NORM-D>
 206         <NORM-D .OBJ .TYP>>
 207 \f
 208 "Handle a normal argument or quoted normal argument."
 209
 210 <DEFINE NORM-D (OBJ TYP) #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
 211         <AND <==? .TYP LIST>
 212             <MESSAGE ERROR " LIST NOT IN OPT OR AUX " .OBJ>>
 213         <SET RQRG <+ .RQRG 1>>
 214         <COND (<==? .TYP ATOM>
 215                <PUT-RES (<PUT-DCL 13 .OBJ <><FIND:DECL .OBJ .DCL> T>)>)
 216               (<SET OBJ <QUOTCH .OBJ>>
 217                <PUT-RES ("QUOTE" <PUT-DCL 12 .OBJ <> <FIND:DECL .OBJ .DCL> T>)>)>
 218         <SET ARGN <+ .ARGN 1>>>
 219
 220 "Handle \"BIND\" decl."
 221
 222 <DEFINE BIND-D (OBJ TYP "AUX" DC) #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 223         <SET ACS:TOP <>>
 224         <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD BIND " .OBJ>>
 225         <SET DC <PUT-DCL 11 .OBJ <> <FIND:DECL .OBJ .DCL> T>>
 226         <TYPE-ATOM-OK? .DC ENVIRONMENT .OBJ>
 227         <SET DOIT ,INIT1-D>>
 228
 229 "Handle \"CALL\" decl."
 230
 231 <DEFINE CALL-D (OBJ TYP "AUX" DC) #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL)
 232         <SET RQRG <+ .RQRG 1>>
 233         <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD CALL " .OBJ>>
 234         <PUT-RES (<SET DC <PUT-DCL 10 .OBJ <> <FIND:DECL .OBJ .DCL> T>>)>
 235         <TYPE-ATOM-OK? .DC FORM .OBJ>
 236         <SET ARGN <+ .ARGN 1>>
 237         <SET DOIT ,ERR-D>>
 238
 239 "Flush on extra atoms after \"CALL\", \"ARGS\" etc."
 240
 241 <DEFINE ERR-D (OBJ TYPE) <MESSAGE ERROR " BAD SYNTAX ARGLIST " .OBJ>>
 242
 243 "Handle \"OPTIONAL\" decl."
 244
 245 <DEFINE OPT-D (OBJ TYP "AUX" DC OBJ1)
 246         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 247         <COND (.ACS:TOP <SET ACS:TOP '(() STACK)>)> ;"Temporary until know how to win."
 248         <COND (<==? .TYP ATOM>
 249                <PUT-RES (<PUT-DCL 9 .OBJ <><FIND:DECL .OBJ .DCL> <>>)>)
 250               (<==? .TYP FORM>
 251                <SET OBJ <QUOTCH .OBJ>>
 252                <PUT-RES ("QUOTE" <PUT-DCL 8 .OBJ <> <FIND:DECL .OBJ .DCL> <>>)>)
 253               (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM>
 254                <PUT-RES (<PAUX .OBJ1 <2 <CHTYPE .OBJ LIST>> <FIND:DECL .OBJ1 .DCL> 7>)>)
 255               (<TYPE? .OBJ1 FORM>
 256                <SET OBJ1 <QUOTCH .OBJ1>>
 257                <PUT-RES ("QUOTE"
 258                          <PAUX .OBJ1 <2 <CHTYPE .OBJ LIST>> <FIND:DECL .OBJ1 .DCL> 6>)>)
 259               (ELSE <MESSAGE ERROR "BAD USE OF OPTIONAL " .OBJ>)>
 260         <SET ARGN <+ .ARGN 1>>>
 261
 262 "Handle \"ARGS\" decl."
 263
 264 <DEFINE ARGS-D (OBJ TYP "AUX" DC)
 265         #DECL ((TYP) ATOM (RQRG ARGN) FIX (DCL) DECL (BNDL:BOT) <LIST SYMTAB>)
 266         <COND (.ACS:TOP <SET ACS:TOP '(() STACK)>)> ;"Temporary until know how to win."
 267         <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD ARGS " .OBJ>>
 268         <PUT-RES (<SET DC <PUT-DCL 5 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>)>
 269         <TYPE-ATOM-OK? .DC LIST .OBJ>
 270         <SET DOIT ,ERR-D>
 271         <SET ARGN <+ .ARGN 1>>>
 272
 273 "Handle \"TUPLE\" decl."
 274
 275 <DEFINE TUP-D (OBJ TYP "AUX" DC)
 276         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 277         <OR <==? .TYP ATOM> <MESSAGE ERROR " BAD TUPLE " .OBJ>>
 278         <COND (<1? .ARGN> <SET ARGN 0> <SET ACS:TOP '(() STACK)>)
 279               (ELSE <SET ACS:TOP <>>)>
 280         <PUT-RES (<SET DC <PUT-DCL 4 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>)>
 281         <TYPE-ATOM-OK? .DC TUPLE .OBJ>
 282         <SET DOIT ,ERR-D>>
 283
 284 \f
 285 "Handle \"AUX\" decl."
 286
 287 <DEFINE AUX-D (OBJ TYP "AUX" DC OBJ1)
 288         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 289         <AND <==? .TYP FORM> <MESSAGE ERROR " QUOTED AUX " .OBJ>>
 290         <COND (<==? .TYP ATOM>
 291                <PUT-DCL 3 .OBJ <> <FIND:DECL .OBJ .DCL> <>>)
 292               (<TYPE? <SET OBJ1 <LISTCH .OBJ>> ATOM>
 293                <PAUX .OBJ1 <2 .OBJ> <FIND:DECL .OBJ1 .DCL> 2>)
 294               (ELSE <MESSAGE ERROR " QUOTED AUX " .OBJ>)>>
 295
 296 "Handle \"NAME\" and \"ACT\" decl."
 297
 298 <DEFINE ACT-D (OBJ TYP "AUX" DC)
 299         #DECL ((TYP) ATOM (ARGN) FIX (DCL) DECL)
 300         <OR <==? .TYP ATOM>
 301                 <MESSAGE ERROR " BAD ACTIVATION " .OBJ>>
 302         <SET DC <PUT-DCL 1 .OBJ <> <FIND:DECL .OBJ .DCL> <>>>
 303         <TYPE-ATOM-OK? .DC ACTIVATION .OBJ>>
 304
 305 "Fixup activation atoms after node generated."
 306
 307 <DEFINE ACT-FIX (N L "AUX" (FLG <>)) #DECL ((N) NODE (L) <LIST [REST SYMTAB]>)
 308         <REPEAT (SYM) #DECL ((SYM) SYMTAB)
 309                 <AND <EMPTY? .L> <RETURN .FLG>>
 310                 <COND (<AND <==? <CODE-SYM <SET SYM <1 .L>>> 1>
 311                             <SET FLG T>
 312                             <NOT <SPEC-SYM .SYM>>>
 313                        <PUT .SYM ,RET-AGAIN-ONLY .N>)>
 314                 <SET L <REST .L>>>>
 315
 316 "Table of varius decl handlers."
 317
 318 <SETG DOITS
 319       ![,ACT-D ,ACT-D ,AUX-D ,AUX-D ,TUP-D ,ARGS-D ,OPT-D ,OPT-D ,CALL-D
 320         ,BIND-D!]>
 321
 322 <GDECL (DOITS) UVECTOR (TOT-MODES) <VECTOR [REST STRING]> (RESTS) <UVECTOR [REST FIX]>>
 323
 324 "Check for quoted arguments."
 325
 326 <DEFINE QUOTCH (OB) #DECL ((OB) FORM (VALUE) ATOM)
 327         <COND (<AND <==? <LENGTH .OB> 2>
 328                     <==? <1 .OB> QUOTE>
 329                     <TYPE? <2 .OB> ATOM>>
 330                <2 .OB>)
 331               (ELSE <MESSAGE ERROR " BAD FORM IN ARGLIST " .OB> T)>>
 332
 333 "Chech for (arg init) or ('arg init)."
 334
 335 <DEFINE LISTCH (OB) #DECL ((OB) LIST)
 336         <COND (<AND <==? <LENGTH .OB> 2>
 337                     <OR <TYPE? <1 .OB> ATOM>
 338                         <AND <TYPE? <1 .OB> FORM> <QUOTCH <1 .OB>>>>>
 339                <1 .OB>)
 340               (ELSE <MESSAGE ERROR " BAD LIST IN ARGLIST " .OB> T)>>
 341
 342 "Add a decl to RSUBR decls and update AC call spec."
 343
 344 <DEFINE PUT-RES (L "AUX" TY)
 345     #DECL ((L) LIST (NACS) FIX (ACS:BOT RES:BOT) LIST)
 346     <PROG ()
 347         <SET RES:BOT <REST <PUTREST .RES:BOT .L> <LENGTH .L>>>
 348         <COND (<AND .ACS:TOP <OR <G? .NACS 5> <=? .ACS:TOP '(() STACK)>>>
 349                <SET ACS:TOP '(() STACK)> <RETURN>)>
 350         <COND (<AND .ACS:TOP
 351                     <REPEAT ()
 352                         <COND (<EMPTY? .L><RETURN <>>)
 353                               (<TYPE? <SET TY <1 .L>> STRING>
 354                                <SET L <REST .L>>)
 355                               (ELSE <RETURN T>)>>>
 356                <COND (<SET TY <ISTYPE-GOOD? .TY>>
 357                       <SET ACS:BOT <REST <PUTREST .ACS:BOT
 358                                                   ((.TY <NTH ,ALLACS .NACS>))>>>
 359                       <SET NACS <+ .NACS 1>>)
 360                      (<L? <SET NACS <+ .NACS 2>> 7>
 361                       <SET ACS:BOT <REST <PUTREST .ACS:BOT
 362                                                   ((<NTH ,ALLACS <- .NACS 2>>
 363                                                    <NTH ,ALLACS <- .NACS 1>>))>>>)
 364                      (ELSE <SET ACS:TOP '(() STACK)>)>)>
 365         T>>
 366
 367 "Add code to set up a certain kind of argument."
 368
 369 <DEFINE PUT-DCL (COD ATM VAL DC COM "AUX" SPC DC1 TT SYM)
 370         #DECL ((DC1) FORM (ATM) ATOM (BNDL:BOT BNDL:TOP TT) LIST (COD) FIX
 371                (SYM) SYMTAB)
 372         <COND (<AND <TYPE? .DC FORM>
 373                     <SET DC1 .DC>
 374                     <==? <LENGTH .DC1> 2>
 375                     <OR <SET SPC <==? <1 .DC1> SPECIAL>>
 376                         <==? <1 .DC1> UNSPECIAL>>>
 377                <SET DC <2 .DC1>>)
 378               (ELSE <SET SPC .GLOSP>)>
 379         <SET SYM <ADDVAR .ATM .SPC .COD .ARGN T (.DC) <> .VAL>>
 380         <COND (<AND .COM <NOT <SPEC-SYM .SYM>>> ;"Can specials commute?"
 381                <SET TT <REST .BNDL:TOP>>
 382                <PUTREST .BNDL:TOP (.SYM !.TT)>
 383                <AND <EMPTY? .TT> <SET BNDL:BOT <REST .BNDL:TOP>>>)
 384               (ELSE <SET BNDL:BOT <REST <PUTREST .BNDL:BOT (.SYM)>>>)>
 385         .DC>
 386
 387 "Find decl associated with a variable, if none, use ANY."
 388
 389 <DEFINE FIND:DECL (ATM "OPTIONAL" (DC .DECLS))
 390         #DECL ((DC) <PRIMTYPE LIST> (ATM) ATOM)
 391         <REPEAT (TT)
 392                 #DECL ((TT) LIST)
 393                 <AND <OR <EMPTY? .DC> <EMPTY? <SET TT <REST .DC>>>>
 394                      <RETURN ANY>>
 395                 <COND (<NOT <TYPE? <1 .DC> LIST>>
 396                        <MESSAGE ERROR " BAD DECL LIST " .DC>)>
 397                 <AND <MEMQ .ATM <CHTYPE <1 .DC> LIST>> <RETURN <1 .TT>>>
 398                 <SET DC <REST .TT>>>>
 399
 400 "Add an AUX variable spec to structure."
 401
 402 <DEFINE PAUX (ATM OBJ DC NTUP "AUX" EV TT)
 403         #DECL ((EV TT) NODE (TUP NTUP) FIX (ATM) ATOM)
 404         <COND (<AND <TYPE? .OBJ FORM>
 405                     <NOT <EMPTY? .OBJ>>
 406                     <OR <==? <1 .OBJ> TUPLE> <==? <1 .OBJ> ITUPLE>>>
 407                <SET TT
 408                     <NODEFM <COND (<==? <1 .OBJ> TUPLE> ,COPY-CODE)
 409                                   (ELSE ,ISTRUC-CODE)>
 410                             ()
 411                             TUPLE
 412                             <1 .OBJ>
 413                             ()
 414                             ,<1 .OBJ>>>
 415                <COND (<==? <NODE-TYPE .TT> ,ISTRUC-CODE>
 416                       <SET EV
 417                            <PCOMP <COND (<==? <LENGTH .OBJ> 3> <3 .OBJ>)
 418                                         (ELSE #LOSE *000000000000*)>
 419                                   .TT>>
 420                       <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
 421                              <SET EV <PCOMP <NODE-NAME .EV> .TT>>
 422                                                                 ;"Reanalyze it."
 423                              <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
 424                       <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> .EV)>)
 425                      (ELSE
 426                       <PUT .TT
 427                            ,KIDS
 428                            <MAPF ,LIST
 429                                  <FUNCTION (O) <PCOMP .O .TT>>
 430                                  <REST .OBJ>>>)>)
 431               (ELSE <SET TT <PCOMP .OBJ ()>>)>
 432         <PUT-DCL .NTUP .ATM .TT .DC <>>>
 433
 434 "Main dispatch function during pass1."
 435
 436 <DEFINE PCOMP (OBJ PARENT)
 437         #DECL ((PARENT) <SPECIAL ANY> (VALUE) NODE)
 438         <APPLY <OR <GET .OBJ PTHIS-OBJECT>
 439                    <GET <TYPE .OBJ> PTHIS-TYPE>
 440                    ,PDEFAULT>
 441                 .OBJ>>
 442
 443 "Build a node for <> or #FALSE ()."
 444
 445 <DEFINE FALSE-QT (O)
 446         #DECL ((VALUE) NODE)
 447         <NODE1 ,QUOTE-CODE .PARENT FALSE <> ()>>
 448
 449 <PUT '<> PTHIS-OBJECT ,FALSE-QT>
 450
 451 "Build a node for ()."
 452
 453 <DEFINE NIL-QT (O) #DECL ((VALUE) NODE)
 454         <NODE1 ,QUOTE-CODE .PARENT LIST () ()>>
 455
 456 <PUT () PTHIS-OBJECT ,NIL-QT>
 457
 458 "Build a node for a LIST, VECTOR or UVECTOR."
 459
 460 <DEFINE PCOPY (OBJ "AUX" (TT <NODEFM ,COPY-CODE .PARENT <TYPE .OBJ> <TYPE .OBJ> () <>>))
 461         #DECL ((VALUE) NODE (TT) NODE)
 462         <PUT .TT ,KIDS
 463                  <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>>
 464
 465 <PUT VECTOR PTHIS-TYPE ,PCOPY>
 466
 467 <PUT UVECTOR PTHIS-TYPE ,PCOPY>
 468
 469 <PUT LIST PTHIS-TYPE ,PCOPY>
 470
 471 "Build a node for unknown things."
 472
 473 <DEFINE PDEFAULT (OBJ) #DECL ((VALUE) NODE)
 474         <NODE1 ,QUOTE-CODE .PARENT <TYPE .OBJ> .OBJ ()>>
 475
 476 "Further analyze a FORM and build appropriate node."
 477
 478 <DEFINE PFORM (OBJ) #DECL ((OBJ) <FORM ANY> (VALUE) NODE)
 479         <PROG APPLICATION ((APPLY <1 .OBJ>))
 480                 #DECL ((APPLICATION) <SPECIAL ACTIVATION>
 481                        (APPLY) <SPECIAL ANY>)
 482                 <APPLY <OR <GET .APPLY PAPPLY-OBJECT>
 483                            <GET <TYPE .APPLY> PAPPLY-TYPE>
 484                            ,PAPDEF>
 485                        .OBJ .APPLY>>>
 486
 487 <PUT FORM PTHIS-TYPE ,PFORM>
 488
 489 "Build a SEGMENT node."
 490
 491 <DEFINE SEG-FCN (OBJ "AUX" (TT <NODE1 ,SEGMENT-CODE .PARENT <> <> ()>))
 492         #DECL ((TT VALUE PARENT) NODE)
 493         <PUT .TT ,KIDS (<PFORM <CHTYPE .OBJ FORM>>)>>
 494
 495 <PUT SEGMENT PTHIS-TYPE ,SEG-FCN>
 496
 497 "Analyze a form or the form <ATM .....>"
 498
 499 <DEFINE ATOM-FCN (OB AP) #DECL ((AP) ATOM (VALUE) NODE)
 500         <COND (<GASSIGNED? .AP>
 501                <SET APPLY ,.AP>
 502                <AGAIN .APPLICATION>)
 503               (<ASSIGNED? .AP>
 504                <MESSAGE WARNING " LOCAL VALUE USED FOR " .AP>
 505                <SET APPLY ..AP>
 506                <AGAIN .APPLICATION>)
 507               (.REASONABLE
 508                <PSUBR-C .OB DUMMY>)
 509               (ELSE <MESSAGE WARNING " NO VALUE FOR " .AP>
 510                <PAPDEF .OB .AP>)>>
 511
 512 <PUT ATOM PAPPLY-TYPE ,ATOM-FCN>
 513
 514 "Expand MACRO and process result."
 515
 516 <DEFINE PMACRO (OBJ AP "AUX" ERR TEM)
 517         <SET ERR <ON "ERROR" ,MACROERR 100>>    ;"Turn On new Error"
 518         <SET TEM <PROG MACACT ()
 519                        #DECL ((MACACT) <SPECIAL ACTIVATION>)
 520                        <SETG MACACT .MACACT>
 521                        <EXPAND .OBJ>>>
 522         <OFF .ERR>                              ;"Turn OFF new Error"
 523         <COND (<TYPE? .TEM FUNNY>
 524                <MESSAGE ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
 525               (ELSE
 526                <PCOMP .TEM .PARENT>)>>
 527
 528 <NEWTYPE FUNNY VECTOR>
 529 <PROG (X)               ;"Find the real Valret Subr"
 530       <COND (<TYPE? ,VALRET SUBR> <SETG REAL-VALRET ,VALRET>)
 531             (<AND <GASSIGNED? <SET X <PARSE "OVALRET!-COMBAT!-">>>
 532                   <TYPE? ,.X SUBR>>
 533              <SETG REAL-VALRET ,.X>)
 534             (<NOT <GASSIGNED? REAL-VALRET>> <ERROR ',VALRET COMPILE>)>>
 535 <PUT MACRO PAPPLY-TYPE ,PMACRO>
 536
 537 <DEFINE MACROERR (FR "TUPLE" T)
 538         #DECL ((T) TUPLE)
 539         <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
 540                <DISMISS <CHTYPE [!.T] FUNNY> ,MACACT>)
 541               (ELSE <REAL-VALRET " ">)>>
 542
 543 "Build a node for a form whose 1st element is a form (could be NTH)."
 544
 545 <DEFINE PFORM-FORM (OBJ AP "AUX" TT)
 546         #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
 547         <COND (<AND <==? <LENGTH .OBJ> 2> <NOT <SEG? .OBJ>>>
 548                <SET TT <NODEFM ,FORM-F-CODE .PARENT <> .OBJ () .AP>>
 549                <PUT .TT ,KIDS
 550                     <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>)
 551               (ELSE <PAPDEF .OBJ .AP>)>>
 552
 553 <PUT FORM PAPPLY-TYPE ,PFORM-FORM>
 554
 555 "Build a node for strange forms."
 556
 557 <DEFINE PAPDEF (OBJ AP) #DECL ((VALUE) NODE)
 558         <MESSAGE WARNING " FORM NOT BEING COMPILED " .OBJ>
 559         <SPECIALIZE .OBJ>
 560         <NODEFM ,FORM-CODE .PARENT <> .OBJ  () .AP>>
 561
 562 "For objects that require EVAL, make sure all atoms used are special."
 563
 564 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
 565         #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
 566         <COND (<AND <TYPE? .OBJ FORM SEGMENT>
 567                     <SET OB <CHTYPE .OBJ FORM>>
 568                     <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
 569                              <==? <1 .OB> LVAL>
 570                              <TYPE? <SET SYM <2 .OB>> ATOM>>
 571                         <AND <==? .T1 3>
 572                              <==? <1 .OB> SET>
 573                              <TYPE? <SET SYM <2 .OB>> ATOM>>>
 574                     <SET T2 <SRCH-SYM .SYM>>>
 575                <COND (<NOT <SPEC-SYM .T2>>
 576                       <MESSAGE NOTE " REDCLARED SPECIAL " .SYM>
 577                       <PUT .T2 ,SPEC-SYM T>)>)>
 578         <COND (<MEMQ <PRIMTYPE .OBJ> '![FORM LIST UVECTOR VECTOR!]>
 579                <MAPF <> ,SPECIALIZE .OBJ>)>>
 580
 581 "Build a SUBR call node."
 582
 583 <DEFINE PSUBR-C (OBJ AP "AUX" (TT <NODEFM ,SUBR-CODE .PARENT <>
 584                                           <SUBR-NAME .AP <1 .OBJ>> () .AP>))
 585         #DECL ((TT) NODE (VALUE) NODE (OBJ) FORM)
 586         <PUT .TT ,KIDS
 587                  <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> <REST .OBJ>>>>
 588
 589 <PUT SUBR PAPPLY-TYPE ,PSUBR-C>
 590
 591 <FLOAD "SBRNAM" "NBIN">
 592
 593 <DEFINE SUBR-NAME (THING DEFAULT)
 594         <COND (<TYPE? .THING SUBR> <HACK-NAME .THING>)
 595               (<TYPE? .THING RSUBR RSUBR-ENTRY> <2 .THING>)
 596               (ELSE .DEFAULT)>>
 597
 598 <DEFINE FIX-FCN (OBJ AP "AUX" TT (LN <LENGTH .OBJ>))
 599         #DECL ((TT VALUE) NODE (OBJ) FORM)
 600         <OR <==? .LN 2> <==? .LN 3>
 601             <MESSAGE ERROR " BAD APPLICATION OF A NUMBER ">>
 602         <SET TT <NODEFM ,SUBR-CODE .PARENT <> <COND (<==? .LN 2> INTH)(ELSE IPUT)>
 603                          () <COND (<==? .LN 2> ,NTH) (ELSE ,PUT)>>>
 604         <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT><PCOMP .AP .TT>
 605                         !<COND (<==? .LN 2> ()) (ELSE (<PCOMP <3 .OBJ> .TT>))>)>>
 606
 607 <PUT FIX PAPPLY-TYPE ,FIX-FCN>
 608
 609 <PUT OFFSET PAPPLY-TYPE ,FIX-FCN>
 610
 611 "PROG/REPEAT node."
 612
 613 <DEFINE PPROG-REPEAT (OBJ AP
 614                       "AUX" (NAME <1 .OBJ>) TT (DCL #DECL ()) (HATOM <>) ARGL
 615                             (VARTBL .VARTBL))
 616         #DECL ((OBJ) <PRIMTYPE LIST> (TT) NODE (VALUE) NODE (DCL) DECL
 617                (ARGL) LIST (VARTBL) <SPECIAL SYMTAB>)
 618         <AND <EMPTY? <SET OBJ <REST .OBJ>>>
 619             <MESSAGE ERROR " EMPTY " .NAME>>
 620         <AND <TYPE? <1 .OBJ> ATOM>
 621             <SET HATOM <1 .OBJ>>
 622             <SET OBJ <REST .OBJ>>>
 623         <SET ARGL <1 .OBJ>>
 624         <SET OBJ <REST .OBJ>>
 625         <AND <NOT <EMPTY? .OBJ>>
 626              <TYPE? <1 .OBJ> DECL>
 627              <SET DCL <1 .OBJ>>
 628              <SET OBJ <REST .OBJ>>>
 629         <AND <EMPTY? .OBJ> <MESSAGE ERROR " NO DODY FOR " .NAME>>
 630         <SET TT
 631              <NODEPR ,PROG-CODE
 632                      .PARENT
 633                      <FIND:DECL VALUE .DCL>
 634                      .NAME
 635                      ()
 636                      .AP
 637                      <2 <GEN-D <COND (<AND <NOT <EMPTY? .ARGL>>
 638                                            <TYPE? <1 .ARGL> STRING>>
 639                                       .ARGL)
 640                                      (ELSE ("AUX" !.ARGL))>
 641                                .DCL
 642                                .HATOM>>
 643                      .HATOM
 644                      .VARTBL>>
 645         <ACT-FIX .TT <BINDING-STRUCTURE .TT>>
 646         <PUT .TT
 647              ,KIDS
 648              <MAPF ,LIST <FUNCTION (O) <PCOMP .O .TT>> .OBJ>>
 649         .TT>
 650
 651 <PUT ,PROG PAPPLY-OBJECT ,PPROG-REPEAT>
 652
 653 <PUT ,REPEAT PAPPLY-OBJECT ,PPROG-REPEAT>
 654
 655 <PUT ,BIND PAPPLY-OBJECT ,PPROG-REPEAT>
 656
 657 "Unwind compiler."
 658
 659 <DEFINE UNWIND-FCN (OBJ AP "AUX" (TT <NODEFM ,UNWIND-CODE .PARENT <>
 660                                                  <1 .OBJ> () .AP>))
 661         #DECL ((PARENT VALUE TT) NODE (OBJ) FORM)
 662         <COND (<==? <LENGTH .OBJ> 3>
 663                <PUT .TT ,KIDS (<PCOMP <2 .OBJ> .TT> <PCOMP <3 .OBJ> .TT>)>)
 664               (ELSE <MESSAGE ERROR "WRONG # OF ARGS TO UNWIND " .OBJ>)>>
 665
 666 <PUT ,UNWIND PAPPLY-OBJECT ,UNWIND-FCN>
 667
 668 "Build a node for a COND."
 669
 670 <DEFINE COND-FCN (OBJ AP "AUX" (PARENT <NODECOND ,COND-CODE .PARENT <> COND ()>))
 671         #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
 672         <PUT .PARENT ,KIDS
 673              <MAPF ,LIST
 674                     <FUNCTION (CLA "AUX" (TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>))
 675                         #DECL ((TT) NODE)
 676                         <COND (<AND <TYPE? .CLA LIST> <NOT <EMPTY? .CLA>>>
 677                                <PUT .TT ,PREDIC <PCOMP <1 .CLA> .TT>>
 678                                <PUT .TT ,CLAUSES
 679                                  <MAPF ,LIST
 680                                        <FUNCTION (O) <PCOMP .O .TT>>
 681                                                      <REST .CLA>>>)
 682                                (ELSE <MESSAGE ERROR "BAD COND" .OBJ>)>>
 683                     <REST .OBJ>>>>
 684
 685 <PUT ,COND PAPPLY-OBJECT ,COND-FCN>
 686
 687 <PUT ,AND PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
 688
 689 <PUT ,OR PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
 690
 691 <PUT ,STACKFORM PAPPLY-OBJECT <GET SUBR PAPPLY-TYPE>>
 692
 693 "Build a node for '<\b-object>\b-."
 694
 695 <DEFINE QUOTE-FCN (OBJ AP "AUX" (TT <NODE1 ,QUOTE-CODE .PARENT <> () ()>))
 696         #DECL ((TT VALUE) NODE (OBJ) FORM)
 697         <COND (<NOT <EMPTY? <REST .OBJ>>>
 698                <PUT .TT ,RESULT-TYPE <TYPE <2 .OBJ>>>
 699                <PUT .TT ,NODE-NAME <2 .OBJ>>)>>
 700
 701 <PUT ,QUOTE PAPPLY-OBJECT ,QUOTE-FCN>
 702
 703 "Build a node for a call to an RSUBR."
 704
 705 <DEFINE RSUBR-FCN (OBJ AP "AUX" (PARENT <NODEFM ,RSUBR-CODE .PARENT <><1 .OBJ> () .AP>))
 706         #DECL ((OBJ) FORM (AP) <OR RSUBR-ENTRY RSUBR> (PARENT) <SPECIAL NODE>
 707                (VALUE) NODE)
 708         <COND (<AND <G? <LENGTH .AP> 2>
 709                     <TYPE? <3 .AP> DECL>>
 710                <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <3 .AP>>>
 711                <PUT .PARENT ,TYPE-INFO
 712                     <MAPF ,LIST
 713                           <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>)
 714               (ELSE <PSUBR-C .OBJ .AP>)>>
 715
 716 <PUT RSUBR PAPPLY-TYPE ,RSUBR-FCN>
 717
 718 <PUT RSUBR-ENTRY PAPPLY-TYPE <GET RSUBR PAPPLY-TYPE>>
 719
 720 <DEFINE INTERNAL-RSUBR-FCN (OBJ AP
 721                             "AUX" (PARENT <NODEFM ,IRSUBR-CODE .PARENT <>
 722                                                   <1 .OBJ> () .AP>))
 723         #DECL ((OBJ) FORM (AP) IRSUBR (PARENT) <SPECIAL NODE>)
 724         <PUT .PARENT ,KIDS <PRSUBR-C <1 .OBJ> .OBJ <1 .AP>>>
 725         <PUT .PARENT ,TYPE-INFO
 726                     <MAPF ,LIST
 727                           <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
 728
 729 <PUT IRSUBR PAPPLY-TYPE ,INTERNAL-RSUBR-FCN>
 730
 731 "Predicate:  any segments in this object?"
 732
 733 <DEFINE SEG? (OB) #DECL ((OB) <PRIMTYPE LIST>)
 734         <REPEAT ()
 735                 <AND <EMPTY? .OB> <RETURN <>>>
 736                 <AND <TYPE? <1 .OB> SEGMENT> <RETURN T>>
 737                 <SET OB <REST .OB>>>>
 738
 739
 740 "Analyze a call to an RSUBR with decls checking number of args and types wherever
 741  possible."
 742
 743 <DEFINE PRSUBR-C (NAME OBJ RDCL
 744                   "AUX" (DOIT ,INIT-R) (SEGSW <>) (SGD '<>) (SGP '(1)) SGN
 745                         (IX 0) DC (RM ,RMODES) (ARG-NUMBER 0) (KDS (()))
 746                         (TKDS .KDS) RMT (OB <REST .OBJ>) (ST <>))
 747    #DECL ((TKDS KDS) <SPECIAL LIST> (OB) LIST (OBJ) <SPECIAL <PRIMTYPE LIST>>
 748           (RM) <SPECIAL <VECTOR [REST STRING]>> (ARG-NUMBER) FIX
 749           (RDCL) <SPECIAL <PRIMTYPE LIST>> (DOIT SEGSW) <SPECIAL ANY> (IX) FIX
 750           (NAME) <SPECIAL ANY> (SGD) FORM (SGP) <LIST ANY> (SGN) NODE)
 751    <REPEAT RSB ()
 752      #DECL ((RSB) <SPECIAL ACTIVATION>)
 753      <COND
 754       (<NOT <EMPTY? .RDCL>>
 755        <COND (<NOT <EMPTY? .RM>>
 756               <SET DC <1 .RDCL>>
 757               <SET RDCL <REST .RDCL>>)>
 758        <COND
 759         (<TYPE? .DC STRING>
 760          <COND (<=? .DC "OPT"> <SET DC "OPTIONAL">)>
 761          <OR <SET RMT <MEMBER .DC .RM>>
 762                  <MESSAGE ERROR "BAD STRING IN RSUBR DECL " .NAME>>
 763          <SET RM .RMT>
 764          <SET DOIT <NTH ,RDOIT <SET IX <LENGTH .RM>>>>
 765          <SET ST <APPLY <NTH ,SDOIT .IX> .ST>>
 766          <COND (<EMPTY? .RM>                                      ;"TUPLE seen."
 767                 <SET DC <GET-ELE-TYPE <1 .RDCL> ALL>>)>)
 768         (<COND
 769           (<EMPTY? .OB>
 770            <AND <L? <LENGTH .RM> 4> <RETURN <REST .TKDS>>>
 771            <MESSAGE ERROR " TOO FEW ARGS TO " .NAME>)
 772           (.SEGSW
 773            <SET ST <>>
 774            <COND (<EMPTY? .RM>
 775                   <PUTREST .SGP ([REST .DC])>
 776                   <PUT .SGN ,RESULT-TYPE <TYPE-AND <RESULT-TYPE .SGN> .SGD>>
 777                   <RETURN <REST .TKDS>>)
 778                  (ELSE <SET SGP <REST <PUTREST .SGP (.DC)>>>)>)
 779           (<TYPE? <1 .OB> SEGMENT>
 780            <SET KDS
 781                 <REST <PUTREST .KDS (<SET SGN <SEGCHK <1 .OB>>>)>>>
 782            <COND
 783             (<EMPTY? <REST .OB>>
 784              <COND (<EMPTY? .RM>
 785                     <PUT .SGN
 786                          ,RESULT-TYPE
 787                          <SEGCH1 .DC <RESULT-TYPE .SGN> <1 .OB>>>
 788                     <RETURN <REST .TKDS>>)
 789                    (ELSE <SET SEGSW T>)>)
 790             (ELSE
 791              <PUTREST
 792               .KDS
 793               <MAPF ,LIST
 794                <FUNCTION (O "AUX" TT)
 795                   <SET TT <PCOMP .O .PARENT>>
 796                   <COND
 797                    (<EMPTY? .RM>
 798                     <COND
 799                      (<==? <NODE-TYPE .TT> ,SEGMENT-CODE>
 800                       <OR <TYPE-OK? <RESULT-TYPE <1 <KIDS .TT>>>
 801                                     <FORM STRUCTURED [REST .DC]>>
 802                           <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>)
 803                      (ELSE
 804                       <OR <TYPE-OK? <RESULT-TYPE .TT> .DC>
 805                           <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>
 806                       <OR <RESULT-TYPE .TT> <PUT .TT ,RESULT-TYPE .DC>>)>)>
 807                   .TT>
 808                <REST .OB>>>
 809              <RETURN <REST .TKDS>>)>
 810            <SET SGP
 811                 <REST <CHTYPE <SET SGD <FORM STRUCTURED .DC>> LIST>>>
 812            <SET ST <>>
 813            <AGAIN>)
 814           (<SET KDS <REST <PUTREST .KDS (<APPLY .DOIT .DC .OB>)>>>
 815            <SET OB <REST .OB>>
 816            <SET ARG-NUMBER <+ .ARG-NUMBER 1>>
 817            <SET ST <>>)>)>)
 818       (<EMPTY? .OB> <RETURN <REST .TKDS>>)
 819       (.SEGSW
 820        <PUT .SGN
 821             ,RESULT-TYPE
 822             <COND (<RESULT-TYPE .SGN> <TYPE-AND <RESULT-TYPE .SGN> .SGD>)
 823                   (ELSE .SGD)>>
 824        <RETURN <REST .TKDS>>)
 825       (ELSE <MESSAGE ERROR " TOO MANY ARGS TO " .NAME>)>>>
 826 \f
 827
 828 <DEFINE SQUOT (F) T>
 829
 830 "Flush one possible decl away."
 831
 832 <DEFINE CHOPPER (F) #DECL ((RM) <VECTOR [REST STRING]>)
 833         <AND .F <MESSAGE ERROR " 2 STRINGS IN ROW IN DCL ">>
 834         <SET RM <REST .RM>>
 835         T>
 836
 837 "Handle Normal arg when \"VALUE\" still possible."
 838
 839 <DEFINE INIT-R (DC OB)
 840         #DECL ((RM) <VECTOR [REST STRING]>)
 841         <SET RM <REST .RM 2>> <SET DOIT ,INIT1-R> <INIT1-R .DC .OB>>
 842
 843 "Handle Normal arg when \"CALL\" still possible."
 844
 845 <DEFINE INIT2-R (DC OB)
 846         #DECL ((RM) <VECTOR [REST STRING]>)
 847         <SET RM <REST .RM>> <SET DOIT ,INIT1-R> <INIT1-R .DC .OB>>
 848
 849 "Handle normal arg."
 850
 851 <DEFINE INIT1-R (DC OB "AUX" TT) #DECL ((TT) NODE (OB) LIST)
 852         <OR <TYPE-OK?
 853                     <RESULT-TYPE
 854                         <SET TT <PCOMP <1 .OB> .PARENT>>> .DC>
 855                 <MESSAGE ERROR "BAD ARG TO " .NAME>>
 856         <OR <RESULT-TYPE .TT><PUT .TT ,RESULT-TYPE .DC>>
 857         .TT>
 858
 859 "Handle \"QUOTE\" arg."
 860
 861 <DEFINE QINIT-R (DC OB "AUX" TT) #DECL ((TT) NODE (OB) LIST)
 862         <OR <TYPE-OK?
 863                    <RESULT-TYPE
 864                         <SET TT
 865                              <NODE1 ,QUOTE-CODE .PARENT <TYPE <1 .OB>>
 866                                     <1 .OB> ()>>> .DC>
 867                 <MESSAGE ERROR "BAD ARG TO " .NAME>>
 868         <SET DOIT ,INIT1-R>
 869         .TT>
 870
 871 "Handle \"CALL\" decl."
 872
 873 <DEFINE CAL-R (DC OB "AUX" TT) #DECL ((TKDS KDS) LIST (TT) NODE)
 874         <OR <TYPE-OK?
 875                    <RESULT-TYPE
 876                         <SET TT
 877                              <NODE1 ,QUOTE-CODE .PARENT FORM .OBJ ()>>> .DC>
 878                 <MESSAGE ERROR "BAD ARG TO " .NAME>>
 879         <PUTREST .KDS (.TT)>
 880         <RETURN <REST .TKDS> .RSB>>
 881
 882 "Handle \"ARGS\" decl."
 883
 884 <DEFINE ARGS-R (DC OB "AUX" TT) #DECL ((TT) NODE (KDS TKDS) LIST)
 885         <OR <TYPE-OK?
 886                      <RESULT-TYPE
 887                         <SET TT
 888                              <NODE1 ,QUOTE-CODE .PARENT LIST .OB ()>>> .DC>
 889                 <MESSAGE "BAD CALL TO " .NAME>>
 890         <PUTREST .KDS (.TT)>
 891         <RETURN <REST .TKDS> .RSB>>
 892
 893 "Handle \"TUPLE\" decl."
 894
 895 <DEFINE TUPL-R (DC OB "AUX" TT) #DECL ((OB) LIST (TT) NODE)
 896         <OR <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP <1 .OB> .PARENT>>> .DC>
 897            <MESSAGE ERROR "BAD ARG TO " .NAME>>
 898         <OR <RESULT-TYPE .TT> <PUT .TT ,RESULT-TYPE .DC>>
 899         .TT>
 900
 901 "Handle stuff with segments in arguments."
 902
 903 <DEFINE SEGCHK (OB "AUX" TT) #DECL ((TT) NODE)
 904         <OR <TYPE-OK? <RESULT-TYPE <SET TT <PCOMP .OB .PARENT>>> STRUCTURED>
 905             <MESSAGE ERROR "BAD SEGMENT GOODIE. " .OB>>
 906         .TT>
 907
 908
 909 <DEFINE SEGCH1 (DC RT OB)
 910         <OR <TYPE-AND .RT <FORM STRUCTURED [REST .DC]>>
 911             <MESSAGE ERROR "BAD ARG TO " .NAME .OB>>>
 912
 913 "Handle \"VALUE\" chop decl and do the rest."
 914
 915 <DEFINE VAL-R (F) #DECL ((RDCL) <PRIMTYPE LIST> (PARENT) NODE)
 916         <CHOPPER .F>
 917         <PUT .PARENT ,RESULT-TYPE <1 .RDCL>>
 918         <SET DOIT ,INIT2-R>
 919         <SET F <TYPE? <1 .RDCL> STRING>>
 920         <SET RDCL <REST .RDCL>> .F>
 921
 922 <DEFINE ERR-R (DC OB)
 923         <MESSAGE INCONISTANCY "SHOULDN'T GET HERE ">>
 924
 925 <SETG RMODES ["VALUE" "CALL" "QUOTE" "OPTIONAL" "QUOTE" "ARGS" "TUPLE"]>
 926
 927 <SETG RDOIT ![,TUPL-R ,ARGS-R ,QINIT-R ,INIT1-R ,QINIT-R ,CAL-R ,ERR-R!]>
 928
 929 <SETG SDOIT ![,CHOPPER ,CHOPPER ,SQUOT ,CHOPPER ,SQUOT ,CHOPPER ,VAL-R!]>
 930
 931 <GDECL (RMODES) <VECTOR [REST STRING]> (RDOIT SDOIT) UVECTOR>
 932
 933 "Create a node for a call to a function."
 934
 935 <DEFINE PFUNC (OB AP "AUX" TEM NAME)
 936         #DECL ((OB) <PRIMTYPE LIST> (VALUE) NODE)
 937         <COND (<TYPE? <1 .OB> ATOM>
 938                <COND (<OR <==? <1 .OB> .FCNS>
 939                           <AND <TYPE? .FCNS LIST> <MEMQ <1 .OB> <CHTYPE .FCNS LIST>>>>
 940                       <RSUBR-CALL2 ,<1 .OB> <1 .OB> .OB>)
 941                      (<SET TEM <GET <1 .OB> RSUB-DEC>>
 942                       <RSUBR-CALL3 .TEM <1 .OB> .OB>)
 943                      (.REASONABLE <PSUBR-C .OB DUMMY>)
 944                      (ELSE
 945                       <MESSAGE WARNING "UNCOMPILED FUNCTION CALLED " <1 .OB>>
 946                       <PAPDEF .OB ,<1 .OB>>)>)
 947               (<TYPE? <1 .OB> FUNCTION>
 948                <SET NAME <MAKE:TAG "ANONF">>
 949                <ANONF .NAME <1 .OB>>
 950                <RSUBR-CALL1 ,.NAME .NAME .OB>)>>
 951
 952 "Call compiler recursively to compile anonymous function."
 953
 954 <DEFINE ANONF (NAME BODY "AUX" (INT? <>) T GROUP-NAME)
 955         #DECL ((INT? GROUP-NAME) <SPECIAL <OR FALSE ATOM>> (VALUE) NODE)
 956         <MESSAGE NOTE " COMPILING ANONYMOUS FUNCTION ">
 957         <SETG .NAME .BODY>
 958         <APPLY ,COMP2 .NAME T> ; "Use APPLY to avoid compilation probs."
 959         <SET T ,.NAME>
 960         <MESSAGE NOTE " FINISHED ANONYMOUS FUNCTION ">
 961         <GUNASSIGN .NAME>
 962         <NODE1 ,QUOTE-CODE .PARENT RSUBR  .T ()>>
 963
 964 "#FUNCTION (....) compiler -- call ANONF."
 965
 966 <DEFINE FCN-FCN (OB "AUX" (NAME <MAKE:TAG "ANONF">)) <ANONF .NAME .OB>>
 967
 968 <PUT FUNCTION PTHIS-TYPE ,FCN-FCN>
 969
 970 <PUT FUNCTION PAPPLY-TYPE ,PFUNC>
 971
 972 "<FUNCTION (..) ....> compiler -- call ANONF."
 973
 974 <DEFINE FCN-FCN1 (OB AP "AUX" (NAME <MAKE:TAG "ANONF">))
 975         #DECL ((OB) <PRIMTYPE LIST>)
 976         <ANONF .NAME <CHTYPE <REST .OB> FUNCTION>>>
 977
 978 <PUT ,FUNCTION PAPPLY-OBJECT ,FCN-FCN1>
 979
 980 "Handle RSUBR that is really a function."
 981
 982 <DEFINE RSUBR-CALL2 (BODY NAME OBJ "AUX" ACF
 983                         (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
 984         #DECL ((PARENT) <SPECIAL NODE> (VALUE) NODE)
 985         <PUT .PARENT
 986              ,KIDS
 987              <PRSUBR-C .NAME .OBJ <RSUBR-DECLS <SET ACF <PASS1 .BODY .NAME T .NAME>>>>>
 988         <PUT .PARENT ,TYPE-INFO
 989                     <MAPF ,LIST
 990                           <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
 991
 992 "Handle an RSUBR that is already an RSUBR."
 993
 994 <DEFINE RSUBR-CALL1 (BODY NAME OBJ "AUX"
 995                         (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () .BODY>))
 996         #DECL ((BODY) <PRIMTYPE LIST> (PARENT) <SPECIAL NODE>
 997                (VALUE) NODE)
 998         <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ <3 .BODY>>>
 999         <PUT .PARENT ,TYPE-INFO
1000                     <MAPF ,LIST
1001                           <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
1002
1003 <DEFINE RSUBR-CALL3 (DC NAME OBJ "AUX"
1004                         (PARENT <NODEFM ,RSUBR-CODE .PARENT <> .NAME () FOO>))
1005         #DECL ((PARENT) <SPECIAL NODE>
1006                (VALUE) NODE)
1007         <PUT .PARENT ,KIDS <PRSUBR-C .NAME .OBJ .DC>>
1008         <PUT .PARENT ,TYPE-INFO
1009                     <MAPF ,LIST
1010                           <FUNCTION (X) <RESULT-TYPE .X>> <KIDS .PARENT>>>>
1011
1012 \f
1013 ;"ILIST, ISTRING, IVECTOR AND IUVECTOR"
1014
1015 <DEFINE PLIST (O A) <PSTRUC .O .A ILIST LIST>>
1016
1017 <PUT ,ILIST PAPPLY-OBJECT ,PLIST>
1018
1019 <DEFINE PIVECTOR (O A) <PSTRUC .O .A IVECTOR VECTOR>>
1020
1021 <PUT ,IVECTOR PAPPLY-OBJECT ,PIVECTOR>
1022
1023 <DEFINE PISTRING (O A) <PSTRUC .O .A ISTRING STRING>>
1024
1025 <PUT ,ISTRING PAPPLY-OBJECT ,PISTRING>
1026
1027 <DEFINE PIUVECTOR (O A) <PSTRUC .O .A IUVECTOR UVECTOR>>
1028
1029 <PUT ,IUVECTOR PAPPLY-OBJECT ,PIUVECTOR>
1030
1031 <DEFINE PIFORM (O A) <PSTRUC .O .A IFORM FORM>>
1032
1033 <PUT ,IFORM PAPPLY-OBJECT ,PIFORM>
1034
1035 <DEFINE PIBYTES (O A) <PSTRUC .O .A IBYTES BYTES>>
1036
1037 <PUT ,IBYTES PAPPLY-OBJECT ,PIBYTES>
1038
1039 <DEFINE PSTRUC (OBJ AP NAME TYP "AUX" (TT <NODEFM ,ISTRUC-CODE .PARENT .TYP .NAME
1040                                                   () ,.NAME>)
1041                                       (LN <LENGTH .OBJ>) N EV SIZ)
1042         #DECL ((VALUE N EV TT) NODE (LN) FIX (OBJ) <PRIMTYPE LIST>)
1043         <COND (<SEG? .OBJ><PSUBR-C .OBJ .AP>)
1044               (ELSE
1045                <COND (<==? .NAME IBYTES>
1046                       <COND (<L=? .LN 2> <ARGCHK 2 3 .NAME>)
1047                             (<G? .LN 4> <ARGCHK .LN 4 .NAME>)>)
1048                      (<1? .LN><ARGCHK 1 2 .NAME>)
1049                      (<G? .LN 3><ARGCHK .LN 3 .NAME>)>
1050                <COND (<==? .NAME IBYTES>
1051                       <SET SIZ <PCOMP <2 .OBJ> .TT>>
1052                       <SET OBJ <REST .OBJ>>
1053                       <SET LN <- .LN 1>>)>
1054                <SET N <PCOMP <2 .OBJ> .TT>>
1055                <SET EV <PCOMP <COND (<==? .LN 3> <3 .OBJ>)
1056                                     (<==? .TYP STRING> <ASCII 0>)
1057                                     (<==? .TYP BYTES> 0)
1058                                     (ELSE #LOSE 0)> .TT>>
1059                <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1060                       <SET EV <PCOMP <NODE-NAME .EV> .TT>>      ;"Reanalyze it."
1061                       <PUT .TT ,NODE-TYPE ,ISTRUC2-CODE>)>
1062                <PUT .TT ,RESULT-TYPE .TYP>
1063                <COND (<ASSIGNED? SIZ> <PUT .TT ,KIDS (.SIZ .N .EV)>)
1064                      (ELSE <PUT .TT ,KIDS (.N .EV)>)>)>>
1065
1066 \f
1067
1068 "READ, READCHR, READSTRING, NEXTCHR, READB, GET, GETL, GETPROP, GETPL"
1069
1070 <PUT ,READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READ 2 ANY>>>
1071
1072 <PUT ,GC-READ PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A GC-READ 2 ANY>>>
1073
1074 <PUT ,READCHR PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READCHR 2 ANY>>>
1075
1076 <PUT ,NEXTCHR PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A NEXTCHR 2 ANY>>>
1077
1078 <PUT ,READB PAPPLY-OBJECT <FUNCTION (O A) <CHANFCNS .O .A READB 3 ANY>>>
1079
1080 <PUT ,READSTRING
1081      PAPPLY-OBJECT
1082      <FUNCTION (O A) <CHANFCNS .O .A READSTRING 4 ANY>>>
1083
1084 <DEFINE CHANFCNS (OBJ AP NAME ARGN TYP "AUX" TT (LN <LENGTH .OBJ>) N (TEM 0))
1085         #DECL ((VALUE) NODE (TT) NODE (N) <LIST [REST NODE]>
1086                (LN) FIX (TEM ARGN) FIX (OBJ) <PRIMTYPE LIST>)
1087         <COND (<OR <SEG? .OBJ> <L? <- .LN 1> .ARGN>>
1088                <PSUBR-C .OBJ .AP>)
1089               (ELSE
1090                <SET TT <NODEFM ,READ-EOF-CODE .PARENT .TYP .NAME () ,.NAME>>
1091                <SET N
1092                     <MAPF ,LIST
1093                           <FUNCTION (OB "AUX" (EV <PCOMP .OB .TT>))
1094                                 #DECL ((EV) NODE)
1095                                 <COND (<==? <SET TEM <+ .TEM 1>> .ARGN>
1096                                        <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1097                                               <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1098                                               <PUT .TT ,NODE-TYPE ,READ-EOF2-CODE>)>
1099                                        <SET EV
1100                                             <NODE1 ,EOF-CODE .TT
1101                                                    <RESULT-TYPE .EV> <> (.EV)>>)>
1102                                 .EV>
1103                            <REST .OBJ>>>
1104                <PUT .TT ,KIDS .N>)>>
1105
1106 <PUT ,GET PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GET>>>
1107
1108 <PUT ,GETL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETL>>>
1109
1110 <PUT ,GETPROP PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPROP>>>
1111
1112 <PUT ,GETPL PAPPLY-OBJECT <FUNCTION (O A) <GETFCNS .O .A GETPL>>>
1113
1114 <DEFINE GETFCNS (OBJ AP NAME "AUX" EV TEM T2 (LN <LENGTH .OBJ>) TT)
1115         #DECL ((OBJ) FORM (LN) FIX (TT VALUE TEM T2 EV) NODE)
1116         <COND (<OR <AND <N==? .LN 4>
1117                         <N==? .LN 3>> <SEG? .OBJ>>
1118                <PSUBR-C .OBJ .AP>)
1119               (ELSE
1120                <SET TT <NODEFM ,GET-CODE .PARENT ANY .NAME () ,.NAME>>
1121                <SET TEM <PCOMP <2 .OBJ> .TT>>
1122                <SET T2 <PCOMP <3 .OBJ> .TT>>
1123                <COND (<==? .LN 3>
1124                       <PUT .TT ,NODE-TYPE ,GET2-CODE>
1125                       <PUT .TT ,KIDS (.TEM .T2)>)
1126                      (ELSE
1127                       <SET EV <PCOMP <4 .OBJ> .TT>>
1128                       <COND (<==? <NODE-TYPE .EV> ,QUOTE-CODE>
1129                              <SET EV <PCOMP <NODE-NAME .EV> .TT>>
1130                              <PUT .TT ,NODE-TYPE ,GET2-CODE>)>
1131                       <PUT .TT ,KIDS (.TEM .T2 .EV)>)>
1132                .TT)>>
1133
1134 <DEFINE ARGCHK (GIV REQ NAME "AUX" (HI .REQ) (LO .REQ))
1135         #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
1136         <COND (<TYPE? .REQ LIST>
1137                <SET HI <2 .REQ>>
1138                <SET LO <1 .REQ>>)>
1139         <COND (<L? .GIV .LO>
1140                <MESSAGE ERROR "TOO FEW ARGS TO " .NAME>)
1141               (<G? .GIV .HI>
1142                <MESSAGE ERROR "TOO MANY ARGS TO " .NAME>)> T>
1143
1144 <ENDPACKAGE>
1145