mim/development/mim/mimc/carana.mud

   1
   2 <PACKAGE "CARANA">
   3
   4 <ENTRY ARITH-ANA
   5        MOD-ANA
   6        ASTATE
   7        ABS-ANA
   8        ROT-ANA
   9        LSH-ANA
  10        FIX-ANA
  11        FLOAT-ANA
  12        ARITHP-ANA
  13        HACK-BOUNDS
  14        BIT-TEST-ANA>
  15
  16 <USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS" "NPRINT">
  17
  18 "       This file contains analyzers and code generators for arithmetic
  19  SUBRs and predicates.  For convenience many of the SUBRs that are
  20 similar are combined into one analyzer/generator.  For more info
  21 on analyzers see SYMANA and on generators see CODGEN.
  22 "
  23
  24 <SETG ASTATE '[![2 3 5] ![2 4 5] ![4 3 5] ![4 4 5] ![5 5 5]]>
  25
  26 <GDECL (ASTATE) <VECTOR [REST <UVECTOR [REST FIX]>]>>
  27
  28 "       Analyze +,-,* and /.  Take care of no arg and one arg problems."
  29
  30 <DEFINE ARITH-ANA (NOD RTYP
  31                    "AUX" (NN <NODE-NAME .NOD>) (DEFLT <GET-DF .NN>) (STATE 1)
  32                          (K <KIDS .NOD>) (FIXDIV <>) RT
  33                          (ALL-CONST ALL-CONST))
  34         #DECL ((NOD) <SPECIAL NODE> (K) <LIST [REST NODE]> (STYP) FIX
  35                (STATE) <SPECIAL FIX> (DEFLT) <OR FIX FLOAT>
  36                (ALL-CONST) <SPECIAL ANY>)
  37         <SET RT
  38              <COND (<NOT <TYPE-OK? .RTYP FLOAT>> FIX) (ELSE '<OR FIX FLOAT>)>>
  39         <COND
  40          (<EMPTY? .K>
  41           <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  42           <PUT .NOD ,RESULT-TYPE <TYPE .DEFLT>>
  43           <PUT .NOD ,NODE-NAME .DEFLT>
  44           <PUT .NOD ,KIDS ()>
  45           <TYPE-OK? <TYPE .DEFLT> .RTYP>)
  46          (<AND <EMPTY? <REST .K>>
  47                <N==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>
  48                <N==? <NODE-TYPE <1 .K>> ,SEG-CODE>
  49                <COND (<==? <NODE-SUBR .NOD> ,/>
  50                       <SET FIXDIV T>
  51                       <PUT .NOD
  52                            ,KIDS
  53                            <SET K
  54                                 (<NODE1 ,QUOTE-CODE
  55                                         .NOD
  56                                         <TYPE .DEFLT>
  57                                         .DEFLT
  58                                         ()>
  59                                  !.K)>>
  60                       <>)
  61                      (ELSE T)>>
  62           <SET RT <EANA <1 .K> .RT <NODE-NAME .NOD>>>
  63           <COND (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
  64                  <COND (<==? <NODE-SUBR .NOD> ,->
  65                         <PUT .NOD ,NODE-NAME <- <NODE-NAME <1 .K>>>>)
  66                        (ELSE <PUT .NOD ,NODE-NAME <NODE-NAME <1 .K>>>)>
  67                  <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  68                  <PUT .NOD ,RESULT-TYPE <TYPE <NODE-NAME .NOD>>>
  69                  <PUT .NOD ,KIDS ()>)
  70                 (<==? <NODE-SUBR .NOD> ,-> <PUT .NOD ,NODE-TYPE ,ABS-CODE>)
  71                 (ELSE <PUT .NOD ,NODE-TYPE ,ID-CODE>)>
  72           .RT)
  73          (ELSE
  74           <MAPF <> <FUNCTION (N) <ARITH-ELE .N .RT <NODE-SUBR .NOD>>> .K>
  75           <COND (<==? .NN +> <PUT .NOD ,KIDS <FLUSH-CONST .K 0>>)
  76                 (<==? .NN ->
  77                  <PUT .NOD ,KIDS <SET K (<1 .K> !<FLUSH-CONST <REST .K> 0>)>>
  78                  <COND (<==? <LENGTH .K> 1>
  79                         <PUT .NOD ,NODE-NAME +>
  80                         <PUT .NOD ,NODE-SUBR ,+>)>)
  81                 (<==? .NN *>
  82                  <COND (<FIND-ZERO .K .NOD>
  83                         <SET ALL-CONST <COND (<==? .STATE 2> 0) (ELSE 0.0)>>)
  84                        (ELSE <PUT .NOD ,KIDS <FLUSH-CONST .K 1>>)>)
  85                 (<==? .NN />
  86                  <COND (<FIND-ZERO <REST .K> .NOD>
  87                         <COMPILE-ERROR "Divide by 0 " .NOD>)
  88                        (<FIND-ZERO (<1 .K>) .NOD>
  89                         <SET ALL-CONST <COND (<==? .STATE 2> 0) (ELSE 0.0)>>)
  90                        (ELSE
  91                         <PUT .NOD
  92                              ,KIDS
  93                              (<1 .K> !<FLUSH-CONST <REST .K> 1>)>)>)>
  94           <COND (.ALL-CONST
  95                  <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  96                  <PUT .NOD ,RESULT-TYPE <TYPE .ALL-CONST>>
  97                  <PUT .NOD ,NODE-NAME .ALL-CONST>
  98                  <PUT .NOD ,KIDS ()>)
  99                 (<L? .STATE 5>
 100                  <COND (<AND .FIXDIV <N==? .STATE 2>>
 101                         <PUT <PUT <1 .K> ,NODE-NAME 1.0> ,RESULT-TYPE FLOAT>)>
 102                  <PUT .NOD
 103                       ,NODE-TYPE
 104                       <COND (<OR <==? .NN MAX> <==? .NN MIN>> ,MIN-MAX-CODE)
 105                             (ELSE ,ARITH-CODE)>>
 106                  <MAPF <>
 107                        <FUNCTION (NN)
 108                                #DECL ((NN) NODE)
 109                                <COND (<==? <NODE-TYPE .NN> ,SEGMENT-CODE>
 110                                       <PUT .NN ,NODE-TYPE ,SEG-CODE>)>>
 111                        .K>)
 112                 (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
 113           <TYPE-OK? <NTH '[FIX FLOAT FLOAT <OR FIX FLOAT>] <- .STATE 1>>
 114                     .RTYP>)>>
 115
 116 <DEFINE FIND-ZERO (K NOD) #DECL ((NOD) NODE (K) <LIST [REST NODE]>)
 117         <COND (<AND <OR <L? <LENGTH .NOD>
 118                             <CHTYPE <INDEX ,SIDE-EFFECTS>
 119                                     FIX>>
 120                         <NOT <SIDE-EFFECTS .NOD>>>
 121                     <MAPF <>
 122                           <FUNCTION (NN) #DECL ((NN) NODE)
 123                                <COND (<AND <==? <NODE-TYPE .NN> ,QUOTE-CODE>
 124                                            <==? <CHTYPE <NODE-NAME .NN> FIX>
 125                                                 0>>
 126                                       <MAPLEAVE>)>>
 127                           .K>>)>>
 128
 129 <DEFINE FLUSH-CONST (K C "AUX" (FC <FLOAT .C>) (KK .K) (KP ()))
 130         #DECL ((KK KP K) <LIST [REST NODE]> (C) FIX (FC) FLOAT)
 131         <REPEAT (NN)
 132                 <COND (<EMPTY? .KK> <RETURN .K>)>
 133                 <COND (<AND <==? <NODE-TYPE <SET NN <1 .KK>>> ,QUOTE-CODE>
 134                             <OR <==? <NODE-NAME .NN> .C>
 135                                 <==? <NODE-NAME .NN> .FC>>>
 136                        <COND (<==? .K .KK>
 137                               <COND (<EMPTY? <SET K <SET KK <REST .K>>>>
 138                                      <RETURN .K>)>)
 139                              (ELSE <PUTREST .KP <REST .KK>>)>)
 140                       (ELSE <SET KP .KK>)>
 141                 <SET KK <REST .KK>>>>
 142
 143 <DEFINE GET-DF (S)
 144         #DECL ((S) ATOM)
 145         <NTH ,DFS <LENGTH <CHTYPE <MEMQ .S '[MAX MIN * / - +]> VECTOR>>>>
 146
 147 <SETG DFS [0 0 1 1 <CHTYPE <MIN> FIX> <CHTYPE <MAX> FIX>]>
 148
 149 <GDECL (DFS) VECTOR>
 150
 151 <DEFINE ARITH-ELE (N RT
 152                    "OPT" OP
 153                    "AUX" TT TEM (FL <>) (A-C .ALL-CONST) (NOD .NOD)
 154                          (ISTATE .STATE))
 155         #DECL ((N NOD) NODE (STATE TT ISTATE) FIX)
 156         <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
 157                    <==? <NODE-TYPE .N> ,SEG-CODE>>
 158                <SET FL T>
 159                <SET TEM
 160                     <EANA <1 <KIDS .N>>
 161                           <FORM STRUCTURED [REST .RT]>
 162                           <NODE-NAME .NOD>>>
 163                <PUT .N ,RESULT-TYPE <RESULT-TYPE <1 <KIDS .N>>>>
 164                <SET ALL-CONST <>>
 165                <SET TEM <OR <AND <ISTYPE? .TEM> <GET-ELE-TYPE .TEM ALL>> ANY>>)
 166               (ELSE
 167                <SET TEM <EANA .N .RT <NODE-NAME .NOD>>>
 168                <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
 169                       <COND (<OR <==? .ISTATE 4> <==? .ISTATE 3>>
 170                              <PUT .N ,NODE-NAME <FLOAT <NODE-NAME .N>>>
 171                              <PUT .N ,RESULT-TYPE FLOAT>)>
 172                       <COND (<==? .A-C ALL-CONST>
 173                              <SET ALL-CONST <NODE-NAME .N>>)
 174                             (.A-C
 175                              <SET ALL-CONST <APPLY .OP .A-C <NODE-NAME .N>>>)>)
 176                      (ELSE <SET ALL-CONST <>>)>)>
 177         <SET TT
 178              <COND (<==? <ISTYPE? .TEM> FIX> 1)
 179                    (<==? .TEM FLOAT> 2)
 180                    (<NOT <TYPE-OK? .TEM FLOAT>>
 181                     <PUT .N
 182                          ,RESULT-TYPE
 183                          <COND (.FL
 184                                 <TYPE-MERGE '<STRUCTURED [REST FIX]>
 185                                             <RESULT-TYPE .N>>)
 186                                (ELSE FIX)>>
 187                     1)
 188                    (<NOT <TYPE-OK? .TEM FIX>>
 189                     <PUT .N
 190                          ,RESULT-TYPE
 191                          <COND (.FL
 192                                 <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
 193                                             <RESULT-TYPE .N>>)
 194                                (ELSE FLOAT)>>
 195                     2)
 196                    (ELSE 3)>>
 197         <COND (<AND .VERBOSE <==? .TT 3>>
 198                <ADDVMESS <PARENT .N>
 199                          ("Arithmetic can't open compile because:  "
 200                           .N
 201                           " is of type:  "
 202                           .TEM)>)>
 203         <SET STATE <NTH <NTH ,ASTATE .ISTATE> .TT>>>
 204
 205 <DEFINE ABS-ANA (N RT "AUX" (K <KIDS .N>) TEM)
 206         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 207         <COND (<SEGFLUSH .N .RT>)
 208               (ELSE
 209                <ARGCHK <LENGTH .K> 1 ABS .N>
 210                <PUT .N ,NODE-TYPE ,ABS-CODE>
 211                <SET TEM <EANA <1 .K> '<OR FIX FLOAT> ABS>>
 212                <TYPE-OK? <TYPE-OK? ,ABS-DECL .RT>
 213                          .TEM>)>>
 214
 215 <SETG ABS-DECL
 216       <FORM OR FLOAT <FORM FIX (0 <MIN>)>>>
 217
 218 <COND (<GASSIGNED? ABS-ANA> <PUTPROP ,ABS ANALYSIS ,ABS-ANA>)>
 219
 220 <DEFINE MOD-ANA (N R "AUX" (K <KIDS .N>))
 221         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 222         <COND (<SEGFLUSH .N .R>)
 223               (ELSE
 224                <ARGCHK <LENGTH .K> 2 MOD .N>
 225                <EANA <1 .K> FIX MOD>
 226                <EANA <2 .K> FIX MOD>
 227                <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 228                            <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
 229                       <PUT .N ,NODE-NAME <MOD <NODE-NAME <1 .K>>
 230                                               <NODE-NAME <2 .K>>>>
 231                       <PUT .N ,NODE-TYPE ,QUOTE-CODE>
 232                       <PUT .N ,KIDS ()>)
 233                      (ELSE
 234                       <PUT .N ,NODE-TYPE ,MOD-CODE>)>)>
 235         <TYPE-OK? <COND (<AND <NOT <EMPTY? <KIDS .N>>>
 236                               <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
 237                          <FORM FIX (0 <- <CHTYPE <NODE-NAME <2 .K>> FIX> 1>)>)
 238                         (ELSE FIX)> .R>>
 239
 240 <COND (<GASSIGNED? MOD-ANA> <PUTPROP ,MOD ANALYSIS ,MOD-ANA>)>
 241
 242 <DEFINE ROT-LSH-ANA (N R COD "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>))
 243         <COND (<SEGFLUSH .N .R>)
 244               (ELSE
 245                <ARGCHK <LENGTH .K> 2 .NAM .N>
 246                <EANA <1 .K> '<PRIMTYPE WORD> .NAM>
 247                <EANA <2 .K> FIX .NAM>
 248                <COND (<AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 249                            <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>>
 250                       <COND (<==? .COD ,LSH-CODE>
 251                              <PUT .N ,NODE-NAME <LSH <NODE-NAME <1 .K>>
 252                                                      <NODE-NAME <2 .K>>>>)
 253                             (ELSE
 254                              <PUT .N ,NODE-NAME <ROT <NODE-NAME <1 .K>>
 255                                                      <NODE-NAME <2 .K>>>>)>
 256                       <PUT .N ,KIDS ()>
 257                       <PUT .N ,NODE-TYPE ,QUOTE-CODE>)
 258                      (ELSE
 259                       <PUT .N ,NODE-TYPE .COD>)>)>
 260         <TYPE-OK? FIX .R>>
 261
 262 <DEFINE ROT-ANA (N R) <ROT-LSH-ANA .N .R ,ROT-CODE>>
 263
 264 <DEFINE LSH-ANA (N R) <ROT-LSH-ANA .N .R ,LSH-CODE>>
 265
 266 <COND (<GASSIGNED? ROT-ANA>
 267        <PUTPROP ,ROT ANALYSIS ,ROT-ANA>
 268        <PUTPROP ,LSH ANALYSIS ,LSH-ANA>)>
 269
 270 <DEFINE FLOAT-ANA (N R)
 271         #DECL ((N) NODE)
 272         <FL-FI-ANA .N .R FLOAT FIX ,FLOAT-CODE>>
 273
 274 <COND (<GASSIGNED? FLOAT-ANA> <PUTPROP ,FLOAT ANALYSIS ,FLOAT-ANA>)>
 275
 276 <DEFINE FIX-ANA (N R) #DECL ((N) NODE) <FL-FI-ANA .N .R FIX FLOAT ,FIX-CODE>>
 277
 278 <COND (<GASSIGNED? FIX-ANA> <PUTPROP ,FIX ANALYSIS ,FIX-ANA>)>
 279
 280 <DEFINE FL-FI-ANA (N RT OT IT COD "AUX" (K <KIDS .N>) TY NUM)
 281         #DECL ((N NUM) NODE (OT IT) ATOM (K) <LIST [REST NODE]> (COD) FIX)
 282         <COND (<SEGFLUSH .N .RT>)
 283               (ELSE
 284                <ARGCHK <LENGTH .K> 1 .OT .N>
 285                <SET TY <EANA <SET NUM <1 .K>> '<OR FIX FLOAT> .OT>>
 286                <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE>
 287                       <PUT .N ,NODE-TYPE ,QUOTE-CODE>
 288                       <PUT .N ,NODE-NAME <APPLY ,.OT <NODE-NAME .NUM>>>)
 289                      (ELSE <PUT .N ,NODE-TYPE .COD>)>)>
 290         <TYPE-OK? .OT .RT>>
 291
 292 <DEFINE ARITHP-ANA (NOD RTYP
 293                     "AUX" (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
 294                           (GLN .NOD) (GLE ()) (NN <NODE-NAME .NOD>)
 295                           (N
 296                            <COND (<OR <==? .NN 0?>
 297                                       <==? .NN 1?>
 298                                       <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
 299                                   1)
 300                                  (ELSE 2)>) (K <KIDS .NOD>) TEM (STATE 1)
 301                           KT NT (ALL-CONST ALL-CONST) (TY BOOLEAN))
 302         #DECL ((WHO) <SPECIAL LIST> (WHON GLN ALL-CONST) <SPECIAL ANY>
 303                (NOD NOD2) <SPECIAL NODE> (TEM) NODE (K) <LIST [REST NODE]>
 304                (STATE) <SPECIAL FIX> (COD N) FIX (GLE) <SPECIAL LIST>)
 305         <COND (<SEGFLUSH .NOD .RTYP> <SET TY '<OR FALSE ATOM>>)
 306               (ELSE
 307                <COND (<AND <==? .N 2>
 308                            <==? <LENGTH .K> 1>
 309                            <==? <NODE-TYPE <SET NT <1 <KIDS .NOD>>>>
 310                                 ,SUBR-CODE>
 311                            <==? <NODE-NAME .NT> LENGTH>
 312                            <==? <LENGTH <SET KT <KIDS .NT>>> 2>>
 313                       <COMPILE-WARNING
 314                        "Attempting to repair probable erroneous code:
 315 "
 316                        .NOD
 317                        "
 318 replaced by">
 319                       <PROG ()
 320                              <PUTREST .K <REST .KT>>
 321                              <PUTREST .KT ()>
 322                              <PUT <1 .KT> ,PARENT .NOD>>
 323                       <NODE-COMPLAIN .NOD>
 324                       <CRLF>)>
 325                <ARGCHK <LENGTH .K> .N <NODE-NAME .NOD> .NOD>
 326                <MAPF <> <FUNCTION (N) <ARITH-ELE .N '<OR FIX FLOAT>
 327                                                  <NODE-SUBR .NOD>>> .K>
 328                <COND (.ALL-CONST
 329                       <COND (<==? .N 1>
 330                              <SET ALL-CONST
 331                                   <APPLY <NODE-SUBR .NOD> .ALL-CONST>>)>
 332                       <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
 333                       <PUT .NOD ,RESULT-TYPE <SET TY <TYPE .ALL-CONST>>>
 334                       <PUT .NOD ,NODE-NAME .ALL-CONST>
 335                       <PUT .NOD ,KIDS ()>
 336                       <SET ALL-CONST T>)
 337                      (<AND <==? .N 2>
 338                            <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 339                                     <OR <==? <NODE-NAME <1 .K>> 0>
 340                                         <==? <NODE-NAME <1 .K>> 0.0>>
 341                                     <SET TEM <2 .K>>
 342                                     <PUT .NOD
 343                                          ,NODE-NAME
 344                                          <FLOPP <NODE-NAME .NOD>>>>
 345                                <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 346                                     <OR <==? <NODE-NAME <2 .K>> 0>
 347                                         <==? <NODE-NAME <2 .K>> 0.0>>
 348                                     <SET TEM <1 .K>>>>>
 349                       <PUT .NOD ,NODE-TYPE ,0-TST-CODE>
 350                       <PUT .NOD ,KIDS (.TEM)>)
 351                      (<==? <NODE-TYPE .NOD> ,0-TST-CODE>)
 352                      (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-NAME .NOD> N0?>>
 353                       <PUT .NOD ,NODE-TYPE ,0-TST-CODE>)
 354                      (<L? .STATE 5>
 355                       <PUT .NOD
 356                            ,NODE-TYPE
 357                            <COND (<==? .N 2> ,TEST-CODE)
 358                                  (<==? <NODE-NAME .NOD> 0?> ,0-TST-CODE)
 359                                  (ELSE ,1?-CODE)>>)
 360                      (<==? <NODE-SUBR .NOD> ,1?>
 361                       <PUT .NOD ,NODE-TYPE ,1?-CODE>)
 362                      (<OR <==? <NODE-SUBR .NOD> ,==?>
 363                           <==? <NODE-SUBR .NOD> ,N==?>>
 364                       <PUT .NOD ,NODE-TYPE ,EQ-CODE>)
 365                      (ELSE
 366                       <SET TY '<OR ATOM FALSE>>
 367                       <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
 368                <COND (<AND <==? .STATE 2> <NOT .ALL-CONST>>
 369                       <HACK-BOUNDS .WHO .GLE .NOD .K>)>
 370                <CHECK-FOR-BIT-HACK .NOD>)>
 371         <TYPE-OK? .TY .RTYP>>
 372
 373 <DEFINE CHECK-FOR-BIT-HACK (N) <>>
 374
 375 '<DEFINE CHECK-FOR-BIT-HACK (N "AUX" (NN <1 <KIDS .N>>) DATA CONST K)
 376          #DECL ((NN DATA N) NODE (CONST) <PRIMTYPE WORD>)
 377          <COND (<AND <==? <NODE-TYPE .N> ,0-TST-CODE>
 378                      <==? <NODE-TYPE .NN> ,CHTYPE-CODE>
 379                      <SET NN <1 <KIDS .NN>>>
 380                      <OR <AND <==? <NODE-TYPE .NN> ,GETBITS-CODE>
 381                               <SET K <KIDS .NN>>
 382                               <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 383                               <SET DATA <1 .K>>
 384                               <SET CONST <PUTBITS 0 <NODE-NAME <2 .K>> -1>>>
 385                          <AND <==? <NODE-TYPE .NN> ,BITL-CODE>
 386                               <==? <NODE-SUBR .NN> ,ANDB>
 387                               <==? <LENGTH <SET K <KIDS .NN>>> 2>
 388                               <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 389                                        <SET CONST <NODE-NAME <1 .K>>>
 390                                        <SET DATA <2 .K>>>
 391                                   <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 392                                        <SET CONST <NODE-NAME <2 .K>>>
 393                                        <SET DATA <1 .K>>>
 394                                   <SET CONST 0>>>>>
 395                 <PUT .N ,NODE-TYPE ,BIT-TEST-CODE>
 396                 <PUT .N ,NODE-SUBR .CONST>
 397                 <PUT .N ,KIDS <COND (<ASSIGNED? DATA> (.DATA)) (ELSE .K)>>
 398                 <COND (<ASSIGNED? DATA> <PUT .DATA ,PARENT .N>)
 399                       (ELSE
 400                        <PUT <1 .K> ,PARENT .N>
 401                        <PUT <2 .K> ,PARENT .N>)>)>>
 402
 403 <DEFINE BIT-TEST-ANA (N R "AUX" (K <KIDS .N>))
 404         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 405         <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>
 406         <COND (<NOT <EMPTY? <SET K <REST .K>>>>
 407                <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>)>
 408         <TYPE-OK? <RESULT-TYPE .N> .R>>
 409
 410 <DEFINE HACK-BOUNDS (WHO GLE NOD K "AUX" NUM YES NO NOD2 (HACKT <>) DC)
 411    #DECL ((WHO GLE) LIST (NOD NOD2) NODE (K) <LIST [REST NODE]>
 412           (NUM) <OR FALSE FIX>)
 413    <SET NUM
 414         <COND (<OR <==? <NODE-NAME .NOD> 0?>
 415                    <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
 416                <SET NOD2 <1 .K>>
 417                0)
 418               (<==? <NODE-NAME .NOD> 1?> <SET NOD2 <1 .K>> 1)
 419               (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 420                <SET NOD2 <2 .K>>
 421                <NODE-NAME <1 .K>>)
 422               (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 423                <SET NOD2 <1 .K>>
 424                <PUT .NOD ,NODE-NAME <FLOPP <NODE-NAME .NOD>>>
 425                <PUT .NOD ,KIDS (<2 .K> <1 .K>)>
 426                <NODE-NAME <2 .K>>)>>
 427    <COND (.NUM
 428           <SET YES <FORM FIX <GTV .NOD .NUM>>>
 429           <SET NO <FORM FIX <NGTV .NOD .NUM>>>
 430           <MAPF <>
 431                 <FUNCTION (L "AUX" (SYM <2 .L>))
 432                         #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
 433                         <SET TRUTH
 434                              <ADD-TYPE-LIST .SYM .YES .TRUTH <> <REST .L 2>>>
 435                         <SET UNTRUTH
 436                              <ADD-TYPE-LIST .SYM .NO .UNTRUTH <> <REST .L 2>>>>
 437                 .WHO>)>
 438    <COND (<AND .NUM <G=? .NUM 0>>
 439           <COND (<OR <AND <NOT <0? .NUM>>
 440                           <OR <==? <NODE-NAME .NOD> G=?>
 441                               <==? <NODE-NAME .NOD> L?>>>
 442                      <AND <0? .NUM>
 443                           <OR <AND <==? <NODE-NAME .NOD> G?> <SET HACKT T>>
 444                               <==? <NODE-NAME .NOD> L=?>>>>
 445                  <SET NUM <+ .NUM 1>>)>
 446           <OR .HACKT <SET HACKT <MEMQ <NODE-NAME .NOD> '[1? L? L=? ==?]>>>
 447           <COND (<==? <NODE-NAME .NOD> 0?> <SET NUM 1>)>
 448           <COND (<L=? .NUM 0> <SET DC STRUCTURED>)
 449                 (ELSE <SET DC <CHTYPE (STRUCTURED !<ANY-PAT .NUM>) FORM>>)>
 450           <MAPF <>
 451                 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
 452                         #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
 453                         <COND (.HACKT
 454                                <SET TRUTH
 455                                     <ADD-TYPE-LIST .SYM
 456                                                    .DC
 457                                                    .TRUTH
 458                                                    <>
 459                                                    <REST .L 2>>>)
 460                               (ELSE
 461                                <SET UNTRUTH
 462                                     <ADD-TYPE-LIST .SYM
 463                                                    .DC
 464                                                    .UNTRUTH
 465                                                    <>
 466                                                    <REST .L 2>>>)>
 467                         T>
 468                 .GLE>)>>
 469
 470 <SETG APSUBTAB [1? 0? L? L=? G? G=? ==? N==?]>
 471
 472 <GDECL (APSUBTAB) <VECTOR [REST ATOM]>>
 473
 474 <SETG DCLTAB
 475       [(1 1)
 476        (0 0)
 477        ('<COND (<==? .VAL ,PLUSINF> .VAL) (ELSE <+ .VAL 1>)> ,PLUSINF)
 478        ('.VAL ,PLUSINF)
 479        (,MINUSINF '<COND (<==? .VAL ,MINUSINF> .VAL) (ELSE <- .VAL 1>)>)
 480        (,MINUSINF '.VAL)
 481        ('.VAL '.VAL)
 482        (,MINUSINF
 483         '<COND (<==? .VAL ,MINUSINF> .VAL) (ELSE <- .VAL 1>)>
 484         '<COND (<==? .VAL ,PLUSINF> .VAL) (ELSE <+ .VAL 1>)>
 485         ,PLUSINF)]>
 486
 487 <SETG NDCLTAB
 488       [(,MINUSINF 0 2 ,PLUSINF)
 489        (,MINUSINF -1 1 ,PLUSINF)
 490        (,MINUSINF '.VAL)
 491        (,MINUSINF '<COND (<==? .VAL ,MINUSINF> .VAL) (ELSE <- .VAL 1>)>)
 492        ('.VAL ,PLUSINF)
 493        ('<COND (<==? .VAL ,PLUSINF> .VAL) (ELSE <+ .VAL 1>)> ,PLUSINF)
 494        (,MINUSINF
 495         '<COND (<==? .VAL ,MINUSINF> .VAL) (ELSE <- .VAL 1>)>
 496         '<COND (<==? .VAL ,PLUSINF> .VAL) (ELSE <+ .VAL 1>)>
 497         ,PLUSINF)
 498        ('.VAL '.VAL)]>
 499
 500 <GDECL (DCLTAB NDCLTAB) VECTOR>
 501
 502 <DEFINE NGTV (NOD VAL)
 503         #DECL ((VAL) <SPECIAL ANY> (NOD) NODE)
 504         <EVAL <NTH ,NDCLTAB
 505                    <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
 506
 507 <DEFINE GTV (NOD VAL)
 508         #DECL ((NOD) NODE (VAL) <SPECIAL ANY>)
 509         <EVAL <NTH ,DCLTAB
 510                    <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
 511
 512 <DEFINE FLOPP (SUBR)
 513         #DECL ((SUBR VALUE) ATOM)
 514         <1 <REST <MEMQ .SUBR '[G? L? G? G=? L=? G=? ==? ==? N==? N==?]>>>>
 515
 516 <COND (<GASSIGNED? ARITH-ANA>
 517        <PUTPROP ,+ ANALYSIS ,ARITH-ANA>
 518        <PUTPROP ,- ANALYSIS ,ARITH-ANA>
 519        <PUTPROP ,* ANALYSIS ,ARITH-ANA>
 520        <PUTPROP ,/ ANALYSIS ,ARITH-ANA>
 521        <PUTPROP ,MAX ANALYSIS ,ARITH-ANA>
 522        <PUTPROP ,MIN ANALYSIS ,ARITH-ANA>
 523        <PUTPROP ,0? ANALYSIS ,ARITHP-ANA>
 524        <PUTPROP ,1? ANALYSIS ,ARITHP-ANA>
 525        <PUTPROP ,L? ANALYSIS ,ARITHP-ANA>
 526        <PUTPROP ,G? ANALYSIS ,ARITHP-ANA>
 527        <PUTPROP ,G=? ANALYSIS ,ARITHP-ANA>
 528        <PUTPROP ,L=? ANALYSIS ,ARITHP-ANA>)>
 529
 530 <ENDPACKAGE>