mim/development/mim/mimc/symana.mud

   1
   2 <PACKAGE "SYMANA">
   3
   4 <ENTRY ANA
   5        EANA
   6        SET-CURRENT-TYPE
   7        TYPE-NTH-REST
   8        WHO
   9        TMPS
  10        GET-TMP
  11        TRUTH
  12        UNTRUTH
  13        SEGFLUSH
  14        KILL-REM
  15        BUILD-TYPE-LIST
  16        GET-CURRENT-TYPE
  17        ADD-TYPE-LIST
  18        PUT-FLUSH
  19        WHON
  20        SAVE-SURVIVORS
  21        SEQ-AN
  22        ARGCHK
  23        ASSUM-OK?
  24        FREST-L-D-STATE
  25        HTMPS
  26        ORUPC
  27        APPLTYP
  28        MSAVE-L-D-STATE
  29        SHTMPS
  30        RESET-VARS
  31        STMPS
  32        ASSERT-TYPES
  33        SAVE-L-D-STATE
  34        MUNG-L-D-STATE
  35        NORM-BAN
  36        SUBR-C-AN
  37        ENTROPY
  38        NAUX-BAN
  39        TUP-BAN
  40        ARGS-BAN
  41        LIFE
  42        MANIFESTQ
  43        SPEC-FLUSH
  44        UPDATE-SIDE-EFFECTS>
  45
  46 <USE "CHKDCL"
  47      "COMPDEC"
  48      "STRANA"
  49      "CARANA"
  50      "NOTANA"
  51      "ADVMESS"
  52      "MAPANA"
  53      "SUBRTY"
  54      "BITSANA"
  55      "CDRIVE">
  56
  57 "       This is the main file associated with the type analysis phase of
  58 the compilation.  It is called by calling FUNC-ANA with the main data structure
  59 pointer.   ANA is the FUNCTION that dispatches to the various special handlers
  60 and the SUBR call analyzer further dispatches for specific functions."
  61
  62 "       Many analyzers for specific SUBRs appear in their own files
  63 (CARITH, STRUCT etc.).  Currently no special hacks are done for TYPE?, EMPTY?
  64 etc. in COND, ANDS and ORS."
  65
  66 "       All analysis functions are called with 2 args, a NODE and a desired
  67 type specification.  These args are usually called NOD and RTYP or
  68 N and R."
  69
  70 " ANA is the main analysis dispatcher (see ANALYZERS at the end of
  71   this file for its dispatch table."
  72
  73 <GDECL (TEMPLATES SUBRS) VECTOR>
  74
  75 <DEFINE ANA (NOD RTYP "AUX" (P <PARENT .NOD>))
  76         #DECL ((NOD) NODE (P) ANY (TEM TT) <OR FALSE LIST>)
  77         <COND (<G=? <LENGTH .NOD> <INDEX ,SIDE-EFFECTS>>
  78                <PUT .NOD ,SIDE-EFFECTS <>>)>
  79         <PUT .NOD ,RESULT-TYPE <ANALYSIS-DISPATCHER .NOD .RTYP>>
  80         <UPDATE-SIDE-EFFECTS .NOD .P>
  81         <RESULT-TYPE .NOD>>
  82
  83 <DEFINE UPDATE-SIDE-EFFECTS (NOD P "AUX" TEM TT)
  84    #DECL ((NOD) NODE (TEM TT) <OR FALSE LIST>)
  85    <COND
  86     (<AND <N==? <NODE-TYPE .NOD> ,QUOTE-CODE>
  87           <SET TEM <SIDE-EFFECTS .NOD>>
  88           <REPEAT ()
  89                   <COND (<NOT <TYPE? .P NODE>> <RETURN <>>)>
  90                   <COND (<G=? <LENGTH .P> <CHTYPE <INDEX ,SIDE-EFFECTS> FIX>>
  91                          <RETURN T>)>
  92                   <SET P <PARENT .P>>>>
  93      <PUT
  94       .P
  95       ,SIDE-EFFECTS
  96       <COND (<EMPTY? .TEM> <SIDE-EFFECTS .P>)
  97             (<EMPTY? <SET TT <SIDE-EFFECTS .P>>> .TEM)
  98             (<AND <MEMQ ALL .TEM> <MEMQ ALL .TT>>
  99              <COND (<G? <LENGTH .TEM> <LENGTH .TT>>
 100                     <SET TT
 101                          <MAPF ,LIST
 102                                <FUNCTION (IT)
 103                                        <COND (<AND <N==? .IT ALL>
 104                                                    <NOT <MEMQ .IT .TEM>>> .IT)
 105                                              (ELSE <MAPRET>)>>
 106                                .TT>>
 107                     <COND (<EMPTY? .TT> .TEM)
 108                           (ELSE
 109                            <PUTREST <REST .TT <- <LENGTH .TT> 1>> .TEM>
 110                            .TT)>)
 111                    (ELSE
 112                     <SET TT
 113                          <MAPF ,LIST
 114                                <FUNCTION (IT)
 115                                        <COND (<AND <N==? .IT ALL>
 116                                                    <NOT <MEMQ .IT .TT>>> .IT)
 117                                              (ELSE <MAPRET>)>>
 118                                .TEM>>
 119                     <COND (<EMPTY? .TEM> .TT)
 120                           (ELSE
 121                            <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .TT>
 122                            .TEM)>)>)
 123             (<G? <LENGTH .TT> <LENGTH .TEM>> (!.TEM !.TT))
 124             (ELSE (!.TT !.TEM))>>)>>
 125
 126 <DEFINE ARGCHK (GIV REQ NAME NOD "AUX" (HI .REQ) (LO .REQ))
 127         #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX> (NOD) NODE)
 128         <COND (<TYPE? .REQ LIST> <SET HI <2 .REQ>> <SET LO <1 .REQ>>)>
 129         <COND (<L? .GIV .LO>
 130                <COMPILE-ERROR "Too many arguments to:  " .NAME .NOD>)
 131               (<G? .GIV .HI>
 132                <COMPILE-ERROR "Too many arguments to:  " .NAME .NOD>)>
 133         T>
 134
 135 <DEFINE EANA (NOD RTYP NAME)
 136         #DECL ((NOD) NODE)
 137         <COND (<ANA .NOD .RTYP>)
 138               (ELSE <COMPILE-ERROR "Argument wrong type to: " .NAME .NOD>)>>
 139
 140 " FUNC-ANA main entry to analysis phase.  Analyzes bindings then body."
 141
 142 <DEFINE FUNC-ANA ANA-ACT (N R
 143                           "AUX" (ANALY-OK
 144                                  <COND (<ASSIGNED? ANALY-OK> .ANALY-OK)
 145                                        (ELSE T)>) (OV .VERBOSE))
 146         #DECL ((ANA-ACT) <SPECIAL ANY> (ANALY-OK) <SPECIAL ANY>)
 147         <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
 148         <FUNC-AN1 .N .R>>
 149
 150 <DEFINE FUNC-AN1 (FCN RTYP
 151                   "AUX" (VARTBL <SYMTAB .FCN>) (TMPS 0) (HTMPS 0) (TRUTH ())
 152                         (UNTRUTH ()) (WHO ()) (WHON <>) (PRED <>) TEM (LIFE ())
 153                         (USE-COUNT 0) (BACKTRACK 0) NRTYP)
 154    #DECL ((FCN) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB>
 155           (TMPS BACKTRACK USE-COUNT HTMPS) <SPECIAL FIX>
 156           (LIFE TRUTH UNTRUTH) <SPECIAL LIST> (WHO PRED WHON) <SPECIAL ANY>)
 157    <RESET-VARS .VARTBL>
 158    <BIND-AN <BINDING-STRUCTURE .FCN>>
 159    <COND (<NOT <SET NRTYP <TYPE-OK? .RTYP <INIT-DECL-TYPE .FCN>>>>
 160           <COMPILE-ERROR "Function returns wrong type: "
 161                          <NODE-NAME .FCN>
 162                          ".  Declared type is "
 163                          <INIT-DECL-TYPE .FCN>
 164                          ", required type is "
 165                          .RTYP>)>
 166    <PROG ((ACT? <ACTIV? <BINDING-STRUCTURE .FCN> T>) (OV .VERBOSE))
 167          <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
 168          <PUT .FCN ,AGND <>>
 169          <PUT .FCN ,LIVE-VARS ()>
 170          <SET LIFE ()>
 171          <PUT .FCN ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
 172          <PUT .FCN ,ACCUM-TYPE <COND (.ACT? .RTYP) (ELSE NO-RETURN)>>
 173          <SET TEM <SEQ-AN <KIDS .FCN> <INIT-DECL-TYPE .FCN>>>
 174          <COND (.ACT? <SPEC-FLUSH> <PUT-FLUSH ALL>)>
 175          <COND
 176           (<OR <AND <OR <AGND .FCN> .ACT?>
 177                     <NOT <ASSUM-OK? <ASSUM .FCN>
 178                                     <OR <AGND .FCN>
 179                                         <BUILD-TYPE-LIST .VARTBL>>>>>
 180                <AND <NOT .ACT?>
 181                     <SET ACT? <ACTIV? <BINDING-STRUCTURE .FCN> T>>
 182                     <ASSERT-TYPES <ASSUM .FCN>>>>
 183            <AGAIN>)>>
 184    <PUT .FCN ,ASSUM ()>
 185    <PUT .FCN ,DEAD-VARS ()>
 186    <COND (<NOT .TEM>
 187           <COMPILE-ERROR "Returned value violates decl of: " .NRTYP>)>
 188    <PUT .FCN ,RESULT-TYPE <TYPE-MERGE <ACCUM-TYPE .FCN> .TEM>>
 189    <PUT <RSUBR-DECLS .FCN> 2 <TASTEFUL-DECL <RESULT-TYPE .FCN>>>
 190    <RESULT-TYPE .FCN>>
 191
 192 " BIND-AN analyze binding structure for PROGs, FUNCTIONs etc."
 193
 194 <DEFINE BIND-AN (BNDS "AUX" COD)
 195         #DECL ((BNDS) <LIST [REST SYMTAB]> (COD) FIX)
 196         <REPEAT (SYM)
 197                 #DECL ((SYM) SYMTAB)
 198                 <COND (<EMPTY? .BNDS> <RETURN>)>
 199                 <PUT <SET SYM <1 .BNDS>> ,COMPOSIT-TYPE ANY>
 200                 <PUT .SYM ,CURRENT-TYPE <>>
 201                 <BIND-DISPATCH .SYM>
 202                 <SET BNDS <REST .BNDS>>>>
 203
 204 " ENTROPY ignore call and return."
 205
 206 <DEFINE ENTROPY (SYM) T>
 207
 208 <DEFINE TUP-BAN (SYM)
 209         #DECL ((SYM) SYMTAB)
 210         <COND (<NOT .ANALY-OK>
 211                <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>
 212                <PUT .SYM ,CURRENT-TYPE ANY>)
 213               (<N==? <ISTYPE? <DECL-SYM .SYM>> TUPLE>
 214                <PUT .SYM ,COMPOSIT-TYPE TUPLE>
 215                <PUT .SYM ,CURRENT-TYPE TUPLE>)
 216               (ELSE
 217                <PUT .SYM ,CURRENT-TYPE <DECL-SYM .SYM>>
 218                <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>)>>
 219
 220 " Analyze AUX and OPTIONAL intializations."
 221
 222 <DEFINE NORM-BAN (SYM
 223                   "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD (N <INIT-SYM .SYM>))
 224         #DECL ((VARTBL) <SPECIAL SYMTAB> (SYM) SYMTAB (COD) FIX (N) NODE)
 225         <COND (<NOT <SET TEM <ANA .N <DECL-SYM .SYM>>>>
 226                <COMPILE-ERROR "AUX/OPT init for:  "
 227                               <NAME-SYM .SYM>
 228                               ".  Init value of: "
 229                               .N
 230                               " whose type is "
 231                               <RESULT-TYPE .N>
 232                               " violates decl of "
 233                               <DECL-SYM .SYM>>)>
 234         <COND (<AND .ANALY-OK
 235                     <OR <G? <SET COD <CODE-SYM .SYM>> ,ARGL-OPT>
 236                         <L? .COD ,ARGL-QIOPT>>>
 237                <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
 238                       <COND (<==? <NODE-NAME .N> <>> <SET TEM BOOL-FALSE>)
 239                             (<==? <NODE-NAME .N> T> <SET TEM BOOL-TRUE>)>)>
 240                <PUT .SYM ,CURRENT-TYPE .TEM>
 241                <PUT .SYM ,COMPOSIT-TYPE .TEM>)
 242               (ELSE
 243                <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>
 244                <PUT .SYM ,CURRENT-TYPE <DECL-SYM .SYM>>)>>
 245
 246 " ARGS-BAN analyze ARGS decl (change to OPTIONAL in some cases)."
 247
 248 <DEFINE ARGS-BAN (SYM)
 249         #DECL ((SYM) SYMTAB)
 250         <PUT .SYM ,INIT-SYM <NODE1 ,QUOTE-CODE () LIST () ()>>
 251         <PUT .SYM ,CODE-SYM ,ARGL-IOPT>
 252         <COND (.ANALY-OK <PUT .SYM ,COMPOSIT-TYPE LIST>)
 253               (ELSE <PUT .SYM ,COMPOSIT-TYPE <DECL-SYM .SYM>>)>
 254         <COND (.ANALY-OK
 255                <PUT .SYM ,CURRENT-TYPE <TYPE-AND LIST <DECL-SYM .SYM>>>)
 256               (<NOT .ANALY-OK> <PUT .SYM ,CURRENT-TYPE ANY>)>>
 257
 258 <DEFINE NAUX-BAN (SYM)
 259         #DECL ((SYM) SYMTAB)
 260         <PUT .SYM
 261              ,COMPOSIT-TYPE
 262              <COND (.ANALY-OK NO-RETURN) (ELSE <DECL-SYM .SYM>)>>
 263         <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN) (ELSE ANY)>>>
 264
 265 "BIND-DISPATCH go to various binding analyzers analyzers."
 266
 267 <DEFINE BIND-DISPATCH (SYM "AUX" (COD <CODE-SYM .SYM>))
 268         <CASE ,==?
 269               .COD
 270               (,ARGL-ACT <ENTROPY .SYM>)
 271               (,ARGL-IAUX <NORM-BAN .SYM>)
 272               (,ARGL-AUX <NAUX-BAN .SYM>)
 273               (,ARGL-TUPLE <TUP-BAN .SYM>)
 274               (,ARGL-ARGS <ARGS-BAN .SYM>)
 275               (,ARGL-QIOPT <NORM-BAN .SYM>)
 276               (,ARGL-IOPT <NORM-BAN .SYM>)
 277               (,ARGL-QOPT <ENTROPY .SYM>)
 278               (,ARGL-OPT <ENTROPY .SYM>)
 279               (,ARGL-CALL <ENTROPY .SYM>)
 280               (,ARGL-BIND <ENTROPY .SYM>)
 281               (,ARGL-QUOTE <ENTROPY .SYM>)
 282               (,ARGL-ARG <ENTROPY .SYM>)>>
 283
 284 " SEQ-AN analyze a sequence of NODES discarding values until the last."
 285
 286 <DEFINE SEQ-AN (L FTYP "OPTIONAL" (DO-PRED <>) "AUX" (SOA <>) VAL)
 287    #DECL ((L) <LIST [REST NODE]>)
 288    <COND
 289     (<EMPTY? .L> <COMPILE-LOSSAGE "Empty KIDS list in SEQ-AN">)
 290     (ELSE
 291      <SET VAL
 292       <REPEAT (TT N X Y TMP (RES NO-RETURN) (SPCD <>) ENDIF-FLAG
 293                (RET-OR-AGAIN <>))
 294         #DECL ((X) NODE (Y) <LIST [REST NODE]> (RET-OR-AGAIN) <SPECIAL ANY>)
 295         <SET N <1 .L>>
 296         <SET ENDIF-FLAG <>>
 297         <COND
 298          (<OR <AND <EMPTY? <SET L <REST .L>>> <NOT <IFSYS-ENDIF? .N "ENDIF">>>
 299               <AND <NOT <EMPTY? .L>>
 300                    <IFSYS-ENDIF? <1 .L> "ENDIF">
 301                    <SET ENDIF-FLAG T>>>
 302           <COND (<AND .DO-PRED <EMPTY? .L>>
 303                  <PROG ((PRED <PARENT .N>)) #DECL ((PRED) <SPECIAL ANY>)
 304                        <SET TT <ANA .N .FTYP>>>)
 305                 (ELSE
 306                  <SET TT <ANA .N .FTYP>>)>
 307           <COND (<AND .ENDIF-FLAG .SPCD>
 308                  <ASSERT-TYPES <ORUPC .VARTBL .SPCD>>
 309                  <SET SPCD <>>)>
 310           <SET RES <TYPE-MERGE .TT .RES>>)
 311          (<IFSYS-ENDIF? .N "IFSYS">
 312           <SET TT <ANA .N ANY>>
 313           <SET SPCD <BUILD-TYPE-LIST .VARTBL>>)
 314          (ELSE
 315           <SET TT <ANA .N ANY>>
 316           <COND
 317            (<OR <L? <LENGTH .N> <CHTYPE <INDEX ,SIDE-EFFECTS> FIX>>
 318                 <NOT <SIDE-EFFECTS .N>>>
 319             <COND
 320              (<NOT .RET-OR-AGAIN>
 321               <COND
 322                (<AND .VERBOSE <NOT <EMPTY? .L>>>
 323                 <ADDVMESS
 324                  <PARENT .N>
 325                  ("This object has no side-effects and its value is ignored"
 326                   .N)>)>)
 327              (ELSE <PUTPROP .N DONT-FLUSH-ME T>)>)>)>
 328         <COND (<NOT .TT> <SET SOA .RET-OR-AGAIN> <RETURN <>>)>
 329         <COND
 330          (<==? .TT NO-RETURN>
 331           <COND (<AND .VERBOSE <NOT <EMPTY? .L>>>
 332                  <ADDVMESS <PARENT .N>
 333                            ("This object ends a sequence of forms"
 334                             .N
 335                             " because it never returns")>)>
 336           <SET SOA .RET-OR-AGAIN>
 337           <RETURN NO-RETURN>)>
 338         <COND (<EMPTY? .L> <SET SOA .RET-OR-AGAIN> <RETURN .RES>)>>>
 339      <COND (.SOA <SET RET-OR-AGAIN T>)>
 340      .VAL)>>
 341
 342 <DEFINE IFSYS-ENDIF? (N STR "AUX" Y NM)
 343         #DECL ((N) NODE (Y) <LIST [REST NODE]>)
 344         <AND <==? <NODE-TYPE .N> ,CALL-CODE>
 345              <G? <LENGTH <SET Y <KIDS .N>>> 1>
 346              <TYPE? <SET NM <NODE-NAME <1 .Y>>> ATOM>
 347              <=? <SPNAME .NM> .STR>>>
 348
 349 " ANALYZE ASSIGNED? usage."
 350
 351 <DEFINE ASSIGNED?-ANA (NOD RTYP
 352                        "AUX" (TEM <KIDS .NOD>) TT T1 T2 (TY '<OR ATOM
 353                                                                  FALSE>))
 354    #DECL ((TT NOD) NODE (T1) SYMTAB (TEM) <LIST [REST NODE]>)
 355    <COND
 356     (<EMPTY? .TEM> <COMPILE-ERROR "No arguments ASSIGNED?: " .NOD>)
 357     (<SEGFLUSH .NOD .RTYP>)
 358     (ELSE
 359      <EANA <SET TT <1 .TEM>> ATOM ASSIGNED?>
 360      <COND (<AND <EMPTY? <REST .TEM>>
 361                  <==? <NODE-TYPE .TT> ,QUOTE-CODE>
 362                  <SET T2 <SRCH-SYM <NODE-NAME .TT>>>
 363                  <NOT <==? <CODE-SYM <SET T1 .T2>> -1>>>
 364             <PUT .NOD ,NODE-TYPE ,ASSIGNED?-CODE>
 365             <PUT .NOD ,NODE-NAME .T1>
 366             <PUT .T1 ,ASS? T>
 367             <PUT .T1 ,USED-AT-ALL T>
 368             <PUT .T1 ,USAGE-SYM <+ <USAGE-SYM .T1> 1>>
 369             <REVIVE .NOD .T1>
 370             <SET TY
 371                  <COND (<==? <GET-CURRENT-TYPE .T1> NO-RETURN> BOOL-FALSE)
 372                        (ELSE BOOLEAN)>>)
 373            (<==? <LENGTH .TEM> 2>
 374             <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> ASSIGNED?>)
 375            (<EMPTY? <REST .TEM>>
 376             <COND (<AND .VERBOSE <==? <NODE-TYPE .TT> ,QUOTE-CODE>>
 377                    <ADDVMESS .NOD
 378                              ("External reference to LVAL:  "
 379                               <NODE-NAME .TT>)>)>
 380             <PUT .NOD ,NODE-TYPE ,ASSIGNED?-CODE>
 381             <SET TY BOOLEAN>)
 382            (ELSE <COMPILE-ERROR "Too many args to ASSIGNED?: " .NOD>)>)>
 383    <TYPE-OK? .TY .RTYP>>
 384
 385 <COND (<GASSIGNED? ASSIGNED?-ANA>
 386        <PUTPROP ,ASSIGNED? ANALYSIS ,ASSIGNED?-ANA>)>
 387
 388 " ANALYZE LVAL usage.  Become either direct reference or PUSHJ"
 389
 390 <DEFINE LVAL-ANA (NOD RTYP
 391                   "AUX" TEM ITYP (TT <>) T1 T2 T3 (P <PARENT .NOD>) NT)
 392    #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (T1) SYMTAB (WHO) LIST)
 393    <COND (<EMPTY? <SET TEM <KIDS .NOD>>>
 394           <COMPILE-ERROR "No arguments LVAL: " .NOD>)
 395          (<SEGFLUSH .NOD .RTYP>)
 396          (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB>
 397                         <SET TT <NODE-NAME .NOD>>>
 398                    <AND <EANA <1 .TEM> ATOM LVAL>
 399                         <EMPTY? <REST .TEM>>
 400                         <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
 401                         <==? <RESULT-TYPE <1 .TEM>> ATOM>
 402                         <SET TT <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
 403                <COND (<==? .WHON .P> <SET WHO ((<> .TT) !.WHO)>) (ELSE T)>
 404                <PROG ()
 405                      <SET ITYP <GET-CURRENT-TYPE .TT>>
 406                      T>
 407                <COND (<AND <==? .PRED .P>
 408                            <SET T2 <TYPE-OK? .ITYP FALSE>>
 409                            <SET T3 <TYPE-OK? .ITYP '<NOT FALSE>>>>
 410                       <SET TRUTH <ADD-TYPE-LIST .TT .T3 .TRUTH <>>>
 411                       <SET UNTRUTH <ADD-TYPE-LIST .TT .T2 .UNTRUTH <>>>)
 412                      (<AND <N==? .PRED .P>
 413                            <OR <NOT <TYPE? .P NODE>>
 414                                <AND <N==? <SET NT <NODE-TYPE .P>> ,SET-CODE>
 415                                     <N==? .NT ,NOT-CODE>
 416                                     <OR <N==? .NT ,SUBR-CODE>
 417                                         <AND <N==? <NODE-SUBR .P> ,SET>
 418                                              <N==? <NODE-SUBR .P> ,NOT>>>>>
 419                            <MEMQ .ITYP '[BOOL-TRUE BOOL-FALSE BOOLEAN]>>
 420                       <SET-CURRENT-TYPE .TT <SET ITYP <GET-DECL .ITYP>>>
 421                       T)
 422                      (ELSE T)>
 423                <NOT <==? <CODE-SYM <SET T1 .TT>> -1>>>
 424           <PUT .NOD ,NODE-TYPE ,LVAL-CODE>
 425           <REVIVE .NOD .T1>
 426           <PUT .T1 ,RET-AGAIN-ONLY <>>
 427           <PUT .T1 ,USED-AT-ALL T>
 428           <PUT .T1 ,USAGE-SYM <+ <USAGE-SYM .T1> 1>>
 429           <PUT .NOD ,NODE-NAME .T1>
 430           <SET ITYP <TYPE-OK? .ITYP .RTYP>>
 431           <COND (.ITYP <SET-CURRENT-TYPE .T1 .ITYP>)>
 432           .ITYP)
 433          (<EMPTY? <REST .TEM>>
 434           <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
 435                  <ADDVMESS .NOD
 436                            ("External variable being referenced: "
 437                             <NODE-NAME <1 .TEM>>)>)>
 438           <PUT .NOD ,NODE-TYPE ,FLVAL-CODE>
 439           <AND .TT <PUT .NOD ,NODE-NAME <SET T1 .TT>>>
 440           <COND (.TT <TYPE-OK? <DECL-SYM .T1> .RTYP>) (ELSE .RTYP)>)
 441          (<AND <==? <LENGTH .TEM> 2>
 442                <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> LVAL>>
 443           ANY)
 444          (ELSE <COMPILE-ERROR "Too many args to LVAL: " .NOD>)>>
 445
 446 <COND (<GASSIGNED? LVAL-ANA> <PUTPROP ,LVAL ANALYSIS ,LVAL-ANA>)>
 447
 448 " SET-ANA analyze uses of SET."
 449
 450 <DEFINE SET-ANA (NOD RTYP
 451                  "AUX" (TEM <KIDS .NOD>) (LN <LENGTH .TEM>) T1 (T2 ATOM) T11
 452                        (NM <2 <CHTYPE <NODE-SUBR .NOD> MSUBR>>) (WHON .WHON)
 453                        (PRED .PRED) OTYP T3 XX N)
 454    #DECL ((N NOD) NODE (TEM) <LIST [REST NODE]> (LN) FIX (T1) SYMTAB
 455           (WHON PRED) <SPECIAL ANY> (WHO) LIST)
 456    <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
 457    <COND
 458     (<SEGFLUSH .NOD .RTYP>)
 459     (<OR <AND <==? .NM SET> <L? .LN 2>>
 460          <AND <==? .NM UNASSIGN> <==? .LN 0>>>
 461      <COMPILE-ERROR "Too few arguments to:  " .NOD>)
 462     (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET T11 <NODE-NAME .NOD>>>
 463               <AND <EANA <1 .TEM> ATOM .NM>
 464                    <OR <AND <==? .NM SET> <==? .LN 2>>
 465                        <AND <==? .NM UNASSIGN> <==? .LN 1>>>
 466                    <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
 467                    <SET T11 <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
 468           <COND (<==? .WHON <PARENT .NOD>>
 469                  <SET WHON .NOD>
 470                  <SET WHO ((T .T11) !.WHO)>)
 471                 (ELSE T)>
 472           <COND (<==? .PRED <PARENT .NOD>> <SET PRED .NOD>) (ELSE T)>
 473           <SET T1 .T11>
 474           <COND (<AND <==? .NM SET>
 475                       <NOT <SET T2 <ANA <SET N <2 .TEM>>
 476                                         <DECL-SYM .T1>>>>>
 477                  <COMPILE-ERROR "Decl violation:  " <NAME-SYM .T1> .NOD>)
 478                 (ELSE T)>>
 479      <PUT .T1 ,PURE-SYM <>>
 480      <SET XX <DECL-SYM .T1>>
 481      <PUT .T1 ,USAGE-SYM <+ <USAGE-SYM .T1> 1>>
 482      <SET OTYP <OR <CURRENT-TYPE .T1> ANY>>
 483      <COND (<AND <==? <CODE-SYM .T1> -1> .VERBOSE>
 484             <ADDVMESS .NOD ("External variable being SET (or UNASSIGNed):  "
 485                             <NAME-SYM .T1>)>)>
 486      <COND (<==? .NM SET> <SET T2 <OR <TYPE-AND .T2 .RTYP> .T2>>)>
 487      <COND (<N==? .NM SET>
 488             <TYPE-INFO .NOD (<> <>)>)
 489            (<SET OTYP <TYPESAME .OTYP .T2>> <PUT .NOD ,TYPE-INFO (.OTYP <>)>)
 490            (ELSE <PUT .NOD ,TYPE-INFO (<> <>)>)>
 491      <PUT .NOD
 492           ,NODE-TYPE
 493           <COND (<==? <CODE-SYM .T1> -1> ,FSET-CODE) (ELSE ,SET-CODE)>>
 494      <PUT .NOD ,NODE-NAME .T1>
 495      <MAKE-DEAD .NOD .T1>
 496      <COND (<AND <==? .NM SET> <==? <NODE-TYPE .N> ,QUOTE-CODE>>
 497             <COND (<==? <NODE-NAME .N> <>> <SET T2 BOOL-FALSE>)
 498                   (<==? <NODE-NAME .N> T> <SET T2 BOOL-TRUE>)>)>
 499      <SET-CURRENT-TYPE .T1 <COND (<==? .NM SET> .T2)(ELSE NO-RETURN)>>
 500      <PUT .T1 ,USED-AT-ALL T>
 501      <COND (<==? .NM SET>
 502             <COND (<AND <==? .PRED .NOD>
 503                         <SET OTYP <TYPE-OK? .T2 '<NOT FALSE>>>
 504                         <SET T3 <TYPE-OK? .T2 FALSE>>>
 505                    <SET TRUTH <ADD-TYPE-LIST .T1 .OTYP .TRUTH T>>
 506                    <SET UNTRUTH <ADD-TYPE-LIST .T1 .T3 .UNTRUTH T>>)>
 507             <TYPE-OK? .T2 .RTYP>)
 508            (ELSE
 509             <TYPE-OK? .T2 .RTYP>)>)
 510     (<AND <==? .NM SET> <L? .LN 4>>
 511      <SET T11 <ANA <2 .TEM> ANY>>
 512      <COND (<==? .LN 2>
 513             <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
 514                    <ADDVMESS .NOD
 515                              ("External variable being SET: "
 516                               <NODE-NAME <1 .TEM>>)>)>
 517             <PUT .NOD ,NODE-TYPE ,FSET-CODE>)
 518            (ELSE <EANA <3 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> SET>)>
 519      <TYPE-OK? .T11 .RTYP>)
 520     (<AND <==? .NM UNASSIGN> <L? .LN 3>>
 521      <COND (<==? .LN 1>
 522             <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
 523                    <ADDVMESS .NOD
 524                              ("External variable being UNASSIGNed: "
 525                               <NODE-NAME <1 .TEM>>)>)>
 526             <PUT .NOD ,NODE-TYPE ,FSET-CODE>)
 527            (ELSE <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> SET>)>)
 528     (ELSE <COMPILE-ERROR "Too many args to SET: " .NOD>)>>
 529
 530 <DEFINE MULTI-SET-ANA (NOD RTYP
 531                        "AUX" (K <KIDS .NOD>) (LN 0) (WHON .WHON) (PRED .PRED)
 532                              (SEG? <>) (N <1 .K>) (L-OF-A <NODE-NAME .N>)
 533                              L-OF-SY TY TY1 TTY FTY)
 534    #DECL ((N NOD) NODE (TEM) <LIST [REST NODE]> (LN) FIX (T1) SYMTAB
 535           (WHON PRED) <SPECIAL ANY> (WHO) LIST (L-OF-A L-OF-SY) LIST)
 536    <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
 537    <SET L-OF-SY
 538     <MAPR ,LIST
 539      <FUNCTION (AL NL
 540                 "AUX" (ATM:<OR ADECL ATOM LIST SYMTAB> <1 .AL>) (N:NODE <1 .NL>)
 541                       (NT:FIX <NODE-TYPE .N>) SY)
 542              <COND
 543               (<OR <==? .NT ,SEGMENT-CODE> <==? .NT ,SEG-CODE>>
 544                <MAPSTOP !<MULTI-SET-SEG .NOD .AL .NL>>)
 545               (ELSE
 546                <COND (<AND <EMPTY? <REST .AL>> <NOT <EMPTY? <REST .NL>>>>
 547                       <COMPILE-ERROR "Too many values for vars:  " .NOD>)
 548                      (<AND <NOT <EMPTY? <REST .AL>>> <EMPTY? <REST .NL>>>
 549                       <COMPILE-ERROR "Too few values for vars:  " .NOD>)>
 550                <SET TY1 ANY>
 551                <COND (<TYPE? .ATM ATOM>
 552                       <COND (<SET SY <SRCH-SYM .ATM>> <SET ATM .SY>)>)
 553                      (<TYPE? .ATM ADECL>
 554                       <COND (<SET SY <SRCH-SYM <1 .ATM>>>
 555                              <SET TY1 <2 .ATM>>
 556                              <SET ATM .SY>)
 557                             (ELSE
 558                              <SET TY1 <2 .ATM>>
 559                              <SET ATM <1 .ATM>>)>)
 560                      (<TYPE? .ATM LIST>
 561                       <SET TY1 <1 .ATM>>
 562                       <SET ATM <2 .ATM>>)>
 563                <COND (<TYPE? .ATM SYMTAB>
 564                       <COND (<AND <==? .WHON <PARENT .NOD>>
 565                                   <EMPTY? <REST .AL>>>
 566                              <SET WHON .NOD>
 567                              <SET WHO ((T .ATM) !.WHO)>)>
 568                       <COND (<AND <==? .PRED <PARENT .NOD>>
 569                                   <EMPTY? <REST .AL>>>
 570                              <SET PRED .NOD>)>
 571                       <COND (<OR <NOT <SET TY <TYPE-OK? .TY1 <DECL-SYM .ATM>>>>
 572                                  <NOT <SET TY <ANA .N .TY>>>>
 573                              <COMPILE-ERROR "Decl violation: "
 574                                             <NAME-SYM .N>
 575                                             .NOD>)>
 576                       <PUT .ATM ,PURE-SYM <>>
 577                       <PUT .ATM ,USAGE-SYM <+ <USAGE-SYM .ATM> 1>>
 578                       <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
 579                              <COND (<==? <NODE-NAME .N> <>>
 580                                     <SET TY BOOL-FALSE>)
 581                                    (<==? <NODE-NAME .N> T>
 582                                     <SET TY BOOL-TRUE>)>)>
 583                       <SET-CURRENT-TYPE .ATM .TY>
 584                       <PUT .ATM ,USED-AT-ALL T>
 585                       <COND (<AND <==? .PRED .NOD>
 586                                   <SET TTY <TYPE-OK? .TY '<NOT FALSE>>>
 587                                   <SET FTY <TYPE-OK? .TY FALSE>>>
 588                              <SET TRUTH <ADD-TYPE-LIST .ATM .TTY .TRUTH T>>
 589                              <SET UNTRUTH
 590                                   <ADD-TYPE-LIST .ATM .FTY .UNTRUTH T>>)>)
 591                      (ELSE <SET TY <ANA .N .TY1>>)>
 592                <COND (<AND .VERBOSE
 593                            <OR <AND <TYPE? .ATM SYMTAB>
 594                                     <==? <CODE-SYM .ATM> -1>
 595                                     <SET ATM <NAME-SYM .ATM>>>
 596                                <TYPE? .ATM ATOM>>>
 597                       <ADDVMESS .NOD ("External variable being SET: " .ATM)>)>
 598                (.ATM .TY1))>>
 599      .L-OF-A
 600      <REST .K>>>
 601    <PUT .NOD ,NODE-NAME .L-OF-SY>
 602    <PUT .NOD ,NODE-TYPE ,MULTI-SET-CODE>
 603    <TYPE-OK? <2 <NTH .L-OF-SY <LENGTH .L-OF-SY>>> .RTYP>>
 604
 605 <DEFINE MULTI-SET-SEG (NOD:NODE AL:LIST NL:<LIST [REST NODE]>
 606                        "AUX" (MIN-LN:FIX 0) (MAX-LN:FIX 0)
 607                              (LN:FIX <LENGTH .AL>) (COMPOSIT-DECL NO-RETURN)
 608                              (COMPOSIT-TYPE NO-RETURN) L-OF-SY:LIST)
 609    <SET L-OF-SY
 610         <MAPF ,LIST
 611               <FUNCTION (ATM:<OR ADECL ATOM LIST SYMTAB> "AUX" SY (TY ANY))
 612                       <COND (<TYPE? .ATM ATOM>
 613                              <COND (<SET SY <SRCH-SYM .ATM>> <SET ATM .SY>)>)
 614                             (<TYPE? .ATM ADECL>
 615                              <COND (<SET SY <SRCH-SYM <1 .ATM>>>
 616                                     <SET TY <2 .ATM>>
 617                                     <SET ATM .SY>)
 618                                    (ELSE
 619                                     <SET TY <2 .ATM>>
 620                                     <SET ATM <1 .ATM>>)>)
 621                             (<TYPE? .ATM LIST>
 622                              <SET TY <1 .ATM>>
 623                              <SET ATM <2 .ATM>>)>
 624                       <COND (<TYPE? .ATM SYMTAB>
 625                              <COND (<NOT <SET TY <TYPE-AND <DECL-SYM .ATM> .TY>>>
 626                                     <COMPILE-ERROR "ADECL and DECL mismatch:  "
 627                                                    <NAME-SYM .ATM>
 628                                                    .NOD>)>
 629                              <SET COMPOSIT-DECL
 630                                   <TYPE-MERGE .COMPOSIT-DECL .TY>>
 631                              <PUT .ATM ,PURE-SYM <>>
 632                              <PUT .ATM ,USAGE-SYM <+ <USAGE-SYM .ATM> 1>>
 633                              <PUT .ATM ,USED-AT-ALL T>)>
 634                       (.ATM .TY)>
 635               .AL>>
 636    <MAPF <>
 637     <FUNCTION (N:NODE "AUX" (NT:FIX <NODE-TYPE .N>) TY ET)
 638        <COND
 639         (<OR <==? .NT ,SEG-CODE> <==? .NT ,SEGMENT-CODE>>
 640          <SET TY <EANA <SET N <1 <KIDS .N>>> '<OR MULTI STRUCTURED> MULTI-SET>>
 641          <COND (<N==? .COMPOSIT-DECL ANY>
 642                 <COND (<NOT <SET ET
 643                                  <TYPE-OK? <GET-ELE-TYPE .TY ALL>
 644                                            .COMPOSIT-DECL>>>
 645                        <COMPILE-ERROR "Decl violation: " .NOD>)>)
 646                (ELSE <SET ET <GET-ELE-TYPE .TY ALL>>)>
 647          <SET COMPOSIT-TYPE <TYPE-MERGE .ET .COMPOSIT-TYPE>>
 648          <SET MAX-LN <MAX <+ .MAX-LN <MAXL .TY>> ,MAX-LENGTH>>
 649          <SET MIN-LN <+ .MIN-LN <MINL .TY>>>)
 650         (ELSE
 651          <SET COMPOSIT-TYPE
 652               <TYPE-MERGE <EANA .N .COMPOSIT-DECL MULTI-SET> .COMPOSIT-TYPE>>
 653          <SET MAX-LN <MAX <+ .MAX-LN 1> ,MAX-LENGTH>>
 654          <SET MIN-LN <+ .MIN-LN 1>>)>>
 655     .NL>
 656    <MAPF <>
 657     <FUNCTION (SY)
 658             <COND (<TYPE? <SET SY <1 .SY>> SYMTAB>
 659                    <SET-CURRENT-TYPE
 660                     .SY <TYPE-AND .COMPOSIT-TYPE <DECL-SYM .SY>>>)>>
 661     .L-OF-SY>
 662    <COND (<G? .MIN-LN .LN> <COMPILE-ERROR "Too many values:  " .NOD>)
 663          (<L? .MAX-LN .LN> <COMPILE-ERROR "Too few values:  " .NOD>)>
 664    .L-OF-SY>
 665
 666 <COND (<GASSIGNED? SET-ANA>
 667        <PUTPROP ,SET ANALYSIS ,SET-ANA>
 668        <PUTPROP ,UNASSIGN ANALYSIS ,SET-ANA>)>
 669
 670 <DEFINE MUNG-L-D-STATE (V)
 671         #DECL ((V) <OR VECTOR SYMTAB>)
 672         <REPEAT ()
 673                 <COND (<TYPE? .V VECTOR> <RETURN>)>
 674                 <PUT .V ,DEATH-LIST ()>
 675                 <SET V <NEXT-SYM .V>>>>
 676
 677 <DEFINE MRESTORE-L-D-STATE (L1 L2 V)
 678         <RESTORE-L-D-STATE .L1 .V>
 679         <RESTORE-L-D-STATE .L2 .V T>>
 680
 681 <DEFINE FREST-L-D-STATE (L)
 682         #DECL ((L) LIST)
 683         <MAPF <>
 684               <FUNCTION (LL)
 685                       #DECL ((LL) <LIST SYMTAB <LIST [REST NODE]>>)
 686                       <COND (<NOT <2 <TYPE-INFO <1 <2 .LL>>>>>
 687                              <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
 688               .L>>
 689
 690 <DEFINE RESTORE-L-D-STATE (L V "OPTIONAL" (FLG <>))
 691    #DECL ((L) <LIST [REST <LIST SYMTAB LIST>]> (V) <OR SYMTAB VECTOR>)
 692    <COND (<NOT .FLG>
 693           <REPEAT (DL)
 694                   #DECL ((DL) <LIST [REST NODE]>)
 695                   <COND (<TYPE? .V VECTOR> <RETURN>)>
 696                   <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
 697                               <NOT <2 <TYPE-INFO <1 .DL>>>>>
 698                          <PUT .V ,DEATH-LIST ()>)>
 699                   <SET V <NEXT-SYM .V>>>)>
 700    <REPEAT (S DL)
 701      #DECL ((DL) <LIST NODE> (S) SYMTAB)
 702      <COND (<EMPTY? .L> <RETURN>)>
 703      <SET S <1 <1 .L>>>
 704      <AND .FLG
 705           <REPEAT ()
 706                   <COND (<==? .S .V> <RETURN>) (<TYPE? .V VECTOR> <RETURN>)>
 707                   <PUT .V
 708                        ,DEATH-LIST
 709                        <MAPF ,LIST
 710                              <FUNCTION (N)
 711                                      #DECL ((N) NODE)
 712                                      <COND (<==? <NODE-TYPE .N> ,SET-CODE>
 713                                             <MAPRET>)
 714                                            (ELSE .N)>>
 715                              <DEATH-LIST .V>>>
 716                   <SET V <NEXT-SYM .V>>>>
 717      <COND (<NOT <2 <TYPE-INFO <1 <SET DL <2 <1 .L>>>>>>>
 718             <PUT .S
 719                  ,DEATH-LIST
 720                  <COND (.FLG <LMERGE <DEATH-LIST .S> .DL>) (ELSE .DL)>>)>
 721      <SET L <REST .L>>>>
 722
 723 <DEFINE SAVE-L-D-STATE (V)
 724         #DECL ((V) <OR VECTOR SYMTAB>)
 725         <REPEAT ((L (())) (LP .L) DL)
 726                 #DECL ((L LP) LIST (DL) <LIST [REST NODE]>)
 727                 <COND (<TYPE? .V VECTOR> <RETURN <REST .L>>)>
 728                 <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
 729                             <NOT <2 <CHTYPE <TYPE-INFO <1 .DL>> LIST>>>>
 730                        <SET LP <REST <PUTREST .LP ((.V .DL))>>>)>
 731                 <SET V <NEXT-SYM .V>>>>
 732
 733 <DEFINE MSAVE-L-D-STATE (L V)
 734         #DECL ((V) <OR VECTOR SYMTAB> (L) LIST)
 735         <REPEAT ((L (() !.L)) (LR .L) (LP <REST .L>) DL S TEM)
 736                 #DECL ((L LP LR TEM) LIST (S) SYMTAB (DL) <LIST [REST NODE]>)
 737                 <COND (<EMPTY? .LP>
 738                        <PUTREST .L <SAVE-L-D-STATE .V>>
 739                        <RETURN <REST .LR>>)
 740                       (<TYPE? .V VECTOR> <RETURN <REST .LR>>)
 741                       (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
 742                             <NOT <2 <TYPE-INFO <1 .DL>>>>>
 743                        <COND (<==? <SET S <1 <1 .LP>>> .V>
 744                               <SET TEM <LMERGE <2 <1 .LP>> .DL>>
 745                               <COND (<EMPTY? .TEM>
 746                                      <PUTREST .L <SET LP <REST .LP>>>)
 747                                     (ELSE
 748                                      <PUT <1 .LP> 2 .TEM>
 749                                      <SET LP <REST <SET L .LP>>>)>)
 750                              (ELSE
 751                               <PUTREST .L <SET L ((.V .DL))>>
 752                               <PUTREST .L .LP>)>)
 753                       (<==? .V <1 <1 .LP>>> <SET LP <REST <SET L .LP>>>)>
 754                 <SET V <NEXT-SYM .V>>>>
 755
 756 <DEFINE LMERGE (L1 L2)
 757         #DECL ((L1 L2) <LIST [REST NODE]>)
 758         <SET L1
 759              <MAPF ,LIST
 760                    <FUNCTION (N)
 761                            <COND (<OR <2 <TYPE-INFO .N>>
 762                                       <AND <==? <NODE-TYPE .N> ,SET-CODE>
 763                                            <NOT <MEMQ .N .L2>>>>
 764                                   <MAPRET>)>
 765                            .N>
 766                    .L1>>
 767         <SET L2
 768              <MAPF ,LIST
 769                    <FUNCTION (N)
 770                            <COND (<OR <2 <TYPE-INFO .N>>
 771                                       <==? <NODE-TYPE .N> ,SET-CODE>
 772                                       <MEMQ .N .L1>>
 773                                   <MAPRET>)>
 774                            .N>
 775                    .L2>>
 776         <COND (<EMPTY? .L1> .L2)
 777               (ELSE <PUTREST <REST .L1 <- <LENGTH .L1> 1>> .L2> .L1)>>
 778
 779 <DEFINE MAKE-DEAD (N SYM)
 780         #DECL ((N) NODE (SYM) SYMTAB)
 781         <PUT .SYM ,DEATH-LIST (.N)>>
 782
 783 <DEFINE KILL-REM (L V)
 784         #DECL ((L) <LIST [REST SYMTAB]> (V) <OR SYMTAB VECTOR>)
 785         <REPEAT ((L1 ()))
 786                 #DECL ((L1) LIST)
 787                 <COND (<TYPE? .V VECTOR> <RETURN .L1>)>
 788                 <COND (<AND <NOT <SPEC-SYM .V>>
 789                             <N==? <CODE-SYM .V> -1>
 790                             <MEMQ .V .L>>
 791                        <SET L1 (.V !.L1)>)>
 792                 <SET V <NEXT-SYM .V>>>>
 793
 794 <DEFINE SAVE-SURVIVORS (LS LI "OPTIONAL" (FLG <>))
 795         #DECL ((LS) <LIST [REST <LIST SYMTAB LIST>]> (LI) <LIST [REST
 796                                                                  SYMTAB]>)
 797         <MAPF <>
 798          <FUNCTION (LL)
 799                  <COND (<MEMQ <1 .LL> .LI>
 800                         <MAPF <>
 801                               <FUNCTION (N)
 802                                       #DECL ((N) NODE)
 803                                       <PUT <TYPE-INFO .N> 2 T>>
 804                               <2 .LL>>)
 805                        (.FLG <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
 806          .LS>>
 807
 808 <DEFINE REVIVE (NOD SYM "AUX" (L <DEATH-LIST .SYM>))
 809         #DECL ((L) <LIST [REST NODE]> (SYM) SYMTAB (NOD) NODE)
 810         <COND (<AND <NOT <SPEC-SYM .SYM>> <N==? <CODE-SYM .SYM> -1>>
 811                <COND (<EMPTY? .L> <SET LIFE (.SYM !.LIFE)>)
 812                      (ELSE
 813                       <MAPF <>
 814                             <FUNCTION (N)
 815                                     #DECL ((N) NODE)
 816                                     <PUT <TYPE-INFO .N> 2 T>>
 817                             .L>)>
 818                <PUT .SYM ,DEATH-LIST (.NOD)>
 819                <PUT .NOD ,TYPE-INFO (<> <>)>)>>
 820
 821 " Ananlyze a FORM that could really be an NTH."
 822
 823 <DEFINE FORM-F-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (OBJ <NODE-NAME .NOD>) TYP)
 824         #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
 825         <COND (<==? <ISTYPE? <SET TYP <ANA <1 .K> APPLICABLE>>> FIX>
 826                <PUT .NOD ,KIDS (<2 .K> <1 .K> !<REST .K 2>)>
 827                <COND (<==? <LENGTH .K> 2>
 828                       <SET RTYP <NTH-REST-ANA .NOD .RTYP ,NTH-CODE .TYP>>)
 829                      (ELSE <SET RTYP <PUT-ANA .NOD .RTYP ,PUT-CODE>>)>
 830                <PUT .NOD ,NODE-SUBR <NODE-TYPE .NOD>>
 831                <PUT .NOD ,KIDS .K>
 832                <PUT .NOD ,NODE-NAME .OBJ>
 833                <PUT .NOD ,NODE-TYPE ,FORM-F-CODE>
 834                .RTYP)
 835               (ELSE
 836                <SPECIALIZE <NODE-NAME .NOD>>
 837                <SPEC-FLUSH>
 838                <PUT-FLUSH ALL>
 839                <PUT .NOD ,SIDE-EFFECTS (ALL)>
 840                <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
 841
 842 " Further analyze a FORM."
 843
 844 <DEFINE FORM-AN (NOD RTYP)
 845         #DECL ((NOD) NODE)
 846         <APPLY <OR <GETPROP <NODE-SUBR .NOD> ANALYSIS>
 847                    <GETPROP <TYPE <NODE-SUBR .NOD>> TANALYSIS>
 848                    <FUNCTION (N R)
 849                            #DECL ((N) NODE)
 850                            <SPEC-FLUSH>
 851                            <PUT-FLUSH ALL>
 852                            <PUT .N ,SIDE-EFFECTS (ALL)>
 853                            <TYPE-OK? <RESULT-TYPE .N> .R>>>
 854                .NOD
 855                .RTYP>>
 856
 857 "Determine if an ATOM is mainfest."
 858
 859 <DEFINE MANIFESTQ (ATM)
 860         #DECL ((ATM) ATOM)
 861         <AND <MANIFEST? .ATM> <GASSIGNED? .ATM> <NOT <TYPE? ,.ATM MSUBR>>>>
 862
 863 " Search for a decl associated with a local value."
 864
 865 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
 866         #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
 867         <REPEAT ()
 868                 <COND (<EMPTY? .TB> <RETURN <>>)>
 869                 <COND (<==? .ATM <NAME-SYM .TB>> <RETURN .TB>)>
 870                 <SET TB <NEXT-SYM .TB>>>>
 871
 872 " Here to flush decls of specials for an external function call."
 873
 874 <DEFINE SPEC-FLUSH () <FLUSHER <>>>
 875
 876 " Here to flush decls when a PUT, PUTREST or external call happens."
 877
 878 <DEFINE PUT-FLUSH (TYP) <FLUSHER .TYP>>
 879
 880 <DEFINE FLUSHER (FLSFLG "AUX" (V .VARTBL))
 881    #DECL ((SYM) SYMTAB (V) <OR SYMTAB VECTOR>)
 882    <COND
 883     (.ANALY-OK
 884      <REPEAT (SYM TEM CT)
 885        #DECL ((SYM) SYMTAB)
 886        <COND
 887         (<AND <SET CT <CURRENT-TYPE <SET SYM .V>>>
 888               <OR <AND <SPEC-SYM .SYM> <NOT .FLSFLG>>
 889                   <AND .FLSFLG
 890                        <N==? .CT NO-RETURN>
 891                        <N==? .CT BOOL-FALSE>
 892                        <N==? .CT BOOLEAN>
 893                        <N==? .CT BOOL-TRUE>
 894                        <TYPE-OK? <CURRENT-TYPE .V> '<STRUCTURED ANY>>
 895                        <OR <==? .FLSFLG ALL>
 896                            <NOT <SET TEM <STRUCTYP <CURRENT-TYPE .V>>>>
 897                            <==? .TEM .FLSFLG>>>>>
 898          <SET-CURRENT-TYPE
 899           .SYM <FLUSH-FIX-TYPE .SYM <CURRENT-TYPE .SYM> .FLSFLG>>)>
 900        <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)
 901     (ELSE
 902      <REPEAT (SYM)
 903              #DECL ((SYM) SYMTAB)
 904              <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)>>
 905
 906 <DEFINE FLUSH-FIX-TYPE (SYM TY FLG "AUX" TEM)
 907         #DECL ((SYM) SYMTAB)
 908         <OR <AND .FLG
 909                  <SET TEM <TOP-TYPE <TYPE-OK? .TY STRUCTURED>>>
 910                  <TYPE-OK? <COND (<SET TY <TYPE-OK? .TY '<NOT STRUCTURED>>>
 911                                   <TYPE-MERGE .TEM .TY>)
 912                                  (ELSE .TEM)>
 913                            <DECL-SYM .SYM>>>
 914             <DECL-SYM .SYM>>>
 915
 916 " Punt forms with segments in them."
 917
 918 <DEFINE SEGFLUSH (NOD RTYP)
 919         #DECL ((NOD) NODE (L) <LIST [REST NODE]>)
 920         <COND
 921          (<REPEAT ((L <KIDS .NOD>))
 922                   <AND <EMPTY? .L> <RETURN <>>>
 923                   <AND <==? <NODE-TYPE <1 .L>> ,SEGMENT-CODE> <RETURN T>>
 924                   <SET L <REST .L>>>
 925           <COND (.VERBOSE
 926                  <ADDVMESS .NOD ("Not open compiled due to SEGMENT.")>)>
 927           <SUBR-C-AN .NOD .RTYP>)>>
 928
 929 " Determine if the arg to STACKFORM is a SUBR."
 930
 931 <DEFINE APPLTYP (NOD "AUX" (NT <NODE-TYPE .NOD>) ATM TT)
 932         #DECL ((ATM) ATOM (NOD TT) NODE (NT) FIX)
 933         <COND (<==? .NT ,GVAL-CODE>
 934                <COND (<AND <==? <NODE-TYPE <SET TT <1 <KIDS .NOD>>>>
 935                                 ,QUOTE-CODE>
 936                            <GASSIGNED? <SET ATM <NODE-NAME .TT>>>
 937                            <TYPE? ,.ATM MSUBR>>
 938                       <SUBR-TYPE ,.ATM>)
 939                      (ELSE ANY)>)
 940               (ELSE ANY)>>
 941
 942 " Return type returned by a SUBR."
 943
 944 <DEFINE SUBR-TYPE (SUB "AUX" TMP)
 945         #DECL ((SUB) MSUBR)
 946         <SET TMP <2 <GET-TMP .SUB>>>
 947         <COND (<TYPE? .TMP ATOM FORM> .TMP) (ELSE ANY)>>
 948
 949 " Access the SUBR data base for return type."
 950
 951 <DEFINE GET-TMP (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
 952         #DECL ((VALUE) <LIST ANY ANY>)
 953         <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>) (ELSE '(ANY ANY))>>
 954
 955 " GVAL analyzer."
 956
 957 <DEFINE GVAL-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT TEM1)
 958    #DECL ((NOD TEM) NODE (TT) <VECTOR VECTOR ATOM ANY> (LN) FIX)
 959    <COND
 960     (<SEGFLUSH .NOD .RTYP>)
 961     (ELSE
 962      <ARGCHK .LN 1 GVAL .NOD>
 963      <PUT .NOD ,NODE-TYPE ,FGVAL-CODE>
 964      <EANA <1 .K> ATOM GVAL>
 965      <COND (<AND <==? <NODE-TYPE <SET TEM <1 .K>>> ,QUOTE-CODE>
 966                  <==? <RESULT-TYPE .TEM> ATOM>>
 967             <PUT .NOD ,NODE-TYPE ,GVAL-CODE>
 968             <COND (<MANIFEST? <SET TEM1 <NODE-NAME .TEM>>>
 969                    <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
 970                    <PUT .NOD ,NODE-NAME ,.TEM1>
 971                    <PUT .NOD ,KIDS ()>
 972                    <TYPE-OK? <GEN-DECL ,.TEM1> .RTYP>)
 973                   (<AND <GBOUND? .TEM1>
 974                         <COND (<GASSIGNED? GLOC>
 975                                <SET TEM1 <GET-DECL <GLOC .TEM1>>>)
 976                               (ELSE <SET TEM1 <GET-DECL <GBIND .TEM1>>>)>>
 977                    <TYPE-OK? .TEM1 .RTYP>)
 978                   (ELSE <TYPE-OK? ANY .RTYP>)>)
 979            (ELSE <TYPE-OK? ANY .RTYP>)>)>>
 980
 981 <COND (<GASSIGNED? GVAL-ANA> <PUTPROP ,GVAL ANALYSIS ,GVAL-ANA>)>
 982
 983 <DEFINE GASSIGNED?-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>)
 984                                        (NM <NODE-NAME .NOD>))
 985         #DECL ((NOD) NODE (K) <LIST [REST NODE]> (LN) FIX)
 986         <COND (<SEGFLUSH .NOD .RTYP>)
 987               (ELSE
 988                <ARGCHK .LN 1 .NM .NOD>
 989                <PUT .NOD ,NODE-TYPE ,GASSIGNED?-CODE>
 990                <EANA <1 .K> ATOM .NM>)>
 991         <TYPE-OK? '<OR ATOM FALSE> .RTYP>>
 992
 993 <COND (<GASSIGNED? GASSIGNED?-ANA>
 994        <PUTPROP ,GASSIGNED? ANALYSIS ,GASSIGNED?-ANA>)>
 995
 996 <COND (<AND <GASSIGNED? GBOUND?> <GASSIGNED? GASSIGNED?-ANA>>
 997        <PUTPROP ,GBOUND? ANALYSIS ,GASSIGNED?-ANA>)>
 998
 999 " Analyze SETG usage."
1000
1001 <DEFINE SETG-ANA (NOD RTYP
1002                   "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT T1 TTT)
1003    #DECL ((NOD TEM) NODE (K) <LIST [REST NODE]> (LN) FIX (TT) VECTOR)
1004    <COND
1005     (<SEGFLUSH .NOD .RTYP>)
1006     (ELSE
1007      <ARGCHK .LN '(2 3) SETG .NOD>
1008      <PUT .NOD ,NODE-TYPE ,FSETG-CODE>
1009      <EANA <SET TEM <1 .K>> ATOM SETG>
1010      <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
1011      <COND (<==? <NODE-TYPE .TEM> ,QUOTE-CODE>
1012             <COND (<MANIFEST? <SET TTT <NODE-NAME .TEM>>>
1013                    <COMPILE-WARNING "SETGing manifest GVAL?  " .TTT .NOD>)>
1014             <PUT .NOD ,NODE-TYPE ,SETG-CODE>
1015             <COND (<AND <GBOUND? .TTT>
1016                         <COND (<GASSIGNED? GLOC>
1017                                <SET T1 <GET-DECL <GLOC .TTT>>>)
1018                               (ELSE <SET T1 <GET-DECL <GBIND .TTT>>>)>>
1019                    <COND (<NOT <ANA <2 .K> .T1>>
1020                           <COMPILE-ERROR "GLOBAL declaration violation"
1021                                          .TTT
1022                                          .NOD>)>
1023                    <SET TTT <TYPE-OK? .T1 .RTYP>>)
1024                   (ELSE
1025                    <SET TTT <ANA <2 .K> ANY>>
1026                    <SET TTT <TYPE-OK? .TTT .RTYP>>)>)
1027            (ELSE <SET TTT <ANA <2 .K> ANY>> <SET TTT <TYPE-OK? .TTT .RTYP>>)>
1028      <COND (<==? .LN 3> <EANA <3 .K> ANY SETG>)>
1029      .TTT)>>
1030
1031 <COND (<GASSIGNED? SETG-ANA> <PUTPROP ,SETG ANALYSIS ,SETG-ANA>)>
1032
1033 <DEFINE BUILD-TYPE-LIST (V "OPT" (ALL T))
1034    #DECL ((V) <OR VECTOR SYMTAB> (VALUE) LIST)
1035    <COND (.ANALY-OK
1036           <REPEAT ((L (())) (LP .L) TEM)
1037                   #DECL ((L LP) LIST)
1038                   <COND (<EMPTY? .V> <RETURN <REST .L>>)
1039                         (<N==? <CODE-SYM .V> -1>
1040                          <SET TEM <GET-CURRENT-TYPE .V>>
1041                          <COND (<OR .ALL <N==? .TEM NO-RETURN>>
1042                                 <SET LP <REST <PUTREST .LP ((.V .TEM T))>>>)>)>
1043                   <SET V <NEXT-SYM .V>>>)
1044          (ELSE ())>>
1045
1046 <DEFINE RESET-VARS (V "OPTIONAL" (VL '[]) (FLG <>))
1047         #DECL ((V VL) <OR SYMTAB VECTOR>)
1048         <REPEAT ()
1049                 <COND (<==? .V .VL> <SET FLG T>)>
1050                 <COND (<EMPTY? .V> <RETURN>)
1051                       (<NOT .FLG>
1052                        <PUT .V ,CURRENT-TYPE <>>
1053                        <PUT .V ,COMPOSIT-TYPE ANY>)>
1054                 <PUT .V ,DEATH-LIST ()>
1055                 <SET V <NEXT-SYM .V>>>>
1056
1057 <DEFINE GET-CURRENT-TYPE (SYM)
1058         #DECL ((SYM) SYMTAB)
1059         <COND (<AND .ANALY-OK <CURRENT-TYPE .SYM>>) (ELSE <DECL-SYM .SYM>)>>
1060
1061 <DEFINE SET-CURRENT-TYPE (SYM ITYP "AUX" (OTYP <DECL-SYM .SYM>))
1062         #DECL ((SYM) SYMTAB)
1063         <COND (<AND .ANALY-OK <N==? <CODE-SYM .SYM> -1>>
1064                <PUT .SYM ,CURRENT-TYPE <TYPE-AND .ITYP .OTYP>>
1065                <PUT .SYM
1066                     ,COMPOSIT-TYPE
1067                     <TYPE-MERGE .ITYP <COMPOSIT-TYPE .SYM>>>)
1068               (ELSE
1069                <PUT .SYM ,CURRENT-TYPE <>>
1070                <PUT .SYM ,COMPOSIT-TYPE .OTYP>)>>
1071
1072 <DEFINE ANDUPC (V L)
1073         #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1074         <REPEAT (TMP)
1075                 <COND (<EMPTY? .V> <RETURN>)>
1076                 <COND (<AND <SET TMP <CURRENT-TYPE .V>> <N==? .TMP NO-RETURN>>
1077                        <SET L <ADD-TYPE-LIST .V <CURRENT-TYPE .V> .L T>>)>
1078                 <SET V <NEXT-SYM .V>>>
1079         .L>
1080
1081 <DEFINE ANDUP (FROM TO)
1082         #DECL ((TO FROM) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1083         <MAPF <>
1084               <FUNCTION (L) <SET TO <ADD-TYPE-LIST <1 .L> <2 .L> .TO T>>>
1085               .FROM>
1086         .TO>
1087
1088 <DEFINE ORUPC (V L "AUX" WIN)
1089    #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1090    <COND
1091     (.ANALY-OK
1092      <REPEAT ()
1093        <COND (<TYPE? .V VECTOR> <RETURN>)>
1094        <SET WIN <>>
1095        <MAPF <>
1096         <FUNCTION (LL)
1097                 #DECL ((LL) <LIST SYMTAB <OR ATOM FORM SEGMENT> ANY>)
1098                 <COND (<==? <1 .LL> .V>
1099                        <PUT .LL 2 <TYPE-MERGE <2 .LL> <GET-CURRENT-TYPE .V>>>
1100                        <PUT .LL 3 T>
1101                        <MAPLEAVE <SET WIN T>>)>>
1102         .L>
1103        <COND (<AND <NOT .WIN> <CURRENT-TYPE .V>>
1104               <SET L ((.V <DECL-SYM .V> T) !.L)>)>
1105        <SET V <NEXT-SYM .V>>>)>
1106    .L>
1107
1108 <DEFINE ORUP (FROM TO "AUX" NDECL (TOTUP <STACK <VECTOR !.TO>>))
1109    #DECL ((TO FROM)
1110           <LIST [REST <LIST SYMTAB <OR ATOM FORM SEGMENT> <OR ATOM FALSE>>]>
1111           (TOTUP) <<PRIMTYPE VECTOR>
1112                    [REST <OR <LIST SYMTAB <OR ATOM FORM SEGMENT>
1113                                    <OR ATOM FALSE>>
1114                              FALSE>]>
1115           (NDECL)
1116           <OR ATOM FORM SEGMENT>)
1117    <MAPF <>
1118     <FUNCTION (L "AUX" (SYM <1 .L>) (WIN <>))
1119             <MAPR <>
1120                   <FUNCTION (TP "AUX" (LL <1 .TP>))
1121                           <COND (<AND .LL <==? <1 .LL> .SYM>>
1122                                  <SET NDECL <TYPE-MERGE <2 .LL> <2 .L>>>
1123                                  <PUT .LL 2 .NDECL>
1124                                  <PUT .LL 3 <3 .LL>>
1125                                  <PUT .TP 1 <>>
1126                                  <MAPLEAVE <SET WIN T>>)>>
1127                   .TOTUP>
1128             <COND (<NOT .WIN>
1129                    <SET TO
1130                         ((.SYM
1131                           <TYPE-MERGE <GET-CURRENT-TYPE .SYM> <2 .L>>
1132                           <3 .L>)
1133                          !.TO)>)>>
1134     .FROM>
1135    <MAPF <>
1136          <FUNCTION (LL) #DECL ((LL) <OR FALSE LIST>)
1137               <COND (.LL
1138                      <PUT .LL 2 <TYPE-MERGE <GET-CURRENT-TYPE <1 .LL>>
1139                                             <2 .LL>>>)>>
1140          .TOTUP>
1141    .TO>
1142
1143 <DEFINE ASSERT-TYPES (L)
1144         #DECL ((L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1145         <MAPF <> <FUNCTION (LL) <SET-CURRENT-TYPE <1 .LL> <2 .LL>>> .L>>
1146
1147 <DEFINE ADD-TYPE-LIST (SYM NDECL INF MUNG
1148                        "OPTIONAL" (NTH-REST ())
1149                        "AUX" (WIN <>) (OD <GET-CURRENT-TYPE .SYM>))
1150    #DECL ((SYM) SYMTAB (INF) LIST (NTH-REST) <LIST [REST ATOM FIX]>
1151           (NDECL) <OR ATOM FALSE FORM SEGMENT> (MUNG) <OR ATOM FALSE>)
1152    <COND (.ANALY-OK
1153           <SET NDECL <TYPE-NTH-REST .NDECL .NTH-REST>>
1154           <MAPF <>
1155                 <FUNCTION (L)
1156                         #DECL ((L) <LIST SYMTAB ANY>)
1157                         <COND (<==? <1 .L> .SYM>
1158                                <SET NDECL
1159                                     <COND (.MUNG <TYPE-AND .NDECL .OD>)
1160                                           (ELSE <TYPE-AND .NDECL <2 .L>>)>>
1161                                <PUT .L 2 .NDECL>
1162                                <PUT .L 3 .MUNG>
1163                                <MAPLEAVE <SET WIN T>>)>>
1164                 .INF>
1165           <COND (<NOT .WIN>
1166                  <SET NDECL <TYPE-AND .NDECL .OD>>
1167                  <SET INF ((.SYM .NDECL .MUNG) !.INF)>)>)>
1168    .INF>
1169
1170 <DEFINE TYPE-NTH-REST (NDECL NTH-REST)
1171         #DECL ((NTH-REST) <LIST [REST ATOM FIX]>)
1172         <REPEAT ((FIRST T) (NUM 0))
1173                 #DECL ((NUM) FIX)
1174                 <COND (<EMPTY? .NTH-REST> <RETURN .NDECL>)>
1175                 <COND (<==? <1 .NTH-REST> NTH>
1176                        <SET NDECL
1177                             <FORM STRUCTURED
1178                                   !<COND (<0? <SET NUM
1179                                                    <+ .NUM <2 .NTH-REST> -1>>>
1180                                           ())
1181                                          (<1? .NUM> (ANY))
1182                                          (ELSE ([.NUM ANY]))>
1183                                   .NDECL>>
1184                        <SET NUM 0>
1185                        <SET FIRST <>>)
1186                       (.FIRST <SET NDECL <REST-DECL .NDECL <2 .NTH-REST>>>)
1187                       (ELSE <SET NUM <+ .NUM <2 .NTH-REST>>>)>
1188                 <SET NTH-REST <REST .NTH-REST 2>>>>
1189
1190 " AND/OR analyzer.  Called from AND-ANA and OR-ANA."
1191
1192 <DEFINE BOOL-AN (NOD RTYP ORER
1193                  "AUX" (L <KIDS .NOD>) FTYP FTY
1194                        (RTY
1195                         <COND (<TYPE-OK? .RTYP FALSE> .RTYP)
1196                               (ELSE <FORM OR .RTYP FALSE>)>)
1197                        (FLG <==? .PRED <PARENT .NOD>>) (SINF ()) STR SUNT
1198                        (FIRST T) FNOK NFNOK PASS)
1199    #DECL ((NOD) NODE (L) <LIST [REST NODE]> (ORER RTYP) ANY (FTYP) FORM
1200           (STR SINF SUNT) LIST)
1201    <PROG ((TRUTH ()) (UNTRUTH ()) (PRED .NOD) L-D)
1202      #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (PRED) <SPECIAL ANY> (L-D) LIST)
1203      <COND
1204       (<EMPTY? .L> <SET FTYP <TYPE-OK? FALSE .RTYP>>)
1205       (ELSE
1206        <SET FTY
1207         <MAPR ,TYPE-MERGE
1208          <FUNCTION (N "AUX" (LAST <EMPTY? <REST .N>>) TY)
1209             #DECL ((N) <LIST NODE>)
1210             <COND (<AND .LAST <NOT .FLG>> <SET PRED <>>)>
1211             <SET TY <ANA <1 .N> <COND (.LAST .RTYP) (.ORER .RTY) (ELSE ANY)>>>
1212             ; "FNOK seems to mean that this clause of the boolean can't
1213                return false; NFNOK means it always returns false"
1214             <SET FNOK <OR <==? .TY NO-RETURN> <NOT <TYPE-OK? .TY FALSE>>>>
1215             <SET NFNOK <==? FALSE <ISTYPE? .TY>>>
1216             ; "Therefore, PASS means this clause's result doesn't need to be
1217                tested, because we'll always go to the next clause."
1218             <SET PASS <COND (.ORER .NFNOK) (ELSE .FNOK)>>
1219             <COND (<NOT .TY>
1220                    <SET TY ANY>
1221                    <COMPILE-WARNING "OR/AND clause returns wrong type: "
1222                                     <1 .N>>)>
1223             <COND
1224              (<COND (.ORER .FNOK) (ELSE .NFNOK)>
1225               ; "If OR, and FNOK, this will terminate the whole thing, etc..."
1226               <COND
1227                (<AND .VERBOSE <NOT .LAST>>
1228                 <ADDVMESS .NOD
1229                           ("This object prematurely ends AND/OR:  "
1230                            <1 .N>
1231                            !<COND (<==? .TY NO-RETURN> '(" it never returns "))
1232                                   (ELSE (" its type is:  " .TY))>)>)>
1233               <SET LAST T>)>
1234             <COND
1235              (<AND <N==? .TY NO-RETURN> <NOT .PASS>>
1236               ; "This clause actually returns an interesting condition..."
1237               <COND (.FIRST
1238                      <SET L-D <SAVE-L-D-STATE .VARTBL>>
1239                      <SET STR <ANDUP <COPY-TYPE-LIST .TRUTH>
1240                                      <BUILD-TYPE-LIST .VARTBL <>>>>
1241                      <SET SUNT <ANDUP <COPY-TYPE-LIST .UNTRUTH>
1242                                       <BUILD-TYPE-LIST .VARTBL <>>>>
1243                      <SET SINF
1244                           <ANDUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
1245                                  <BUILD-TYPE-LIST .VARTBL>>>)
1246                     (ELSE
1247                      <SET L-D <MSAVE-L-D-STATE .L-D .VARTBL>>
1248                      <COND (.ORER
1249                             <SET SUNT <ANDUP .UNTRUTH <ANDUPC .VARTBL .SUNT>>>
1250                             <SET STR <ORUP .STR .TRUTH>>)
1251                            (ELSE
1252                             <SET SUNT <ORUP .SUNT .UNTRUTH>>
1253                             <SET STR <ANDUP .TRUTH <ANDUPC .VARTBL .STR>>>)>
1254                      <SET SINF
1255                           <ORUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
1256                                 <ORUPC .VARTBL .SINF>>>)>
1257               <SET FIRST <>>)
1258              (<NOT .FIRST>
1259               <COND (.ORER <SET SUNT <ANDUPC .VARTBL .SUNT>>)
1260                     (ELSE <SET STR <ANDUPC .VARTBL .STR>>)>
1261               <SET SINF <ORUPC .VARTBL .SINF>>)
1262              (T
1263               <SET STR <ANDUP <COPY-TYPE-LIST .TRUTH>
1264                               <BUILD-TYPE-LIST .VARTBL <>>>>
1265               <SET SUNT <ANDUP <COPY-TYPE-LIST .UNTRUTH>
1266                                <BUILD-TYPE-LIST .VARTBL <>>>>
1267               <SET SINF <ANDUP <COND (.ORER .TRUTH) (T .UNTRUTH)>
1268                                <BUILD-TYPE-LIST .VARTBL>>>
1269               <SET FIRST <>>)>
1270             <ASSERT-TYPES <COND (.ORER .SUNT) (ELSE .STR)>>
1271             <SET TRUTH <SET UNTRUTH ()>>
1272             <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
1273             <COND (<==? .TY NO-RETURN>
1274                    <COND (<NOT .LAST>
1275                           <COMPILE-WARNING "AND/OR clause is unreachable: "
1276                                            <1 .N>>)>
1277                    <SET FLG <>>
1278                    <ASSERT-TYPES .SINF>
1279                    <MAPSTOP NO-RETURN>)
1280                   (.LAST <ASSERT-TYPES <ORUPC .VARTBL .SINF>> <MAPSTOP .TY>)
1281                   (<AND .ORER .NFNOK> <MAPRET>)
1282                   (.ORER .TY)
1283                   (.FNOK <MAPRET>)
1284                   (ELSE FALSE)>>
1285          .L>>
1286        <COND (<AND .FNOK .ORER> <SET FTY <TYPE-OK? .FTY '<NOT FALSE>>>)>)>>
1287    <COND (.FLG <SET TRUTH .STR> <SET UNTRUTH .SUNT>)>
1288    .FTY>
1289
1290 <DEFINE COPY-TYPE-LIST (L)
1291         #DECL ((L) LIST)
1292         <MAPF ,LIST
1293               <FUNCTION (LL)
1294                       #DECL ((LL) <LIST ANY ANY ANY>)
1295                       (<1 .LL> <2 .LL> <3 .LL>)>
1296               .L>>
1297
1298 <DEFINE AND-ANA (NOD RTYP)
1299         #DECL ((NOD) NODE)
1300         <PUT .NOD ,NODE-TYPE ,AND-CODE>
1301         <BOOL-AN .NOD .RTYP <>>>
1302
1303 <COND (<GASSIGNED? AND-ANA> <PUTPROP ,AND ANALYSIS ,AND-ANA>)>
1304
1305 <DEFINE OR-ANA (NOD RTYP)
1306         #DECL ((NOD) NODE)
1307         <PUT .NOD ,NODE-TYPE ,OR-CODE>
1308         <BOOL-AN .NOD .RTYP T>>
1309
1310 <COND (<GASSIGNED? OR-ANA> <PUTPROP ,OR ANALYSIS ,OR-ANA>)>
1311
1312 " COND analyzer."
1313
1314 <DEFINE CASE-ANA (N R) <COND-CASE .N .R T>>
1315
1316 <DEFINE COND-ANA (N R) <COND-CASE .N .R <>>>
1317
1318
1319 <DEFINE COND-CASE (NOD RTYP CASE?
1320                    "AUX" (L <KIDS .NOD>) (FIRST T) (LAST <>) TT FNOK NFNOK STR
1321                          SUNT (FIRST1 T) PRAT (DFLG <>) TST-TYP SVWHO
1322                          (PRED-FLG <==? .PRED <PARENT .NOD>>))
1323    #DECL ((NOD) NODE (L) <LIST [REST NODE]> (RTYP) ANY)
1324    <PROG ((TRUTH ()) (UNTRUTH ()) (TINF1 ()) (TINF ()) L-D L-D1 (PRED .PRED))
1325      #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (TINF1 TINF L-D L-D1) LIST
1326             (PRED) <SPECIAL <OR FALSE NODE>>)
1327      <COND
1328       (<EMPTY? .L> <TYPE-OK? FALSE .RTYP>)
1329       (ELSE
1330        <COND (.CASE?
1331               <SET PRAT <NODE-NAME <1 <KIDS <1 .L>>>>>
1332               <PROG ((WHON .NOD) (WHO ()))
1333                     #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL NODE>)
1334                     <SET TST-TYP <EANA <2 .L> ANY CASE>>
1335                     <SET SVWHO .WHO>>
1336               <SET L <REST .L 2>>)>
1337        <SET TT
1338         <MAPR ,TYPE-MERGE
1339          <FUNCTION (BRN "AUX" (BR <1 .BRN>) (EC T) STR1 SUNT1)
1340             #DECL ((BRN) <LIST NODE> (BR) NODE)
1341             <COND (<N==? <NODE-TYPE .BR> ,QUOTE-CODE>
1342                    <PUT .BR ,SIDE-EFFECTS <>>)>
1343             <SET PRED .BR>
1344             <COND (<AND .CASE? <==? <NODE-TYPE .BR> ,QUOTE-CODE> <SET DFLG T>>
1345                    <MAPRET>)>
1346             <COND (<NOT <PREDIC .BR>>
1347                    <COMPILE-ERROR "Empty COND clause: " .BR>)>
1348             <SET UNTRUTH <SET TRUTH ()>>
1349             <SET LAST <EMPTY? <REST .BRN>>>
1350             <SET TT
1351                  <COND (<NOT <EMPTY? <CLAUSES .BR>>> <SET EC <>> ANY)
1352                        (.LAST .RTYP)
1353                        (ELSE <TYPE-MERGE .RTYP FALSE>)>>
1354             <SET TT
1355                  <COND (.CASE?
1356                         <SPEC-ANA <NODE-NAME <CHTYPE <PREDIC .BR> NODE>>
1357                                   .PRAT
1358                                   .TST-TYP
1359                                   .TT
1360                                   .DFLG
1361                                   .BR
1362                                   .SVWHO>)
1363                        (ELSE <ANA <PREDIC .BR> .TT>)>>
1364             <SET DFLG <SET PRED <>>>
1365             <SET FNOK <OR <==? .TT NO-RETURN> <NOT <TYPE-OK? .TT FALSE>>>>
1366             <SET NFNOK <==? <ISTYPE? .TT> FALSE>>
1367             <COND
1368              (.VERBOSE
1369               <COND
1370                (.NFNOK
1371                 <ADDVMESS
1372                  .NOD
1373                  ("Cond predicate always FALSE:  "
1374                   <PREDIC .BR>
1375                   !<COND (<EMPTY? <CLAUSES .BR>> ())
1376                          (ELSE (" and non-reachable code in clause."))>)>)>
1377               <COND
1378                (<AND .FNOK <NOT .LAST>>
1379                 <ADDVMESS
1380                  .NOD
1381                  ("Cond ended prematurely because predicate always true:  "
1382                   <PREDIC .BR>
1383                   " type of value:  "
1384                   .TT)>)>)>
1385             <COND (.PRED-FLG
1386                    <SET STR1 <ANDUP <COPY-TYPE-LIST .TRUTH>
1387                                     <BUILD-TYPE-LIST .VARTBL <>>>>
1388                    <SET SUNT1 <ANDUP <COPY-TYPE-LIST .UNTRUTH>
1389                                      <BUILD-TYPE-LIST .VARTBL <>>>>)>
1390             <COND (<NOT <OR .FNOK <AND <NOT .LAST> .NFNOK>>>
1391                    <SET L-D <SAVE-L-D-STATE .VARTBL>>
1392                    <COND (.FIRST
1393                           <SET TINF
1394                                <ANDUP .UNTRUTH <BUILD-TYPE-LIST .VARTBL>>>)
1395                          (ELSE
1396                           <SET TINF <ANDUP .UNTRUTH <ORUPC .VARTBL .TINF>>>)>
1397                    <COND (<NOT .EC> <ASSERT-TYPES .TRUTH>)>
1398                    <SET FIRST <>>)>
1399             <COND (<AND <NOT .NFNOK>
1400                         <OR .EC <SET TT <SEQ-AN <CLAUSES .BR>
1401                                                 .RTYP .PRED-FLG>>>>
1402                    <COND (<N==? .TT NO-RETURN>
1403                           <COND (.PRED-FLG
1404                                  <COND (.EC
1405                                         <COND (.FIRST1
1406                                                <SET STR .STR1>
1407                                                <SET SUNT .SUNT1>)
1408                                               (ELSE
1409                                                <SET STR <ORUP .STR .STR1>>
1410                                                <SET SUNT
1411                                                     <ANDUP .SUNT .SUNT1>>)>)
1412                                        (.FIRST1
1413                                         <SET STR
1414                                              <ANDUP .TRUTH
1415                                                     <ANDUPC .VARTBL .STR1>>>
1416                                         <SET SUNT <ORUP .SUNT1 .UNTRUTH>>)
1417                                        (ELSE
1418                                         <SET STR <ORUP .STR
1419                                                        <ANDUP .TRUTH
1420                                                               .STR1>>>
1421                                         <SET SUNT
1422                                              <ANDUP .SUNT
1423                                                     <ORUP .SUNT1 .UNTRUTH>>>)>)>
1424                           <COND (.FIRST1
1425                                  <SET TINF1 <BUILD-TYPE-LIST .VARTBL>>
1426                                  <SET L-D1 <SAVE-L-D-STATE .VARTBL>>)
1427                                 (ELSE
1428                                  <SET TINF1 <ORUPC .VARTBL .TINF1>>
1429                                  <SET L-D1 <MSAVE-L-D-STATE .L-D1 .VARTBL>>)>
1430                           <SET FIRST1 <>>)>
1431                    <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
1432                    <COND (.LAST
1433                           <AND <NOT .FNOK> <SET TT <TYPE-MERGE .TT FALSE>>>)
1434                          (.EC <SET TT <TYPE-OK? .TT '<NOT FALSE>>>)>)
1435                   (.NFNOK <SET TT FALSE>)>
1436             <UPDATE-SIDE-EFFECTS .BR .NOD>
1437             <COND
1438              (<AND <OR .LAST .FNOK> .TT>
1439               <COND (.FNOK
1440                      <ASSERT-TYPES .TINF1>
1441                      <OR .FIRST1 <RESTORE-L-D-STATE .L-D1 .VARTBL>>)
1442                     (ELSE
1443                      <COND (.FIRST1
1444                             <ASSERT-TYPES .TINF>
1445                             <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>)
1446                            (ELSE
1447                             <ASSERT-TYPES <ORUP .TINF .TINF1>>
1448                             <MRESTORE-L-D-STATE .L-D1 .L-D .VARTBL>)>)>
1449               <MAPSTOP .TT>)
1450              (.TT <ASSERT-TYPES .TINF> .TT)
1451
1452              (ELSE <ASSERT-TYPES .TINF> <MAPRET>)>>
1453          .L>>)>>
1454    <COND (.PRED-FLG
1455           <SET TRUTH .STR>
1456           <SET UNTRUTH .SUNT>)>
1457    .TT>
1458
1459 " PROG/REPEAT analyzer.  Hacks bindings and sets up info for GO/RETURN/AGAIN
1460   analyzers."
1461
1462 <DEFINE PRG-REP-ANA (PPNOD RT
1463                      "AUX" (OV .VARTBL) (VARTBL <SYMTAB .PPNOD>) TT L-D
1464                            (OPN <AND <ASSIGNED? PNOD> .PNOD>) PNOD PRTYP)
1465    #DECL ((PNOD) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB> (OV) SYMTAB
1466           (L-D) LIST (PPNOD) NODE)
1467    <COND (<N==? <NODE-SUBR .PPNOD> ,BIND> <SET PNOD .PPNOD>)
1468          (.OPN <SET PNOD .OPN>)>
1469    <PROG ((TMPS 0) (HTMPS 0) (ACT? <ACTIV? <BINDING-STRUCTURE .PPNOD> T>))
1470      #DECL ((TMPS HTMPS) <SPECIAL FIX>)
1471      <BIND-AN <BINDING-STRUCTURE .PPNOD>>
1472      <SET L-D <SAVE-L-D-STATE .VARTBL>>
1473      <RESET-VARS .VARTBL .OV T>
1474      <COND (<NOT <SET PRTYP <TYPE-OK? .RT <INIT-DECL-TYPE .PPNOD>>>>
1475             <COMPILE-ERROR
1476 "Required type of PROG/REPEAT call violates its decl."
1477                            "Required type is "
1478                            .RT
1479                            " and value decl is "
1480                            <INIT-DECL-TYPE .PPNOD>>)>
1481      <PUT .PPNOD ,RESULT-TYPE .PRTYP>
1482      <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
1483        #DECL ((STMPS SHTMPS) FIX (LL LIFE) LIST)
1484        <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
1485        <MUNG-L-D-STATE .VARTBL>
1486        <SET LIFE .LL>
1487        <PUT .PPNOD ,AGND <>>
1488        <PUT .PPNOD ,DEAD-VARS ()>
1489        <PUT .PPNOD ,VSPCD ()>
1490        <PUT .PPNOD ,LIVE-VARS ()>
1491        <SET TMPS .STMPS>
1492        <SET HTMPS .SHTMPS>
1493        <PUT .PPNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
1494        <PUT .PPNOD ,ACCUM-TYPE NO-RETURN>
1495        <SET TT
1496             <SEQ-AN <KIDS .PPNOD>
1497                     <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> .PRTYP)
1498                           (ELSE ANY)>>>
1499        <COND (.ACT? <SPEC-FLUSH> <PUT-FLUSH ALL>)>
1500        <COND
1501         (<OR .ACT? <==? <NODE-SUBR .PPNOD> ,REPEAT> <AGND .PPNOD>>
1502          <COND
1503           (<NOT <ASSUM-OK? <ASSUM .PPNOD>
1504                            <COND (<AND <N==? <NODE-SUBR .PPNOD> ,REPEAT>
1505                                        <AGND .PPNOD>>
1506                                   <AGND .PPNOD>)
1507                                  (<AGND .PPNOD>
1508                                   <ORUPC .VARTBL <CHTYPE <AGND .PPNOD> LIST>>)
1509                                  (ELSE <BUILD-TYPE-LIST .VARTBL>)>>>
1510            <AGAIN>)>)
1511         (<AND <NOT .ACT?> <SET ACT? <ACTIV? <BINDING-STRUCTURE .PPNOD> T>>>
1512          <ASSERT-TYPES <ASSUM .PPNOD>>
1513          <AGAIN>)>>
1514      <COND (<==? <NODE-SUBR .PPNOD> ,REPEAT>
1515             <COND (<AGND .PPNOD>
1516                    <PUT .PPNOD
1517                         ,LIVE-VARS
1518                         <MSAVE-L-D-STATE <LIVE-VARS .PPNOD> .VARTBL>>)
1519                   (ELSE <PUT .PPNOD ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>)>
1520      <SAVE-SURVIVORS .L-D .LIFE T>
1521      <SAVE-SURVIVORS <LIVE-VARS .PPNOD> .LIFE>
1522      <COND (<NOT .TT>
1523             <COMPILE-ERROR "PROG/REPEAT returns incorrect type "
1524                            .PRTYP
1525                            .PPNOD>)>
1526      <COND (<NOT <OR <==? .TT NO-RETURN> <==? <NODE-SUBR .PPNOD> ,REPEAT>>>
1527             <PUT .PPNOD
1528                  ,DEAD-VARS
1529                  <MSAVE-L-D-STATE <DEAD-VARS .PPNOD> .VARTBL>>
1530             <COND (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1531                    <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .PPNOD>>>)>)
1532            (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1533             <ASSERT-TYPES <VSPCD .PPNOD>>)>
1534      <FREST-L-D-STATE <DEAD-VARS .PPNOD>>
1535      <SET LIFE <KILL-REM .LIFE .OV>>
1536      <PUT .PPNOD
1537           ,ACCUM-TYPE
1538           <COND (.ACT? <PUT .PPNOD ,SIDE-EFFECTS (ALL)> .PRTYP)
1539                 (<==? <NODE-SUBR .PPNOD> ,REPEAT> <ACCUM-TYPE .PPNOD>)
1540                 (ELSE <TYPE-MERGE .TT <ACCUM-TYPE .PPNOD>>)>>>
1541    <ACCUM-TYPE .PPNOD>>
1542
1543 " Determine if assumptions made for this loop are still valid."
1544
1545 <DEFINE ASSUM-OK? (AS TY "AUX" (OK? T))
1546    #DECL ((TY AS) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1547    <COND
1548     (.ANALY-OK
1549      <MAPF <>
1550       <FUNCTION (L "AUX" (SYM <1 .L>) (TT <>))
1551          #DECL ((L) <LIST SYMTAB <OR ATOM FORM SEGMENT>>)
1552          <COND
1553           (<N==? <2 .L> ANY>
1554            <MAPF <>
1555             <FUNCTION (LL)
1556                     <COND (<AND <SET TT <==? <1 .LL> .SYM>>
1557                                 <N=? <2 .L> <2 .LL>>
1558                                 <OR <==? <2 .L> NO-RETURN>
1559                                     <TYPE-OK? <2 .LL> <NOTIFY <2 .L>>>>>
1560                            <COND (.OK?
1561                                   <SET BACKTRACK <+ .BACKTRACK 1>>
1562                                   <COND (,STATUS-LINE
1563                                          <UPDATE-STATUS "Comp" <> "ANA"
1564                                                         .BACKTRACK>)>)>
1565                            <SET OK? <>>
1566                            <AND <GASSIGNED? DEBUGSW>
1567                                 ,DEBUGSW
1568                                 <PRIN1 <NAME-SYM .SYM>>
1569                                 <PRINC " NOT OK current type:  ">
1570                                 <PRIN1 <2 .LL>>
1571                                 <PRINC " assumed type:  ">
1572                                 <PRIN1 <2 .L>>
1573                                 <CRLF>>)>
1574                     <AND .TT
1575                          <PUT .L 2 <TYPE-MERGE <2 .LL> <2 .L>>>
1576                          <MAPLEAVE>>>
1577             .TY>)>>
1578       .AS>
1579      <COND (<NOT .OK?> <ASSERT-TYPES .AS>)>)>
1580    .OK?>
1581
1582 <DEFINE NOTIFY (D)
1583         <COND (<AND <TYPE? .D FORM> <==? <LENGTH .D> 2> <==? <1 .D> NOT>>
1584                <2 .D>)
1585               (ELSE <FORM NOT .D>)>>
1586
1587 " Analyze RETURN from a PROG/REPEAT.  Check with PROGs final type."
1588
1589 <DEFINE RETURN-ANA (NOD RTYP "AUX" (TT <KIDS .NOD>) N (LN <LENGTH .TT>) TEM)
1590         #DECL ((NOD) NODE (TT) <LIST [REST NODE]> (LN) FIX (N) <OR NODE
1591                                                                    FALSE>)
1592         <SET RET-OR-AGAIN T>
1593         <COND (<G? .LN 2> <COMPILE-ERROR "Too many args to RETURN." .NOD>)
1594               (<OR <AND <==? .LN 2> <SET N <ACT-CHECK <2 .TT>>>>
1595                    <AND <L=? .LN 1> <SET N <PROGCHK RETURN .NOD>>>>
1596                <SET N <CHTYPE .N NODE>>
1597                <AND <0? .LN>
1598                     <PUT .NOD
1599                          ,KIDS
1600                          <SET TT (<NODE1 ,QUOTE-CODE .NOD ATOM T ()>)>>>
1601                <SET TEM <EANA <1 .TT> <INIT-DECL-TYPE .N> RETURN>>
1602                <COND (<==? <ACCUM-TYPE .N> NO-RETURN>
1603                       <PUT .N ,VSPCD <BUILD-TYPE-LIST <SYMTAB .N>>>
1604                       <PUT .N ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
1605                      (ELSE
1606                       <PUT .N ,VSPCD <ORUPC <SYMTAB .N> <VSPCD .N>>>
1607                       <PUT .N
1608                            ,DEAD-VARS
1609                            <MSAVE-L-D-STATE <DEAD-VARS .N> .VARTBL>>)>
1610                <PUT .N ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .N>>>
1611                <PUT .NOD ,NODE-TYPE ,RETURN-CODE>
1612                NO-RETURN)
1613               (ELSE <SUBR-C-AN .NOD ANY>)>>
1614
1615 <COND (<GASSIGNED? RETURN-ANA> <PUTPROP ,RETURN ANALYSIS ,RETURN-ANA>)>
1616
1617 <DEFINE MULTI-RETURN-ANA (NOD RTYP
1618                           "AUX" (TT <KIDS .NOD>) N (LN <LENGTH .TT>) TEM
1619                                 (SEG <>) (TYPS <FORM MULTI>)
1620                                 (TP <CHTYPE .TYPS LIST>))
1621         #DECL ((NOD) NODE (TT) <LIST [REST NODE]> (LN) FIX (N) <OR NODE
1622                                                                    FALSE>)
1623         <COND (<L? .LN 1> <COMPILE-ERROR "Too few args to MULTI-RETURN." .NOD>)
1624               (ELSE
1625                <COND (<AND <==? <NODE-TYPE <SET N <1 .TT>>> ,QUOTE-CODE>
1626                            <==? <NODE-NAME .N> <>>>
1627                       <SET N <PROGCHK MULTI-RETURN .N>>)
1628                      (<SET N <ACT-CHECK .N>>)
1629                      (ELSE <EANA <1 .TT> '<OR FRAME T$FRAME> MULTI-RETURN>)>
1630                <MAPR <>
1631                      <FUNCTION (NP "AUX" (NN <1 .NP>) TY)
1632                              #DECL ((NN) NODE)
1633                              <COND (<==? <NODE-TYPE .NN> ,SEGMENT-CODE>
1634                                     <SET TY
1635                                          <EANA <1 <KIDS .NN>>
1636                                                '<OR MULTI STRUCTURED>
1637                                                MULTI-RETURN>>
1638                                     <COND (<AND <N==? .TY ANY>
1639                                                 <N==? <SET TY
1640                                                            <GET-ELE-TYPE .TY ALL>>
1641                                                       ANY>>
1642                                            <COND (<AND <NOT .SEG>
1643                                                        <EMPTY? <REST .NP>>>
1644                                                   <PUTREST .TP ([REST .TY])>)
1645                                                  (<AND <EMPTY? <REST .NP>>
1646                                                        <N==? .SEG ANY>>
1647                                                   <PUTREST .TP
1648                                                            ([REST
1649                                                              <TYPE-MERGE .SEG
1650                                                                          .TY>])>)
1651                                                  (<N==? .SEG ANY>
1652                                                   <SET SEG
1653                                                        <TYPE-MERGE .SEG .TY>>)>)
1654                                           (ELSE <SET SEG ANY>)>)
1655                                    (ELSE
1656                                     <SET TY <EANA .NN ANY MULTI-RETURN>>
1657                                     <COND (<NOT .SEG>
1658                                            <PUTREST .TP <SET TP (.TY)>>)>)>>
1659                      <REST .TT>>
1660                <COND (<AND .N <==? <ACCUM-TYPE .N> NO-RETURN>>
1661                       <PUT .N ,VSPCD <BUILD-TYPE-LIST <SYMTAB .N>>>
1662                       <PUT .N ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
1663                      (.N
1664                       <PUT .N ,VSPCD <ORUPC <SYMTAB .N> <VSPCD .N>>>
1665                       <PUT .N
1666                            ,DEAD-VARS
1667                            <MSAVE-L-D-STATE <DEAD-VARS .N> .VARTBL>>)>
1668                <COND (.N <PUT .N ,ACCUM-TYPE <TYPE-MERGE .TYPS
1669                                                          <ACCUM-TYPE .N>>>)>
1670                <PUT .NOD ,NODE-TYPE ,MULTI-RETURN-CODE>
1671                NO-RETURN)>>
1672
1673 <COND (<AND <GASSIGNED? MULTI-RETURN> <GASSIGNED? MULTI-RETURN-ANA>>
1674        <PUTPROP ,MULTI-RETURN ANALYSIS ,MULTI-RETURN-ANA>)>
1675
1676 <DEFINE ACT-CHECK (N "OPT" (RETMNG T) "AUX" SYM RAO N1 (NT <NODE-TYPE .N>))
1677         #DECL ((N N1) NODE (SYM) <OR SYMTAB FALSE> (RAO VALUE) <OR FALSE NODE>
1678                (NT) FIX)
1679         <COND (<OR <AND <==? .NT ,LVAL-CODE>
1680                         <TYPE? <NODE-NAME .N> SYMTAB>
1681                         <PURE-SYM <SET SYM <NODE-NAME .N>>>
1682                         <==? <CODE-SYM .SYM> 1>>
1683                    <AND <OR <==? .NT ,RSUBR-CODE> <==? .NT ,SUBR-CODE>>
1684                         <==? <NODE-SUBR .N> ,LVAL>
1685                         <==? <LENGTH <KIDS .N>> 1>
1686                         <==? <NODE-TYPE <SET N1 <1 <KIDS .N>>>> ,QUOTE-CODE>
1687                         <TYPE? <NODE-NAME .N1> ATOM>
1688                         <SET SYM <SRCH-SYM <NODE-NAME .N1>>>
1689                         <PURE-SYM .SYM>
1690                         <==? <CODE-SYM .SYM> 1>>>
1691                <SET RAO <RET-AGAIN-ONLY <CHTYPE .SYM SYMTAB>>>
1692                <EANA .N FRAME AGAIN-RETURN>
1693                <COND (.RETMNG <PUT <CHTYPE .SYM SYMTAB> ,RET-AGAIN-ONLY .RAO>)>
1694                .RAO)>>
1695
1696 " AGAIN analyzer."
1697
1698 <DEFINE AGAIN-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N)
1699         #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (N) <OR FALSE NODE>)
1700         <SET RET-OR-AGAIN T>
1701         <COND (<OR <AND <EMPTY? .TEM> <SET N <PROGCHK AGAIN .NOD>>>
1702                    <AND <EMPTY? <REST .TEM>> <SET N <ACT-CHECK <1 .TEM>>>>>
1703                <PUT .NOD ,NODE-TYPE ,AGAIN-CODE>
1704                <SET N <CHTYPE .N NODE>>
1705                <COND (<AGND .N>
1706                       <PUT .N
1707                            ,LIVE-VARS
1708                            <MSAVE-L-D-STATE <LIVE-VARS .N> .VARTBL>>)
1709                      (ELSE <PUT .N ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>
1710                <PUT .N
1711                     ,AGND
1712                     <COND (<NOT <AGND .N>> <BUILD-TYPE-LIST <SYMTAB .N>>)
1713                           (ELSE <ORUPC <SYMTAB .N> <AGND .N>>)>>
1714                NO-RETURN)
1715               (<EMPTY? <REST .TEM>>
1716                <COND (<NOT <ANA <1 .TEM> FRAME>>
1717                       <COMPILE-ERROR "Again not passed an activation" .NOD>)>
1718                ANY)
1719               (ELSE <COMPILE-ERROR "Too many arguments to AGAIN" .NOD>)>>
1720
1721 <COND (<GASSIGNED? AGAIN-ANA> <PUTPROP ,AGAIN ANALYSIS ,AGAIN-ANA>)>
1722
1723 " If not in PROG/REPEAT complain about NAME."
1724
1725 <DEFINE PROGCHK (NAME NOD)
1726         #DECL ((NOD) NODE)
1727         <COND (<NOT <ASSIGNED? PNOD>>
1728                <COMPILE-ERROR "Not in PROG/REPEAT " .NAME .NOD>)>
1729         .PNOD>
1730
1731 " Dispatch to special handlers for SUBRs.  Or use standard."
1732
1733 <DEFINE SUBR-ANA (NOD RTYP)
1734         #DECL ((NOD) NODE)
1735         <APPLY <GETPROP <NODE-SUBR .NOD> ANALYSIS ',SUBR-C-AN> .NOD .RTYP>>
1736
1737 " Hairy SUBR call analyzer.  Also looks for internal calls."
1738
1739 <DEFINE SUBR-C-AN (NOD RTYP
1740                    "AUX" (ARGS 0) (TYP ANY) (TMPL <GET-TMP <NODE-SUBR .NOD>>)
1741                          (NRGS1 <1 .TMPL>))
1742    #DECL ((NOD) <SPECIAL NODE> (ARGS) <SPECIAL FIX> (TYP NRGS1) <SPECIAL ANY>
1743           (TMPL) <SPECIAL LIST>)
1744    <MAPF
1745     <FUNCTION ("TUPLE" T
1746                "AUX" NARGS TEM (NARGS1 .NRGS1) (N .NOD) (TPL .TMPL)
1747                      (RGS .ARGS))
1748             #DECL ((T) TUPLE (ARGS RGS TL) FIX (TMPL TPL) <LIST ANY ANY>
1749                    (N NOD) NODE (NARGS) <LIST FIX FIX>)
1750             <SET TYP <2 .TPL>>
1751             <SPEC-FLUSH>
1752             <PUT-FLUSH ALL>
1753             <COND (<SEGS .N>
1754                    <COND (<TYPE? .TYP ATOM FORM>) (ELSE <SET TYP ANY>)>)
1755                   (ELSE
1756                    <COND (<TYPE? .NARGS1 FIX>
1757                           <ARGCHK .RGS .NARGS1 <NODE-NAME .N> .NOD>)
1758                          (<TYPE? .NARGS1 LIST>
1759                           <COND (<G? .RGS <2 <SET NARGS .NARGS1>>>
1760                                  <COMPILE-ERROR "Too many arguments to "
1761                                                 <NODE-NAME .N>
1762                                                 .N>)>
1763                           <COND (<L? .RGS <1 .NARGS>>
1764                                  <COMPILE-ERROR
1765                                   "Too few arguments to "
1766                                   <NODE-NAME .N>
1767                                   .N>)>)>
1768                    <COND (<TYPE? .TYP ATOM FORM>)
1769                          (ELSE <SET TYP <APPLY .TYP !.T>>)>
1770                    <SET ARGS .RGS>)>>
1771     <FUNCTION (N "AUX" TYP)
1772             #DECL ((N NOD) NODE (ARGS) FIX (ARGACS) <PRIMTYPE LIST>)
1773             <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1774                    <EANA <1 <KIDS .N>> '<OR MULTI STRUCTURED> SEGMENT>
1775                    <PUT .NOD ,SEGS T>
1776                    ANY)
1777                   (ELSE <SET ARGS <+ .ARGS 1>> <SET TYP <ANA .N ANY>> .TYP)>>
1778     <KIDS .NOD>>
1779    <PUT .NOD ,SIDE-EFFECTS (ALL)>
1780    <TYPE-OK? .TYP .RTYP>>
1781
1782 <DEFINE SEGMENT-ANA (NOD RTYP)
1783         <COMPILE-ERROR "Illegal segment (not in form or structure)" .NOD>>
1784
1785 " Analyze VECTOR, UVECTOR and LIST builders."
1786
1787 <DEFINE COPY-AN (NOD RTYP
1788                  "AUX" (ARGS 0) (RT <ISTYPE? <RESULT-TYPE .NOD>>)
1789                        (K <KIDS .NOD>) N (LWIN <==? .RT LIST>) NN COD)
1790    #DECL ((NOD N) NODE (ARGS) FIX (K) <LIST [REST NODE]>)
1791    <COND
1792     (<NOT <EMPTY? .K>>
1793      <REPEAT (DC STY PTY TEM TT (SG <>) (FRM <FORM .RT>)
1794               (FRME <CHTYPE .FRM LIST>) (GOTDC <>))
1795        #DECL ((FRM) FORM (FRME) <LIST ANY>)
1796        <COND
1797         (<EMPTY? .K>
1798          <COND (<==? .RT LIST>
1799                 <RETURN <SET RT
1800                              <COND (<EMPTY? <REST .FRM>> <1 .FRM>)
1801                                    (ELSE .FRM)>>>)>
1802          <COND (.DC <PUTREST .FRME ([REST .DC])>)
1803                (.STY <PUTREST .FRME ([REST .STY])>)
1804                (.PTY <PUTREST .FRME ([REST <FORM PRIMTYPE .PTY>])>)>
1805          <RETURN <SET RT .FRM>>)
1806         (<OR <==? <SET COD <NODE-TYPE <SET N <1 .K>>>> ,SEGMENT-CODE>
1807              <==? .COD ,SEG-CODE>>
1808          <SET TEM <GET-ELE-TYPE <EANA <1 <KIDS .N>>
1809                                       '<OR MULTI STRUCTURED> SEGMENT> ALL>>
1810          <PUT .NOD ,SEGS T>
1811          <COND (<NOT .SG> <SET GOTDC <>>)>
1812          <SET SG T>
1813          <COND (<AND .LWIN
1814                      <MEMQ <STRUCTYP <RESULT-TYPE <1 <KIDS .N>>>>
1815                            '[LIST VECTOR UVECTOR TUPLE]>>)
1816                (ELSE <SET LWIN <>>)>)
1817         (ELSE <SET ARGS <+ .ARGS 2>> <SET TEM <ANA .N ANY>>)>
1818        <COND (<NOT .GOTDC>
1819               <SET GOTDC T>
1820               <SET PTY
1821                    <COND (<SET STY <ISTYPE? <SET DC .TEM>>> <MTYPR .STY>)>>)
1822              (<OR <NOT .DC> <N==? .DC .TEM>>
1823               <SET DC <>>
1824               <COND (<OR <N==? <SET TT <ISTYPE? .TEM>> .STY> <NOT .STY>>
1825                      <SET STY <>>
1826                      <COND (<AND .PTY <==? .PTY <AND .TT <MTYPR .TT>>>>)
1827                            (ELSE <SET PTY <>>)>)>)>
1828        <COND (<NOT .SG> <SET FRME <REST <PUTREST .FRME (.TEM)>>>)>
1829        <SET K <REST .K>>>)>
1830    <PUT .NOD ,RESULT-TYPE .RT>
1831    <COND
1832     (<AND <GASSIGNED? COPY-LIST-CODE> .LWIN>
1833      <MAPF <>
1834            <FUNCTION (N)
1835                    #DECL ((N) NODE)
1836                    <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1837                           <PUT .N ,NODE-TYPE ,SEG-CODE>)>>
1838            <KIDS .NOD>>
1839      <COND (<AND <==? <LENGTH <SET K <KIDS .NOD>>> 1>
1840                  <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
1841                  <==? <STRUCTYP <RESULT-TYPE <SET NN <1 <KIDS <1 .K>>>>>>
1842                       LIST>>
1843             <COND (<NOT <EMPTY? <PARENT .NOD>>>
1844                    <MAPR <>
1845                          <FUNCTION (L "AUX" (N <1 .L>))
1846                                  #DECL ((N) NODE (L) <LIST [REST NODE]>)
1847                                  <COND (<==? .NOD .N>
1848                                         <PUT .L 1 .NN>
1849                                         <MAPLEAVE>)>>
1850                          <KIDS <CHTYPE <PARENT .NOD> NODE>>>)>
1851             <PUT .NN ,PARENT <CHTYPE <PARENT .NOD> NODE>>
1852             <SET RT <RESULT-TYPE .NN>>)
1853            (ELSE <PUT .NOD ,NODE-TYPE ,COPY-LIST-CODE>)>)
1854     (ELSE
1855      <MAPF <>
1856            <FUNCTION (N)
1857                    #DECL ((N) NODE)
1858                    <COND (<==? <NODE-TYPE .N> ,SEG-CODE>
1859                           <PUT .N ,NODE-TYPE ,SEGMENT-CODE>)>>
1860            <KIDS .NOD>>
1861      <PUT .NOD ,NODE-TYPE ,COPY-CODE>)>
1862    <TYPE-OK? .RT .RTYP>>
1863
1864 " Analyze quoted objects, for structures hack type specs."
1865
1866 <DEFINE QUOTE-ANA (NOD RTYP)
1867         #DECL ((NOD) NODE)
1868         <TYPE-OK? <GEN-DECL <NODE-NAME .NOD>> .RTYP>>
1869
1870 <DEFINE QUOTE-ANA2 (NOD RTYP)
1871         #DECL ((NOD) NODE)
1872         <COND (<1? <LENGTH <KIDS .NOD>>>
1873                <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1874                <PUT .NOD ,NODE-NAME <1 <KIDS .NOD>>>
1875                <PUT .NOD ,KIDS ()>
1876                <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)
1877               (ELSE <COMPILE-ERROR "Empty QUOTE?">)>>
1878
1879 <COND (<GASSIGNED? QUOTE-ANA2> <PUTPROP ,QUOTE ANALYSIS ,QUOTE-ANA2>)>
1880
1881 " Analyze a call to an RSUBR."
1882
1883 <DEFINE RSUBR-ANA (NOD RTYP
1884                    "AUX" (ARGS 0)
1885                          (DCL:<LIST [REST !<LIST ATOM ANY!>]> <TYPE-INFO .NOD>)
1886                          (SEGF <>) (MUST-EMPTY T) FRST (TUPF <>) (OPTF <>)
1887                          (K:<LIST [REST NODE]> <KIDS .NOD>)
1888                          (NM:ATOM <NODE-NAME .NOD>) (RT <>))
1889    #DECL ((NOD) NODE (ARGS) FIX)
1890    <MAPF <>
1891     <FUNCTION (ARG "AUX" TY ET)
1892             #DECL ((ARG NOD) NODE)
1893             <COND (<NOT <EMPTY? .DCL>>
1894                    <COND (<==? <SET FRST <1 <SET RT <1 .DCL>>>> OPTIONAL>
1895                           <SET OPTF T>)
1896                          (<==? .FRST TUPLE> <SET TUPF T>)>
1897                    <SET RT <2 .RT>>
1898                    <SET DCL <REST .DCL>>)
1899                   (<NOT .TUPF> <SET OPTF <SET RT <>>>)>
1900             <COND (<==? <NODE-TYPE .ARG> ,SEGMENT-CODE>
1901                    <SET SEGF T>
1902                    <SET ET
1903                         <GET-ELE-TYPE <SET TY <ANA <1 <KIDS .ARG>> ANY>> ALL>>
1904                    <COND (<COND (.TUPF <TYPE-OK? <GET-ELE-TYPE .RT ALL> .ET>)
1905                                 (.RT <TYPE-OK? .RT .ET>)>)
1906                          (<AND <OR <NOT .RT> .TUPF .OPTF> <L=? <MINL .TY> 0>>
1907                           <SET MUST-EMPTY T>
1908                           <COMPILE-WARNING "Segment must be empty:  " .NOD>)
1909                          (<NOT .RT> <COMPILE-ERROR "Too many arguments to:  "
1910                                                    .NM .ARG>)
1911                          (ELSE
1912                           <COMPILE-ERROR "Argument wrong type to:  "
1913                                          .NM
1914                                          .ARG>)>
1915                    <PUT .NOD ,SEGS T>)
1916                   (ELSE
1917                    <SET ARGS <+ .ARGS 1>>
1918                    <EANA .ARG
1919                          <COND (.TUPF <GET-ELE-TYPE .RT <COND (.SEGF ALL)
1920                                                               (ELSE .ARGS)>>)
1921                                (ELSE .RT)> .NM>)>>
1922     .K>
1923    <COND (<OR <==? .NM PRINC> <==? .NM PRINT> <==? .NM PRIN1>>
1924           <RESULT-TYPE .NOD <TYPE-AND <RESULT-TYPE .NOD>
1925                                       <RESULT-TYPE <1 .K>>>>)>
1926    <SPEC-FLUSH>
1927    <PUT-FLUSH ALL>
1928    <PUT .NOD ,SIDE-EFFECTS (ALL)>
1929    <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>>
1930
1931 " Analyze CHTYPE, in some cases do it at compile time."
1932
1933 <DEFINE CHTYPE-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) NTN NT OBN OB TARG S1 S2
1934                     TDECL)
1935    #DECL ((NOD OBN NTN) NODE (K) <LIST [REST NODE]> (NT) ATOM)
1936    <COND
1937     (<SEGFLUSH .NOD .RTYP>)
1938     (ELSE
1939      <ARGCHK <LENGTH .K> 2 CHTYPE .NOD>
1940      <SET OB <ANA <SET OBN <1 .K>> ANY>>
1941      <EANA <SET NTN <2 .K>> ATOM CHTYPE>
1942      <COND
1943       (<==? <NODE-TYPE .NTN> ,QUOTE-CODE>
1944        <COND (<NOT <ISTYPE? <SET NT <NODE-NAME .NTN>>>>
1945               <COMPILE-ERROR "Second arg to CHTYPE not a type " .NT .NOD>)>
1946        <COND (<NOT <TYPE-OK? .OB <FORM PRIMTYPE <MTYPR .NT>>>>
1947               <COMPILE-ERROR "Primtypes differ in CHTYPE" .OB .NT .NOD>)>
1948        <COND (<==? <NODE-TYPE .OBN> ,QUOTE-CODE>
1949               <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1950               <PUT .NOD ,KIDS ()>
1951               <PUT .NOD ,NODE-NAME <CHTYPE <NODE-NAME .OBN> .NT>>)
1952              (<TYPESAME .OB .NT>
1953               <COMPILE-WARNING "Redundant CHTYPE" .NOD>
1954               <PUT .NOD ,NODE-TYPE ,ID-CODE>)
1955              (<SET TDECL <GET-DECL .NT>>
1956               <SET TDECL <CHTYPE
1957                           (<FORM PRIMTYPE <TYPEPRIM .NT>> !<REST .TDECL>)
1958                           <TYPE .TDECL>>>
1959               <COND (<NOT <TYPE-OK? .OB .TDECL>>
1960                      <COMPILE-ERROR "DECL violation in CHTYPE "
1961                                     .NOD>)>
1962               <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>)
1963              (ELSE <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>)>
1964        <PUT .NOD ,RESULT-TYPE .NT>
1965        <TYPE-OK? .NT .RTYP>)
1966       (<AND <==? <NODE-TYPE .NTN> ,RSUBR-CODE> <==? <NODE-NAME .NTN> TYPE>>
1967        <COND
1968         (<AND <SET S1 <PRIMITIVE-TYPE .OB>>
1969               <SET S2
1970                    <PRIMITIVE-TYPE <SET TARG <RESULT-TYPE <1 <KIDS .NTN>>>>>>
1971               <NOT <TYPE-OK? .S1 .S2>>>
1972          <COMPILE-ERROR "Primtypes differ in CHTYPE" .OB .TARG .NOD>)
1973         (ELSE
1974          <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1975          <PUT .NOD ,RESULT-TYPE .TARG>
1976          <TYPE-OK? .TARG .RTYP>)>)
1977       (ELSE
1978        <COND (.VERBOSE <ADDVMESS .NOD ("Can't open compile CHTYPE.")>)>
1979        <TYPE-OK? ANY .RTYP>)>)>>
1980
1981 <COND (<GASSIGNED? CHTYPE-ANA> <PUTPROP ,CHTYPE ANALYSIS ,CHTYPE-ANA>)>
1982
1983 " Analyze use of ASCII sometimes do at compile time."
1984
1985 <DEFINE ASCII-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) ITM TYP TEM)
1986         #DECL ((NOD ITM) NODE (K) <LIST [REST NODE]>)
1987         <COND (<SEGFLUSH .NOD .RTYP>)
1988               (ELSE
1989                <ARGCHK <LENGTH .K> 1 ASCII .NOD>
1990                <SET TYP <EANA <SET ITM <1 .K>> '<OR FIX CHARACTER> ASCII>>
1991                <COND (<==? <NODE-TYPE .ITM> ,QUOTE-CODE>
1992                       <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1993                       <PUT .NOD ,NODE-NAME <SET TEM <ASCII <NODE-NAME .ITM>>>>
1994                       <PUT .NOD ,RESULT-TYPE <TYPE .TEM>>
1995                       <PUT .NOD ,KIDS ()>)
1996                      (<==? <ISTYPE? .TYP> FIX>
1997                       <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1998                       <PUT .NOD ,RESULT-TYPE CHARACTER>)
1999                      (<==? .TYP CHARACTER>
2000                       <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
2001                       <PUT .NOD ,RESULT-TYPE FIX>)
2002                      (ELSE <PUT .NOD ,RESULT-TYPE '<OR FIX CHARACTER>>)>
2003                <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
2004
2005 <COND (<GASSIGNED? ASCII-ANA> <PUTPROP ,ASCII ANALYSIS ,ASCII-ANA>)>
2006
2007 <DEFINE UNWIND-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) ITYP)
2008         #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
2009         <SET ITYP <EANAQ <1 .K> ANY UNWIND .NOD>>
2010         <EANA <2 .K> ANY UNWIND>
2011         <PUTPROP .FCN UNWIND T>
2012         <TYPE-OK? .ITYP .RTYP>>
2013
2014 " Analyze READ type SUBRS in two cases (print uncertain usage message maybe?)"
2015
2016 <DEFINE READ-ANA (N R)
2017    #DECL ((N) NODE)
2018    <MAPF <>
2019          <FUNCTION (NN "AUX" TY)
2020                  #DECL ((NN N) NODE)
2021                  <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
2022                         <SPEC-FLUSH>
2023                         <PUT-FLUSH ALL>
2024                         <SET TY <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>>
2025                         <COND (<TYPE-OK? .TY '<OR FORM LIST VECTOR UVECTOR>>
2026                                <COMPILE-WARNING
2027                                 "Uncertain use of " <NODE-NAME .N> .N>)
2028                               (ELSE <PUT .N ,NODE-TYPE ,READ-EOF2-CODE>)>)
2029                        (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
2030          <KIDS .N>>
2031    <SPEC-FLUSH>
2032    <PUT-FLUSH ALL>
2033    <TYPE-OK? ANY .R>>
2034
2035 <DEFINE READ2-ANA (N R)
2036         #DECL ((N) NODE)
2037         <MAPF <>
2038               <FUNCTION (NN)
2039                       #DECL ((NN N) NODE)
2040                       <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
2041                              <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>)
2042                             (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
2043               <KIDS .N>>
2044         <SPEC-FLUSH>
2045         <PUT-FLUSH ALL>
2046         <TYPE-OK? ANY .R>>
2047
2048 <DEFINE GET-ANA (N R "AUX" TY (K <KIDS .N>) (NAM <NODE-NAME .N>))
2049         #DECL ((N) NODE (K) <LIST NODE NODE NODE>)
2050         <EANA <1 .K> ANY .NAM>
2051         <EANA <2 .K> ANY .NAM>
2052         <SET TY <EANAQ <3 .K> ANY .NAM .N>>
2053         <COND (<TYPE-OK? .TY '<OR LIST VECTOR UVECTOR FORM>>
2054                <COMPILE-WARNING "Uncertain use of " .NAM .N>
2055                <SPEC-FLUSH>
2056                <PUT-FLUSH ALL>)
2057               (ELSE <PUT .N ,NODE-TYPE ,GET2-CODE>)>
2058         <TYPE-OK? ANY .R>>
2059
2060 <DEFINE GET2-ANA (N R
2061                   "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>) (LN <LENGTH .K>))
2062         #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (LN) FIX)
2063         <EANA <1 .K> ANY .NAM>
2064         <EANA <2 .K> ANY .NAM>
2065         <COND (<==? .LN 3> <EANAQ <3 .K> ANY .NAM .N>)>
2066         <TYPE-OK? ANY .R>>
2067
2068 <DEFINE EANAQ (N R NAM INOD "AUX" SPCD)
2069         #DECL ((N) NODE (SPCD) LIST)
2070         <SET SPCD <BUILD-TYPE-LIST .VARTBL>>
2071         <SET R <EANA .N .R .NAM>>
2072         <ASSERT-TYPES <ORUPC .VARTBL .SPCD>>
2073         .R>
2074
2075 <DEFINE ACTIV? (BST NOACT)
2076         #DECL ((BST) <LIST [REST SYMTAB]>)
2077         <REPEAT ()
2078                 <AND <EMPTY? .BST> <RETURN <>>>
2079                 <AND <==? <CODE-SYM <1 .BST>> 1>
2080                      <OR <NOT .NOACT>
2081                          <NOT <RET-AGAIN-ONLY <1 .BST>>>
2082                          <SPEC-SYM <1 .BST>>>
2083                      <RETURN T>>
2084                 <SET BST <REST .BST>>>>
2085
2086 <DEFINE SAME-DECL? (D1 D2) <OR <=? .D1 .D2> <NOT <TYPE-OK? .D2 <NOTIFY .D1>>>>>
2087
2088 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
2089         #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
2090         <COND (<AND <TYPE? .OBJ FORM SEGMENT>
2091                     <SET OB <CHTYPE .OBJ FORM>>
2092                     <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
2093                              <==? <1 .OB> LVAL>
2094                              <TYPE? <SET SYM <2 .OB>> ATOM>>
2095                         <AND <==? .T1 3>
2096                              <==? <1 .OB> SET>
2097                              <TYPE? <SET SYM <2 .OB>> ATOM>>>
2098                     <SET T2 <SRCH-SYM .SYM>>>
2099                <COND (<NOT <SPEC-SYM .T2>>
2100                       <COMPILE-NOTE "Redeclared special " .SYM>
2101                       <PUT .T2 ,SPEC-SYM T>)>)>
2102         <COND (<MEMQ <PRIMTYPE .OBJ> '[FORM LIST UVECTOR VECTOR]>
2103                <MAPF <> ,SPECIALIZE .OBJ>)>>
2104
2105 <DEFINE ADECL-ANA (NOD RTYP "AUX" (RT <NODE-NAME .NOD>) (N <1 <KIDS .NOD>>) TY)
2106
2107         <COND (<NOT <SET TY <TYPE-OK? .RT .RTYP>>>
2108                <COMPILE-ERROR "ADECL asserts incompatible type."
2109                               "Required type is "
2110                               .RTYP
2111                               " ADECL type is "
2112                               .RT>)
2113               (<NOT <SET RT <ANA .N .TY>>>
2114                <COMPILE-ERROR "ADECL asserts incompatible type."
2115                               "Result type is "
2116                               <RESULT-TYPE .N>
2117                               " ADECL type is "
2118                               .TY>)>
2119         <PUT .NOD ,RESULT-TYPE .RT>
2120         .RT>
2121
2122 <DEFINE CALL-ANA (N R "AUX" (K <KIDS .N>) INS TYP NN)
2123    #DECL ((N INS) NODE (K) <LIST [REST NODE]> (NN) <OR FALSE NODE>)
2124    <COND
2125     (<EMPTY? .K> <COMPILE-ERROR "CALL has no instruction supplied" .N>)
2126     (<AND <==? <NODE-TYPE <SET INS <1 .K>>> ,QUOTE-CODE>
2127           <TYPE? <NODE-NAME .INS> ATOM>
2128           <SET TYP <LEGAL-MIM-INS .INS>>>
2129      <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>
2130      <COND (<==? <NODE-NAME .INS> `RTUPLE>
2131             <EANA <2 .K> FIX RTUPLE>
2132             <COND (<SET NN <ACT-CHECK <3 .K> <>>>
2133                    <COND (<==? <ACCUM-TYPE .NN> NO-RETURN>
2134                           <PUT .NN ,VSPCD <BUILD-TYPE-LIST <SYMTAB .NN>>>
2135                           <PUT .NN ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
2136                          (ELSE
2137                           <PUT .NN ,VSPCD <ORUPC <SYMTAB .NN> <VSPCD .NN>>>
2138                           <PUT .NN
2139                                ,DEAD-VARS
2140                                <MSAVE-L-D-STATE <DEAD-VARS .NN> .VARTBL>>)>
2141                    <PUT .NN ,ACCUM-TYPE <TYPE-MERGE TUPLE <ACCUM-TYPE .NN>>>)
2142                   (ELSE <EANA <3 .K> FRAME RTUPLE>)>)
2143            (ELSE
2144             <MAPF <>
2145                   <FUNCTION (N)
2146                           #DECL ((N) NODE)
2147                           <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
2148                                  <EANA <1 <KIDS .N>> '<OR MULTI STRUCTURED> CALL>)
2149                                 (ELSE <EANA .N ANY CALL>)>>
2150                   <REST .K>>)>
2151      <TYPE-OK? .R .TYP>)
2152     (ELSE <COMPILE-ERROR "CALL with a non-instruction: " .N>)>>
2153
2154 <DEFINE LEGAL-MIM-INS (N "AUX" (ATM <NODE-NAME .N>) MIMOP)
2155         #DECL ((FCN N) NODE (ATM) ATOM)
2156         <COND (<SET MIMOP <LOOKUP <SPNAME .ATM> ,MIM-OBL>>
2157                <PUT .N ,NODE-NAME .MIMOP>
2158                <COND (<=? <SPNAME .MIMOP> "ACTIVATION">
2159                       <PUT .FCN ,ACTIVATED T>)>
2160                <COND (<GETPROP .MIMOP TYPE>) (ELSE ANY)>)>>
2161
2162 <DEFINE APPLY-ANA (N R "AUX" (K <KIDS .N>))
2163         #DECL ((N) NODE (K) <LIST [REST NODE]>)
2164         <COND (<EMPTY? .K> <COMPILE-ERROR "APPLY has nothing to apply" .N>)
2165               (ELSE
2166                <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>
2167                <MAPF <>
2168                      <FUNCTION (N)
2169                              #DECL ((N) NODE)
2170                              <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
2171                                     <EANA <1 <KIDS .N>>
2172                                           '<OR MULTI STRUCTURED> CALL>)
2173                                    (ELSE <EANA .N ANY CALL>)>>
2174                      .K>
2175                <PUT .N ,NODE-TYPE ,APPLY-CODE>
2176                <TYPE-OK? .R ANY>)>>
2177
2178 <COND (<GASSIGNED? APPLY-ANA> <PUTPROP ,APPLY ANALYSIS ,APPLY-ANA>)>
2179
2180 <DEFINE ANALYSIS-DISPATCHER (NOD RTYP)
2181         <CASE ,==?
2182               <NODE-TYPE .NOD>
2183               (,QUOTE-CODE <QUOTE-ANA .NOD .RTYP>)
2184               (,FUNCTION-CODE <FUNC-ANA .NOD .RTYP>)
2185               (,SEGMENT-CODE <SEGMENT-ANA .NOD .RTYP>)
2186               (,FORM-CODE <FORM-AN .NOD .RTYP>)
2187               (,PROG-CODE <PRG-REP-ANA .NOD .RTYP>)
2188               (,SUBR-CODE <SUBR-ANA .NOD .RTYP>)
2189               (,COND-CODE <COND-ANA .NOD .RTYP>)
2190               (,COPY-CODE <COPY-AN .NOD .RTYP>)
2191               (,RSUBR-CODE <RSUBR-ANA .NOD .RTYP>)
2192               (,ISTRUC-CODE <ISTRUC-ANA .NOD .RTYP>)
2193               (,ISTRUC2-CODE <ISTRUC2-ANA .NOD .RTYP>)
2194               (,READ-EOF-CODE <READ-ANA .NOD .RTYP>)
2195               (,READ-EOF2-CODE <READ2-ANA .NOD .RTYP>)
2196               (,GET-CODE <GET-ANA .NOD .RTYP>)
2197               (,GET2-CODE <GET2-ANA .NOD .RTYP>)
2198               (,MAP-CODE <MAPPER-AN .NOD .RTYP>)
2199               (,MARGS-CODE <MARGS-ANA .NOD .RTYP>)
2200               (,ARITH-CODE <ARITH-ANA .NOD .RTYP>)
2201               (,TEST-CODE <ARITHP-ANA .NOD .RTYP>)
2202               (,0-TST-CODE <ARITHP-ANA .NOD .RTYP>)
2203               (,1?-CODE <ARITHP-ANA .NOD .RTYP>)
2204               (,MIN-MAX-CODE <ARITH-ANA .NOD .RTYP>)
2205               (,ABS-CODE <ABS-ANA .NOD .RTYP>)
2206               (,FIX-CODE <FIX-ANA .NOD .RTYP>)
2207               (,FLOAT-CODE <FLOAT-ANA .NOD .RTYP>)
2208               (,MOD-CODE <MOD-ANA .NOD .RTYP>)
2209               (,LNTH-CODE <LENGTH-ANA .NOD .RTYP>)
2210               (,MT-CODE <EMPTY?-ANA .NOD .RTYP>)
2211               (,NTH-CODE <NTH-ANA .NOD .RTYP>)
2212               (,REST-CODE <REST-ANA .NOD .RTYP>)
2213               (,PUT-CODE <PUT-ANA .NOD .RTYP>)
2214               (,PUTR-CODE <PUTREST-ANA .NOD .RTYP>)
2215               (,UNWIND-CODE <UNWIND-ANA .NOD .RTYP>)
2216               (,FORM-F-CODE <FORM-F-ANA .NOD .RTYP>)
2217               (,IRSUBR-CODE <IRSUBR-ANA .NOD .RTYP>)
2218               (,ROT-CODE <ROT-ANA .NOD .RTYP>)
2219               (,LSH-CODE <LSH-ANA .NOD .RTYP>)
2220               (,BIT-TEST-CODE <BIT-TEST-ANA .NOD .RTYP>)
2221               (,CASE-CODE <CASE-ANA .NOD .RTYP>)
2222               (,COPY-LIST-CODE <COPY-AN .NOD .RTYP>)
2223               (,ADECL-CODE <ADECL-ANA .NOD .RTYP>)
2224               (,CALL-CODE <CALL-ANA .NOD .RTYP>)
2225               (,APPLY-CODE <APPLY-ANA .NOD .RTYP>)
2226               (,FGETBITS-CODE <FGETBITS-ANA .NOD .RTYP>)
2227               (,FPUTBITS-CODE <FPUTBITS-ANA .NOD .RTYP>)
2228               (,STACK-CODE <STACK-ANA .NOD .RTYP>)
2229               (,BACK-CODE <BACK-ANA .NOD .RTYP>)
2230               (,TOP-CODE <TOP-ANA .NOD .RTYP>)
2231               (,CHANNEL-OP-CODE <CHANNEL-OP-ANA .NOD .RTYP>)
2232               (,ATOM-PART-CODE <ATOM-PART-ANA .NOD .RTYP>)
2233               (,OFFSET-PART-CODE <OFFSET-PART-ANA .NOD .RTYP>)
2234               (,PUT-GET-DECL-CODE <PUT-GET-DECL-ANA .NOD .RTYP>)
2235               (,SUBSTRUC-CODE <SUBSTRUC-ANA .NOD .RTYP>)
2236               (,MULTI-SET-CODE <MULTI-SET-ANA .NOD .RTYP>)
2237               DEFAULT
2238               (<SUBR-ANA .NOD .RTYP>)>>
2239
2240 <DEFINE SPEC-ANA (CONST PRED-NAME OTYPE RTYP DFLG NOD WHO "AUX" TEM PAT)
2241         #DECL ((NOD) NODE)
2242         <SET PAT
2243              <COND (<TYPE? .CONST LIST>
2244                     <COND (<==? .PRED-NAME ==?> <GEN-DECL <1 .CONST>>)
2245                           (<==? .PRED-NAME TYPE?> <TYPE-MERGE !.CONST>)
2246                           (ELSE
2247                            <MAPF ,TYPE-MERGE
2248                                  <FUNCTION (X) <FORM PRIMTYPE .X>>
2249                                  .CONST>)>)
2250                    (ELSE
2251                     <COND (<==? .PRED-NAME ==?> <GEN-DECL .CONST>)
2252                           (<==? .PRED-NAME TYPE?> .CONST)
2253                           (ELSE <FORM PRIMTYPE .CONST>)>)>>
2254         <COND
2255          (.DFLG <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? ATOM .RTYP>>> .TEM)
2256          (ELSE
2257           <COND (<AND <N==? .PRED-NAME ==?>
2258                       <N==? .OTYPE ANY>
2259                       <NOT <TYPE-OK? <FORM NOT .PAT> .OTYPE>>>
2260                  <SET TEM ATOM>)
2261                 (<TYPE-OK? .OTYPE .PAT> <SET TEM '<OR FALSE ATOM>>)
2262                 (ELSE <SET TEM FALSE>)>
2263           <MAPF <>
2264                 <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
2265                         #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB> (SYM) SYMTAB)
2266                         <SET TRUTH
2267                              <ADD-TYPE-LIST .SYM .PAT .TRUTH .FLG <REST .L 2>>>
2268                         <OR <==? .TEM ATOM>
2269                             <SET UNTRUTH
2270                                  <ADD-TYPE-LIST .SYM
2271                                                 <FORM NOT .PAT>
2272                                                 .UNTRUTH
2273                                                 .FLG
2274                                                 <REST .L 2>>>>>
2275                 .WHO>
2276           <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? .TEM .RTYP>>>
2277           .TEM)>>
2278
2279 <DEFINE ISTRUC-ANA (N R "AUX" (K <KIDS .N>) FM NUM TY (NEL REST) SIZ)
2280         #DECL ((N FM NUM) NODE)
2281         <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
2282         <SET TY
2283              <EANA <SET FM <2 .K>>
2284                    <COND (<==? <NODE-NAME .FM> ISTRING> CHARACTER)
2285                          (<==? <NODE-NAME .FM> IBYTES> FIX)
2286                          (<==? <NODE-NAME .FM> UVECTOR> FIX)
2287                          (ELSE ANY)>
2288                    <NODE-NAME .N>>>
2289         <COND (<TYPE-OK? .TY '<OR FORM LIST VECTOR UVECTOR LVAL GVAL>>
2290                <COMPILE-WARNING "Explicit EVAL required: " <NODE-NAME .N> .N>
2291                <SPEC-FLUSH>
2292                <PUT-FLUSH ALL>)>
2293         <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
2294         <COND (<TYPE-OK? .TY FORM> <SET TY ANY>)>
2295         <TYPE-OK? <FORM <ISTYPE? <RESULT-TYPE .N>>
2296                         !<COND (<TYPE? .NEL FIX> ([.NEL .TY])) (ELSE ())>
2297                         !<COND (<==? .TY ANY> ()) (ELSE ([REST .TY]))>>
2298                   .R>>
2299
2300 <DEFINE ISTRUC2-ANA (N R "AUX" (K <KIDS .N>) GD NUM TY (NEL REST) SIZ)
2301         #DECL ((N NUM GD) NODE)
2302         <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
2303         <SET TY
2304              <COND (<==? <NODE-NAME .N> ISTRING> CHARACTER)
2305                    (<OR <==? <NODE-NAME .N> IBYTES>
2306                         <==? <NODE-NAME .N> IUVECTOR>>
2307                     FIX)
2308                    (ELSE ANY)>>
2309         <COND (<==? <LENGTH .K> 2>
2310                <SET TY <EANA <SET GD <2 .K>> .TY <NODE-NAME .N>>>)>
2311         <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
2312         <TYPE-OK? <COND (<AND <==? .NEL REST> <==? .TY ANY>>
2313                          <ISTYPE? <RESULT-TYPE .N>>)
2314                         (ELSE
2315                          <FORM <ISTYPE? <RESULT-TYPE .N>>
2316                                !<COND (<N==? .NEL REST> ([.NEL .TY]))
2317                                       (ELSE ())>
2318                                !<COND (<==? .TY ANY> ())
2319                                       (ELSE ([REST .TY]))>>)>
2320                   .R>>
2321
2322 <DEFINE STACK-ANA (N R) #DECL ((N) NODE) <EANA <1 <KIDS .N>> .R STACK>>
2323
2324 <DEFINE CHANNEL-OP-ANA (N R "AUX" (K <KIDS .N>) TY)
2325         #DECL ((N) NODE (K) <LIST [REST NODE]>)
2326         <COND (<SEGFLUSH .N .R>)
2327               (ELSE
2328                <PUT .N ,SIDE-EFFECTS (.N !<SIDE-EFFECTS .N>)>
2329                <COND (<L? <LENGTH .K> 2> <ARGCHK <LENGTH .K> 2 CHANNEL-OP .N>)>
2330                <SET TY <EANA <1 .K> CHANNEL CHANNEL-OP>>
2331                <EANA <2 .K> ATOM CHANNEL-OP>
2332                <MAPF <>
2333                      <FUNCTION (NN) #DECL ((NN) NODE) <ANA .NN ANY>>
2334                      <REST .K 2>>
2335                <COND (<AND <TYPE? .TY FORM SEGMENT>
2336                            <==? <LENGTH .TY> 2>
2337                            <TYPE? <SET TY <2 .TY>> FORM>
2338                            <==? <LENGTH .TY> 2>
2339                            <==? <1 .TY> QUOTE>
2340                            <TYPE? <2 .TY> ATOM>>
2341                       <PUT .N ,NODE-TYPE ,CHANNEL-OP-CODE>
2342                       <PUT .N ,NODE-SUBR <2 .TY>>)>
2343                <TYPE-OK? .R ANY>)>>
2344
2345 <COND (<AND <GASSIGNED? CHANNEL-OP> <GASSIGNED? CHANNEL-OP-ANA>>
2346        <PUTPROP ,CHANNEL-OP ANALYSIS ,CHANNEL-OP-ANA>)>
2347
2348 <ENDPACKAGE>