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