mim/development/mim/mimc/mapana.mud

   1
   2 <PACKAGE "MAPANA">
   3
   4 <ENTRY MAPPER-AN
   5        MAPRET-STOP-ANA
   6        MAPLEAVE-ANA
   7        MENTROPY
   8        MAUX
   9        MAUX1
  10        MTUPLE
  11        MBAD
  12        MOPT
  13        MOPT2
  14        MNORM
  15        MARGS-ANA>
  16
  17 <USE "COMPDEC" "SYMANA" "CHKDCL" "CARANA" "ADVMESS">
  18
  19 <SETG SPECIAL-MAPF-R-SUBRS [,LIST ,+ ,* ,MAX ,MIN]>
  20
  21 <DEFINE MAPPER-AN (MNOD MRTYP
  22                    "AUX" (K <KIDS .MNOD>) TT ITRNOD FAP T TF (MPSTRS ())
  23                          (R? <==? <NODE-SUBR .MNOD> ,MAPR>) (TUPCNT 1)
  24                          (RETYPS NO-RETURN) TEM ASSU L-D L-V D-V VALSPCD SBR
  25                          (SBRL <>) (SEGFX ()) FINTYPE STATE (FRET T) (FSTOP T)
  26                          (OV .VARTBL) NSTR (CHF <>))
  27    #DECL ((FAP ITRNOD) NODE (K) <LIST [REST NODE]> (TT NSTR) FIX
  28           (MPSTRS L-V D-V) <SPECIAL LIST> (R?) <SPECIAL <OR ATOM FALSE>>
  29           (STATE TUPCNT) <SPECIAL FIX> (SEGFX) <SPECIAL <LIST [REST NODE]>>
  30           (MNOD) <SPECIAL NODE> (OV) <SPECIAL SYMTAB>
  31           (FRET FSTOP MRTYP RETYPS) <SPECIAL ANY> (VALSPCD) <SPECIAL LIST>
  32           (ASSU L-D) LIST (SBRL) <OR VECTOR FALSE>)
  33    <SET TF <EANA <SET FAP <1 .K>> ANY <NODE-NAME .MNOD>>>
  34    <COND (<AND <SET SBR <SUBAP? .FAP>>
  35                <SET SBRL <MEMQ ,.SBR ,SPECIAL-MAPF-R-SUBRS>>>
  36           <PUT .FAP ,NODE-TYPE ,MFIRST-CODE>
  37           <COND (<N==? ,.SBR ,LIST>
  38                  <SET FINTYPE '<OR FIX FLOAT>>
  39                  <SET STATE 1>)
  40                 (ELSE <SET FINTYPE LIST>)>
  41           <PUT .FAP ,NODE-SUBR <LENGTH .SBRL>>)>
  42    <SET ITRNOD <2 .K>>
  43    <MAPF <>
  44          <FUNCTION (N)
  45                  #DECL ((N) NODE)
  46                  <COND (<L? <MINL <RESULT-TYPE .N>> 1> <SET CHF T>)>>
  47          <REST .K 2>>
  48    <COND
  49     (<==? <SET TT <NODE-TYPE .ITRNOD>> ,MFCN-CODE>
  50      <PUT .ITRNOD ,SIDE-EFFECTS <>>
  51      <MAPF <>
  52       <FUNCTION (N "AUX" RT R)
  53               #DECL ((N) NODE)
  54               <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
  55                          <==? <NODE-TYPE .N> ,SEG-CODE>>
  56                      <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
  57                      <SET RT <GET-ELE-TYPE .RT ALL>>
  58                      <COND (<NOT <TYPE-OK? .RT STRUCTURED>>
  59                             <COMPILE-ERROR "MAPF/R on non structured object(s)"
  60                                            .MNOD>)>)
  61                     (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
  62               <COND (<AND .VERBOSE
  63                           <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
  64                      <ADDVMESS
  65                       .MNOD
  66                       ("Non-specific structure for MAPF/R:  "
  67                        .N
  68                        " type is:  "
  69                        .RT)>)>>
  70       <SET K <REST .K 2>>>
  71      <SET L-D <SAVE-L-D-STATE .VARTBL>>
  72      <PROG ((HTMPS 0) (TMPS 0) (VARTBL <SYMTAB .ITRNOD>) (KK .K) (LL .LIFE)
  73             (OVV .VERBOSE))
  74            #DECL ((HTMPS TMPS) <SPECIAL FIX> (VARTBL) <SPECIAL SYMTAB>
  75                   (KK) <LIST [REST NODE]>)
  76            <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
  77            <SET LIFE .LL>
  78            <SET L-V ()>
  79            <SET FSTOP T>
  80            <RESET-VARS .VARTBL .OV>
  81            <MUNG-L-D-STATE .VARTBL>
  82            <SET K .KK>
  83            <SET RETYPS NO-RETURN>
  84            <SET ASSU <BUILD-TYPE-LIST .OV>>
  85            <SET VALSPCD <BUILD-TYPE-LIST .OV>>
  86            <REPEAT ((BNDS <BINDING-STRUCTURE .ITRNOD>) (TUPF <>) (LAST-SEG <>)
  87                     (SKIPF <>))
  88                    <COND (<EMPTY? .BNDS>
  89                           <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
  90                                  <COMPILE-ERROR
  91 "MAPF/R function takes too few args "
  92                                                 .ITRNOD>)>
  93                           <RETURN>)>
  94                    <COND (<==? <CODE-SYM <1 .BNDS>> ,ARGL-TUPLE> <SET TUPF T>)>
  95                    <COND (<AND <NOT <EMPTY? .K>>
  96                                <OR <==? <NODE-TYPE <1 .K>> ,SEG-CODE>
  97                                    <==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>>>
  98                           <COND (<EMPTY? <REST .K>> <SET LAST-SEG 1>)>
  99                           <COND (<NOT <OR .LAST-SEG .TUPF>> <SET SKIPF T>)>)>
 100                    <COND (<OR <MANAL-DISP <1 .BNDS>
 101                                           <COND (<NOT <EMPTY? .K>> <1 .K>)>
 102                                           .SKIPF
 103                                           .LAST-SEG>
 104                               .TUPF>
 105                           <SET BNDS <REST .BNDS>>)>
 106                    <COND (<AND <NOT <EMPTY? .BNDS>>
 107                                <SPEC-SYM <1 .BNDS>>>
 108                           <PUT .ITRNOD ,SPCS-X T>)>
 109                    <COND (.LAST-SEG <SET LAST-SEG <+ .LAST-SEG 1>>)>
 110                    <COND (<AND <NOT .LAST-SEG> <NOT <EMPTY? .K>>>
 111                           <SET K <REST .K>>)>>
 112            <PUT .ITRNOD ,VSPCD (())>
 113            <PROG ((STMPS .TMPS) (SHTMPS .HTMPS) (LL .LIFE) (OVV .VERBOSE))
 114                  #DECL ((STMPS SHTMPS) FIX)
 115                  <COND (.VERBOSE <PUTREST <SET VERBOSE .OVV> ()>)>
 116                  <SET LIFE .LL>
 117                  <SET FRET T>
 118                  <SET TMPS .STMPS>
 119                  <SET HTMPS .SHTMPS>
 120                  <PUT .ITRNOD ,ASSUM <BUILD-TYPE-LIST .VARTBL>>
 121                  <PUT .ITRNOD ,ACCUM-TYPE NO-RETURN>
 122                  <SET TEM <SEQ-AN <KIDS .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>
 123                  <OR <NOT <AGND .ITRNOD>>
 124                      <ASSUM-OK? <ASSUM .ITRNOD> <AGND .ITRNOD>>
 125                      <AGAIN>>>
 126            <COND (<N==? .TEM NO-RETURN>
 127                   <COND (<NOT .FRET>
 128                          <SET L-V <MSAVE-L-D-STATE .L-V .OV>>
 129                          <ASSERT-TYPES <ORUPC .VARTBL <VSPCD .ITRNOD>>>)
 130                         (ELSE <SET L-V <SAVE-L-D-STATE .OV>>)>)
 131                  (<N==? <ACCUM-TYPE .ITRNOD> NO-RETURN>
 132                   <ASSERT-TYPES <VSPCD .ITRNOD>>)>
 133            <SET VALSPCD <ORUPC .OV .VALSPCD>>
 134            <OR <ASSUM-OK? .ASSU <BUILD-TYPE-LIST .VARTBL>> <AGAIN>>
 135            <PUT .ITRNOD ,ACCUM-TYPE <TYPE-MERGE .TEM <ACCUM-TYPE .ITRNOD>>>
 136            <PUT .ITRNOD
 137                 ,RESULT-TYPE
 138                 <TYPE-OK? <ACCUM-TYPE .ITRNOD> <INIT-DECL-TYPE .ITRNOD>>>>
 139      <ASSERT-TYPES .VALSPCD>
 140      <COND (<ASSIGNED? STATE>
 141             <FIX-STATE <ACCUM-TYPE .ITRNOD> .ITRNOD>
 142             <COND (<G? .STATE 4>
 143                    <SET SBRL <>>
 144                    <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
 145                    <SET FINTYPE '<OR FIX FLOAT>>)
 146                   (ELSE
 147                    <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
 148      <SAVE-SURVIVORS .L-D .LIFE T>
 149      <SAVE-SURVIVORS .L-V .LIFE>
 150      <SET D-V
 151           <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
 152                 (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
 153      <FREST-L-D-STATE .D-V>
 154      <SET LIFE <KILL-REM .LIFE .OV>>
 155      <COND (.SBRL <MUNG-SEGS .SEGFX>)>
 156      <COND (<SIDE-EFFECTS .ITRNOD>
 157             <UPDATE-SIDE-EFFECTS .ITRNOD .MNOD>)>
 158      <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
 159                  <==? <NODE-NAME .FAP> #FALSE ()>>
 160             <TYPE-OK? <COND (.CHF <TYPE-MERGE FALSE .TEM .RETYPS>)
 161                             (ELSE <TYPE-OK? <TYPE-MERGE .TEM .RETYPS> .MRTYP>)>
 162                       .MRTYP>)
 163            (<ASSIGNED? FINTYPE>
 164             <COND (<==? .FINTYPE LIST>
 165                    <TYPE-OK? <TYPE-MERGE <FORM LIST
 166                                                [REST <RESULT-TYPE .ITRNOD>]>
 167                                          .RETYPS>
 168                              .MRTYP>)
 169                   (ELSE <TYPE-OK? <TYPE-MERGE .FINTYPE .RETYPS> .MRTYP>)>)
 170            (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
 171                  <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
 172             <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
 173             <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
 174            (ELSE <TYPE-OK? <TYPE-MERGE <APPLTYP .FAP> .RETYPS> .MRTYP>)>)
 175     (ELSE
 176      <COND (<N==? .TT ,MPSBR-CODE>
 177             <EANA .ITRNOD APPLICABLE <NODE-NAME .MNOD>>)>
 178      <MAPF <>
 179       <FUNCTION (N "AUX" RT R)
 180               #DECL ((N) NODE)
 181               <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
 182                          <==? <NODE-TYPE .N> ,SEG-CODE>>
 183                      <SET RT <EANA <1 <KIDS .N>> STRUCTURED <NODE-NAME .MNOD>>>
 184                      <SET RT <GET-ELE-TYPE .RT ALL>>)
 185                     (ELSE <SET RT <EANA .N STRUCTURED <NODE-NAME .MNOD>>>)>
 186               <COND (<AND .VERBOSE
 187                           <OR <NOT <SET R <STRUCTYP .RT>>> <==? .R TEMPLATE>>>
 188                      <ADDVMESS
 189                       .MNOD
 190                       ("Non-specific structure for MAPF/R:  "
 191                        .N
 192                        " type is:  "
 193                        .RT)>)>>
 194       <SET MPSTRS <REST .K 2>>>
 195      <COND (<==? .TT ,MPSBR-CODE>
 196             <SET TEM <EANA <1 <KIDS .ITRNOD>> ANY <NODE-NAME .MNOD>>>
 197             <COND (.CHF <SET TEM <TYPE-MERGE .TEM FALSE>>)>)
 198            (ELSE <SET TEM ANY>)>
 199      <COND (<ASSIGNED? STATE>
 200             <FIX-STATE .TEM <1 <KIDS .ITRNOD>>>
 201             <COND (<G? .STATE 4>
 202                    <SET SBRL <>>
 203                    <PUT .FAP ,NODE-TYPE ,GVAL-CODE>
 204                    <SET FINTYPE '<OR FIX FLOAT>>)
 205                   (ELSE
 206                    <SET FINTYPE <NTH '[FIX FLOAT FLOAT] <- .STATE 1>>>)>)>
 207      <COND (.SBRL <MUNG-SEGS .SEGFX>)>
 208      <COND (<AND <==? <NODE-TYPE .FAP> ,QUOTE-CODE>
 209                  <==? <NODE-NAME .FAP> #FALSE ()>>
 210             <TYPE-OK? .TEM .MRTYP>)
 211            (<ASSIGNED? FINTYPE>
 212             <COND (<==? .FINTYPE LIST>
 213                    <TYPE-OK? <FORM LIST [REST .TEM]> .MRTYP>)
 214                   (ELSE <TYPE-OK? .FINTYPE .MRTYP>)>)
 215            (<AND <==? <NODE-TYPE .FAP> ,GVAL-CODE>
 216                  <MEMQ <NODE-NAME .FAP> '[TUPLE VECTOR UVECTOR]>>
 217             <SET TEM <FORM <NODE-NAME .FAP> [REST .TEM]>>
 218             <TYPE-OK? <TYPE-MERGE .RETYPS .TEM> .MRTYP>)
 219            (ELSE <TYPE-OK? <APPLTYP .FAP> .MRTYP>)>)>>
 220
 221 \\f
 222
 223 <DEFINE FIX-STATE (TEM N "AUX" TT (SG <MEMQ <NODE-TYPE .N> ,SEG-CODES>))
 224         #DECL ((STATE TT) FIX (N) NODE)
 225         <SET TT
 226              <COND (<==? .TEM FIX> 1)
 227                    (<==? .TEM FLOAT> 2)
 228                    (<NOT <TYPE-OK? .TEM FLOAT>>
 229                     <PUT .N
 230                          ,RESULT-TYPE
 231                          <COND (.SG
 232                                 <TYPE-MERGE '<STRUCTURED [REST FIX]>
 233                                             <RESULT-TYPE .N>>)
 234                                (ELSE FIX)>>
 235                     1)
 236                    (<NOT <TYPE-OK? .TEM FIX>>
 237                     <PUT .N
 238                          ,RESULT-TYPE
 239                          <COND (.SG
 240                                 <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
 241                                             <RESULT-TYPE .N>>)
 242                                (ELSE FLOAT)>>
 243                     2)
 244                    (ELSE 3)>>
 245         <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
 246
 247 <SETG SEG-CODES [,SEG-CODE ,SEGMENT-CODE]>
 248
 249 <DEFINE MUNG-SEGS (SEGS)
 250         #DECL ((SEGS) <LIST [REST NODE]>)
 251         <MAPF <>
 252               <FUNCTION (N) #DECL ((N) NODE) <PUT .N ,NODE-TYPE ,SEG-CODE>>
 253               .SEGS>>
 254
 255 <DEFINE MARGS-ANA (N R "AUX" (MK .MPSTRS) (NN <NODE-NAME .N>))
 256         #DECL ((N) NODE (NN) FIX (MK) <LIST [REST NODE]>)
 257         <SET R
 258              <TYPE-OK? <GET-ELE-TYPE <RESULT-TYPE <NTH .MK .NN>> ALL .R?> .R>>
 259         <COND (.R? <TYPE-OK? .R '<STRUCTURED ANY>>) (ELSE .R)>>
 260
 261 <DEFINE MAUX (SYM STRUC SKIPF LAST-SEG)
 262         #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
 263         <COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
 264                <COMPILE-ERROR "MAPF/R function takes too many args "
 265                               <2 <KIDS .MNOD>>>)
 266               (ELSE <NORM-BAN .SYM>)>
 267         T>
 268
 269 <DEFINE MAUX1 (SYM STRUC SKIPF LAST-SEG)
 270         #DECL ((SYM) SYMTAB (STRUC) <OR FALSE NODE> (MNOD) NODE)
 271         <COND (<AND .STRUC <NOT .SKIPF> <NOT .LAST-SEG>>
 272                <COMPILE-ERROR "MAPF/R function takes too many args "
 273                               <2 <KIDS .MNOD>>>)>
 274         <PUT .SYM
 275              ,COMPOSIT-TYPE
 276              <COND (.ANALY-OK NO-RETURN) (ELSE <DECL-SYM .SYM>)>>
 277         <PUT .SYM ,CURRENT-TYPE <COND (.ANALY-OK NO-RETURN) (ELSE ANY)>>
 278         T>
 279
 280 <DEFINE MNORM (SYM STRUC SKIPF LAST-SEG
 281                "AUX" (VARTBL <NEXT-SYM .SYM>) TEM COD N TYP)
 282         #DECL ((SYM) SYMTAB (STRUC) <OR NODE FALSE> (VARTBL) <SPECIAL SYMTAB>
 283                (MNOD N) NODE)
 284         <COND (<AND .STRUC <NOT .SKIPF>>
 285                <COND (.LAST-SEG
 286                       <SET TYP
 287                            <GET-ELE-TYPE
 288                             <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>
 289                             .LAST-SEG>>)
 290                      (ELSE <SET TYP <EANA .STRUC ANY MAPF/R>>)>
 291                <COND (<NOT <SET TEM
 292                                 <TYPE-OK? <GET-ELE-TYPE .TYP ALL .R?>
 293                                           <DECL-SYM .SYM>>>>
 294                       <COMPILE-ERROR "MAPF/R structure violates arg DECL "
 295                                      <NAME-SYM .SYM>
 296                                      " "
 297                                      <DECL-SYM .SYM>
 298                                      .STRUC>)>
 299                <COND (.R? <SET TEM <TYPE-AND .TEM '<STRUCTURED ANY>>>)>
 300                <COND (<N=? .TEM <DECL-SYM .SYM>>
 301                       <PUT .SYM ,CURRENT-TYPE .TEM>)>
 302                <PUT .SYM ,COMPOSIT-TYPE .TEM>)
 303               (<NOT .SKIPF>
 304                <COMPILE-ERROR "Too fewa argumens MAPF/R function" .MNOD>)>
 305         T>
 306
 307 <DEFINE MOPT (SYM STRUC SKIPF LAST-SEG "AUX" (VARTBL <NEXT-SYM .SYM>))
 308         #DECL ((SYM) SYMTAB (VARTBL) <SPECIAL SYMTAB> (STRUC) <OR FALSE NODE>)
 309         <COND (.STRUC
 310                <PUT .SYM ,INIT-SYM <>>
 311                <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
 312         <COND (<OR <NOT .STRUC> .SKIPF .LAST-SEG> <NORM-BAN .SYM>)>
 313         T>
 314
 315 <DEFINE MBAD (SYM STRUC SKIPF LAST-SEG)
 316         <COMPILE-ERROR "Unrecognized arg decl in MAPF/R function "
 317                        <NAME-SYM .SYM>>>
 318
 319 <DEFINE MOPT2 (SYM STRUC SKIPF LAST-SEG)
 320         <COND (.STRUC <MNORM .SYM .STRUC .SKIPF .LAST-SEG>)>
 321         T>
 322
 323 \\f
 324
 325 <DEFINE MTUPLE (SYM STRUC SKIPF LAST-SEG
 326                 "AUX" (VARTBL <NEXT-SYM .SYM>) TYP
 327                       (ATYP
 328                        <GET-ELE-TYPE <DECL-SYM .SYM>
 329                                      <COND (.LAST-SEG ALL)
 330                                            (ELSE <SET TUPCNT <+ .TUPCNT 1>>)>>)
 331                       TEM)
 332    #DECL ((VARTBL) <SPECIAL ANY> (TUPCNT) FIX)
 333    <COND
 334     (<AND .STRUC <NOT .SKIPF>>
 335      <COND (.R?
 336             <COND (<NOT <COND (.LAST-SEG
 337                                <SET TEM
 338                                     <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
 339                                <==? <STRUCTYP <GET-ELE-TYPE .TEM ALL>>
 340                                     <STRUCTYP .ATYP>>)
 341                               (ELSE
 342                                <SET TEM <EANA .STRUC STRUCTURED MAPF/R>>
 343                                <==? <STRUCTYP .TEM> <STRUCTYP .ATYP>>)>>
 344                    <COMPILE-ERROR "Bad argument to MAPF/R function "
 345                                   <NAME-SYM .SYM>
 346                                   .MNOD>)>)
 347            (.LAST-SEG
 348             <SET TEM <EANA <1 <KIDS .STRUC>> STRUCTURED MAPF/R>>
 349             <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <GET-ELE-TYPE .TEM ALL>
 350                                                 ALL>
 351                                   .ATYP>>
 352                    <COMPILE-ERROR "Bad argument to MAPF/R function "
 353                                   <NAME-SYM .SYM>
 354                                   .MNOD>)>)
 355            (<AND .STRUC .SKIPF> <ANA .STRUC ANY>)
 356            (<NOT .SKIPF>
 357             <COND (<NOT <TYPE-OK? <GET-ELE-TYPE <EANA .STRUC STRUCTURED MAPF/R>
 358                                                 ALL>
 359                                   .ATYP>>
 360                    <COMPILE-ERROR "Bad argument to MAPF/R function "
 361                                   <NAME-SYM .SYM>
 362                                   .MNOD>)>)>
 363      <>)
 364     (ELSE T)>>
 365
 366 <DEFINE MENTROPY (N R "OPT" X Y) T>
 367
 368 <DEFINE MANAL-DISP (SYM NOD SKIPF LAST-SEG "AUX" (COD <CODE-SYM .SYM>))
 369         <CASE ,==?
 370               .COD
 371               (,ARGL-ACT <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
 372               (,ARGL-IAUX <MAUX .SYM .NOD .SKIPF .LAST-SEG>)
 373               (,ARGL-AUX <MAUX1 .SYM .NOD .SKIPF .LAST-SEG>)
 374               (,ARGL-TUPLE <MTUPLE .SYM .NOD .SKIPF .LAST-SEG>)
 375               (,ARGL-ARGS <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
 376               (,ARGL-QIOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
 377               (,ARGL-IOPT <MOPT .SYM .NOD .SKIPF .LAST-SEG>)
 378               (,ARGL-QOPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
 379               (,ARGL-OPT <MOPT2 .SYM .NOD .SKIPF .LAST-SEG>)
 380               (,ARGL-CALL <MBAD .SYM .NOD .SKIPF .LAST-SEG>)
 381               (,ARGL-BIND <MENTROPY .SYM .NOD .SKIPF .LAST-SEG>)
 382               (,ARGL-QUOTE <MNORM .SYM .NOD .SKIPF .LAST-SEG>)
 383               (,ARGL-ARG <MNORM .SYM .NOD .SKIPF .LAST-SEG>)>>
 384
 385 "Additional SUBR analyzers associated with MAP hackers."
 386
 387 <DEFINE MAPLEAVE-ANA (N R "AUX" (K <KIDS .N>) (LN <LENGTH .K>) TEM)
 388         #DECL ((N) NODE (K) <LIST [REST NODE]> (LN) FIX)
 389         <SET RET-OR-AGAIN T>
 390         <COND (<ASSIGNED? MNOD>
 391                <ARGCHK .LN '(0 1) MAPLEAVE .N>
 392                <COND (<0? .LN>
 393                       <PUT .N
 394                            ,KIDS
 395                            <SET K (<NODE1 ,QUOTE-CODE .N ATOM T ()>)>>)>
 396                <SET TEM <EANA <1 .K> .MRTYP MAPLEAVE>>
 397                <SET VALSPCD <ORUPC .OV .VALSPCD>>
 398                <SET D-V
 399                     <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
 400                           (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
 401                <SET FSTOP <>>
 402                <SET RETYPS <TYPE-MERGE .RETYPS .TEM>>
 403                <PUT .N ,NODE-TYPE ,MAPLEAVE-CODE>)
 404               (ELSE <SUBR-C-AN .N .R>)>
 405         NO-RETURN>
 406
 407 \\f
 408
 409 <DEFINE MAPRET-STOP-ANA (NOD R "AUX" (ARGS 0) (TYP NO-RETURN) TYP1 ITRNOD)
 410    #DECL ((MNOD NOD ITRNOD) NODE (ARGS) FIX)
 411    <SET RET-OR-AGAIN T>
 412    <PROG ()
 413      <OR <ASSIGNED? MNOD> <RETURN <SUBR-C-AN .NOD .R>>>
 414      <PUT <SET ITRNOD <2 <KIDS .MNOD>>> ,ACTIVATED T>
 415                                            ;"So frame will be built"
 416      <COND (<NOT <NODE-NAME <1 <KIDS .MNOD>>>>
 417             <COMPILE-ERROR "MAPRET/STOP with no final function." .MNOD>)>
 418      <MAPF <>
 419       <FUNCTION (N)
 420               #DECL ((N) NODE)
 421               <COND
 422                (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
 423                     <==? <NODE-TYPE .N> ,SEG-CODE>>
 424                 <SET TYP1
 425                      <EANA <1 <KIDS .N>>
 426                            <COND (<ASSIGNED? STATE>
 427                                   '<STRUCTURED [REST <OR FIX FLOAT>]>)
 428                                  (ELSE STRUCTURED)>
 429                            SEGMENT>>
 430                 <SET TYP <TYPE-MERGE .TYP <GET-ELE-TYPE .TYP1 ALL>>>
 431                 <PUT .NOD ,SEGS T>)
 432                (ELSE
 433                 <SET ARGS <+ .ARGS 1>>
 434                 <SET TYP
 435                      <TYPE-MERGE
 436                       .TYP
 437                       <EANA .N
 438                             <COND (<ASSIGNED? STATE> '<OR FIX FLOAT>)
 439                                   (ELSE ANY)>
 440                             <NODE-NAME .NOD>>>>)>>
 441       <KIDS .NOD>>
 442      <AND <ASSIGNED? STATE> <N==? .TYP NO-RETURN> <FIX-STATE .TYP .NOD>>
 443      <COND (<==? <NODE-SUBR .NOD> ,MAPRET>
 444             <SET L-V
 445                  <COND (.FRET <SAVE-L-D-STATE .VARTBL>)
 446                        (ELSE <MSAVE-L-D-STATE .L-V .VARTBL>)>>
 447             <PUT .ITRNOD
 448                  ,VSPCD
 449                  <COND (.FRET <BUILD-TYPE-LIST .VARTBL>)
 450                        (ELSE <ORUPC .VARTBL <VSPCD .ITRNOD>>)>>
 451             <SET FRET <>>)
 452            (ELSE
 453             <SET D-V
 454                  <COND (.FSTOP <SAVE-L-D-STATE .VARTBL>)
 455                        (ELSE <MSAVE-L-D-STATE .D-V .VARTBL>)>>
 456             <SET VALSPCD <ORUPC .OV .VALSPCD>>
 457             <SET FSTOP <>>)>
 458      <PUT <2 <KIDS .MNOD>>
 459           ,ACCUM-TYPE
 460           <TYPE-MERGE <ACCUM-TYPE <2 <KIDS .MNOD>>> .TYP>>
 461      <PUT .NOD ,NODE-TYPE ,MAPRET-STOP-CODE>>
 462    NO-RETURN>
 463
 464 <COND (<GASSIGNED? MAPLEAVE-ANA>
 465        <PUTPROP ,MAPLEAVE ANALYSIS ,MAPLEAVE-ANA>
 466        <PUTPROP ,MAPRET ANALYSIS ,MAPRET-STOP-ANA>
 467        <PUTPROP ,MAPSTOP ANALYSIS ,MAPRET-STOP-ANA>)>
 468
 469 <DEFINE SUBAP? (NOD "AUX" TT (COD 0))
 470         #DECL ((COD) FIX (NOD) NODE)
 471         <AND <OR <==? <SET COD <NODE-TYPE .NOD>> ,FGVAL-CODE>
 472                  <==? .COD ,GVAL-CODE>
 473                  <==? .COD ,MFIRST-CODE>>
 474              <==? <NODE-TYPE <SET NOD <1 <KIDS .NOD>>>> ,QUOTE-CODE>
 475              <GASSIGNED? <SET TT <NODE-NAME .NOD>>>
 476              .TT>>
 477
 478 <ENDPACKAGE>