<mdl.comp>/carana.mud.337

   1 <PACKAGE "CARANA">
   2
   3 <ENTRY ARITH-ANA MOD-ANA ABS-ANA ROT-ANA LSH-ANA FIX-ANA FLOAT-ANA ARITHP-ANA
   4         HACK-BOUNDS BIT-TEST-ANA>
   5
   6 <USE "SYMANA" "CHKDCL" "COMPDEC" "ADVMESS">
   7
   8 "       This file contains analyzers and code generators for arithmetic
   9  SUBRs and predicates.  For convenience many of the SUBRs that are
  10 similar are combined into one analyzer/generator.  For more info
  11 on analyzers see SYMANA and on generators see CODGEN.
  12 "
  13
  14 <SETG ASTATE ![![2 3 5!] ![2 4 5!] ![4 3 5!] ![4 4 5!] ![5 5 5!]!]>
  15
  16 "       Analyze +,-,* and /.  Take care of no arg and one arg problems."
  17
  18 <DEFINE ARITH-ANA (NOD RTYP
  19                    "AUX" (NN <NODE-NAME .NOD>) (DEFLT <GET-DF .NN>) (STATE 1)
  20                          (K <KIDS .NOD>) (FIXDIV <>) RT)
  21    #DECL ((NOD) <SPECIAL NODE> (K) <LIST [REST NODE]> (STYP) FIX
  22           (STATE) <SPECIAL FIX> (DEFLT) <OR FIX FLOAT>)
  23    <SET RT <COND (<NOT <TYPE-OK? .RTYP FLOAT>> FIX) (ELSE '<OR FIX FLOAT>)>>
  24    <COND
  25     (<EMPTY? .K>
  26      <PUT .NOD ,NODE-TYPE ,QUOTE-CODE>
  27      <PUT .NOD ,RESULT-TYPE <TYPE .DEFLT>>
  28      <PUT .NOD ,NODE-NAME .DEFLT>
  29      <PUT .NOD ,KIDS ()>
  30      <TYPE-OK? <TYPE .DEFLT> .RTYP>)
  31     (<AND <EMPTY? <REST .K>>
  32           <N==? <NODE-TYPE <1 .K>> ,SEGMENT-CODE>
  33           <N==? <NODE-TYPE <1 .K>> ,SEG-CODE>
  34           <COND (<==? <NODE-SUBR .NOD> ,/>
  35                  <SET FIXDIV T>
  36                  <PUT .NOD
  37                       ,KIDS
  38                       <SET K
  39                            (<NODE1 ,QUOTE-CODE .NOD <TYPE .DEFLT> .DEFLT ()>
  40                             !.K)>>
  41                  <>)
  42                 (ELSE T)>>
  43      <COND (<==? <NODE-SUBR .NOD> ,-> <PUT .NOD ,NODE-TYPE ,ABS-CODE>
  44                                           ;"Treat like a call
  45                                                          to ABS.")
  46            (ELSE <PUT .NOD ,NODE-TYPE ,ID-CODE>)>
  47      <EANA <1 .K> .RT <NODE-NAME .NOD>>)
  48     (ELSE
  49      <MAPF <> <FUNCTION (N) <ARITH-ELE .N .RT>> .K>
  50      <COND (<L? .STATE 5>
  51             <COND (<AND .FIXDIV <N==? .STATE 2>>
  52                    <PUT <PUT <1 .K> ,NODE-NAME 1.0> ,RESULT-TYPE FLOAT>)>
  53             <PUT .NOD
  54                  ,NODE-TYPE
  55                  <COND (<OR <==? .NN MAX> <==? .NN MIN>> ,MIN-MAX-CODE)
  56                        (ELSE ,ARITH-CODE)>>
  57             <MAPF <>
  58                   <FUNCTION (NN)
  59                           #DECL ((NN) NODE)
  60                           <COND (<==? <NODE-TYPE .NN> ,SEGMENT-CODE>
  61                                  <PUT .NN ,NODE-TYPE ,SEG-CODE>)>>
  62                   .K>)
  63            (ELSE
  64             <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>
  65             <PUT .NOD
  66                  ,STACKS
  67                  <* <MAPF ,+
  68                           <FUNCTION (N "AUX" (CD <NODE-TYPE .N>))
  69                                   #DECL ((N) NODE (CD) FIX)
  70                                   <COND (<OR <==? .CD ,SEGMENT-CODE>
  71                                              <==? .CD ,SEG-CODE>>
  72                                          <PUT .NOD ,SEGS T>
  73                                          <PUT .N ,NODE-TYPE ,SEGMENT-CODE>
  74                                          <MAPRET>)
  75                                         (ELSE 1)>>
  76                           .K>
  77                     2>>)>
  78      <TYPE-OK? <NTH '[FIX FLOAT FLOAT <OR FIX FLOAT>] <- .STATE 1>> .RTYP>)>>
  79
  80 <DEFINE GET-DF (S)
  81         #DECL ((S) ATOM)
  82         <NTH '[0 0 1 1 1.7014117E+38 -1.7014117E+38]
  83              <LENGTH <MEMQ .S '![MAX MIN * / - +!]>>>>
  84
  85 <DEFINE ARITH-ELE (N RT "AUX" TT TEM (FL <>))
  86         #DECL ((N NOD) NODE (STATE TT) FIX)
  87         <COND (<OR <==? <NODE-TYPE .N> ,SEGMENT-CODE>
  88                    <==? <NODE-TYPE .N> ,SEG-CODE>>
  89                <SET FL T>
  90                <SET TEM
  91                     <EANA <1 <KIDS .N>>
  92                           <FORM STRUCTURED [REST .RT]>
  93                           <NODE-NAME .NOD>>>
  94                <PUT .N ,RESULT-TYPE <RESULT-TYPE <1 <KIDS .N>>>>
  95                <SET TEM <OR <AND <ISTYPE? .TEM> <GET-ELE-TYPE .TEM ALL>> ANY>>)
  96               (ELSE
  97                <SET TEM <EANA .N .RT <NODE-NAME .NOD>>>
  98                <AND <==? <NODE-TYPE .N> ,QUOTE-CODE>
  99                     <OR <==? .STATE 4> <==? .STATE 3>>
 100                     <PUT .N ,NODE-NAME <FLOAT <NODE-NAME .N>>>
 101                     <PUT .N ,RESULT-TYPE FLOAT>>)>
 102         <SET TT
 103              <COND (<==? <ISTYPE? .TEM> FIX> 1)
 104                    (<==? .TEM FLOAT> 2)
 105                    (<NOT <TYPE-OK? .TEM FLOAT>>
 106                     <PUT .N
 107                          ,RESULT-TYPE
 108                          <COND (.FL
 109                                 <TYPE-MERGE '<STRUCTURED [REST FIX]>
 110                                             <RESULT-TYPE .N>>)
 111                                (ELSE FIX)>>
 112                     1)
 113                    (<NOT <TYPE-OK? .TEM FIX>>
 114                     <PUT .N
 115                          ,RESULT-TYPE
 116                          <COND (.FL
 117                                 <TYPE-MERGE '<STRUCTURED [REST FLOAT]>
 118                                             <RESULT-TYPE .N>>)
 119                                (ELSE FLOAT)>>
 120                     2)
 121                    (ELSE 3)>>
 122         <COND (<AND .VERBOSE <==? .TT 3>>
 123                <ADDVMESS <PARENT .N>
 124                          ("Arithmetic can't open compile because:  " .N
 125                           " is of type:  " .TEM)>)>
 126         <SET STATE <NTH <NTH ,ASTATE .STATE> .TT>>>
 127
 128 <DEFINE ABS-ANA (N RT "AUX" (K <KIDS .N>) TEM)
 129         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 130         <COND (<SEGFLUSH .N .RT>)
 131               (ELSE
 132                <ARGCHK <LENGTH .K> 1 ABS>
 133                <PUT .N ,NODE-TYPE ,ABS-CODE>
 134                <SET TEM <EANA <1 .K> '<OR FIX FLOAT> ABS>>
 135                <TYPE-OK? <TYPE-OK? '<OR FLOAT <FIX (0 34359738367)>> .RT>
 136                          .TEM>)>>
 137
 138 <PUT ,ABS ANALYSIS ,ABS-ANA>
 139
 140 <DEFINE MOD-ANA (N R "AUX" (K <KIDS .N>))
 141         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 142         <COND (<SEGFLUSH .N .R>)
 143               (ELSE
 144                <ARGCHK <LENGTH .K> 2 MOD>
 145                <EANA <1 .K> FIX MOD>
 146                <EANA <2 .K> FIX MOD>
 147                <PUT .N ,NODE-TYPE ,MOD-CODE>)>
 148         <TYPE-OK? <COND (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 149                          <FORM FIX (0 <- <NODE-NAME <2 .K>> 1>)>)
 150                         (ELSE FIX)> .R>>
 151
 152 <PUT ,MOD ANALYSIS ,MOD-ANA>
 153
 154 <DEFINE ROT-LSH-ANA (N R COD "AUX" (K <KIDS .N>) (NAM <NODE-NAME .N>))
 155         <COND (<SEGFLUSH .N .R>)
 156               (ELSE
 157                <ARGCHK <LENGTH .K> 2 .NAM>
 158                <EANA <1 .K> '<PRIMTYPE WORD> .NAM>
 159                <EANA <2 .K> FIX .NAM>
 160                <PUT .N ,NODE-TYPE .COD>)>
 161         <TYPE-OK? WORD .R>>
 162
 163 <DEFINE ROT-ANA (N R) <ROT-LSH-ANA .N .R ,ROT-CODE>>
 164
 165 <DEFINE LSH-ANA (N R) <ROT-LSH-ANA .N .R ,LSH-CODE>>
 166
 167 <PUT ,ROT ANALYSIS ,ROT-ANA>
 168
 169 <PUT ,LSH ANALYSIS ,LSH-ANA>
 170
 171 <DEFINE FLOAT-ANA (N R)
 172         #DECL ((N) NODE)
 173         <FL-FI-ANA .N .R FLOAT FIX ,FLOAT-CODE>>
 174
 175 <PUT ,FLOAT ANALYSIS ,FLOAT-ANA>
 176
 177 <DEFINE FIX-ANA (N R) #DECL ((N) NODE) <FL-FI-ANA .N .R FIX FLOAT ,FIX-CODE>>
 178
 179 <PUT ,FIX ANALYSIS ,FIX-ANA>
 180
 181 <DEFINE FL-FI-ANA (N RT OT IT COD "AUX" (K <KIDS .N>) TY NUM)
 182         #DECL ((N NUM) NODE (OT IT) ATOM (K) <LIST [REST NODE]> (COD) FIX)
 183         <COND (<SEGFLUSH .N .RT>)
 184               (ELSE
 185                <ARGCHK <LENGTH .K> 1 .OT>
 186                <SET TY <EANA <SET NUM <1 .K>> '<OR FIX FLOAT> .OT>>
 187                <COND (<==? <NODE-TYPE .NUM> ,QUOTE-CODE>
 188                       <PUT .N ,NODE-TYPE ,QUOTE-CODE>
 189                       <PUT .N ,NODE-NAME <APPLY ,.OT <NODE-NAME .NUM>>>)
 190                      (ELSE
 191                       <PUT .N ,NODE-TYPE .COD>)>)>
 192         <TYPE-OK? .OT .RT>>
 193
 194 <DEFINE ARITHP-ANA (NOD RTYP
 195                     "AUX" (WHON <AND <==? .PRED <PARENT .NOD>> .NOD>) (WHO ())
 196                           (GLN .NOD) (GLE ()) (NN <NODE-NAME .NOD>)
 197                           (N
 198                            <COND (<OR <==? .NN 0?>
 199                                       <==? .NN 1?>
 200                                       <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
 201                                   1)
 202                                  (ELSE 2)>) (K <KIDS .NOD>) TEM (STATE 1))
 203         #DECL ((WHO) <SPECIAL LIST> (WHON GLN) <SPECIAL ANY>
 204                (NOD NOD2) <SPECIAL NODE> (TEM) NODE (K) <LIST [REST NODE]>
 205                (STATE) <SPECIAL FIX> (COD N) FIX (GLE) <SPECIAL LIST>)
 206         <COND (<SEGFLUSH .NOD .RTYP>)
 207               (ELSE
 208                <ARGCHK <LENGTH .K> .N <NODE-NAME .NOD>>
 209                <MAPF <> <FUNCTION (N) <ARITH-ELE .N '<OR FIX FLOAT>>> .K>
 210                <COND (<AND <==? .N 2>
 211                            <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 212                                     <0? <NODE-NAME <1 .K>>>
 213                                     <SET TEM <2 .K>>
 214                                     <PUT .NOD
 215                                          ,NODE-NAME
 216                                          <FLOPP <NODE-NAME .NOD>>>>
 217                                <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 218                                     <0? <NODE-NAME <2 .K>>>
 219                                     <SET TEM <1 .K>>>>>
 220                       <PUT .NOD ,NODE-TYPE ,0-TST-CODE>
 221                       <PUT .NOD ,KIDS (.TEM)>)
 222                      (<==? <NODE-TYPE .NOD> ,0-TST-CODE>)
 223                      (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-NAME .NOD> N0?>>
 224                       <PUT .NOD ,NODE-TYPE ,0-TST-CODE>)
 225                      (<L? .STATE 5>
 226                       <PUT .NOD
 227                            ,NODE-TYPE
 228                            <COND (<==? .N 2> ,TEST-CODE)
 229                                  (<==? <NODE-NAME .NOD> 0?> ,0-TST-CODE)
 230                                  (ELSE ,1?-CODE)>>)
 231                      (<==? <NODE-SUBR .NOD> ,1?> <PUT .NOD ,NODE-TYPE ,1?-CODE>)
 232                      (<OR <==? <NODE-SUBR .NOD> ,==?>
 233                           <==? <NODE-SUBR .NOD> ,N==?>>
 234                       <PUT .NOD ,NODE-TYPE ,EQ-CODE>)
 235                      (ELSE <PUT .NOD ,NODE-TYPE ,ISUBR-CODE>)>
 236                <COND (<==? .STATE 2> <HACK-BOUNDS .WHO .GLE .NOD .K>)>
 237                <CHECK-FOR-BIT-HACK .NOD>)>
 238         <TYPE-OK? '<OR FALSE ATOM> .RTYP>>
 239
 240 <DEFINE CHECK-FOR-BIT-HACK (N "AUX" (NN <1 <KIDS .N>>) DATA CONST K)
 241         #DECL ((NN DATA N) NODE (CONST) <PRIMTYPE WORD>)
 242         <COND (<AND <==? <NODE-TYPE .N> ,0-TST-CODE>
 243                     <==? <NODE-TYPE .NN> ,CHTYPE-CODE>
 244                     <SET NN <1 <KIDS .NN>>>
 245                     <OR <AND <==? <NODE-TYPE .NN> ,GETBITS-CODE>
 246                              <SET K <KIDS .NN>>
 247                              <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 248                              <SET DATA <1 .K>>
 249                              <SET CONST <PUTBITS 0 <NODE-NAME <2 .K>> -1>>>
 250                         <AND <==? <NODE-TYPE .NN> ,BITL-CODE>
 251                              <==? <NODE-SUBR .NN> ,ANDB>
 252                              <==? <LENGTH <SET K <KIDS .NN>>> 2>
 253                              <OR <AND <==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 254                                       <SET CONST <NODE-NAME <1 .K>>>
 255                                       <SET DATA <2 .K>>>
 256                                  <AND <==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 257                                       <SET CONST <NODE-NAME <2 .K>>>
 258                                       <SET DATA <1 .K>>>
 259                                  <SET CONST 0>>>>>
 260                <PUT .N ,NODE-TYPE ,BIT-TEST-CODE>
 261                <PUT .N ,NODE-SUBR .CONST>
 262                <PUT .N ,KIDS <COND (<ASSIGNED? DATA> (.DATA)) (ELSE .K)>>
 263                <COND (<ASSIGNED? DATA> <PUT .DATA ,PARENT .N>)
 264                      (ELSE
 265                       <PUT <1 .K> ,PARENT .N>
 266                       <PUT <2 .K> ,PARENT .N>)>)>>
 267
 268 <DEFINE BIT-TEST-ANA (N R "AUX" (K <KIDS .N>))
 269         #DECL ((N) NODE (K) <LIST [REST NODE]>)
 270         <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>
 271         <COND (<NOT <EMPTY? <SET K <REST .K>>>>
 272                <EANA <1 .K> '<PRIMTYPE WORD> BIT-TEST>)>
 273         <TYPE-OK? <RESULT-TYPE .N> .R>>
 274
 275 <DEFINE HACK-BOUNDS (WHO GLE NOD K "AUX" NUM YES NO NOD2 (HACKT <>))
 276    #DECL ((WHO GLE) LIST (NOD NOD2) NODE (K) <LIST [REST NODE]>)
 277    <SET NUM
 278         <COND (<OR <==? <NODE-NAME .NOD> 0?> <==? <NODE-TYPE .NOD> ,0-TST-CODE>>
 279                <SET NOD2 <1 .K>>
 280                0)
 281               (<==? <NODE-NAME .NOD> 1?> <SET NOD2 <1 .K>> 1)
 282               (<==? <NODE-TYPE <1 .K>> ,QUOTE-CODE>
 283                <SET NOD2 <2 .K>>
 284                <NODE-NAME <1 .K>>)
 285               (<==? <NODE-TYPE <2 .K>> ,QUOTE-CODE>
 286                <SET NOD2 <1 .K>>
 287                <PUT .NOD ,NODE-NAME <FLOPP <NODE-NAME .NOD>>>
 288                <PUT .NOD ,KIDS (<2 .K> <1 .K>)>
 289                <NODE-NAME <2 .K>>)>>
 290    <COND (.NUM
 291           <SET YES <FORM FIX <GTV .NOD .NUM>>>
 292           <SET NO <FORM FIX <NGTV .NOD .NUM>>>
 293           <MAPF <>
 294                 <FUNCTION (L "AUX" (SYM <2 .L>))
 295                         #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
 296                         <SET TRUTH
 297                              <ADD-TYPE-LIST .SYM .YES .TRUTH <> <REST .L 2>>>
 298                         <SET UNTRUTH
 299                              <ADD-TYPE-LIST .SYM .NO .UNTRUTH <> <REST .L 2>>>>
 300                 .WHO>)>
 301    <COND (<AND .NUM <G=? .NUM 0>>
 302           <COND (<OR <AND <NOT <0? .NUM>>
 303                           <OR <==? <NODE-NAME .NOD> G=?>
 304                               <==? <NODE-NAME .NOD> L?>>>
 305                      <AND <0? .NUM>
 306                           <OR <AND <==? <NODE-NAME .NOD> G?> <SET HACKT T>>
 307                               <==? <NODE-NAME .NOD> L=?>>>>
 308                  <SET NUM <+ .NUM 1>>)>
 309           <OR .HACKT <SET HACKT <MEMQ <NODE-NAME .NOD> '![1? L? L=? ==?!]>>>
 310           <COND (<==? <NODE-NAME .NOD> 0?> <SET NUM 1>)>
 311           <COND (<L=? .NUM 0> STRUCTURED)
 312                 (ELSE <SET NUM <CHTYPE (STRUCTURED !<ANY-PAT .NUM>) FORM>>)>
 313           <MAPF <>
 314                 <FUNCTION (L "AUX" (SYM <2 .L>) (FLG <1 .L>))
 315                         #DECL ((L) <LIST ANY SYMTAB> (SYM) SYMTAB)
 316                         <COND (.HACKT
 317                                <SET TRUTH
 318                                     <ADD-TYPE-LIST .SYM
 319                                                    .NUM
 320                                                    .TRUTH
 321                                                    <>
 322                                                    <REST .L 2>>>)
 323                               (ELSE
 324                                <SET UNTRUTH
 325                                     <ADD-TYPE-LIST .SYM
 326                                                    .NUM
 327                                                    .UNTRUTH
 328                                                    <>
 329                                                    <REST .L 2>>>)>
 330                         T>
 331                 .GLE>)>>
 332
 333 <SETG APSUBTAB [1? 0? L? L=? G? G=? ==? N==?]>
 334
 335 <SETG DCLTAB
 336       [(1 1)
 337        (0 0)
 338        ('<+ .VAL 1> ,PLUSINF)
 339        ('.VAL ,PLUSINF)
 340        (,MINUSINF '<- .VAL 1>)
 341        (,MINUSINF '.VAL)
 342        ('.VAL '.VAL)
 343        (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)]>
 344
 345 <SETG NDCLTAB
 346       [(,MINUSINF 0 2 ,PLUSINF)
 347        (,MINUSINF -1 1 ,PLUSINF)
 348        (,MINUSINF '.VAL)
 349        (,MINUSINF '<- .VAL 1>)
 350        ('.VAL ,PLUSINF)
 351        ('<+ .VAL 1> ,PLUSINF)
 352        (,MINUSINF '<- .VAL 1> '<+ .VAL 1> ,PLUSINF)
 353        ('.VAL '.VAL)]>
 354
 355 <DEFINE NGTV (NOD VAL)
 356         #DECL ((VAL) <SPECIAL ANY> (NOD) NODE)
 357         <EVAL <NTH ,NDCLTAB
 358                    <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
 359
 360 <DEFINE GTV (NOD VAL)
 361         #DECL ((NOD) NODE (VAL) <SPECIAL ANY>)
 362         <EVAL <NTH ,DCLTAB
 363                    <- 9 <LENGTH <MEMQ <NODE-NAME .NOD> ,APSUBTAB>>>>>>
 364
 365 <DEFINE FLOPP (SUBR)
 366         #DECL ((SUBR VALUE) ATOM)
 367         <1 <REST <MEMQ .SUBR '![G? L? G? G=? L=? G=? ==? ==? N==? N==?!]>>>>
 368
 369 <PUT ,+ ANALYSIS ,ARITH-ANA>
 370
 371 <PUT ,- ANALYSIS ,ARITH-ANA>
 372
 373 <PUT ,* ANALYSIS ,ARITH-ANA>
 374
 375 <PUT ,/ ANALYSIS ,ARITH-ANA>
 376
 377 <PUT ,MAX ANALYSIS ,ARITH-ANA>
 378
 379 <PUT ,MIN ANALYSIS ,ARITH-ANA>
 380
 381 <PUT ,0? ANALYSIS ,ARITHP-ANA>
 382
 383 <PUT ,1? ANALYSIS ,ARITHP-ANA>
 384
 385 <PUT ,L? ANALYSIS ,ARITHP-ANA>
 386
 387 <PUT ,G? ANALYSIS ,ARITHP-ANA>
 388
 389 <PUT ,G=? ANALYSIS ,ARITHP-ANA>
 390
 391 <PUT ,L=? ANALYSIS ,ARITHP-ANA>
 392
 393 <ENDPACKAGE>\ 3\ 3\ 3\ 3