<mdl.comp>/symana.mud.70

   1 <PACKAGE "SYMANA">
   2
   3
   4 <ENTRY ANA EANA SET-CURRENT-TYPE  TYPE-NTH-REST WHO TMPS GET-TMP TRUTH UNTRUTH SEGFLUSH
   5         KILL-REM BUILD-TYPE-LIST ANALYSIS GET-CURRENT-TYPE ADD-TYPE-LIST PUT-FLUSH WHON
   6         SAVE-SURVIVORS SEQ-AN ARGCHK ASSUM-OK? FREST-L-D-STATE HTMPS ORUPC APPLTYP
   7         MSAVE-L-D-STATE  SHTMPS RESET-VARS STMPS ASSERT-TYPES SAVE-L-D-STATE
   8         MUNG-L-D-STATE NORM-BAN SUBR-C-AN ENTROPY NAUX-BAN TUP-BAN ARGS-BAN
   9         SPEC-FLUSH LIFE MANIFESTQ>
  10
  11 <USE "CHKDCL" "SUBRTY" "COMPDEC" "STRANA" "CARANA" "BITANA" "NOTANA" "ADVMESS" "MAPANA">
  12
  13 "       This is the main file associated with the type analysis phase of
  14 the compilation.  It is called by calling FUNC-ANA with the main data structure
  15 pointer.   ANA is the FUNCTION that dispatches to the various special handlers
  16 and the SUBR call analyzer further dispatches for specific functions."
  17
  18 "       Many analyzers for specific SUBRs appear in their own files
  19 (CARITH, STRUCT etc.).  Currently no special hacks are done for TYPE?, EMPTY? etc.
  20 in COND, ANDS and ORS."
  21
  22 "       All analysis functions are called with 2 args, a NODE and a desired
  23 type specification.  These args are usually called NOD and RTYP or
  24 N and R."
  25
  26 " ANA is the main analysis dispatcher (see ANALYZERS at the end of
  27   this file for its dispatch table."
  28
  29 <GDECL (TEMPLATES SUBRS) UVECTOR>
  30
  31 <DEFINE ANA (NOD RTYP "AUX" (P <PARENT .NOD>) TT TEM)
  32         #DECL ((NOD) NODE (P) ANY (TEM TT) <OR FALSE LIST>)
  33         <COND (<G=? <LENGTH .NOD> <INDEX ,SIDE-EFFECTS>>
  34                <PUT .NOD ,SIDE-EFFECTS <>>)>
  35         <PUT .NOD
  36              ,RESULT-TYPE
  37              <APPLY <NTH ,ANALYZERS <NODE-TYPE .NOD>> .NOD .RTYP>>
  38         <AND <N==? <NODE-TYPE .NOD> ,QUOTE-CODE>
  39              <SET TEM <SIDE-EFFECTS .NOD>>
  40              <TYPE? .P NODE>
  41              <PUT .P
  42                   ,SIDE-EFFECTS
  43                   <COND (<EMPTY? .TEM> <SIDE-EFFECTS .P>)
  44                         (<EMPTY? <SET TT <SIDE-EFFECTS .P>>> .TEM)
  45                         (<OR <AND <TYPE? .TEM LIST>
  46                                   <NOT <EMPTY? .TEM>>
  47                                   <==? <1 .TEM> ALL>>
  48                              <AND <TYPE? .TT LIST>
  49                                   <NOT <EMPTY? .TT>>
  50                                   <==? <1 .TT> ALL>>>
  51                          (ALL))
  52                         (ELSE
  53                          <PUTREST <REST .TEM <- <LENGTH .TEM> 1>> .TT>
  54                          .TEM)>>>
  55         <RESULT-TYPE .NOD>>
  56
  57 <DEFINE ARGCHK (GIV REQ NAME "AUX" (HI .REQ) (LO .REQ))
  58         #DECL ((GIV) FIX (REQ HI LO) <OR <LIST FIX FIX> FIX>)
  59         <COND (<TYPE? .REQ LIST>
  60                <SET HI <2 .REQ>>
  61                <SET LO <1 .REQ>>)>
  62         <COND (<L? .GIV .LO>
  63                <MESSAGE ERROR "TOO FEW ARGS TO " .NAME>)
  64               (<G? .GIV .HI>
  65                <MESSAGE ERROR "TOO MANY ARGS TO " .NAME>)> T>
  66
  67 <DEFINE EANA (NOD RTYP NAME)
  68         #DECL ((NOD) NODE)
  69         <OR <ANA .NOD .RTYP>
  70                 <MESSAGE ERROR "BAD ARGUMENT TO " .NAME .NOD>>>
  71
  72 " FUNC-ANA main entry to analysis phase.  Analyzes bindings then body."
  73
  74 <DEFINE FUNC-ANA ANA-ACT (N R
  75                           "AUX" (ANALY-OK
  76                                  <COND (<ASSIGNED? ANALY-OK> .ANALY-OK)
  77                                        (ELSE T)>) (OV .VERBOSE))
  78         #DECL ((ANA-ACT) <SPECIAL ACTIVATION> (ANALY-OK) <SPECIAL ANY>)
  79         <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
  80         <FUNC-AN1 .N .R>>
  81
  82 <DEFINE FUNC-AN1 (FCN RTYP
  83                   "AUX" (VARTBL <SYMTAB .FCN>) (TMPS 0) (HTMPS 0) (TRUTH ())
  84                         (UNTRUTH ()) (WHO ()) (WHON <>) (PRED <>) TEM (LIFE ())
  85                         (USE-COUNT 0) (BACKTRACK 0))
  86         #DECL ((FCN) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB>
  87                (TMPS BACKTRACK USE-COUNT HTMPS) <SPECIAL FIX>
  88                (LIFE TRUTH UNTRUTH) <SPECIAL LIST>
  89                (WHO PRED WHON) <SPECIAL ANY>)
  90         <RESET-VARS .VARTBL>
  91         <BIND-AN <BINDING-STRUCTURE .FCN>>
  92         <OR <SET RTYP <TYPE-OK? .RTYP <INIT-DECL-TYPE .FCN>>>
  93                 <MESSAGE ERROR "FUNCTION RETURNS WRONG TYPE " <NODE-NAME .FCN>>>
  94         <PROG ((ACT? <ACTIV? <BINDING-STRUCTURE .FCN> T>) (OV .VERBOSE))
  95               <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
  96               <PUT .FCN ,AGND <>>
  97               <PUT .FCN ,LIVE-VARS ()>
  98               <SET LIFE ()>
  99               <PUT .FCN ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
 100               <PUT .FCN ,ACCUM-TYPE <COND (.ACT? .RTYP) (ELSE NO-RETURN)>>
 101               <SET TEM <SEQ-AN <KIDS .FCN> <INIT-DECL-TYPE .FCN>>>
 102               <COND (.ACT? <SPEC-FLUSH> <PUT-FLUSH ALL>)>
 103               <OR <NOT <AGND .FCN>>
 104                   <ASSUM-OK? <ASSUM .FCN> <AGND .FCN>>
 105                   <AGAIN>>>
 106         <PUT .FCN ,ASSUM ()>
 107         <PUT .FCN ,DEAD-VARS ()>
 108         <OR .TEM
 109             <MESSAGE ERROR " RETURNED VALUE VIOLATES VALUE DECL  OF " .RTYP>>
 110         <PUT .FCN ,RESULT-TYPE <TYPE-MERGE <ACCUM-TYPE .FCN> .TEM>>
 111         <PUT <RSUBR-DECLS .FCN> 2 <TASTEFUL-DECL <RESULT-TYPE .FCN>>>
 112         <RESULT-TYPE .FCN>>
 113
 114 " BIND-AN analyze binding structure for PROGs, FUNCTIONs etc."
 115
 116 <DEFINE BIND-AN (BNDS "AUX" COD)
 117         #DECL ((BNDS) <LIST [REST SYMTAB]> (COD) FIX)
 118         <REPEAT (SYM)
 119                 #DECL ((SYM) SYMTAB)
 120                 <AND <EMPTY? .BNDS> <RETURN>>
 121                 <PUT <SET SYM <1 .BNDS>> ,COMPOSIT-TYPE ANY>
 122                 <PUT .SYM ,CURRENT-TYPE <>>
 123                 <APPLY <NTH ,BANALS <SET COD <CODE-SYM .SYM>>> .SYM>
 124                 <SET BNDS <REST .BNDS>>>>
 125
 126 " ENTROPY ignore call and return."
 127
 128 <DEFINE ENTROPY (SYM) T>
 129
 130 <DEFINE TUP-BAN (SYM) #DECL ((SYM) SYMTAB)
 131         <COND (<NOT .ANALY-OK>
 132                <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>
 133                <PUT .SYM ,CURRENT-TYPE ANY>)
 134               (<N==? <ISTYPE? <1 <DECL-SYM .SYM>>> TUPLE>
 135                <PUT .SYM ,COMPOSIT-TYPE TUPLE>
 136                <PUT .SYM ,CURRENT-TYPE TUPLE>)
 137               (ELSE
 138                <PUT .SYM ,CURRENT-TYPE <1 <DECL-SYM .SYM>>>
 139                <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>)>>
 140
 141 " Analyze AUX and OPTIONAL intializations."
 142
 143 <DEFINE NORM-BAN (SYM "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD)
 144         #DECL ((VARTBL) <SPECIAL SYMTAB> (SYM) SYMTAB (COD) FIX)
 145         <OR <SET TEM <ANA <INIT-SYM .SYM> <1 <DECL-SYM .SYM>>>>
 146                 <MESSAGE ERROR "BAD AUX/OPT INIT " <NAME-SYM .SYM>
 147                          <INIT-SYM .SYM>
 148                          "DECL MISMATCH"
 149                          <RESULT-TYPE <INIT-SYM .SYM>>
 150                          <1 <DECL-SYM .SYM>>>>
 151         <COND (<AND .ANALY-OK
 152                     <OR <G? <SET COD <CODE-SYM .SYM>> 9>
 153                         <L? .COD 6>>>
 154                <COND (<NOT <SAME-DECL? .TEM <1 <DECL-SYM .SYM>>>>
 155                       <PUT .SYM ,CURRENT-TYPE .TEM>)>
 156                <PUT .SYM ,COMPOSIT-TYPE .TEM>)
 157               (ELSE
 158                <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>
 159                <PUT .SYM ,CURRENT-TYPE <1 <DECL-SYM .SYM>>>)>>
 160
 161 " ARGS-BAN analyze ARGS decl (change to OPTIONAL in some cases)."
 162
 163 <DEFINE ARGS-BAN (SYM)
 164         #DECL ((SYM) SYMTAB)
 165         <PUT .SYM ,INIT-SYM <NODE1 ,QUOTE-CODE () LIST () ()>>
 166         <PUT .SYM ,CODE-SYM 7>
 167         <COND (.ANALY-OK <PUT .SYM ,COMPOSIT-TYPE LIST>)
 168               (ELSE <PUT .SYM ,COMPOSIT-TYPE <1 <DECL-SYM .SYM>>>)>
 169         <COND (<AND .ANALY-OK <NOT <SAME-DECL? LIST <1 <DECL-SYM .SYM>>>>>
 170                <PUT .SYM ,CURRENT-TYPE LIST>)
 171               (<NOT .ANALY-OK> <PUT .SYM ,CURRENT-TYPE ANY>)>>
 172
 173 <DEFINE NAUX-BAN (SYM)
 174         #DECL ((SYM) SYMTAB)
 175         <PUT .SYM ,COMPOSIT-TYPE
 176              <COND (.ANALY-OK NO-RETURN) (ELSE <1 <DECL-SYM .SYM>>)>>
 177         <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN)(ELSE ANY)>>>
 178
 179 " VECTOR of binding analyzers."
 180
 181 <SETG BANALS
 182       ![,ENTROPY
 183         ,NORM-BAN
 184         ,NAUX-BAN
 185         ,TUP-BAN
 186         ,ARGS-BAN
 187         ,NORM-BAN
 188         ,NORM-BAN
 189         ,ENTROPY
 190         ,ENTROPY
 191         ,ENTROPY
 192         ,ENTROPY
 193         ,ENTROPY
 194         ,ENTROPY!]>
 195
 196 " SEQ-AN analyze a sequence of NODES discarding values until the last."
 197
 198 <DEFINE SEQ-AN (L FTYP "OPTIONAL" (INP <>))
 199    #DECL ((L) <LIST [REST NODE]> (FTYP) ANY)
 200    <COND (<EMPTY? .L> <MESSAGE INCONSISTENCY "EMPTY KIDS LIST ">)
 201          (ELSE
 202           <REPEAT (TT N)
 203                   <AND .INP
 204                        <==? <NODE-TYPE <1 .L>> ,QUOTE-CODE>
 205                        <==? <RESULT-TYPE <1 .L>> ATOM>
 206                        <RESET-VARS .VARTBL>>
 207                   <OR <SET TT
 208                            <ANA <SET N <1 .L>>
 209                                 <COND (<EMPTY? <SET L <REST .L>>> .FTYP)
 210                                       (ELSE ANY)>>>
 211                       <RETURN <>>>
 212                   <COND (<==? .TT NO-RETURN>
 213                          <COND (<AND .VERBOSE <NOT <EMPTY? .L>>>
 214                                 <ADDVMESS <PARENT .N>
 215                                  ("This object ends a sequence of forms"
 216                                   .N " because it never returns")>)>
 217                          <RETURN NO-RETURN>)>
 218                   <AND <EMPTY? .L> <RETURN .TT>>>)>>
 219
 220 " ANALYZE ASSIGNED? usage."
 221
 222 <DEFINE ASSIGNED?-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) TT T1 T2)
 223         #DECL ((TT NOD) NODE (T1) SYMTAB (TEM) <LIST [REST NODE]>)
 224         <COND (<EMPTY? .TEM> <MESSAGE ERROR "NO ARGS ASSIGNED? " .NOD>)
 225               (<SEGFLUSH .NOD .RTYP>)
 226               (ELSE
 227                <EANA <SET TT <1 .TEM>> ATOM ASSIGNED?>
 228                <COND (<AND <EMPTY? <REST .TEM>>
 229                            <==? <NODE-TYPE .TT> ,QUOTE-CODE>
 230                            <SET T2 <SRCH-SYM <NODE-NAME .TT>>>
 231                            <NOT <==? <CODE-SYM <SET T1 .T2>> -1>>>
 232                       <PUT .NOD ,NODE-TYPE ,ASSIGNED?-CODE>
 233                       <PUT .NOD ,NODE-NAME .T1>
 234                       <PUT .T1 ,ASS? T>
 235                       <PUT .T1 ,USED-AT-ALL T>
 236                       <REVIVE .NOD .T1>)
 237                      (<==? <LENGTH .TEM> 2>
 238                       <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> ASSIGNED?>)
 239                      (<EMPTY? <REST .TEM>>
 240                       <COND (<AND .VERBOSE <==? <NODE-TYPE .TT> ,QUOTE-CODE>>
 241                              <ADDVMESS .NOD
 242                                       ("External reference to LVAL:  "
 243                                        <NODE-NAME .TT>)>)>
 244                       <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)
 245                      (ELSE <MESSAGE ERROR "TOO MANY ARGS TO ASSIGNED?" .NOD>)>)>
 246         <TYPE-OK? '<OR ATOM FALSE> .RTYP>>
 247
 248 <PUT ,ASSIGNED? ANALYSIS ,ASSIGNED?-ANA>
 249
 250 " ANALYZE LVAL usage.  Become either direct reference or PUSHJ"
 251
 252 <DEFINE LVAL-ANA (NOD RTYP "AUX" TEM ITYP (TT <>) T1 T2 T3)
 253    #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (T1) SYMTAB (WHO) LIST
 254           (USE-COUNT) FIX)
 255    <COND
 256     (<EMPTY? <SET TEM <KIDS .NOD>>> <MESSAGE ERROR "NO ARGS TO LVAL " .NOD>)
 257     (<SEGFLUSH .NOD .RTYP>)
 258     (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET TT <NODE-NAME .NOD>>>
 259               <AND <EANA <1 .TEM> ATOM LVAL>
 260                    <EMPTY? <REST .TEM>>
 261                    <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
 262                    <==? <RESULT-TYPE <1 .TEM>> ATOM>
 263                    <SET TT <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
 264           <COND (<==? .WHON <PARENT .NOD>> <SET WHO ((<> .TT) !.WHO)>) (ELSE T)>
 265           <PROG ()
 266                 <SET ITYP <GET-CURRENT-TYPE .TT>>
 267                 T>
 268           <COND (<AND <==? .PRED <PARENT .NOD>>
 269                       <SET T2 <TYPE-OK? .ITYP FALSE>>
 270                       <SET T3 <TYPE-OK? .ITYP '<NOT FALSE>>>>
 271                  <SET TRUTH <ADD-TYPE-LIST .TT .T3 .TRUTH <>>>
 272                  <SET UNTRUTH <ADD-TYPE-LIST .TT .T2 .UNTRUTH <>>>)
 273                 (ELSE T)>
 274           <NOT <==? <CODE-SYM <SET T1 .TT>> -1>>>
 275      <PUT .NOD ,NODE-TYPE ,LVAL-CODE>
 276      <COND (<==? <USAGE-SYM .T1> 0>
 277             <PUT .T1 ,USAGE-SYM <SET USE-COUNT <+ .USE-COUNT 1>>>)>
 278      <REVIVE .NOD .T1>
 279      <PUT .T1 ,RET-AGAIN-ONLY <>>
 280      <PUT .T1 ,USED-AT-ALL T>
 281      <PUT .NOD ,NODE-NAME .T1>
 282      <SET ITYP <TYPE-OK? .ITYP .RTYP>>
 283      <AND .ITYP <SET-CURRENT-TYPE .T1 .ITYP>>
 284      .ITYP)
 285     (<EMPTY? <REST .TEM>>
 286      <COND
 287       (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
 288        <ADDVMESS .NOD
 289                  ("External variable being referenced:  " <NODE-NAME <1 .TEM>>)>)>
 290      <PUT .NOD ,NODE-TYPE ,FLVAL-CODE>
 291      <AND .TT <PUT .NOD ,NODE-NAME <SET T1 .TT>>>
 292      <COND (.TT <TYPE-OK? <1 <DECL-SYM .T1>> .RTYP>)
 293            (.CAREFUL ANY)
 294            (ELSE .RTYP)>)
 295     (<AND <==? <LENGTH .TEM> 2>
 296           <EANA <2 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> LVAL>>
 297      ANY)
 298     (ELSE <MESSAGE ERROR "BAD CALL TO LVAL " .NOD>)>>
 299
 300 <PUT ,LVAL ANALYSIS ,LVAL-ANA>
 301
 302 " SET-ANA analyze uses of SET."
 303
 304 <DEFINE SET-ANA (NOD RTYP
 305                  "AUX" (TEM <KIDS .NOD>) (LN <LENGTH .TEM>) T1 T2 T11
 306                        (WHON .WHON) (PRED .PRED) OTYP T3 XX)
 307    #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (LN) FIX (T1) SYMTAB
 308           (WHON PRED) <SPECIAL ANY> (WHO) LIST)
 309    <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
 310    <COND
 311     (<SEGFLUSH .NOD .RTYP>)
 312     (<L? .LN 2> <MESSAGE ERROR "TOO FEW ARGS TO SET " .NOD>)
 313     (<AND <OR <AND <TYPE? <NODE-NAME .NOD> SYMTAB> <SET T11 <NODE-NAME .NOD>>>
 314               <AND <EANA <1 .TEM> ATOM SET>
 315                    <==? .LN 2>
 316                    <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>
 317                    <==? <RESULT-TYPE <1 .TEM>> ATOM>
 318                    <SET T11 <SRCH-SYM <NODE-NAME <1 .TEM>>>>>>
 319           <COND (<==? .WHON <PARENT .NOD>>
 320                  <SET WHON .NOD>
 321                  <SET WHO ((T .T11) !.WHO)>)
 322                 (ELSE T)>
 323           <COND (<==? .PRED <PARENT .NOD>> <SET PRED .NOD>) (ELSE T)>
 324           <OR <SET T2 <ANA <2 .TEM> <1 <DECL-SYM <SET T1 .T11>>>>>
 325                   <MESSAGE ERROR "DECL VIOLATION " <NAME-SYM .T1> .NOD>>>
 326      <PUT .T1 ,PURE-SYM <>>
 327      <SET XX <1 <DECL-SYM .T1>>>
 328      <SET OTYP <OR <CURRENT-TYPE .T1> ANY>>
 329      <COND (<AND <==? <CODE-SYM .T1> -1> .VERBOSE>
 330             <ADDVMESS .NOD ("External variable being SET:  " <NAME-SYM .T1>)>)>
 331      <COND (<SET OTYP <TYPESAME .OTYP .T2>> <PUT .NOD ,TYPE-INFO (.OTYP <>)>)
 332            (ELSE <PUT .NOD ,TYPE-INFO (<> <>)>)>
 333      <PUT .NOD
 334           ,NODE-TYPE
 335           <COND (<==? <CODE-SYM .T1> -1> ,FSET-CODE) (ELSE ,SET-CODE)>>
 336      <PUT .NOD ,NODE-NAME .T1>
 337      <MAKE-DEAD .NOD .T1>
 338      <SET-CURRENT-TYPE .T1 .T2>
 339      <PUT .T1 ,USED-AT-ALL T>
 340      <COND (<AND <==? .PRED .NOD>
 341                  <SET OTYP <TYPE-OK? .T2 '<NOT FALSE>>>
 342                  <SET T3 <TYPE-OK? .T2 FALSE>>>
 343             <SET TRUTH <ADD-TYPE-LIST .T1 .OTYP .TRUTH T>>
 344             <SET UNTRUTH <ADD-TYPE-LIST .T1 .T3 .UNTRUTH T>>)>
 345      <TYPE-OK? .T2 .RTYP>)
 346     (<L? .LN 4>
 347      <SET T11 <ANA <2 .TEM> ANY>>
 348      <COND (<==? .LN 2>
 349             <COND (<AND .VERBOSE <==? <NODE-TYPE <1 .TEM>> ,QUOTE-CODE>>
 350                    <ADDVMESS .NOD
 351                              ("External variable being SET: "
 352                               <NODE-NAME <1 .TEM>>)>)>
 353             <PUT .NOD ,NODE-TYPE ,FSET-CODE>)
 354            (ELSE <EANA <3 .TEM> '<OR <PRIMTYPE FRAME> PROCESS> SET>)>
 355      <TYPE-OK? .T11 .RTYP>)
 356     (ELSE <MESSAGE ERROR "BAD CALL TO SET " <NODE-NAME <1 .TEM>> .NOD>)>>
 357
 358 <PUT ,SET ANALYSIS ,SET-ANA>
 359
 360 <DEFINE MUNG-L-D-STATE (V) #DECL ((V) <OR VECTOR SYMTAB>)
 361         <REPEAT () <COND (<TYPE? .V VECTOR> <RETURN>)>
 362                 <PUT .V ,DEATH-LIST ()>
 363                 <SET V <NEXT-SYM .V>>>>
 364
 365 <DEFINE MRESTORE-L-D-STATE (L1 L2 V)
 366         <RESTORE-L-D-STATE .L1 .V>
 367         <RESTORE-L-D-STATE .L2 .V T>>
 368
 369 <DEFINE FREST-L-D-STATE (L)
 370         #DECL ((L) LIST)
 371         <MAPF <>
 372               <FUNCTION (LL)
 373                       #DECL ((LL) <LIST SYMTAB <LIST [REST NODE]>>)
 374                       <COND (<NOT <2 <TYPE-INFO <1 <2 .LL>>>>>
 375                              <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
 376               .L>>
 377
 378 <DEFINE RESTORE-L-D-STATE (L V "OPTIONAL" (FLG <>))
 379    #DECL ((L) <LIST [REST <LIST SYMTAB LIST>]> (V) <OR SYMTAB VECTOR>)
 380    <OR .FLG
 381        <REPEAT (DL)
 382                #DECL ((DL) <LIST [REST NODE]>)
 383                <COND (<TYPE? .V VECTOR> <RETURN>)>
 384                <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
 385                            <NOT <2 <TYPE-INFO <1 .DL>>>>>
 386                       <PUT .V ,DEATH-LIST ()>)>
 387                <SET V <NEXT-SYM .V>>>>
 388    <REPEAT (S DL)
 389      #DECL ((DL) <LIST NODE> (S) SYMTAB)
 390      <COND (<EMPTY? .L> <RETURN>)>
 391      <SET S <1 <1 .L>>>
 392      <AND .FLG
 393           <REPEAT ()
 394                   <COND (<==? .S .V> <RETURN>) (<TYPE? .V VECTOR> <RETURN>)>
 395                   <PUT .V
 396                        ,DEATH-LIST
 397                        <MAPF ,LIST
 398                              <FUNCTION (N)
 399                                      #DECL ((N) NODE)
 400                                      <COND (<==? <NODE-TYPE .N> ,SET-CODE>
 401                                             <MAPRET>)
 402                                            (ELSE .N)>>
 403                              <DEATH-LIST .V>>>
 404                   <SET V <NEXT-SYM .V>>>>
 405      <COND (<NOT <2 <TYPE-INFO <1 <SET DL <2 <1 .L>>>>>>>
 406             <PUT .S
 407                  ,DEATH-LIST
 408                  <COND (.FLG <LMERGE <DEATH-LIST .S> .DL>) (ELSE .DL)>>)>
 409      <SET L <REST .L>>>>
 410
 411 <DEFINE SAVE-L-D-STATE (V)
 412         #DECL ((V) <OR VECTOR SYMTAB>)
 413         <REPEAT ((L (())) (LP .L) DL)
 414                 #DECL ((L LP) LIST (DL) <LIST [REST NODE]>)
 415                 <COND (<TYPE? .V VECTOR> <RETURN <REST .L>>)>
 416                 <COND (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
 417                             <NOT <2 <CHTYPE <TYPE-INFO <1 .DL>> LIST>>>>
 418                        <SET LP <REST <PUTREST .LP ((.V .DL))>>>)>
 419                 <SET V <NEXT-SYM .V>>>>
 420
 421 <DEFINE MSAVE-L-D-STATE (L V)
 422         #DECL ((V) <OR VECTOR SYMTAB> (L) LIST)
 423         <REPEAT ((L (() !.L)) (LR .L) (LP <REST .L>) DL S TEM)
 424                 #DECL ((L LP LR TEM) LIST (S) SYMTAB (DL) <LIST [REST NODE]>)
 425                 <COND (<EMPTY? .LP>
 426                        <PUTREST .L <SAVE-L-D-STATE .V>>
 427                        <RETURN <REST .LR>>)
 428                       (<TYPE? .V VECTOR> <RETURN <REST .LR>>)
 429                       (<AND <NOT <EMPTY? <SET DL <DEATH-LIST .V>>>>
 430                             <NOT <2 <TYPE-INFO <1 .DL>>>>>
 431                        <COND (<==? <SET S <1 <1 .LP>>> .V>
 432                               <SET TEM <LMERGE <2 <1 .LP>> .DL>>
 433                               <COND (<EMPTY? .TEM>
 434                                      <PUTREST .L <SET LP <REST .LP>>>)
 435                                     (ELSE
 436                                      <PUT <1 .LP> 2 .TEM>
 437                                      <SET LP <REST <SET L .LP>>>)>)
 438                              (ELSE
 439                               <PUTREST .L <SET L ((.V .DL))>>
 440                               <PUTREST .L .LP>)>)
 441                       (<==? .V <1 <1 .LP>>> <SET LP <REST <SET L .LP>>>)>
 442                 <SET V <NEXT-SYM .V>>>>
 443
 444 <DEFINE LMERGE (L1 L2)
 445         #DECL ((L1 L2) <LIST [REST NODE]>)
 446         <SET L1
 447              <MAPF ,LIST
 448                    <FUNCTION (N)
 449                            <COND (<OR <2 <TYPE-INFO .N>>
 450                                       <AND <==? <NODE-TYPE .N> ,SET-CODE>
 451                                            <NOT <MEMQ .N .L2>>>>
 452                                   <MAPRET>)>
 453                            .N>
 454                    .L1>>
 455         <SET L2
 456              <MAPF ,LIST
 457                    <FUNCTION (N)
 458                            <COND (<OR <2 <TYPE-INFO .N>>
 459                                       <==? <NODE-TYPE .N> ,SET-CODE>
 460                                       <MEMQ .N .L1>>
 461                                   <MAPRET>)>
 462                            .N>
 463                    .L2>>
 464         <COND (<EMPTY? .L1> .L2)
 465               (ELSE <PUTREST <REST .L1 <- <LENGTH .L1> 1>> .L2> .L1)>>
 466
 467 <DEFINE MAKE-DEAD (N SYM) #DECL ((N) NODE (SYM) SYMTAB)
 468         <PUT .SYM ,DEATH-LIST (.N)>>
 469
 470 <DEFINE KILL-REM (L V)
 471         #DECL ((L) <LIST [REST SYMTAB]> (V) <OR SYMTAB VECTOR>)
 472         <REPEAT ((L1 ()))
 473                 #DECL ((L1) LIST)
 474                 <COND (<TYPE? .V VECTOR> <RETURN .L1>)>
 475                 <COND (<AND <NOT <SPEC-SYM .V>>
 476                             <N==? <CODE-SYM .V> -1>
 477                             <MEMQ .V .L>>
 478                        <SET L1 (.V !.L1)>)>
 479                 <SET V <NEXT-SYM .V>>>>
 480
 481 <DEFINE SAVE-SURVIVORS (LS LI "OPTIONAL" (FLG <>))
 482         #DECL ((LS) <LIST [REST <LIST SYMTAB LIST>]> (LI) <LIST [REST SYMTAB]>)
 483         <MAPF <>
 484               <FUNCTION (LL)
 485                       <COND (<MEMQ <1 .LL> .LI>
 486                              <MAPF <>
 487                                    <FUNCTION (N)
 488                                            #DECL ((N) NODE)
 489                                            <PUT <TYPE-INFO .N> 2 T>>
 490                                    <2 .LL>>)
 491                             (.FLG <PUT <1 .LL> ,DEATH-LIST <2 .LL>>)>>
 492               .LS>>
 493
 494 <DEFINE REVIVE (NOD SYM "AUX" (L <DEATH-LIST .SYM>))
 495         #DECL ((L) <LIST [REST NODE]> (SYM) SYMTAB (NOD) NODE)
 496         <COND (<AND <NOT <SPEC-SYM .SYM>> <N==? <CODE-SYM .SYM> -1>>
 497                <COND (<EMPTY? .L> <SET LIFE (.SYM !.LIFE)>)
 498                      (ELSE
 499                       <MAPF <> <FUNCTION (N) #DECL ((N) NODE) <PUT <TYPE-INFO .N> 2 T>>
 500                                                             ;"Temporary kludge."
 501                             .L>)>
 502                <PUT .SYM ,DEATH-LIST (.NOD)>
 503                <PUT .NOD ,TYPE-INFO (<> <>)>)>>
 504
 505 " Ananlyze a FORM that could really be an NTH."
 506
 507 <DEFINE FORM-F-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (OBJ <NODE-NAME .NOD>) TYP)
 508         #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
 509         <COND (<==? <ISTYPE? <SET TYP <ANA <1 .K> APPLICABLE>>> FIX>
 510                <PUT .NOD ,KIDS (<2 .K> <1 .K> !<REST .K 2>)>
 511                <COND (<==? <LENGTH .K> 2>
 512                       <SET RTYP <NTH-REST-ANA .NOD .RTYP ,NTH-CODE .TYP>>)
 513                      (ELSE
 514                       <SET RTYP <PUT-ANA .NOD .RTYP ,PUT-CODE .TYP>>)>
 515                <PUT .NOD ,NODE-SUBR <NODE-TYPE .NOD>>
 516                <PUT .NOD ,KIDS .K>
 517                <PUT .NOD ,NODE-NAME .OBJ>
 518                <PUT .NOD ,NODE-TYPE ,FORM-F-CODE>
 519                .RTYP)
 520               (ELSE
 521                <SPECIALIZE <NODE-NAME .NOD>>
 522                <SPEC-FLUSH>
 523                <PUT-FLUSH ALL>
 524                <PUT .NOD ,SIDE-EFFECTS (ALL)>
 525                <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
 526
 527 " Further analyze a FORM."
 528
 529 <DEFINE FORM-AN (NOD RTYP)
 530         #DECL ((NOD) NODE)
 531         <APPLY <OR <GET <NODE-SUBR .NOD> ANALYSIS>
 532                    <GET <TYPE <NODE-SUBR .NOD>> TANALYSIS>
 533                    <FUNCTION (N R)
 534                            #DECL ((N) NODE)
 535                            <SPEC-FLUSH>
 536                            <PUT-FLUSH ALL>
 537                            <PUT .N ,SIDE-EFFECTS (ALL)>
 538                            <TYPE-OK? <RESULT-TYPE .N> .R>>>
 539                .NOD
 540                .RTYP>>
 541
 542 "Determine if an ATOM is mainfest."
 543
 544 <DEFINE MANIFESTQ (ATM)
 545         #DECL ((ATM) ATOM)
 546         <AND <MANIFEST? .ATM>
 547              <GASSIGNED? .ATM>
 548              <NOT <TYPE? ,.ATM SUBR>>
 549              <NOT <TYPE? ,.ATM RSUBR>>>>
 550
 551 " Search for a decl associated with a local value."
 552
 553 <DEFINE SRCH-SYM (ATM "AUX" (TB .VARTBL))
 554         #DECL ((ATM) ATOM (TB) <PRIMTYPE VECTOR>)
 555         <REPEAT ()
 556                 <AND <EMPTY? .TB> <RETURN <>>>
 557                 <AND <==? .ATM <NAME-SYM .TB>> <RETURN .TB>>
 558                 <SET TB <NEXT-SYM .TB>>>>
 559
 560 " Here to flush decls of specials for an external function call."
 561
 562 <DEFINE SPEC-FLUSH () <FLUSHER <>>>
 563
 564 " Here to flush decls when a PUT, PUTREST or external call happens."
 565
 566 <DEFINE PUT-FLUSH (TYP) <FLUSHER .TYP>>
 567
 568 <DEFINE FLUSHER (FLSFLG "AUX" (V .VARTBL))
 569    #DECL ((SYM) SYMTAB (V) <OR SYMTAB VECTOR>)
 570    <COND
 571     (.ANALY-OK
 572      <REPEAT (SYM TEM)
 573        #DECL ((SYM) SYMTAB)
 574        <COND
 575         (<AND <CURRENT-TYPE <SET SYM .V>>
 576               <OR <AND <SPEC-SYM .SYM> <NOT .FLSFLG>>
 577                   <AND .FLSFLG
 578                        <N==? <CURRENT-TYPE .V> NO-RETURN>
 579                        <TYPE-OK? <CURRENT-TYPE .V> STRUCTURED>
 580                        <OR <==? .FLSFLG ALL>
 581                            <NOT <SET TEM <STRUCTYP <CURRENT-TYPE .V>>>>
 582                            <==? .TEM .FLSFLG>>>>>
 583          <SET-CURRENT-TYPE
 584           .SYM <FLUSH-FIX-TYPE .SYM <CURRENT-TYPE .SYM> .FLSFLG>>)>
 585        <COND (<==? <USAGE-SYM .SYM> 0> <PUT .SYM ,USAGE-SYM <>>)>
 586        <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)
 587     (ELSE
 588      <REPEAT (SYM)
 589              #DECL ((SYM) SYMTAB)
 590              <COND (<==? <USAGE-SYM <SET SYM .V>> 0> <PUT .SYM ,USAGE-SYM <>>)>
 591              <COND (<EMPTY? <SET V <NEXT-SYM .V>>> <RETURN>)>>)>>
 592
 593 <DEFINE FLUSH-FIX-TYPE (SYM TY FLG "AUX" TEM)
 594         #DECL ((SYM) SYMTAB)
 595         <OR <AND .FLG
 596                  <SET TEM <TOP-TYPE <TYPE-OK? .TY STRUCTURED>>>
 597                  <TYPE-OK? <COND (<SET TY <TYPE-OK? .TY '<NOT STRUCTURED>>>
 598                                   <TYPE-MERGE .TEM .TY>)
 599                                  (ELSE .TEM)>
 600                            <1 <DECL-SYM .SYM>>>>
 601             <1 <DECL-SYM .SYM>>>>
 602
 603
 604 " Punt forms with segments in them."
 605
 606 <DEFINE SEGFLUSH (NOD RTYP)
 607         #DECL ((NOD) NODE (L) <LIST [REST NODE]>)
 608         <COND (<REPEAT ((L <KIDS .NOD>))
 609                        <AND <EMPTY? .L> <RETURN <>>>
 610                        <AND <==? <NODE-TYPE <1 .L>> ,SEGMENT-CODE> <RETURN T>>
 611                        <SET L <REST .L>>>
 612                <COND (.VERBOSE
 613                       <ADDVMESS .NOD
 614                                 ("Not open compiled due to SEGMENT.")>)>
 615                <SUBR-C-AN .NOD .RTYP>)>>
 616
 617 " STACKFORM analyzer."
 618
 619 <DEFINE STACKFORM-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) TEM STFTYP TT)
 620         #DECL ((NOD TT) NODE (K) <LIST [REST NODE]>)
 621         <MESSAGE WARNING "STACKFORM IS HAZARDOUS TO YOUR CODE!">
 622         <PUT .NOD ,NODE-TYPE ,STACKFORM-CODE>
 623         <ARGCHK <LENGTH .K> 3 STACKFORM>
 624         <ANA <SET TT <1 .K>> ANY>
 625         <SET STFTYP <APPLTYP .TT>>
 626         <ANA <2 .K> ANY>
 627         <SET TEM <ANA <3 .K> ANY>>
 628         <OR <TYPE-OK? .TEM FALSE>
 629                 <MESSAGE WARNING " STACKFORM CAN'T STOP " .NOD>>
 630         <PUT .NOD ,SIDE-EFFECTS (ALL)>
 631         <PUT-FLUSH ALL>
 632         <SPEC-FLUSH>
 633         <TYPE-OK? .STFTYP .RTYP>>
 634
 635 <PUT ,STACKFORM ANALYSIS ,STACKFORM-ANA>
 636
 637 " Determine if the arg to STACKFORM is a SUBR."
 638
 639 <DEFINE APPLTYP (NOD "AUX" (NT <NODE-TYPE .NOD>) ATM TT)
 640         #DECL ((ATM) ATOM (NOD TT) NODE (NT) FIX)
 641         <COND (<==? .NT ,GVAL-CODE>                       ;"<STACKFORM ,FOO ..."
 642                <COND (<AND <==? <NODE-TYPE <SET TT <1 <KIDS .NOD>>>>
 643                                 ,QUOTE-CODE>
 644                            <GASSIGNED? <SET ATM <NODE-NAME .TT>>>
 645                            <TYPE? ,.ATM SUBR>>
 646                       <SUBR-TYPE ,.ATM>)
 647                      (ELSE ANY)>)
 648               (ELSE ANY)                              ;"MAY TRY OTHERS LATER ">>
 649
 650 " Return type returned by a SUBR."
 651
 652 <DEFINE SUBR-TYPE (SUB "AUX" TMP)
 653         #DECL ((SUB) SUBR)
 654         <SET TMP <2 <GET-TMP .SUB>>>
 655         <COND (<TYPE? .TMP ATOM FORM> .TMP) (ELSE ANY)>>
 656
 657 " Access the SUBR data base for return type."
 658
 659 <DEFINE GET-TMP (SUB "AUX" (LS <MEMQ .SUB ,SUBRS>))
 660         #DECL ((VALUE) <LIST ANY ANY>)
 661         <COND (.LS <NTH ,TEMPLATES <LENGTH .LS>>)
 662               (ELSE '(ANY ANY))>>
 663
 664 " GVAL analyzer."
 665
 666 <DEFINE GVAL-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT TEM1)
 667         #DECL ((NOD TEM) NODE (TT) <VECTOR VECTOR ATOM ANY> (LN) FIX)
 668         <COND (<SEGFLUSH .NOD .RTYP>)
 669               (ELSE
 670                <ARGCHK .LN 1 GVAL>
 671                <PUT .NOD ,NODE-TYPE ,FGVAL-CODE>
 672                <EANA <1 .K> ATOM GVAL>
 673                <COND (<AND <==? <NODE-TYPE <SET TEM <1 .K>>> ,QUOTE-CODE>
 674                            <==? <RESULT-TYPE .TEM> ATOM>>
 675                       <PUT .NOD ,NODE-TYPE ,GVAL-CODE>
 676                       <COND (<MANIFEST? <SET TEM1 <NODE-NAME .TEM>>>
 677                              <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
 678                              <PUT .NOD ,NODE-NAME ,.TEM1>
 679                              <PUT .NOD ,KIDS ()>
 680                              <TYPE-OK? <GEN-DECL ,.TEM1> .RTYP>)
 681                             (<AND <GBOUND? .TEM1> <SET TEM1 <GET-DECL <GLOC .TEM1>>>>
 682                              <TYPE-OK? .TEM .RTYP>)
 683                             (ELSE <TYPE-OK? ANY .RTYP>)>)
 684                      (ELSE <TYPE-OK? ANY .RTYP>)>)>>
 685
 686 <PUT ,GVAL ANALYSIS ,GVAL-ANA>
 687
 688 " Analyze SETG usage."
 689
 690 <DEFINE SETG-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) (LN <LENGTH .K>) TEM TT T1 TTT)
 691         #DECL ((NOD TEM) NODE (K) <LIST [REST NODE]> (LN) FIX (TT) VECTOR)
 692         <COND (<SEGFLUSH .NOD .RTYP>)
 693               (ELSE
 694                <ARGCHK .LN 2 SETG>
 695                <PUT .NOD ,NODE-TYPE ,FSETG-CODE>
 696                <EANA <SET TEM <1 .K>> ATOM SETG>
 697                <PUT .NOD ,SIDE-EFFECTS (.NOD !<SIDE-EFFECTS .NOD>)>
 698                <COND (<==? <NODE-TYPE .TEM> ,QUOTE-CODE>
 699                       <AND <MANIFEST? <SET TTT <NODE-NAME .TEM>>>
 700                           <MESSAGE WARNING
 701                                    "ATTEMPT TO SETG MANIFEST VARIABLE "
 702                                    .TTT .NOD>>
 703                       <PUT .NOD ,NODE-TYPE ,SETG-CODE>
 704                       <COND (<AND <GBOUND? .TTT>
 705                                   <SET T1 <GET-DECL <GLOC .TTT>>>>
 706                              <OR <ANA <2 .K> .T1>
 707                                      <MESSAGE ERROR
 708                                               " GLOBAL DECL VIOLATION "
 709                                               .TTT .NOD>>
 710                              <TYPE-OK? .T1 .RTYP>)
 711                             (ELSE
 712                              <SET TTT <ANA <2 .K> ANY>>
 713                              <TYPE-OK? .TTT .RTYP>)>)
 714                      (ELSE
 715                       <SET TTT <ANA <2 .K> ANY>>
 716                       <TYPE-OK? .TTT .RTYP>)>)>>>
 717
 718 <PUT ,SETG ANALYSIS ,SETG-ANA>
 719
 720 <DEFINE BUILD-TYPE-LIST (V)
 721         #DECL ((V) <OR VECTOR SYMTAB> (VALUE) LIST)
 722         <COND (.ANALY-OK
 723                <REPEAT ((L (())) (LP .L) TEM)
 724                        #DECL ((L LP) LIST)
 725                        <COND (<EMPTY? .V> <RETURN <REST .L>>)
 726                              (<N==? <CODE-SYM .V> -1>
 727                               <SET TEM <GET-CURRENT-TYPE .V>>
 728                               <SET LP <REST <PUTREST .LP ((.V .TEM T))>>>)>
 729                        <SET V <NEXT-SYM .V>>>) (ELSE ())>>
 730
 731 <DEFINE RESET-VARS (V "OPTIONAL" (VL '[]) (FLG <>))
 732         #DECL ((V VL) <OR SYMTAB VECTOR>)
 733         <REPEAT ()
 734                 <COND (<==? .V .VL> <SET FLG T>)>
 735                 <COND (<EMPTY? .V> <RETURN>)
 736                       (<NOT .FLG>
 737                        <PUT .V ,CURRENT-TYPE <>>
 738                        <PUT .V ,COMPOSIT-TYPE ANY>)>
 739                 <PUT .V ,USAGE-SYM 0>
 740                 <PUT .V ,DEATH-LIST ()>
 741                 <SET V <NEXT-SYM .V>>>>
 742
 743 <DEFINE GET-CURRENT-TYPE (SYM)
 744         #DECL ((SYM) SYMTAB)
 745         <OR <AND .ANALY-OK <CURRENT-TYPE .SYM>> <1 <DECL-SYM .SYM>>>>
 746
 747 <DEFINE SET-CURRENT-TYPE (SYM ITYP "AUX" (OTYP <1 <DECL-SYM .SYM>>))
 748         #DECL ((SYM) SYMTAB)
 749         <COND (<AND .ANALY-OK
 750                     <N==? <CODE-SYM .SYM> -1>
 751                     <NOT <SAME-DECL? <TYPE-AND .ITYP .OTYP> .OTYP>>>
 752                <PUT .SYM ,CURRENT-TYPE .ITYP>
 753                <PUT .SYM
 754                     ,COMPOSIT-TYPE
 755                     <TYPE-MERGE .ITYP <COMPOSIT-TYPE .SYM>>>)
 756               (ELSE
 757                <PUT .SYM ,CURRENT-TYPE <>>
 758                <PUT .SYM ,COMPOSIT-TYPE .OTYP>)>>
 759
 760 <DEFINE ANDUPC (V L)
 761         #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
 762         <REPEAT ()
 763                 <COND (<EMPTY? .V> <RETURN>)>
 764                 <COND (<CURRENT-TYPE .V>
 765                        <SET L <ADD-TYPE-LIST .V <CURRENT-TYPE .V> .L T>>)>
 766                 <SET V <NEXT-SYM .V>>>
 767         .L>
 768
 769 <DEFINE ANDUP (FROM TO)
 770         #DECL ((TO FROM) <LIST [REST <LIST SYMTAB ANY ANY>]>)
 771         <MAPF <>
 772               <FUNCTION (L) <SET TO <ADD-TYPE-LIST <1 .L> <2 .L> .TO T>>>
 773               .FROM>
 774         .TO>
 775
 776 <DEFINE ORUPC (V L "AUX" WIN)
 777    #DECL ((V) <OR VECTOR SYMTAB> (L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
 778    <COND
 779     (.ANALY-OK
 780      <REPEAT ()
 781        <COND (<TYPE? .V VECTOR> <RETURN>)>
 782        <SET WIN <>>
 783        <MAPF <>
 784           <FUNCTION (LL) #DECL ((LL) <LIST SYMTAB <OR ATOM FORM SEGMENT> ANY>)
 785                   <COND (<==? <1 .LL> .V>
 786                          <PUT .LL 2 <TYPE-MERGE <2 .LL> <GET-CURRENT-TYPE .V>>>
 787                          <PUT .LL 3 T>
 788                          <MAPLEAVE <SET WIN T>>)>>
 789           .L>
 790        <COND (<AND <NOT .WIN>
 791                    <CURRENT-TYPE .V>>
 792               <SET L ((.V <1 <DECL-SYM .V>> T) !.L)>)>
 793        <SET V <NEXT-SYM .V>>>)>
 794    .L>
 795
 796 <DEFINE ORUP (FROM TO "AUX" NDECL)
 797    #DECL ((TO FROM) <LIST [REST <LIST SYMTAB <OR ATOM FORM SEGMENT> <OR ATOM FALSE>>]>
 798           (NDECL) <OR ATOM FORM SEGMENT>)
 799    <MAPF <>
 800     <FUNCTION (L "AUX" (SYM <1 .L>) (WIN <>))
 801             <MAPF <>
 802                   <FUNCTION (LL)
 803                           <COND (<==? <1 .LL> .SYM>
 804                                  <SET NDECL <TYPE-MERGE <2 .LL> <2 .L>>>
 805                                  <PUT .LL 2 .NDECL>
 806                                  <PUT .LL 3 <3 .LL>>
 807                                  <MAPLEAVE <SET WIN T>>)>>
 808                   .TO>
 809             <COND (<NOT .WIN>
 810                    <SET TO
 811                         ((.SYM
 812                           <TYPE-MERGE <GET-CURRENT-TYPE .SYM> <2 .L>>
 813                           <3 .L>)
 814                          !.TO)>)>>
 815     .FROM>
 816    .TO>
 817
 818 <DEFINE ASSERT-TYPES (L)
 819         #DECL ((L) <LIST [REST <LIST SYMTAB ANY ANY>]>)
 820         <MAPF <>
 821               <FUNCTION (LL) <SET-CURRENT-TYPE <1 .LL> <2 .LL>>>
 822               .L>>
 823
 824 <DEFINE ADD-TYPE-LIST (SYM NDECL INF MUNG
 825                        "OPTIONAL" (NTH-REST ())
 826                        "AUX" (WIN <>) (OD <GET-CURRENT-TYPE .SYM>))
 827    #DECL ((SYM) SYMTAB (INF) LIST (NTH-REST) <LIST [REST ATOM FIX]>
 828           (NDECL) <OR ATOM FALSE FORM SEGMENT> (MUNG) <OR ATOM FALSE>)
 829    <COND (.ANALY-OK
 830           <SET NDECL <TYPE-NTH-REST .NDECL .NTH-REST>>
 831           <MAPF <>
 832                 <FUNCTION (L)
 833                         #DECL ((L) <LIST SYMTAB ANY>)
 834                         <COND (<==? <1 .L> .SYM>
 835                                <SET NDECL
 836                                     <COND (.MUNG <TYPE-AND .NDECL .OD>)
 837                                           (ELSE <TYPE-AND .NDECL <2 .L>>)>>
 838                                <PUT .L 2 .NDECL>
 839                                <PUT .L 3 .MUNG>
 840                                <MAPLEAVE <SET WIN T>>)>>
 841                 .INF>
 842           <COND (<NOT .WIN>
 843                  <SET NDECL <TYPE-AND .NDECL .OD>>
 844                  <SET INF ((.SYM .NDECL .MUNG) !.INF)>)>)>
 845    .INF>
 846
 847 <DEFINE TYPE-NTH-REST (NDECL NTH-REST) #DECL ((NTH-REST) <LIST [REST ATOM FIX]>)
 848        <REPEAT ((FIRST T) (NUM 0))
 849                #DECL ((NUM) FIX)
 850                <COND (<EMPTY? .NTH-REST> <RETURN .NDECL>)>
 851                <COND (<==? <1 .NTH-REST> NTH>
 852                       <SET NDECL
 853                            <FORM STRUCTURED
 854                                  !<COND (<0? <SET NUM
 855                                                   <+ .NUM <2 .NTH-REST> -1>>>
 856                                          ())
 857                                         (<1? .NUM> (ANY))
 858                                         (ELSE ([.NUM ANY]))>
 859                                  .NDECL>>
 860                       <SET NUM 0>
 861                       <SET FIRST <>>)
 862                      (.FIRST <SET NDECL <REST-DECL .NDECL <2 .NTH-REST>>>)
 863                      (ELSE <SET NUM <+ .NUM <2 .NTH-REST>>>)>
 864                <SET NTH-REST <REST .NTH-REST 2>>>>
 865
 866 " AND/OR analyzer.  Called from AND-ANA and OR-ANA."
 867
 868 <DEFINE BOOL-AN (NOD RTYP ORER
 869                  "AUX" (L <KIDS .NOD>) FTYP FTY
 870                        (RTY
 871                         <COND (<TYPE-OK? .RTYP FALSE> .RTYP)
 872                               (ELSE <FORM OR .RTYP FALSE>)>)
 873                        (FLG <==? .PRED <PARENT .NOD>>) (SINF ()) STR SUNT
 874                        (FIRST T) FNOK NFNOK PASS)
 875    #DECL ((NOD) NODE (L) <LIST [REST NODE]> (ORER RTYP) ANY (FTYP) FORM
 876           (STR SINF SUNT) LIST)
 877    <PROG ((TRUTH ()) (UNTRUTH ()) (PRED .NOD) L-D)
 878      #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (PRED) <SPECIAL ANY> (L-D) LIST)
 879      <COND
 880       (<EMPTY? .L> <SET FTYP <TYPE-OK? FALSE .RTYP>>)
 881       (ELSE
 882        <SET FTY
 883         <MAPR ,TYPE-MERGE
 884          <FUNCTION (N
 885                     "AUX" (LAST <EMPTY? <REST .N>>) TY)
 886             #DECL ((N) <LIST NODE>)
 887             <COND (<AND .LAST <NOT .FLG>> <SET PRED <>>)>
 888             <SET TY <ANA <1 .N> <COND (.LAST .RTYP) (.ORER .RTY) (ELSE ANY)>>>
 889             <SET FNOK
 890                  <OR <==? .TY NO-RETURN> <NOT <TYPE-OK? .TY FALSE>>>>
 891             <SET NFNOK <==? FALSE <ISTYPE? .TY>>>
 892             <SET PASS <COND (.ORER .NFNOK) (ELSE .FNOK)>>
 893             <COND (<NOT .TY>
 894                    <SET TY ANY>
 895                    <MESSAGE WARNING " OR/AND MAY RETURN WRONG TYPE " <1 .N>>)>
 896             <COND (<COND (.ORER .FNOK) (ELSE .NFNOK)>
 897                                                      ;"This must end the AND/OR"
 898                    <COND (<AND .VERBOSE <NOT .LAST>>
 899                           <ADDVMESS .NOD
 900                                     ("This object prematurely ends AND/OR:  "
 901                                      <1 .N> " its type is:  " .TY)>)>
 902                    <SET LAST T>)>
 903             <COND (<AND <N==? .TY NO-RETURN> <OR .LAST <NOT .PASS>>>
 904                    <COND (.FIRST
 905                           <SET L-D <SAVE-L-D-STATE .VARTBL>>
 906                           <SET SINF
 907                                <ANDUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
 908                                       <BUILD-TYPE-LIST .VARTBL>>>)
 909                          (ELSE
 910                           <SET L-D <MSAVE-L-D-STATE .L-D .VARTBL>>
 911                           <SET SINF
 912                                <ORUP <COND (.ORER .TRUTH) (ELSE .UNTRUTH)>
 913                                      <ORUPC .VARTBL .SINF>>>)>
 914                    <SET FIRST <>>)>
 915             <ASSERT-TYPES <COND (.ORER .UNTRUTH) (ELSE .TRUTH)>>
 916             <SET TRUTH <SET UNTRUTH ()>>
 917             <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
 918             <COND (<==? .TY NO-RETURN>
 919                    <OR .LAST
 920                            <MESSAGE WARNING
 921                                     "UNREACHABLE AND/OR CLAUSE "
 922                                     <1 .N>>>
 923                    <SET FLG <>>
 924                    <ASSERT-TYPES .SINF>
 925                    <MAPSTOP NO-RETURN>)
 926                   (.LAST
 927                    <COND (.FLG
 928                           <SET STR
 929                                <COND (.ORER .SINF)
 930                                      (ELSE <BUILD-TYPE-LIST .VARTBL>)>>
 931                           <SET SUNT
 932                                <COND (.ORER <BUILD-TYPE-LIST .VARTBL>)
 933                                      (ELSE .SINF)>>)>
 934                    <ASSERT-TYPES <ORUPC .VARTBL .SINF>>
 935                    <MAPSTOP .TY>)
 936                   (<AND .ORER .NFNOK> <MAPRET>)
 937                   (.ORER .TY)
 938                   (.FNOK <MAPRET>)
 939                   (ELSE FALSE)>>
 940          .L>>
 941        <COND (<AND .FNOK .ORER> <SET FTY <TYPE-OK? .FTY '<NOT FALSE>>>)>)>>
 942    <COND (.FLG <SET TRUTH .STR> <SET UNTRUTH .SUNT>)>
 943    .FTY>
 944
 945 <DEFINE AND-ANA (NOD RTYP)
 946         #DECL ((NOD) NODE)
 947         <PUT .NOD ,NODE-TYPE ,AND-CODE>
 948         <BOOL-AN .NOD .RTYP <>>>
 949
 950 <PUT ,AND ANALYSIS ,AND-ANA>
 951
 952 <DEFINE OR-ANA (NOD RTYP)
 953         #DECL ((NOD) NODE)
 954         <PUT .NOD ,NODE-TYPE ,OR-CODE>
 955         <BOOL-AN .NOD .RTYP T>>
 956
 957 <PUT ,OR ANALYSIS ,OR-ANA>
 958
 959 " COND analyzer."
 960
 961 <DEFINE CASE-ANA (N R) <COND-CASE .N .R T>>
 962
 963 <DEFINE COND-ANA (N R) <COND-CASE .N .R <>>>
 964
 965 <DEFINE COND-CASE (NOD RTYP CASE?
 966                    "AUX" (L <KIDS .NOD>) (FIRST T) (LAST <>) TT FNOK NFNOK STR
 967                          SUNT (FIRST1 T) PRAT (DFLG <>) TST-TYP SVWHO)
 968    #DECL ((NOD) NODE (L) <LIST [REST NODE]> (RTYP) ANY)
 969    <PROG ((TRUTH ()) (UNTRUTH ()) (TINF1 ()) (TINF ()) L-D L-D1)
 970      #DECL ((TRUTH UNTRUTH) <SPECIAL LIST> (TINF1 TINF L-D L-D1) LIST)
 971      <COND
 972       (<EMPTY? .L> <TYPE-OK? FALSE .RTYP>)
 973       (ELSE
 974        <COND (.CASE?
 975               <SET PRAT <NODE-NAME <1 <KIDS <1 .L>>>>>
 976               <PROG ((WHON .NOD) (WHO ()))
 977                     #DECL ((WHO) <SPECIAL LIST> (WHON) <SPECIAL NODE>)
 978                     <SET TST-TYP <EANA <2 .L> ANY CASE>>
 979                     <SET SVWHO .WHO>>
 980               <SET L <REST .L 2>>)>
 981        <SET TT
 982         <MAPR ,TYPE-MERGE
 983          <FUNCTION (BRN "AUX" (BR <1 .BRN>) (PRED .BR) (EC T))
 984             #DECL ((BRN) <LIST NODE> (BR) NODE (PRED) <SPECIAL
 985                                                        <OR NODE FALSE>>)
 986             <COND (<AND .CASE? <==? <NODE-TYPE .BR> ,QUOTE-CODE> <SET DFLG T>>
 987                    <MAPRET>)>
 988             <OR <PREDIC .BR> <MESSAGE ERROR "EMPTY COND CLAUSE " .BR>>
 989             <SET UNTRUTH <SET TRUTH ()>>
 990             <SET LAST <EMPTY? <REST .BRN>>>
 991             <SET TT
 992                  <COND (<NOT <EMPTY? <CLAUSES .BR>>> <SET EC <>> ANY)
 993                        (.LAST .RTYP)
 994                        (ELSE <TYPE-MERGE .RTYP FALSE>)>>
 995             <SET TT
 996                  <COND (.CASE?
 997                         <SPEC-ANA <NODE-NAME <CHTYPE <PREDIC .BR> NODE>>
 998                                   .PRAT
 999                                   .TST-TYP
1000                                   .TT
1001                                   .DFLG
1002                                   .BR
1003                                   .SVWHO>)
1004                        (ELSE <ANA <PREDIC .BR> .TT>)>>
1005             <SET DFLG <SET PRED <>>>
1006             <SET FNOK <OR <==? .TT NO-RETURN> <NOT <TYPE-OK? .TT FALSE>>>>
1007             <SET NFNOK <==? <ISTYPE? .TT> FALSE>>
1008             <COND
1009              (.VERBOSE
1010               <COND
1011                (.NFNOK
1012                 <ADDVMESS
1013                  .NOD
1014                  ("Cond predicate always FALSE:  "
1015                   <PREDIC .BR>
1016                   !<COND (<EMPTY? <CLAUSES .BR>> ())
1017                          (ELSE (" and non-reachable code in clause."))>)>)>
1018               <COND
1019                (<AND .FNOK <NOT .LAST>>
1020                 <ADDVMESS
1021                  .NOD
1022                  ("Cond ended prematurely because predicate always true:  "
1023                   <PREDIC .BR>
1024                   " type of value:  "
1025                   .TT)>)>)>
1026             <COND (<NOT <OR .FNOK <AND <NOT .LAST> .NFNOK>>>
1027                    <SET L-D <SAVE-L-D-STATE .VARTBL>>
1028                    <COND (.FIRST
1029                           <SET TINF <ANDUP .UNTRUTH <BUILD-TYPE-LIST .VARTBL>>>)
1030                          (ELSE
1031                           <SET TINF <ANDUP .UNTRUTH <ORUPC .VARTBL .TINF>>>)>
1032                    <ASSERT-TYPES .TRUTH>
1033                    <SET FIRST <>>)>
1034             <COND (<NOT .NFNOK>
1035                    <OR .EC <SET TT <SEQ-AN <CLAUSES .BR> .RTYP>>>
1036                    <COND (<N==? .TT NO-RETURN>
1037                           <COND (.FIRST1
1038                                  <SET TINF1 <BUILD-TYPE-LIST .VARTBL>>
1039                                  <SET L-D1 <SAVE-L-D-STATE .VARTBL>>)
1040                                 (ELSE
1041                                  <SET TINF1 <ORUPC .VARTBL .TINF1>>
1042                                  <SET L-D1 <MSAVE-L-D-STATE .L-D1 .VARTBL>>)>
1043                           <SET FIRST1 <>>)>
1044                    <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>
1045                    <COND (.LAST
1046                           <AND <NOT .FNOK> <SET TT <TYPE-MERGE .TT FALSE>>>)
1047                          (.EC <SET TT <TYPE-OK? .TT '<NOT FALSE>>>)>)
1048                   (.NFNOK <SET TT FALSE>)>
1049             <COND (<OR .LAST .FNOK>
1050                    <COND (.FNOK
1051                           <ASSERT-TYPES .TINF1>
1052                           <OR .FIRST1 <RESTORE-L-D-STATE .L-D1 .VARTBL>>)
1053                          (ELSE
1054                           <COND (.FIRST1
1055                                  <ASSERT-TYPES .TINF>
1056                                  <OR .FIRST <RESTORE-L-D-STATE .L-D .VARTBL>>)
1057                                 (ELSE
1058                                  <ASSERT-TYPES <ORUP .TINF .TINF1>>
1059                                  <MRESTORE-L-D-STATE .L-D1 .L-D .VARTBL>)>)>
1060                    <MAPSTOP .TT>)
1061                   (ELSE <ASSERT-TYPES .TINF> .TT)>>
1062          .L>>)>>
1063    .TT>
1064
1065
1066 <DEFINE SPEC-ANA (CONST PRED-NAME OTYPE RTYP DFLG NOD WHO "AUX" TEM PAT)
1067         #DECL ((NOD) NODE)
1068         <SET PAT
1069              <COND (<TYPE? .CONST LIST>
1070                     <COND (<==? .PRED-NAME ==?> <GEN-DECL <1 .CONST>>)
1071                           (<==? .PRED-NAME TYPE?> <TYPE-MERGE !.CONST>)
1072                           (ELSE
1073                            <MAPF ,TYPE-MERGE
1074                                  <FUNCTION (X) <FORM PRIMTYPE .X>>
1075                                  .CONST>)>)
1076                    (ELSE
1077                     <COND (<==? .PRED-NAME ==?> <GEN-DECL .CONST>)
1078                           (<==? .PRED-NAME TYPE?> .CONST)
1079                           (ELSE <FORM PRIMTYPE .CONST>)>)>>
1080         <COND (.DFLG
1081                <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? ATOM .RTYP>>>
1082                .TEM)
1083               (ELSE
1084                <COND (<AND <N==? .PRED-NAME ==?>
1085                            <N==? .OTYPE ANY>
1086                            <NOT <TYPE-OK? <FORM NOT .PAT> .OTYPE>>>
1087                       <SET TEM ATOM>)
1088                      (<TYPE-OK? .OTYPE .PAT> <SET TEM '<OR FALSE ATOM>>)
1089                      (ELSE <SET TEM FALSE>)>
1090                <MAPF <>
1091                      <FUNCTION (L "AUX" (FLG <1 .L>) (SYM <2 .L>))
1092                              #DECL ((L) <LIST <OR ATOM FALSE> SYMTAB>
1093                                     (SYM) SYMTAB)
1094                              <SET TRUTH
1095                                   <ADD-TYPE-LIST .SYM
1096                                                  .PAT
1097                                                  .TRUTH
1098                                                  .FLG
1099                                                  <REST .L 2>>>
1100                              <OR <==? .TEM ATOM>
1101                                  <SET UNTRUTH
1102                                       <ADD-TYPE-LIST
1103                                        .SYM
1104                                        <FORM NOT .PAT>
1105                                        .UNTRUTH
1106                                        .FLG
1107                                        <REST .L 2>>>>>
1108                      .WHO>
1109                <PUT .NOD ,RESULT-TYPE <SET TEM <TYPE-OK? .TEM .RTYP>>>
1110                .TEM)>>
1111
1112 " PROG/REPEAT analyzer.  Hacks bindings and sets up info for GO/RETURN/AGAIN
1113   analyzers."
1114
1115 <DEFINE PRG-REP-ANA (PPNOD PRTYP
1116                      "AUX" (OV .VARTBL) (VARTBL <SYMTAB .PPNOD>) TT L-D
1117                            (OPN <AND <ASSIGNED? PNOD> .PNOD>) PNOD)
1118    #DECL ((PNOD) <SPECIAL NODE> (VARTBL) <SPECIAL SYMTAB> (OV) SYMTAB (L-D) LIST
1119           (PPNOD) NODE)
1120    <COND (<N==? <NODE-SUBR .PPNOD> ,BIND> <SET PNOD .PPNOD>)
1121          (.OPN <SET PNOD .OPN>)>
1122    <PROG ((TMPS 0) (HTMPS 0) (ACT? <ACTIV? <BINDING-STRUCTURE .PPNOD> T>))
1123          #DECL ((TMPS HTMPS) <SPECIAL FIX>)
1124          <BIND-AN <BINDING-STRUCTURE .PPNOD>>
1125          <SET L-D <SAVE-L-D-STATE .VARTBL>>
1126          <RESET-VARS .VARTBL .OV T>
1127          <OR <SET PRTYP <TYPE-OK? .PRTYP <INIT-DECL-TYPE .PPNOD>>>
1128                  <MESSAGE ERROR "PROG RETURNS WRONG TYPE ">>
1129          <PUT .PPNOD ,RESULT-TYPE .PRTYP>
1130          <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OV .VERBOSE))
1131                #DECL ((STMPS SHTMPS) FIX (LL LIFE) LIST)
1132                <COND (.VERBOSE <PUTREST <SET VERBOSE .OV> ()>)>
1133                <MUNG-L-D-STATE .VARTBL>
1134                <SET LIFE .LL>
1135                <PUT .PPNOD ,AGND <>>
1136                <PUT .PPNOD ,DEAD-VARS ()>
1137                <PUT .PPNOD ,VSPCD ()>
1138                <PUT .PPNOD ,LIVE-VARS ()>
1139                <SET TMPS .STMPS>
1140                <SET HTMPS .SHTMPS>
1141                <PUT .PPNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
1142                <PUT .PPNOD ,ACCUM-TYPE NO-RETURN>
1143                <SET TT
1144                     <SEQ-AN <KIDS .PPNOD>
1145                             <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> .PRTYP)
1146                                   (ELSE ANY)>>>
1147                <AND .ACT? <PROG ()
1148                                 <SPEC-FLUSH>
1149                                 <PUT-FLUSH ALL>>>
1150                <OR <AND <N==? <NODE-SUBR .PPNOD> ,REPEAT> <NOT <AGND .PPNOD>>>
1151                    <ASSUM-OK?
1152                     <ASSUM .PPNOD>
1153                     <COND (<N==? <NODE-SUBR .PPNOD> ,REPEAT> <AGND .PPNOD>)
1154                           (<AGND .PPNOD>
1155                            <ORUPC .VARTBL <CHTYPE <AGND .PPNOD> LIST>>)
1156                           (ELSE <BUILD-TYPE-LIST .VARTBL>)>>
1157                    <AGAIN>>>
1158          <COND (<==? <NODE-SUBR .PPNOD> ,REPEAT>
1159                 <COND (<AGND .PPNOD>
1160                        <PUT .PPNOD
1161                             ,LIVE-VARS
1162                             <MSAVE-L-D-STATE <LIVE-VARS .PPNOD> .VARTBL>>)
1163                       (ELSE <PUT .PPNOD ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>)>
1164          <SAVE-SURVIVORS .L-D .LIFE T>
1165          <SAVE-SURVIVORS <LIVE-VARS .PPNOD> .LIFE>
1166          <OR .TT
1167              <MESSAGE " ERROR PROG VALUE VIOLATES VALUE DECL OF "
1168                       .PRTYP
1169                       .PPNOD>>
1170          <COND (<NOT <OR <==? .TT NO-RETURN> <==? <NODE-SUBR .PPNOD> ,REPEAT>>>
1171                 <PUT .PPNOD
1172                      ,DEAD-VARS
1173                      <MSAVE-L-D-STATE <DEAD-VARS .PPNOD> .VARTBL>>
1174                 <COND (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1175                        <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .PPNOD>>>)>)
1176                (<N==? <ACCUM-TYPE .PPNOD> NO-RETURN>
1177                 <ASSERT-TYPES <VSPCD .PPNOD>>)>
1178          <FREST-L-D-STATE <DEAD-VARS .PPNOD>>
1179          <SET LIFE <KILL-REM .LIFE .OV>>
1180          <PUT .PPNOD
1181               ,ACCUM-TYPE
1182               <COND (.ACT? <PUT .PPNOD ,SIDE-EFFECTS (ALL)> .PRTYP)
1183                     (<==? <NODE-SUBR .PPNOD> ,REPEAT> <ACCUM-TYPE .PPNOD>)
1184                     (ELSE <TYPE-MERGE .TT <ACCUM-TYPE .PPNOD>>)>>>
1185    <ACCUM-TYPE .PPNOD>>
1186
1187 " Determine if assumptions made for this loop are still valid."
1188
1189 <DEFINE ASSUM-OK? (AS TY "AUX" (OK? T))
1190    #DECL ((TY AS) <LIST [REST <LIST SYMTAB ANY ANY>]>)
1191    <COND
1192     (.ANALY-OK
1193      <MAPF <>
1194       <FUNCTION (L "AUX" (SYM <1 .L>) (TT <>))
1195          #DECL ((L) <LIST SYMTAB <OR ATOM FORM SEGMENT>>)
1196          <COND
1197           (<N==? <2 .L> ANY>
1198            <MAPF <>
1199                  <FUNCTION (LL)
1200                          <COND (<AND <SET TT <==? <1 .LL> .SYM>>
1201                                      <N=? <2 .L> <2 .LL>>
1202                                      <OR <==? <2 .L> NO-RETURN>
1203                                          <TYPE-OK? <2 .LL> <NOTIFY <2 .L>>>>>
1204                                 <COND (.OK? <SET BACKTRACK <+ .BACKTRACK 1>>)>
1205                                 <SET OK? <>>
1206                                 <AND <GASSIGNED? DEBUGSW>
1207                                      ,DEBUGSW
1208                                      <PRIN1 <NAME-SYM .SYM>>
1209                                      <PRINC " NOT OK current type:  ">
1210                                      <PRIN1 <2 .LL>>
1211                                      <PRINC " assumed type:  ">
1212                                      <PRIN1 <2 .L>>
1213                                      <TERPRI>>)>
1214                          <AND .TT
1215                               <PUT .L 2 <TYPE-MERGE <2 .LL> <2 .L>>>
1216                               <MAPLEAVE>>>
1217                  .TY>)>>
1218       .AS>
1219      <COND (<NOT .OK?> <ASSERT-TYPES .AS>)>)>
1220    .OK?>
1221
1222 <DEFINE NOTIFY (D)
1223         <COND (<AND <TYPE? .D FORM> <==? <LENGTH .D> 2> <==? <1 .D> NOT>>
1224                <2 .D>)
1225               (ELSE <FORM NOT .D>)>>
1226
1227 " Analyze RETURN from a PROG/REPEAT.  Check with PROGs final type."
1228
1229 <DEFINE RETURN-ANA (NOD RTYP "AUX" (TT <KIDS .NOD>) N (LN <LENGTH .TT>) TEM)
1230         #DECL ((NOD) NODE (TT) <LIST [REST NODE]> (LN) FIX (N) <OR NODE FALSE>)
1231         <COND (<G? .LN 2>
1232                <MESSAGE ERROR "TOO MANY ARGS TO RETURN " .NOD>)
1233               (<OR <AND <==? .LN 2> <SET N <ACT-CHECK <2 .TT>>>>
1234                    <AND <L=? .LN 1> <SET N <PROGCHK RETURN>>>>
1235                <SET N <CHTYPE .N NODE>>
1236                <AND <0? .LN>
1237                     <PUT .NOD
1238                          ,KIDS
1239                          <SET TT (<NODE1 ,QUOTE-CODE .NOD ATOM T ()>)>>>
1240                <SET TEM <EANA <1 .TT> <INIT-DECL-TYPE .N> RETURN>>
1241                <COND (<==? <ACCUM-TYPE .N> NO-RETURN>
1242                       <PUT .N ,VSPCD <BUILD-TYPE-LIST <SYMTAB .N>>>
1243                       <PUT .N ,DEAD-VARS <SAVE-L-D-STATE .VARTBL>>)
1244                      (ELSE
1245                       <PUT .N ,VSPCD <ORUPC <SYMTAB .N> <VSPCD .N>>>
1246                       <PUT .N
1247                            ,DEAD-VARS
1248                            <MSAVE-L-D-STATE <DEAD-VARS .N> .VARTBL>>)>
1249                <PUT .N ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .N>>>
1250                <PUT .NOD ,NODE-TYPE ,RETURN-CODE>
1251                NO-RETURN)
1252               (ELSE <SUBR-C-AN .NOD ANY>)>>
1253
1254 <PUT ,RETURN ANALYSIS ,RETURN-ANA>
1255
1256 <DEFINE ACT-CHECK (N "AUX" SYM RAO N1)
1257         #DECL ((N N1) NODE (SYM) <OR SYMTAB FALSE> (RAO VALUE) <OR FALSE NODE>)
1258         <COND (<OR <AND <==? <NODE-TYPE .N> ,LVAL-CODE>
1259                         <TYPE? <NODE-NAME .N> SYMTAB>
1260                         <PURE-SYM <SET SYM <NODE-NAME .N>>>
1261                         <==? <CODE-SYM .SYM> 1>>
1262                    <AND <==? <NODE-TYPE .N> ,SUBR-CODE>
1263                         <==? <NODE-SUBR .N> ,LVAL>
1264                         <==? <LENGTH <KIDS .N>> 1>
1265                         <==? <NODE-TYPE <SET N1 <1 <KIDS .N>>>> ,QUOTE-CODE>
1266                         <TYPE? <NODE-NAME .N1> ATOM>
1267                         <SET SYM <SRCH-SYM <NODE-NAME .N1>>>
1268                         <PURE-SYM .SYM>
1269                         <==? <CODE-SYM .SYM> 1>>>
1270                <SET RAO <RET-AGAIN-ONLY <CHTYPE .SYM SYMTAB>>>
1271                <EANA .N ACTIVATION AGAIN-RETURN>
1272                <PUT <CHTYPE .SYM SYMTAB> ,RET-AGAIN-ONLY .RAO>
1273                .RAO)>>
1274
1275 " AGAIN analyzer."
1276
1277 <DEFINE AGAIN-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N)
1278         #DECL ((NOD) NODE (TEM) <LIST [REST NODE]> (N) <OR FALSE NODE>)
1279         <COND (<OR <AND <EMPTY? .TEM> <SET N <PROGCHK AGAIN>>>
1280                    <AND <EMPTY? <REST .TEM>> <SET N <ACT-CHECK <1 .TEM>>>>>
1281                <PUT .NOD ,NODE-TYPE ,AGAIN-CODE>
1282                <SET N <CHTYPE .N NODE>>
1283                <COND (<AGND .N>
1284                       <PUT .N ,LIVE-VARS
1285                            <MSAVE-L-D-STATE <LIVE-VARS .N> .VARTBL>>)
1286                      (ELSE <PUT .N ,LIVE-VARS <SAVE-L-D-STATE .VARTBL>>)>
1287                <PUT .N
1288                     ,AGND
1289                     <COND (<NOT <AGND .N>> <BUILD-TYPE-LIST <SYMTAB .N>>)
1290                           (ELSE <ORUPC <SYMTAB .N> <AGND .N>>)>>
1291                NO-RETURN)
1292               (<EMPTY? <REST .TEM>>
1293                <OR <ANA <1 .TEM> ACTIVATION>
1294                        <MESSAGE ERROR "WRONG TYPE FOR AGAIN " .NOD>>
1295                ANY)
1296               (ELSE <MESSAGE ERROR "TOO MANY ARGS TO AGAIN " .NOD>)>>
1297
1298 <PUT ,AGAIN ANALYSIS ,AGAIN-ANA>
1299
1300 " Analyze losing GOs."
1301
1302 <DEFINE GO-ANA (NOD RTYP "AUX" (TEM <KIDS .NOD>) N RT)
1303      #DECL ((NOD N) NODE (TEM) <LIST [REST NODE]>)
1304      <MESSAGE WARGINING "GO/TAG NOT REALLY SUPPORTED.">
1305      <COND (<1? <LENGTH .TEM>>
1306             <SET RT <EANA <SET N <1 .TEM>> '<OR TAG ATOM> GO>>
1307             <COND (<OR <AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
1308                             <==? .RT ATOM>
1309                             <PROGCHK GO>>
1310                        <==? .RT TAG>>
1311                    <AND <==? .RT ATOM> .ANALY-OK
1312                         <PROG () <SET ANALY-OK <>> <AGAIN .ANA-ACT>>>
1313                    <PUT .NOD ,NODE-TYPE ,GO-CODE> NO-RETURN)
1314                   (ELSE <MESSAGE ERROR "BAD ARG TO GO " .NOD>)>)
1315            (ELSE <MESSAGE ERROR "WRONG NO. OF ARGS TO GO " .NOD>)>>
1316
1317 <PUT ,GO ANALYSIS ,GO-ANA>
1318
1319 <DEFINE TAG-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) N)
1320         #DECL ((PNOD N NOD) NODE (K) <LIST [REST NODE]>)
1321         <MESSAGE WARGINING "GO/TAG NOT REALLY SUPPORTED.">
1322         <COND (<1? <LENGTH .K>>
1323                <PROGCHK TAG>
1324                <AND .ANALY-OK <PROG () <SET ANALY-OK <>> <AGAIN .ANA-ACT>>>
1325                <PUT .PNOD ,ACTIVATED T>
1326                <EANA <SET N <1 .K>> ATOM TAG>
1327                <COND (<AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
1328                            <==? <RESULT-TYPE .N> ATOM>>
1329                       <PUT .NOD ,NODE-TYPE ,TAG-CODE> TAG)
1330                      (ELSE <MESSAGE ERROR "BAD ARG TO TAG " .NOD>)>)>>
1331
1332 <PUT ,TAG ANALYSIS ,TAG-ANA>
1333
1334 " If not in PROG/REPEAT complain about NAME."
1335
1336 <DEFINE PROGCHK (NAME)
1337         <OR <ASSIGNED? PNOD>
1338                 <MESSAGE ERROR "NOT IN PROG/REPEAT " .NAME>>
1339         .PNOD>
1340
1341 " Dispatch to special handlers for SUBRs.  Or use standard."
1342
1343 <DEFINE SUBR-ANA (NOD RTYP)
1344         #DECL ((NOD) NODE)
1345         <APPLY <GET <NODE-SUBR .NOD> ANALYSIS ',SUBR-C-AN>
1346                .NOD
1347                .RTYP>>
1348
1349 " Hairy SUBR call analyzer.  Also looks for internal calls."
1350
1351 <DEFINE SUBR-C-AN (NOD RTYP
1352                    "AUX" (ARGS 0) (TYP ANY)
1353                          (TMPL <GET-TMP <NODE-SUBR .NOD>>) (NRGS1 <1 .TMPL>)
1354                          (ARGACS
1355                           <COND (<AND <G? <LENGTH .TMPL> 4>
1356                                       <NOT <==? <4 .TMPL> STACK>>>
1357                                  <4 .TMPL>)>))
1358    #DECL ((NOD) <SPECIAL NODE> (ARGS) <SPECIAL FIX>
1359           (TYP NRGS1 ARGACS) <SPECIAL ANY> (TMPL) <SPECIAL LIST>)
1360    <MAPF
1361     <FUNCTION ("TUPLE" T "AUX" NARGS (TL <LENGTH .TMPL>) TEM (NARGS1 .NRGS1) (N .NOD)
1362                                (TPL .TMPL) (RGS .ARGS))
1363        #DECL ((T) TUPLE (ARGS  RGS TL) FIX
1364               (TMPL TPL) <LIST ANY ANY [REST LIST ANY ANY ANY]> (N NOD) NODE
1365               (NARGS) <LIST FIX FIX>)
1366        <SET TYP <2 .TPL>>
1367        <SPEC-FLUSH>
1368        <PUT-FLUSH ALL>
1369        <COND
1370         (<SEGS .N>
1371          <COND (<TYPE? .TYP ATOM FORM>) (ELSE <SET TYP ANY>)>
1372          <COND (<AND <G? .TL 2> <NOT .ARGACS>>
1373                 <PUT .N ,NODE-TYPE ,ISUBR-CODE>)>)
1374         (ELSE
1375          <COND
1376           (<TYPE? .NARGS1 FIX>
1377            <ARGCHK .RGS .NARGS1 <NODE-NAME .N>>)
1378           (<TYPE? .NARGS1 LIST>
1379            <AND <G? .RGS <2 <SET NARGS .NARGS1>>>
1380                <MESSAGE ERROR " TOO MANY ARGS TO " <NODE-NAME .N> .N>>
1381            <AND <L? .RGS <1 .NARGS>>
1382                <MESSAGE ERROR " TOO FEW ARGS TO " <NODE-NAME .N> .N>>
1383            <AND <G? .TL 2>
1384                 <G? .RGS <+ <1 .NARGS> <LENGTH <3 .TPL>>>>
1385                 <SET TL 0>>      ;"Dont handle funny calls to things like LLOC."
1386            <COND (<AND <L? .RGS <2 .NARGS>> <G? .TL 2>>
1387                                                    ;"For funny cases like LLOC."
1388                   <SET TEM
1389                        <MAPF ,LIST
1390                              <FUNCTION (DEF)
1391                                      <NODE1 ,QUOTE-CODE
1392                                             .NOD
1393                                             <TYPE .DEF>
1394                                             .DEF
1395                                             ()>>
1396                              <REST <3 .TPL> <- .RGS <1 .NARGS>>>>>
1397                   <SET RGS <2 .NARGS>>
1398                   <COND (<EMPTY? <KIDS .N>> <PUT .N ,KIDS .TEM>)
1399                         (ELSE
1400                          <PUTREST <REST <KIDS .N> <- <LENGTH <KIDS .N>> 1>>
1401                                   .TEM>)>)>)>
1402          <COND (<TYPE? .TYP ATOM FORM>)
1403                (ELSE <SET TYP <APPLY .TYP !.T>>)>
1404          <COND (<G? .TL 2>                                ;"Short call exists?."
1405                 <OR <==? <4 .TPL> STACK> <SET RGS 0>>
1406                 <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
1407          <SET ARGS .RGS>)>>
1408     <FUNCTION (N "AUX" TYP)
1409             #DECL ((N NOD) NODE (ARGS) FIX (ARGACS) <PRIMTYPE LIST>)
1410             <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1411                    <EANA <1 <KIDS .N>> STRUCTURED SEGMENT>
1412                    <PUT .NOD ,SEGS T>
1413                    ANY)
1414                   (ELSE
1415                    <SET ARGS <+ .ARGS 1>>
1416                    <SET TYP <ANA .N ANY>>
1417                    <COND (<AND <NOT <SEGS .NOD>> .ARGACS <NOT <EMPTY? .ARGACS>>>
1418                           <SET ARGACS <REST .ARGACS>>)>
1419                    .TYP)>>
1420     <KIDS .NOD>>
1421    <PUT .NOD ,SIDE-EFFECTS (ALL)>
1422    <PUT .NOD ,STACKS <* .ARGS 2>>
1423    <TYPE-OK? .TYP .RTYP>>
1424
1425 <DEFINE SEGMENT-ANA (NOD RTYP) <MESSAGE ERROR "ILLEGAL SEGMENT " .NOD>>
1426
1427 " Analyze VECTOR, UVECTOR and LIST builders."
1428
1429 <DEFINE COPY-AN (NOD RTYP
1430                  "AUX" (ARGS 0) (RT <ISTYPE? <RESULT-TYPE .NOD>>) (K <KIDS .NOD>) N
1431                        (LWIN <==? .RT LIST>) NN COD)
1432    #DECL ((NOD N) NODE (ARGS) FIX (K) <LIST [REST NODE]>)
1433    <COND
1434     (<NOT <EMPTY? .K>>
1435      <REPEAT (DC STY PTY TEM TT (SG <>) (FRM <FORM .RT>)
1436               (FRME <CHTYPE .FRM LIST>) (GOTDC <>))
1437              #DECL ((FRM) FORM (FRME) <LIST ANY>)
1438              <COND (<EMPTY? .K>
1439                     <COND (<==? .RT LIST>
1440                            <RETURN <SET RT
1441                                         <COND (<EMPTY? <REST .FRM>> <1 .FRM>)
1442                                               (ELSE .FRM)>>>)>
1443                     <COND (.DC <PUTREST .FRME ([REST .DC])>)
1444                           (.STY <PUTREST .FRME ([REST .STY])>)
1445                           (.PTY <PUTREST .FRME ([REST <FORM PRIMTYPE .PTY>])>)>
1446                     <RETURN <SET RT .FRM>>)
1447                    (<OR <==? <SET COD <NODE-TYPE <SET N <1 .K>>>> ,SEGMENT-CODE>
1448                         <==? .COD ,SEG-CODE>>
1449                     <SET TEM
1450                          <GET-ELE-TYPE <EANA <1 <KIDS .N>> STRUCTURED SEGMENT>
1451                                        ALL>>
1452                     <PUT .NOD ,SEGS T>
1453                     <COND (<NOT .SG> <SET GOTDC <>>)>
1454                     <SET SG T>
1455                     <COND (<AND .LWIN
1456                                 <MEMQ <STRUCTYP <RESULT-TYPE <1 <KIDS .N>>>>
1457                                       '![LIST VECTOR UVECTOR TUPLE!]>>)
1458                           (ELSE <SET LWIN <>>)>)
1459                    (ELSE <SET ARGS <+ .ARGS 2>> <SET TEM <ANA .N ANY>>)>
1460              <COND (<NOT .GOTDC>
1461                     <SET GOTDC T>
1462                     <SET PTY
1463                          <COND (<SET STY <ISTYPE? <SET DC .TEM>>>
1464                                 <TYPEPRIM .STY>)>>)
1465                    (<OR <NOT .DC> <N==? .DC .TEM>>
1466                     <SET DC <>>
1467                     <COND (<OR <N==? <SET TT <ISTYPE? .TEM>> .STY> <NOT .STY>>
1468                            <SET STY <>>
1469                            <COND (<AND .PTY
1470                                        <==? .PTY <AND .TT <TYPEPRIM .TT>>>>)
1471                                  (ELSE <SET PTY <>>)>)>)>
1472              <COND (<NOT .SG> <SET FRME <REST <PUTREST .FRME (.TEM)>>>)>
1473              <SET K <REST .K>>>)>
1474    <PUT .NOD ,RESULT-TYPE .RT>
1475    <PUT .NOD ,STACKS .ARGS>
1476    <COND
1477     (<AND <GASSIGNED? COPY-LIST-CODE> .LWIN>
1478      <MAPF <>
1479            <FUNCTION (N)
1480                    #DECL ((N) NODE)
1481                    <COND (<==? <NODE-TYPE .N> ,SEGMENT-CODE>
1482                           <PUT .N ,NODE-TYPE ,SEG-CODE>)>>
1483            <KIDS .NOD>>
1484      <COND (<AND <==? <LENGTH <SET K <KIDS .NOD>>> 1>
1485                  <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
1486                  <==? <STRUCTYP <RESULT-TYPE <SET NN <1 <KIDS <1 .K>>>>>> LIST>>
1487             <COND (<NOT <EMPTY? <PARENT .NOD>>>
1488                    <MAPR <>
1489                          <FUNCTION (L "AUX" (N <1 .L>))
1490                                  #DECL ((N) NODE (L) <LIST [REST NODE]>)
1491                                  <COND (<==? .NOD .N>
1492                                         <PUT .L 1 .NN>
1493                                         <MAPLEAVE>)>>
1494                          <KIDS <CHTYPE <PARENT .NOD> NODE>>>)>
1495             <PUT .NN ,PARENT <CHTYPE <PARENT .NOD> NODE>>
1496             <SET RT <RESULT-TYPE .NN>>)
1497            (ELSE <PUT .NOD ,NODE-TYPE ,COPY-LIST-CODE>)>)
1498     (ELSE
1499      <MAPF <>
1500            <FUNCTION (N)
1501                    #DECL ((N) NODE)
1502                    <COND (<==? <NODE-TYPE .N> ,SEG-CODE>
1503                           <PUT .N ,NODE-TYPE ,SEGMENT-CODE>)>>
1504            <KIDS .NOD>>
1505     <PUT .NOD ,NODE-TYPE ,COPY-CODE>)>
1506    <TYPE-OK? .RT .RTYP>>
1507
1508 " Analyze quoted objects, for structures hack type specs."
1509
1510 <DEFINE QUOTE-ANA (NOD RTYP)
1511         #DECL ((NOD) NODE)
1512         <TYPE-OK? <GEN-DECL <NODE-NAME .NOD>> .RTYP>>
1513
1514 <DEFINE QUOTE-ANA2 (NOD RTYP)
1515         #DECL ((NOD) NODE)
1516         <COND (<1? <LENGTH <KIDS .NOD>>>
1517                <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1518                <PUT .NOD ,NODE-NAME <1 <KIDS .NOD>>>
1519                <PUT .NOD ,KIDS ()>
1520                <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)
1521               (ELSE <MESSAGE ERROR "BAD CALL TO QUOTE ">)>>
1522
1523 <PUT ,QUOTE ANALYSIS ,QUOTE-ANA2>
1524
1525 <DEFINE IRSUBR-ANA (NOD RTYP)
1526         <RSUBRC-ANA .NOD .RTYP <>>>
1527
1528 " Analyze a call to an RSUBR."
1529
1530 <DEFINE RSUBR-ANA (NOD RTYP "AUX" ACST RN)
1531         #DECL ((NOD RN FCN) NODE)
1532         <COND (<AND <TYPE? <NODE-SUBR .NOD> FUNCTION>
1533                     <SET ACST <ACS <SET RN <GET <NODE-NAME .NOD> .IND>>>>
1534                     <OR <ASSIGNED? GROUP-NAME> <==? .FCN .RN>>>
1535                <RSUBRC-ANA .NOD .RTYP .ACST>)
1536               (ELSE <RSUBRC-ANA .NOD .RTYP <>>)>>
1537
1538 <DEFINE RSUBRC-ANA (NOD RTYP ACST "AUX" (ARGS 0))
1539         #DECL ((NOD N) NODE (ACST) <PRIMTYPE LIST> (ARGS) FIX)
1540         <AND <=? .ACST '(STACK)> <SET ACST <>>>
1541         <MAPF <>
1542               <FUNCTION (ARG RT)
1543                       #DECL ((ARG NOD) NODE)
1544                       <COND (<==? <NODE-TYPE .ARG> ,SEGMENT-CODE>
1545                              <EANA <1 <KIDS .ARG>> .RT SEGMENT>
1546                              <PUT .NOD ,SEGS T>)
1547                             (ELSE
1548                              <EANA .ARG .RT <NODE-NAME .NOD>>
1549                              <COND (<AND <NOT <SEGS .NOD>> .ACST>
1550                                     <SET ACST <REST .ACST>>)>
1551                              <SET ARGS <+ .ARGS 1>>)>>
1552               <KIDS .NOD> <TYPE-INFO .NOD>>
1553         <SPEC-FLUSH>
1554         <PUT-FLUSH ALL>
1555         <OR .ACST <PUT .NOD ,STACKS <* .ARGS 2>>>
1556         <PUT .NOD ,SIDE-EFFECTS (ALL)>
1557         <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>>
1558
1559 " Analyze CHTYPE, in some cases do it at compile time."
1560
1561 <DEFINE CHTYPE-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) NTN NT OBN OB)
1562         #DECL ((NOD OBN NTN) NODE (K) <LIST [REST NODE]> (NT) ATOM)
1563         <COND (<SEGFLUSH .NOD .RTYP>)
1564               (ELSE
1565                <ARGCHK <LENGTH .K> 2 CHTYPE>
1566                <SET OB <ANA <SET OBN <1 .K>> ANY>>
1567                <EANA <SET NTN <2 .K>> ATOM CHTYPE>
1568                <COND (<==? <NODE-TYPE .NTN> ,QUOTE-CODE>
1569                       <OR <MEMQ <SET NT <NODE-NAME .NTN>> <ALLTYPES>>
1570                               <MESSAGE ERROR " 2D ARG CHTYPE NOT A TYPE " .NT .NOD>>
1571                       <OR <TYPE-OK? .OB <FORM PRIMTYPE <TYPEPRIM .NT>>>
1572                               <MESSAGE ERROR
1573                                        " PRIMTYPES DIFFER CHTYPE"
1574                                        .OB
1575                                        .NT .NOD>>
1576                       <COND (<==? <NODE-TYPE .OBN> ,QUOTE-CODE>
1577                              <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1578                              <PUT .NOD ,KIDS ()>
1579                              <PUT .NOD
1580                                   ,NODE-NAME
1581                                   <CHTYPE <NODE-NAME .OBN> .NT>>)
1582                             (ELSE <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>)>
1583                       <PUT .NOD ,RESULT-TYPE .NT>
1584                       <TYPE-OK? .NT .RTYP>)
1585                      (ELSE
1586                       <COND (.VERBOSE
1587                              <ADDVMESS .NOD
1588                                        ("Can't open compile CHTYPE.")>)>
1589                       <TYPE-OK? ANY .RTYP>)>)>>
1590
1591 <PUT ,CHTYPE ANALYSIS ,CHTYPE-ANA>
1592
1593 " Analyze use of ASCII sometimes do at compile time."
1594
1595 <DEFINE ASCII-ANA (NOD RTYP "AUX" (K <KIDS .NOD>) ITM TYP TEM)
1596         #DECL ((NOD ITM) NODE (K) <LIST [REST NODE]>)
1597         <COND (<SEGFLUSH .NOD .RTYP>)
1598               (ELSE
1599                <ARGCHK <LENGTH .K> 1 ASCII>
1600                <SET TYP <EANA <SET ITM <1 .K>> '<OR FIX CHARACTER> ASCII>>
1601                <COND (<==? <NODE-TYPE .ITM> ,QUOTE-CODE>
1602                       <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
1603                       <PUT .NOD ,NODE-NAME <SET TEM <ASCII <NODE-NAME .ITM>>>>
1604                       <PUT .NOD ,RESULT-TYPE <TYPE .TEM>>
1605                       <PUT .NOD ,KIDS ()>)
1606                      (<==? <ISTYPE? .TYP> FIX>
1607                       <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1608                       <PUT .NOD ,RESULT-TYPE CHARACTER>)
1609                      (<==? .TYP CHARACTER>
1610                       <PUT .NOD ,NODE-TYPE ,CHTYPE-CODE>
1611                       <PUT .NOD ,RESULT-TYPE FIX>)
1612                      (ELSE
1613                       <PUT .NOD ,RESULT-TYPE '<OR FIX CHARACTER>>)>
1614                <TYPE-OK? <RESULT-TYPE .NOD> .RTYP>)>>
1615
1616 <PUT ,ASCII ANALYSIS ,ASCII-ANA>
1617
1618 <DEFINE UNWIND-ANA (NOD RTYP"AUX" (K <KIDS .NOD>) ITYP)
1619         #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
1620         <SET ITYP <EANA <1 .K> ANY UNWIND>>
1621         <EANA <2 .K> ANY UNWIND>
1622         <TYPE-OK? .ITYP .RTYP>>
1623
1624 " Analyze ISTRING/ILIST/IVECTOR/IUVECTOR in cases of known and unknown last arg."
1625
1626 <DEFINE ISTRUC-ANA (N R "AUX" (K <KIDS .N>) FM NUM TY (NEL REST) SIZ)
1627         #DECL ((N FM NUM) NODE)
1628         <COND (<==? <NODE-SUBR .N> ,IBYTES>
1629                <EANA <1 .K> FIX <NODE-NAME .N>>
1630                <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
1631                       <SET SIZ <NODE-NAME <1 .K>>>)>
1632                <SET K <REST .K>>)>
1633         <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
1634         <SET TY
1635              <EANA <SET FM <2 .K>>
1636                    <COND (<==? <NODE-NAME .FM> ISTRING> CHARACTER)
1637                          (<==? <NODE-NAME .FM> IBYTES> FIX)
1638                          (ELSE ANY)>
1639                    <NODE-NAME .N>>>
1640         <COND (<TYPE-OK? .TY '<OR FORM LIST VECTOR UVECTOR>>
1641                <MESSAGE WARNING "UNCERTAIN USE OF " <NODE-NAME .N> .N>
1642                <SPEC-FLUSH>
1643                <PUT-FLUSH ALL>)
1644               (ELSE <PUT .N ,NODE-TYPE ,ISTRUC2-CODE>)>
1645         <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
1646         <AND <TYPE-OK? .TY FORM> <SET TY ANY>>
1647         <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,IBYTES>
1648                          <COND (<ASSIGNED? SIZ>
1649                                 <COND (<TYPE? .NEL FIX> <FORM BYTES .SIZ .NEL>)
1650                                       (ELSE <FORM BYTES .SIZ>)>)
1651                                (ELSE BYTES)>)
1652                         (ELSE
1653                          <FORM <ISTYPE? <RESULT-TYPE .N>>
1654                                [.NEL .TY]
1655                                !<COND (<==? .TY ANY> ())
1656                                       (ELSE ([REST .TY]))>>)>
1657                   .R>>
1658
1659 <DEFINE ISTRUC2-ANA (N R "AUX" (K <KIDS .N>) GD NUM TY (NEL REST) SIZ)
1660         #DECL ((N NUM GD) NODE)
1661         <COND (<==? <NODE-SUBR .N> ,IBYTES>
1662                <EANA <1 .K> FIX <NODE-NAME .N>>
1663                <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
1664                       <SET SIZ <NODE-NAME <1 .K>>>)>
1665                <SET K <REST .K>>)>
1666         <EANA <SET NUM <1 .K>> FIX <NODE-NAME .N>>
1667         <SET TY
1668              <EANA <SET GD <2 .K>>
1669                    <COND (<==? <NODE-SUBR .N> ,ISTRING> CHARACTER)
1670                          (<==? <NODE-SUBR .N> ,IBYTES> FIX)
1671                          (ELSE ANY)>
1672                    <NODE-NAME .N>>>
1673         <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE> <SET NEL <NODE-NAME .NUM>>)>
1674         <TYPE-OK? <COND (<==? <NODE-SUBR .N> ,IBYTES>
1675                          <COND (<ASSIGNED? SIZ>
1676                                 <COND (<TYPE? .NEL FIX> <FORM BYTES .SIZ .NEL>)
1677                                       (ELSE <FORM BYTES .SIZ>)>)
1678                                (ELSE BYTES)>)
1679                         (ELSE
1680                          <FORM <ISTYPE? <RESULT-TYPE .N>>
1681                                [.NEL .TY]
1682                                !<COND (<==? .TY ANY> ())
1683                                       (ELSE ([REST .TY]))>>)>
1684                   .R>>
1685
1686 " Analyze READ type SUBRS in two cases (print uncertain usage message maybe?)"
1687
1688 <DEFINE READ-ANA (N R)
1689         #DECL ((N) NODE)
1690         <MAPF <>
1691               <FUNCTION (NN "AUX" TY)
1692                       #DECL ((NN N) NODE)
1693                       <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
1694                              <SPEC-FLUSH> <PUT-FLUSH ALL>
1695                              <SET TY <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>>
1696                              <COND (<TYPE-OK? .TY
1697                                               '<OR FORM LIST VECTOR UVECTOR>>
1698                                     <MESSAGE WARNING
1699                                              " UNCERTAIN USE OF "
1700                                              <NODE-NAME .N> .N>)
1701                                    (ELSE <PUT .N ,NODE-TYPE ,READ-EOF2-CODE>)>)
1702                             (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
1703               <KIDS .N>>
1704         <SPEC-FLUSH><PUT-FLUSH ALL>
1705         <TYPE-OK? ANY .R>>
1706
1707 <DEFINE READ2-ANA (N R)
1708         #DECL ((N) NODE)
1709         <MAPF <>
1710               <FUNCTION (NN)
1711                       #DECL ((NN N) NODE)
1712                       <COND (<==? <NODE-TYPE .NN> ,EOF-CODE>
1713                              <EANAQ <1 <KIDS .NN>> ANY <NODE-NAME .N> .N>)
1714                             (ELSE <EANA .NN ANY <NODE-NAME .N>>)>>
1715               <KIDS .N>>
1716         <SPEC-FLUSH><PUT-FLUSH ALL>
1717         <TYPE-OK? ANY .R>>
1718
1719 <DEFINE GET-ANA (N R "AUX" TY (K <KIDS .N>) (NAM <NODE-NAME .N>))
1720         #DECL ((N) NODE (K) <LIST NODE NODE NODE>)
1721         <EANA <1 .K> ANY .NAM>
1722         <EANA <2 .K> ANY .NAM>
1723         <SET TY <EANAQ <3 .K> ANY .NAM .N>>
1724         <COND (<TYPE-OK? .TY '<OR LIST VECTOR UVECTOR FORM>>
1725                <MESSAGE WARNING "UNCERTAIN USE OF " .NAM .N>
1726                <SPEC-FLUSH> <PUT-FLUSH ALL>)
1727               (ELSE <PUT .N ,NODE-TYPE ,GET2-CODE>)>
1728         <TYPE-OK? ANY .R>>
1729
1730 <DEFINE GET2-ANA (N R "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>) (LN <LENGTH .K>))
1731         #DECL ((N) NODE (K) <LIST NODE NODE [REST NODE]> (LN) FIX)
1732         <EANA <1 .K> ANY .NAM>
1733         <EANA <2 .K> ANY .NAM>
1734         <COND (<==? .LN 3> <EANAQ <3 .K> ANY .NAM .N>)>
1735         <TYPE-OK? ANY .R>>
1736
1737 <DEFINE EANAQ (N R NAM INOD "AUX" SPCD)
1738         #DECL ((N) NODE (SPCD) LIST)
1739         <SET SPCD <BUILD-TYPE-LIST .VARTBL>>
1740         <SET R <EANA .N .R .NAM>>
1741         <ASSERT-TYPES <ORUPC .VARTBL .SPCD>>
1742         .R>
1743
1744 <DEFINE USE-REG ()
1745         #DECL ((TMPS HTMPS) FIX)
1746         <COND (<0? ,REGS>
1747                <AND <G? <SET TMPS <+ .TMPS 2>> .HTMPS> <SET HTMPS .TMPS>>)
1748               (ELSE <SETG REGS <- ,REGS 1>>)>>
1749
1750 <DEFINE UNUSE-REG ()
1751         #DECL ((TMPS) FIX)
1752         <COND (<==? ,REGS 5> <SET TMPS <- .TMPS 2>>)
1753               (ELSE <SETG REGS <+ ,REGS 1>>)>>
1754
1755 <DEFINE REGFLS ()
1756         #DECL ((TMPS HTMPS) FIX)
1757         <AND <G? <SET TMPS <+ .TMPS <* <- 5 ,REGS> 2>>> .HTMPS>
1758             <SET HTMPS .TMPS>>
1759         <SETG REGS 5>>
1760
1761 <DEFINE ACTIV? (BST NOACT)
1762         #DECL ((BST) <LIST [REST SYMTAB]>)
1763         <REPEAT ()
1764                 <AND <EMPTY? .BST> <RETURN <>>>
1765                 <AND <==? <CODE-SYM <1 .BST>> 1>
1766                      <OR <NOT .NOACT>
1767                          <NOT <RET-AGAIN-ONLY <1 .BST>>>
1768                          <SPEC-SYM <1 .BST>>>
1769                      <RETURN T>>
1770                 <SET BST <REST .BST>>>>
1771
1772 <DEFINE SAME-DECL? (D1 D2) <OR <=? .D1 .D2> <NOT <TYPE-OK? .D2 <NOTIFY .D1>>>>>
1773
1774 <DEFINE SPECIALIZE (OBJ "AUX" T1 T2 SYM OB)
1775         #DECL ((T1) FIX (OB) FORM (T2) <OR FALSE SYMTAB>)
1776         <COND (<AND <TYPE? .OBJ FORM SEGMENT>
1777                     <SET OB <CHTYPE .OBJ FORM>>
1778                     <OR <AND <==? <SET T1 <LENGTH .OB>> 2>
1779                              <==? <1 .OB> LVAL>
1780                              <TYPE? <SET SYM <2 .OB>> ATOM>>
1781                         <AND <==? .T1 3>
1782                              <==? <1 .OB> SET>
1783                              <TYPE? <SET SYM <2 .OB>> ATOM>>>
1784                     <SET T2 <SRCH-SYM .SYM>>>
1785                <COND (<NOT <SPEC-SYM .T2>>
1786                       <MESSAGE NOTE " REDCLARED SPECIAL " .SYM>
1787                       <PUT .T2 ,SPEC-SYM T>)>)>
1788         <COND (<MEMQ <PRIMTYPE .OBJ> '![FORM LIST UVECTOR VECTOR!]>
1789                <MAPF <> ,SPECIALIZE .OBJ>)>>
1790
1791 <COND (<GASSIGNED? ARITH-ANA>
1792        <SETG ANALYZERS
1793              <DISPATCH ,SUBR-ANA
1794                 (,QUOTE-CODE ,QUOTE-ANA)
1795                 (,FUNCTION-CODE ,FUNC-ANA)
1796                 (,SEGMENT-CODE ,SEGMENT-ANA)
1797                 (,FORM-CODE ,FORM-AN)
1798                 (,PROG-CODE ,PRG-REP-ANA)
1799                 (,SUBR-CODE ,SUBR-ANA)
1800                 (,COND-CODE ,COND-ANA)
1801                 (,COPY-CODE ,COPY-AN)
1802                 (,RSUBR-CODE ,RSUBR-ANA)
1803                 (,ISTRUC-CODE ,ISTRUC-ANA)
1804                 (,ISTRUC2-CODE ,ISTRUC2-ANA)
1805                 (,READ-EOF-CODE ,READ-ANA)
1806                 (,READ-EOF2-CODE ,READ2-ANA)
1807                 (,GET-CODE ,GET-ANA)
1808                 (,GET2-CODE ,GET2-ANA)
1809                 (,MAP-CODE ,MAPPER-AN)
1810                 (,MARGS-CODE ,MARGS-ANA)
1811                 (,ARITH-CODE ,ARITH-ANA)
1812                 (,TEST-CODE ,ARITHP-ANA)
1813                 (,0-TST-CODE ,ARITHP-ANA)
1814                 (,1?-CODE ,ARITHP-ANA)
1815                 (,MIN-MAX-CODE ,ARITH-ANA)
1816                 (,ABS-CODE ,ABS-ANA)
1817                 (,FIX-CODE ,FIX-ANA)
1818                 (,FLOAT-CODE ,FLOAT-ANA)
1819                 (,MOD-CODE ,MOD-ANA)
1820                 (,LNTH-CODE ,LENGTH-ANA)
1821                 (,MT-CODE ,EMPTY?-ANA)
1822                 (,NTH-CODE ,NTH-ANA)
1823                 (,REST-CODE ,REST-ANA)
1824                 (,PUT-CODE ,PUT-ANA)
1825                 (,PUTR-CODE ,PUTREST-ANA)
1826                 (,UNWIND-CODE ,UNWIND-ANA)
1827                 (,FORM-F-CODE ,FORM-F-ANA)
1828                 (,IRSUBR-CODE ,IRSUBR-ANA)
1829                 (,ROT-CODE ,ROT-ANA)
1830                 (,LSH-CODE ,LSH-ANA)
1831                 (,BIT-TEST-CODE ,BIT-TEST-ANA)
1832                 (,CASE-CODE ,CASE-ANA)
1833                 (,COPY-LIST-CODE ,COPY-AN)>>)>
1834
1835 <ENDPACKAGE>