MUDDLE/microm.1

   1 <PRINC "/MICROMED">
   2 <BLOCK (<MOBLIST M!- 13> <ROOT>)>
   3 CO CI CL+1 LST LOC
   4 O GETC NC
   5 PUSHO POPO
   6 L R DR DL UR UL
   7 I K G C
   8 SR SL WR WL
   9 CWR CWL
  10 <ENDBLOCK>
  11
  12 <BLOCK (<MOBLIST IM!-M!- 23> <GET M!- OBLIST> <ROOT>)>
  13
  14 <SETG O <FUNCTION (IT)
  15         <SET LOC .IT>
  16         <SET LST ()>
  17         <SET CL+1 2>
  18         <SET CI 1>
  19         <SET CO (<IN .IT>)>
  20         T>>
  21
  22 <NEWTYPE CURSOR!- VECTOR>
  23
  24 <SET OPDL ()>
  25
  26 <SETG GETC <FUNCTION () <CHTYPE [.CO .CI .CL+1 .LST .LOC] CURSOR>>>
  27
  28 <SETG PUSHO <FUNCTION (IT) <PUSH!- OPDL <GETC>> <O .IT>>>
  29
  30 <SETG POPO <FUNCTION () <NC <POP!- OPDL>>>>
  31
  32 <SETG NC <FUNCTION (IT)
  33         <SET CO <1 .IT>>
  34         <SET CI <2 .IT>>
  35         <SET CL+1 <3 .IT>>
  36         <SET LST <4 .IT>>
  37         <SET LOC <5 .IT>>
  38         T>>
  39 \f<SETG L <FUNCTION (N "AUX" (T <- .CI .N>))
  40                 <==? .T <SET CI <MAX 1 .T>>>>>
  41
  42 <SETG R <FUNCTION (N "AUX" (T <+ .CI .N>))
  43                 <==? .T <SET CI <MIN .CL+1 .T>>>>>
  44
  45
  46 <SETG DR <FUNCTION ()
  47                 <COND   (<==? .CI .CL+1> #FALSE("NO-RIGHT"))
  48                         (ELSE <PRID .CI T>)>>>
  49
  50
  51 <SETG DL <FUNCTION ()
  52                 <COND   (<1? .CI> #FALSE("NO-LEFT"))
  53                         (ELSE <PRID <- .CI 1> #FALSE()>)>>>
  54
  55 <SETG PRID <FUNCTION (N T)
  56                 <COND (<MONAD? <.N .CO>> #FALSE("MONAD"))
  57                       (ELSE
  58                         <SET LST (.CO .N .CL+1 !.LST)>
  59                         <SET CO <.N .CO>>
  60                         <SET CL+1 <+ 1 <LENGTH .CO>>>
  61                         <SET CI <COND (.T 1) (ELSE .CL+1)>>)>>>
  62
  63 <SETG UL <FUNCTION ()
  64                 <COND (<EMPTY? .LST> #FALSE("TOP"))
  65                       (ELSE <SET CI <2 .LST>> <PRIU>)>>>
  66
  67 <SETG UR <FUNCTION ()
  68                 <COND (<EMPTY? .LST> #FALSE("TOP"))
  69                       (ELSE <SET CI <+ 1 <2 .LST>>> <PRIU>)>>>
  70
  71 <SETG PRIU <FUNCTION ()
  72         <SET CO <1 .LST>>
  73         <SET CL+1 <3 .LST>>
  74         <SET LST <REST .LST 3>>
  75         T>>
  76 \f<SETG WR <FUNCTION () <OR <DR> <R 1> <UR>>>>
  77 <SETG WL <FUNCTION () <OR <DL> <L 1> <UL>>>>
  78
  79 <SETG SR <FUNCTION (IT) <PRIMS .IT ,DR ,R ,UR>>>
  80 <SETG SL <FUNCTION (IT) <PRIMS .IT ,DL ,L ,UL>>>
  81
  82 <SETG PRIMS <FUNCTION (IT DOWN ACROSS UP)
  83      <REPEAT ()
  84         <COND (<AND <L? .CI .CL+1> <=? .IT <.CI .CO>>>
  85                 <RETURN T>)
  86               (<.DOWN>) (<.ACROSS 1>) (<.UP>)
  87               (ELSE <RETURN #FALSE ("NOT-FOUND")>)>>>>
  88
  89 <SETG CWR <FUNCTION (C) <PRIMCW .C ,DR ,R ,UR>>>
  90 <SETG CWL <FUNCTION (C) <PRIMCW .C ,DL ,L ,UL>>>
  91
  92 <SETG PRIMCW <FUNCTION (C DOWN ACROSS UP)
  93      <REPEAT ()
  94         <COND   (<EVAL .C> <RETURN T>)
  95                 (<.DOWN>) (<.ACROSS 1>) (<.UP>)
  96                 (ELSE <RETURN #FALSE ("END")>)>>>>
  97 \f<SETG I <FUNCTION (IT "AUX" (RCI <- .CI 1>) (LIT <LENGTH .IT>) (OCI .CI))
  98         <SET CI <+ .CI .LIT>>
  99         <SET CL+1 <+ .CL+1 .LIT>>
 100         <COND (<==? <PRIMTYPE .CO> LIST>
 101                 <COND   (<EMPTY? .IT> T)
 102                         (ELSE   <SET IT (!.IT)>
 103                                 <PUTREST <REST .IT <- .LIT 1>> <REST .CO .RCI>>
 104                                 <LIPSTIC .IT>)>)
 105               (ELSE
 106                 <SET CO <CHTYPE <NEWSTRUC ,<PRIMTYPE .CO>
 107                                         (.CO .IT <REST .CO .RCI>)
 108                                         (.RCI .LIT <- .CL+1 .CI>)>
 109                                 <TYPE .CO>>>
 110                 <UPDATE>)>>>
 111
 112
 113 <SETG K <FUNCTION (N "AUX" (RCO <REST .CO <MIN <- .CL+1 1> <+ .CI .N -1>>>)
 114                                 (LCO <LENGTH .RCO>) (OCI .CI))
 115         <SET CL+1 <+ .CI .LCO>>
 116         <COND (<==? <PRIMTYPE .CO> LIST> <LIPSTIC .RCO>)
 117               (ELSE
 118                 <SET CO <CHTYPE <NEWSTRUC ,<PRIMTYPE .CO>
 119                                         (.CO .RCO)
 120                                         (<- .CI 1> .LCO)>
 121                                 <TYPE .CO>>>
 122                 <UPDATE>)>>>
 123
 124 <SETG LIPSTIC <FUNCTION (L)
 125         <COND (<1? .OCI> <SET CO <CHTYPE .L <TYPE .CO>>> <UPDATE>)
 126               (ELSE <PUTREST <REST .CO <- .OCI 2>> .L> T)>>>
 127
 128
 129
 130 <SETG UPDATE <FUNCTION ("AUX" (LLST <LENGTH .LST>))
 131         <COND (<0? .LLST>
 132                 <SETLOC .LOC
 133                         <COND (<AND <NOT <MONAD? .CO>> <1? <LENGTH .CO>>> <1 .CO>)
 134                               (ELSE .CO)>>)
 135               (ELSE <COND (<==? 3 .LLST> <SETLOC .LOC .CO>)>
 136                    <SETLOC <AT <1 .LST> <2 .LST>> .CO>)>
 137         T>>
 138
 139 <SETG G <FUNCTION (N "AUX" (M <MIN .N <- .CL+1 .CI>>) (N <- .CI 1>))
 140         <ILIST .M '<<SET N <+ .N 1>> .CO>>>>
 141
 142 <SETG C <FUNCTION (N)
 143         <COND   (<==? .CI .CL+1> #FALSE ("RIGHT-EDGE"))
 144                 (ELSE <SETLOC <AT .CO .CI> .N>)>>>
 145 \f
 146 <SETG NEWSTRUC
 147       <FUNCTION (FN OL NL "AUX" T (O <1 .OL>) (N <1 .NL>) (IX 0))
 148   ;"Actual structure hacker.  STACKFORMs FN, gobbling <1 .NL> members from <1 .OL> 'till gone."
 149                 <STACKFORM .FN
 150                            .T
 151                            <COND (<==? .N .IX>
 152                                   <REPEAT ()
 153                                           <COND (<EMPTY? <SET OL <REST .OL>>>
 154                                                  <RETURN #FALSE ()>)
 155                                                 (ELSE
 156                                                  <COND (<0? <SET N
 157                                                                  <1 <SET NL
 158                                                                          <REST .NL>>>>>
 159                                                         <AGAIN>)>
 160                                                  <SET IX 1>
 161                                                  <SET T <1 <SET O <1 .OL>>>>
 162                                                  <RETURN <SET O <REST .O>>>)>>)
 163                                  (ELSE <SET T <1 .O>> <SET IX <+ .IX 1>> <SET O <REST .O>>)>>>>
 164 <ENDBLOCK>
 165 \f\f\ 3\fð`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\a