mim/development/mim/20c/disp20.mud

   1 <DEFINE DISPATCH!-MIMOC (L
   2                          "AUX" (VAR <1 .L>) (BASE <2 .L>) DELBL AC (DF <>)
   3                                (DLBL <GENLBL "DISP">) RLBLS (LL .MIML) NEW AC-T
   4                                TAC (NV <- <LENGTH .L> 2>) (DISP-L ()))
   5         #DECL ((LL MIML L) LIST (BASE NV) FIX (DISP-L) <SPECIAL LIST>)
   6         <SET RLBLS
   7              <MAPF ,LIST
   8                    <FUNCTION (LBL "AUX" LB LBX)
   9                            <COND (<AND <SET LB <FIND-LABEL .LBL>>
  10                                        <LAB-LOOP .LB>>
  11                                   <COND (<NOT <FIND-LABEL
  12                                                <SET LBX <GENLBL "LOOPD">>>>
  13                                          <MAKE-LABEL .LBX <> ()>)>
  14                                   (.LBL .LBX))
  15                                  (ELSE (.LBL .LBL))>>
  16                    <REST .L 2>>>
  17         <SET DISP-L <MAPF ,LIST <FUNCTION (L:LIST) <2 .L>> .RLBLS>>
  18         <REPEAT (ITM)
  19                 <COND (<OR <EMPTY? <SET LL <REST .LL>>>
  20                            <AND <TYPE? <SET ITM <1 .LL>> FORM>
  21                                 <OR <EMPTY? .ITM> <N==? <1 .ITM> DEAD>>>>
  22                        <RETURN>)
  23                       (<TYPE? .ITM ATOM>
  24                        <SET DELBL .ITM>
  25                        <SET DF T>
  26                        <RETURN>)>>
  27         <COND (<SET AC <IN-AC? .VAR BOTH>> <SET AC <NEXT-AC <SET TAC .AC>>>)
  28               (<SET AC <IN-AC? .VAR VALUE>>)
  29               (ELSE <SET AC <NEXT-AC <SET TAC <LOAD-AC .VAR BOTH>>>>)>
  30         <COND (<NOT .DF>
  31                <SET DELBL <GENLBL "DEFAULT">>
  32                <COND (<NOT <FIND-LABEL .DELBL>>
  33                       <MAKE-LABEL .DELBL <> ()>)>)>
  34         <LABEL-UPDATE-ACS .DELBL <>>
  35         <COND (<AND <G=? .BASE 0> <L=? .BASE 1>>
  36                <OCEMIT <COND (<==? .BASE 0> JUMPL) (ELSE JUMPLE)>
  37                        .AC
  38                        <XJUMP .DELBL>>
  39                <OCEMIT CAILE .AC <+ .NV .BASE -1>>
  40                <OCEMIT JRST O* <XJUMP .DELBL>>)
  41               (ELSE
  42                <COND (<G? .BASE 0> <OCEMIT CAIL .AC .BASE>)
  43                      (ELSE <OCEMIT CAML .AC !<OBJ-VAL .BASE>>)>
  44                <COND (<G? <SET NV <+ .NV .BASE -1>> 0> <OCEMIT CAILE .AC .NV>)
  45                      (ELSE <OCEMIT CAMLE .AC !<OBJ-CAL .NV>>)>
  46                <OCEMIT JRST O* <XJUMP .DELBL>>)>
  47         <OCEMIT XMOVEI O1* <XJUMP .DLBL>>
  48         <OCEMIT ADD O1* .AC>
  49         <MAPF <> <FUNCTION (LBL) <LABEL-UPDATE-ACS <2 .LBL> <>>> .RLBLS>
  50         <SETG LAST-UNCON T>
  51         <OCEMIT JRST @ <- .BASE> '(O1*)>
  52         <LABEL .DLBL>
  53         <MAPF <> <FUNCTION (LBL) <OCEMIT SETZ O* <XJUMP <2 .LBL>>>> .RLBLS>
  54         <MAPF <>
  55               <FUNCTION (LBL)
  56                       <COND (<N==? <1 .LBL> <2 .LBL>>
  57                              <LABEL <2 .LBL>>
  58                              <JUMP!-MIMOC <1 .LBL>>)>>
  59               .RLBLS>
  60         <COND (<NOT .DF>
  61                <COND (,PASS1 <SET LB <LABEL .DELBL>> <SAVE-LABEL-STATE .LB>)
  62                      (,NO-AC-FUNNYNESS <SAVE-ACS> <SET LB <LABEL .DELBL>>)
  63                      (ELSE
  64                       <SET LB <FIND-LABEL .DELBL>>
  65                       <ESTABLISH-LABEL-STATE .LB>
  66                       <LABEL .DELBL>)>)>>