<mdl.comp>/case.mud.59

   1 <PACKAGE "CASE">
   2
   3 <ENTRY CASE-FCN CASE-GEN>
   4
   5 <USE "PASS1" "CODGEN" "CHKDCL" "CACS" "COMPDEC" "COMCOD">
   6
   7 <SETG PMAX ,NUMPRI!-MUDDLE>
   8
   9 <SETG MAX-DENSE 2>
  10
  11 <NEWTYPE OR LIST>
  12
  13 <FLOAD "PRCOD.NBIN">
  14
  15 <DEFINE CASE-FCN (OBJ AP
  16                   "AUX" (OP!-PACKAGE .PARENT) (PARENT .PARENT) (FLG T) (WIN T)
  17                         TYP (DF <>) P TEM X)
  18    #DECL ((PARENT) <SPECIAL NODE> (OBJ) <FORM ANY> (VALUE) NODE)
  19    <COND
  20     (<AND
  21       <G? <LENGTH .OBJ> 3>
  22       <PROG ()
  23             <COND (<AND <TYPE? <SET X <2 .OBJ>> FORM>
  24                         <==? <LENGTH .X> 2>
  25                         <==? <1 .X> GVAL>
  26                         <MEMQ <SET P <2 .X>> '![==? TYPE? PRIMTYPE?!]>>)
  27                   (ELSE <SET WIN <>>)>
  28             1>
  29       <MAPF <>
  30        <FUNCTION (O)
  31           <COND
  32            (<AND .FLG <==? .O DEFAULT>> <SET DF T>)
  33            (<AND .DF <TYPE? .O LIST>> <SET DF <>> <SET FLG <>>)
  34            (<AND <NOT .DF> <TYPE? .O LIST> <NOT <EMPTY? .O>>>
  35             <COND
  36              (<SET TEM <VAL-CHK <1 .O>>>
  37               <COND (<ASSIGNED? TYP> <OR <==? .TYP <TYPE .TEM>> <SET WIN <>>>)
  38                     (ELSE <SET TYP <TYPE .TEM>>)>)
  39              (<OR <TYPE? <SET TEM <1 .O>> OR>
  40                   <AND <N==? .P ==?>
  41                        <TYPE? .TEM SEGMENT>
  42                        <==? <LENGTH .TEM> 2>
  43                        <==? <1 .TEM> QUOTE>
  44                        <NOT <MONAD? <SET TEM <2 .TEM>>>>>>
  45               <MAPF <>
  46                     <FUNCTION (TY)
  47                             <COND (<NOT <SET TY <VAL-CHK .TY>>> <SET WIN <>>)
  48                                   (ELSE
  49                                    <COND (<ASSIGNED? TYP>
  50                                           <OR <==? .TYP <TYPE .TY>>
  51                                               <SET WIN <>>>)
  52                                          (ELSE <SET TYP <TYPE .TY>>)>)>>
  53                     .TEM>)
  54              (ELSE <SET WIN <>>)>)
  55            (ELSE <MAPLEAVE <>>)>
  56           T>
  57        <REST .OBJ 3>>
  58       <NOT .DF>>
  59      <COND (<AND .WIN
  60                  <NOT <OR <AND <==? <TYPEPRIM .TYP> WORD> <==? .P ==?>>
  61                           <AND <N==? .P ==?> <==? .TYP ATOM>>>>>
  62             <SET WIN <>>)>
  63      <COND
  64       (.WIN
  65        <SET PARENT <NODECOND ,CASE-CODE .OP!-PACKAGE <> CASE ()>>
  66        <PUT
  67         .PARENT
  68         ,KIDS
  69         (<PCOMP <2 .OBJ> .PARENT>
  70          <PCOMP <3 .OBJ> .PARENT>
  71          !<MAPF ,LIST
  72            <FUNCTION (CLA "AUX" TT)
  73                    #DECL ((CLA) <OR ATOM LIST> (TT) NODE)
  74                    <COND (.DF <SET CLA (ELSE !.CLA)>)>
  75                    <COND
  76                     (<NOT <TYPE? .CLA ATOM>>
  77                      <PUT <SET TT <NODEB ,BRANCH-CODE .PARENT <> <> ()>>
  78                           ,PREDIC
  79                           <PCOMP <COND (<TYPE? <SET TEM <1 .CLA>> SEGMENT>
  80                                         <FORM QUOTE
  81                                               <MAPF ,LIST ,VAL-CHK <2 .TEM>>>)
  82                                        (<TYPE? .TEM OR>
  83                                         <FORM QUOTE <MAPF ,LIST ,VAL-CHK .TEM>>)
  84                                        (ELSE <VAL-CHK .TEM>)>
  85                                  .TT>>
  86                      <PUT .TT
  87                           ,CLAUSES
  88                           <MAPF ,LIST
  89                                 <FUNCTION (O) <PCOMP .O .TT>>
  90                                 <REST .CLA>>>
  91                      <SET DF <>>
  92                      .TT)
  93                     (ELSE <SET DF T> <PCOMP .CLA .PARENT>)>>
  94            <REST .OBJ 3>>)>)
  95       (ELSE <PMACRO .OBJ .OP!-PACKAGE>)>)
  96     (ELSE <MESSAGE ERROR "BAD CASE USAGE" .OBJ>)>>
  97
  98 <DEFINE VAL-CHK (TEM "AUX" TT)
  99         <OR <AND <OR <TYPE? .TEM ATOM> <==? <PRIMTYPE .TEM> WORD>>
 100                  .TEM>
 101             <AND <TYPE? .TEM FORM>
 102                  <==? <LENGTH .TEM> 2>
 103                  <OR <AND <==? <1 .TEM> QUOTE> <2 .TEM>>
 104                      <AND <==? <1 .TEM> GVAL> <MANIFESTQ <2 .TEM>> ,<2 .TEM>>
 105                      <AND <==? <1 .TEM> ASCII>
 106                           <TYPE? <2 .TEM> CHARACTER FIX>
 107                           <EVAL .TEM>>>>
 108             <AND <TYPE? .TEM FORM>
 109                  <==? <LENGTH .TEM> 3>
 110                  <==? <1 .TEM> CHTYPE>
 111                  <TYPE? <3 .TEM> ATOM>
 112                  <NOT <TYPE? <2 .TEM> FORM LIST VECTOR UVECTOR SEGMENT>>
 113                  <EVAL .TEM>>
 114             <AND <TYPE? .TEM FORM>
 115                  <NOT <EMPTY? .TEM>>
 116                  <TYPE? <SET TT <1 .TEM>> ATOM>
 117                  <GASSIGNED? .TT>
 118                  <TYPE? ,.TT MACRO>
 119                  <VAL-CHK <EMACRO .TEM>>>>>
 120
 121 <DEFINE EMACRO (OBJ "AUX" (ERR <GET ERROR!-INTERRUPTS INTERRUPT>) TEM)
 122         <COND (.ERR <OFF .ERR>)>
 123         <ON "ERROR"
 124             <FUNCTION (FR "TUPLE" T)
 125                     <COND (<AND <GASSIGNED? MACACT> <LEGAL? ,MACACT>>
 126                            <DISMISS [!.T] ,MACACT>)
 127                           (ELSE <APPLY ,<PARSE "OVALRET!-COMBAT!-"> " ">)>>
 128             100>
 129         <COND (<TYPE? <SET TEM
 130                            <PROG MACACT () #DECL ((MACACT) <SPECIAL ACTIVATION>)
 131                                  <SETG MACACT .MACACT>
 132                                  (<EXPAND .OBJ>)>>
 133                       VECTOR>
 134                <OFF "ERROR">
 135                <COND (.ERR <EVENT .ERR>)>
 136                <ERROR " MACRO EXPANSION LOSSAGE " !.TEM>)
 137               (ELSE <OFF "ERROR"> <AND .ERR <EVENT .ERR>> <1 .TEM>)>>
 138
 139
 140
 141 <DEFINE DATFIX (W) <COND (<TYPE? .W DATUM> <DATUM !.W>) (ELSE .W)>>
 142 \f
 143 <DEFINE CASE-GEN (N W
 144                   "AUX" (K <KIDS .N>) (P <NODE-NAME <1 <KIDS <1 .K>>>>)
 145                         (N1 <2 .K>) (SKIP-CH <>) (RW .W) (LNT 0) (DF <>) DN
 146                         (DFT <MAKE:TAG "CASEDF">) MI MX RNGS W1 (TAGS (X))
 147                         (TBL <MAKE:TAG "CASETBL">) (ET <MAKE:TAG "CASEND">) NOW
 148                         DAC TG TT W2 (FIRST T) S1 (S2 ()) TNUM)
 149    #DECL ((N DN N1) NODE (P) ATOM (S1) SAVED-STATE
 150           (S2) <LIST [REST SAVED-STATE]> (RNGS) UVECTOR)
 151    <REGSTO <>>
 152    <SET W
 153         <COND (<==? .W FLUSHED> FLUSHED) (ELSE <GOODACS .N .W>)>>
 154    <PREFER-DATUM .W>
 155    <SET W2
 156         <GEN .N1
 157              <COND (<AND <==? .P ==?> <SET TT <ISTYPE? <RESULT-TYPE .N1>>>>
 158                     <DATUM .TT ANY-AC>)
 159                    (ELSE DONT-CARE)>>>
 160    <SET K
 161         <MAPR ,UVECTOR
 162               <FUNCTION (NP "AUX" (N <1 .NP>))
 163                       #DECL ((N) NODE)
 164                       <COND (<==? <NODE-TYPE .N> ,QUOTE-CODE>
 165                              <SET DF T>
 166                              <MAPRET>)>
 167                       <COND (.DF <SET DN .N> <SET DF <>> <MAPRET>)>
 168                       <COND (<==? <RESULT-TYPE .N> FALSE>
 169                              <MESSAGE NOTE " CASE PHRASE ALWAYS FALSE " .N>
 170                              <MAPRET>)>
 171                       <COND (<AND <==? <RESULT-TYPE .N> ATOM>
 172                                   <NOT <EMPTY? <REST .NP>>>>
 173                              <MESSAGE NOTE
 174                                       " NON REACHABLE CASE CLAUSE(S) "
 175                                       <2 .NP>>
 176                              (.N () FOO))>
 177                       (.N () FOO)>
 178               <REST .K 2>>>
 179    <SET LNT
 180     <LENGTH
 181      <SET RNGS
 182       <MAPF ,UVECTOR
 183        <FUNCTION (L "AUX" (N <1 .L>) (NN <NODE-NAME <PREDIC .N>>))
 184           #DECL ((N) NODE)
 185           <PUT .L 3 <MAKE:TAG "CASE">>
 186           <COND
 187            (<==? .P ==?>
 188             <COND (<TYPE? .NN LIST>
 189                    <MAPR <> <FUNCTION (L) <PUT .L 1 <FIX <1 .L>>>> .NN>)
 190                   (ELSE <SET NN <CHTYPE .NN FIX>>)>)
 191            (<==? .P TYPE?>
 192             <COND (<TYPE? .NN LIST>
 193                    <MAPR <>
 194                          <FUNCTION (L "AUX" TT)
 195                                  <COND (<G? <SET TT <CHTYPE <1 .L> FIX>> ,PMAX>
 196                                         <SET SKIP-CH T>)>
 197                                  <PUT .L 1 .TT>>
 198                          .NN>)
 199                   (ELSE
 200                    <COND (<G? <SET NN <CHTYPE <TYPE-C .NN> FIX>> ,PMAX>
 201                           <SET SKIP-CH T>)>
 202                    .NN)>)
 203            (<TYPE? .NN LIST>
 204             <MAPR <>
 205                   <FUNCTION (L) <PUT .L 1 <CHTYPE <PTYPE-C <1 .L>> FIX>>>
 206                   .NN>)
 207            (ELSE <SET NN <CHTYPE <PTYPE-C .NN> FIX>>)>
 208           <COND (<TYPE? .NN LIST> <PUT .L 2 .NN> <MAPRET !.NN>)
 209                 (ELSE <PUT .L 2 (.NN)> .NN)>>
 210        .K>>>>
 211    <SORT <> .RNGS>
 212    <COND (<L=? .LNT 3> <SET SKIP-CH T>)
 213          (<G? <- <SET MX <NTH .RNGS .LNT>> <SET MI <SET TNUM <1 .RNGS>>>>
 214                   <* .LNT ,MAX-DENSE>>
 215           <SET SKIP-CH T>)>
 216    <MAPF <>
 217          <FUNCTION (NUM)
 218                  <COND (<==? .NUM .TNUM>
 219                         <MESSAGE ERROR " DUPLICATE CASE ENTRY " .N>)>
 220                  <SET TNUM .NUM>>
 221          <REST .RNGS>>
 222    <COND
 223     (<==? .P ==?>
 224      <COND
 225       (<NOT .TT>
 226        <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE `O  !<ADDR:TYPE .W2>>>
 227        <EMIT
 228         <INSTRUCTION
 229          `CAIE
 230          `O
 231          <FORM
 232           TYPE-CODE!-OP!-PACKAGE
 233           <TYPE <COND (<TYPE? <SET TT <NODE-NAME <PREDIC <1 <1 .K>>>>> LIST>
 234                        <1 .TT>)
 235                       (ELSE .TT)>>>>>
 236        <BRANCH:TAG .DFT>)>
 237      <SET W2 <TOACV .W2>>
 238      <SET DAC <DATVAL .W2>>)
 239     (<==? .P TYPE?>
 240      <SET DAC <GETREG <>>>
 241      <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
 242                         <ACSYM .DAC>
 243                         !<ADDR:TYPE .W2>>>)
 244     (ELSE
 245      <SET DAC <GETREG <>>>
 246      <EMIT <INSTRUCTION GETYP!-OP!-PACKAGE
 247                         <ACSYM .DAC>
 248                         !<ADDR:TYPE .W2>>>
 249      <EMIT <INSTRUCTION `ASH  <ACSYM .DAC> 1>>
 250      <EMIT <INSTRUCTION `ADD  <ACSYM .DAC> TYPVEC!-MUDDLE 1 `(TVP) >>
 251      <EMIT <INSTRUCTION `LDB
 252                         <ACSYM .DAC>
 253                         [<FORM (576) (<ADDRSYM .DAC>)>]>>)>
 254    <COND
 255     (<NOT .SKIP-CH>
 256      <MUNG-AC .DAC .W2>
 257      <RET-TMP-AC .W2>
 258      <COND (<0? .MI> <EMIT <INSTRUCTION `JUMPL  <ACSYM .DAC> .DFT>>)
 259            (<==? .MI 1>
 260             <EMIT <INSTRUCTION `JUMPLE  <ACSYM .DAC> .DFT>>)
 261            (ELSE
 262             <IMCHK '(`CAMGE `CAIGE) <ACSYM .DAC> <REFERENCE:ADR .MI>>
 263             <BRANCH:TAG .DFT>)>
 264      <COND (<0? .MX> <EMIT <INSTRUCTION `JUMPG  <ACSYM .DAC> .DFT>>)
 265            (<==? .MX -1>
 266             <EMIT <INSTRUCTION `JUMPGE  <ACSYM .DAC> .DFT>>)
 267            (ELSE
 268             <IMCHK '(`CAMLE `CAILE) <ACSYM .DAC> <REFERENCE:ADR .MX>>
 269             <BRANCH:TAG .DFT>)>
 270      <EMIT <INSTRUCTION `ADD  <ACSYM .DAC> [<INSTRUCTION `SETZ .TBL>]>>
 271      <EMIT <INSTRUCTION `JRST  `@  <- .MI> (<ADDRSYM .DAC>)>>
 272      <LABEL:TAG .DFT>
 273      <SET S1 <SAVE-STATE>>
 274      <COND (<ASSIGNED? DN>
 275             <SET W1 <SEQ-GEN <KIDS .DN> <DATFIX .W>>>
 276             <ACFIX .W .W1>
 277             <COND (<N==? <RESULT-TYPE .DN> NO-RETURN>
 278                    <SET S2 (<SAVE-STATE>)>
 279                    <BRANCH:TAG .ET>)>
 280             <VAR-STORE <>>)
 281            (ELSE
 282             <SET W1 <MOVE:ARG <REFERENCE <>> <DATFIX .W>>>
 283             <ACFIX .W .W1>
 284             <SET S2 (<SAVE-STATE>)>
 285             <VAR-STORE <>>
 286             <BRANCH:TAG .ET>)>
 287      <LABEL:TAG .TBL>
 288      <SET NOW <+ .MI 1>>
 289      <REPEAT ()
 290              <COND (<EMPTY? .RNGS> <RETURN>)>
 291              <COND (<N==? .NOW <+ <1 .RNGS> 1>>
 292                     <SET NOW <+ .NOW 1>>
 293                     <EMIT <INSTRUCTION `SETZ .DFT>>)
 294                    (ELSE
 295                     <EMIT <INSTRUCTION `SETZ <DOTAGS <1 .RNGS> .K>>>
 296                     <SET NOW <+ .NOW 1>>
 297                     <SET RNGS <REST .RNGS>>)>>
 298      <MAPF <>
 299       <FUNCTION (L "AUX" (N <1 .L>) (TG <3 .L>))
 300          <RET-TMP-AC .W1>
 301          <RESTORE-STATE .S1>
 302          <COND (<NOT .FIRST> <OR <==? .W1 ,NO-DATUM> <BRANCH:TAG .ET>>)
 303                (ELSE <SET FIRST <>>)>
 304          <LABEL:TAG .TG>
 305          <COND
 306           (<NOT <EMPTY? <KIDS .N>>>
 307            <SET W1 <SEQ-GEN <KIDS .N> <DATFIX .W>>>)
 308           (ELSE
 309            <SET W1
 310                 <MOVE:ARG
 311                  <REFERENCE <COND (<==? .P ==?> T)
 312                                   (ELSE <NODE-NAME <PREDIC .N>>)>>
 313                  <DATFIX .W>>>)>
 314          <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>
 315          <ACFIX .W .W1>>
 316       .K>)
 317     (ELSE
 318      <RET-TMP-AC .W2>
 319      <SET S1 <SAVE-STATE>>
 320      <REPEAT (L)
 321              <COND (<EMPTY? .K> <RETURN>)>
 322              <DISTAG <2 <SET L <1 .K>>> .DAC <SET TG <3 .L>>>
 323              <COND (<NOT <EMPTY? <KIDS <1 .L>>>>
 324                     <SET W1 <SEQ-GEN <KIDS <1 .L>> <DATFIX .W>>>)
 325                    (ELSE <SET W1 <MOVE:ARG <REFERENCE T> <DATFIX .W>>>)>
 326              <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>
 327              <VAR-STORE <>>
 328              <RESTORE-STATE .S1>
 329              <ACFIX .W .W1>
 330              <OR <==? .W1 ,NO-DATUM> <BRANCH:TAG .ET>>
 331              <LABEL:TAG .TG>
 332              <SET K <REST .K>>
 333              <RET-TMP-AC .W1>>
 334      <COND (<ASSIGNED? DN> <SET W1 <SEQ-GEN <KIDS .DN> <DATFIX .W>>>)
 335            (ELSE <SET W1 <MOVE:ARG <REFERENCE <>> <DATFIX .W>>>)>
 336      <OR <==? .W1 ,NO-DATUM> <SET S2 (<SAVE-STATE> !.S2)>>)>
 337    <COND (<AND <TYPE? .W DATUM> <N==? <RESULT-TYPE .N> NO-RETURN>>
 338           <SET W2 .W>
 339           <AND <ISTYPE? <DATTYP .W2>>
 340                <TYPE? <DATTYP .W1> AC>
 341                <NOT <==? <DATTYP .W2> <DATTYP .W1>>>
 342                <RET-TMP-AC <DATTYP .W1> .W1>>
 343           <AND <TYPE? <DATTYP .W2> AC>
 344                <FIX-ACLINK <DATTYP .W2> .W2 .W1>>
 345           <AND <TYPE? <DATVAL .W2> AC>
 346                <FIX-ACLINK <DATVAL .W2> .W2 .W1>>)>
 347    <MERGE-STATES .S2>
 348    <LABEL:TAG .ET>
 349    <MOVE:ARG .W .RW>>
 350
 351 <DEFINE DOTAGS (N L)
 352         #DECL ((N) FIX (L) <UVECTOR [REST <LIST NODE <LIST [REST FIX]> ATOM>]>)
 353         <MAPF <>
 354               <FUNCTION (LL) <COND (<MEMQ .N <2 .LL>> <MAPLEAVE <3 .LL>>)>>
 355               .L>>
 356
 357 <DEFINE DISTAG (L DAC ATM "AUX" TG)
 358         #DECL ((L) <LIST [REST FIX]> (DAC) AC (ATM) ATOM)
 359         <COND (<G=? <LENGTH .L> 2> <SET TG <MAKE:TAG>>)>
 360         <REPEAT ()
 361                 <COND (<EMPTY? .L>
 362                        <BRANCH:TAG .ATM>
 363                        <AND <ASSIGNED? TG> <LABEL:TAG .TG>>
 364                        <RETURN>)
 365                       (<EMPTY? <REST .L>>
 366                        <IMCHK '(`CAME `CAIE) <ACSYM .DAC> <REFERENCE:ADR <1 .L>>>
 367                        <BRANCH:TAG .ATM>
 368                        <AND <ASSIGNED? TG> <LABEL:TAG .TG>>
 369                        <RETURN>)
 370                       (ELSE
 371                        <IMCHK '(`CAME `CAIE) <ACSYM .DAC> <REFERENCE:ADR <1 .L>>>
 372                        <IMCHK '(`CAMN `CAIN) <ACSYM .DAC> <REFERENCE:ADR <2 .L>>>
 373                        <BRANCH:TAG .TG>)>
 374                 <SET L <REST .L 2>>>>
 375
 376 <DEFINE PTYPE-C (ATM) <PRIM-CODE <TYPE-C .ATM>>>
 377
 378 <ENDPACKAGE>
 379
 380 \f