MUDDLE/nutil.1

   1 <SETG DEFINE
   2  <FUNCTION ("STACK" FUNNAME  DEF)
   3    <SETG .FUNNAME .DEF>
   4    <PRINT .FUNNAME>   >>
   5
   6
   7 <DEFINE FRAMEN
   8   <FUNCTION ("STACK" N)
   9    <COND (<0? .N> <FRAME>)
  10          (T <FRAME <FRAMEN <- .N 1>>>)>>>\e
  11
  12
  13
  14 <DEFINE CLEANUP
  15   <FUNCTION CF ("STACK" )
  16     <FINALIZE>
  17     <BUMPER>>>
  18
  19
  20 <DEFINE BUMPER
  21   <FUNCTION ()
  22    <FAILPOINT FP ("STACK" )
  23       <> ("STACK" M A)
  24       <RESTORE .FP (FAILURE CAUGHT WITH M = .M AND A = .A)>>   >>
  25
  26
  27
  28 <DEFINE THSET
  29   <FUNCTION ("STACK" VAR\  VAL "AUX" (OV <RLVAL .VAR\ >))
  30       <FAILPOINT ()
  31          <SET .VAR\  <RLVAL VAL>>
  32          ("STACK" M A)
  33          <SET .VAR\  <RLVAL OV>>
  34          <FAIL .M .A>>   >>
  35
  36
  37 <DEFINE THDELQ
  38  <FUNCTION ("STACK" ELT L)
  39    <COND (<EMPTY? .L> .L)
  40          (<==? .ELT <1 .L>>
  41           <CHTYPE <REST .L> <TYPE .L>>)
  42          (T <THDELQ1 .ELT .L>)   >>>
  43
  44
  45 <DEFINE THDELQ1
  46  <FUNCTION ("STACK" ELT L)
  47    <COND (<EMPTY? <REST .L>> .L)
  48          (<==? <2 .L> .ELT> <THPUTREST .L <REST .L 2>>)
  49          (T <THDELQ1 .ELT <REST .L>>)   >  >>
  50
  51
  52 <DEFINE THPUTREST
  53  <FUNCTION ("STACK" LIST1 LIST2)
  54    <FAILPOINT ("STACK" (OREST <REST .LIST1>))
  55       <PUTREST .LIST1 .LIST2>
  56       ("STACK" M A)
  57       <PUTREST .LIST1 .OREST>
  58       <FAIL .M .A>   >>>
  59
  60
  61 <DEFINE THPUT
  62  <FUNCTION ("STACK" THING IND "OPTIONAL" PROP)
  63    <FAILPOINT ("STACK" (OPROP <GET .THING .IND>))
  64       <COND (<ASSIGNED? PROP>
  65              <PUT .THING .IND .PROP>)
  66             (T <PUT .THING .IND>)   >
  67       ("STACK" M A)
  68       <COND (.OPROP <PUT .THING .IND .OPROP>)
  69             (<PUT .THING .IND>)   >
  70       <FAIL .M .A>   >>>
  71
  72
  73 <DEFINE THSETLOC
  74  <FUNCTION ("STACK" LOC VAL "AUX" (OVAL <IN .LOC>))
  75    <FAILPOINT ()
  76       <SETLOC .LOC <RLVAL VAL>>
  77       ("STACK" M A)
  78       <SETLOC .LOC <RLVAL OVAL>>
  79       <FAIL .M .A>   >>>\f<DEFINE FALSE
  80   <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> FALSE>  >>
  81
  82
  83 <DEFINE FORM
  84   <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> FORM>  >>
  85
  86 <DEFINE UNASSIGNED
  87   <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> UNASSIGNED>  >>
  88
  89 <DEFINE SEGMENT
  90   <FUNCTION ("STACK" "REST" 'A) <CHTYPE <EVAL .A> SEGMENT>  >>
  91
  92 <DEFINE CONSTRUCTOR
  93  <FUNCTION ("STACK" TYPE)
  94    <GET .TYPE 'CONSTRUCTOR>   >>
  95
  96
  97 <PUT LIST CONSTRUCTOR ,CONSL>
  98 <PUT FORM CONSTRUCTOR ,FORM>
  99 <PUT FALSE CONSTRUCTOR ,FALSE>
 100 <PUT VECTOR  CONSTRUCTOR ,CONSV>
 101 <PUT SEGMENT CONSTRUCTOR ,SEGMENT>
 102 <PUT UVECTOR CONSTRUCTOR ,CONSU>
 103
 104
 105
 106 <DEFINE AVAL
 107   <FUNCTION ("STACK" ATOM)
 108    <COND (<GASSIGNED? .ATOM> <GVAL .ATOM>)
 109          (<LVAL .ATOM>)>  >>
 110 \f<DEFINE CLIP
 111  <FUNCTION ("STACK" VAR)
 112    <FAILPOINT CLIPPER ("STACK" (VAL ..VAR))
 113       <FAIL>
 114       ("STACK")
 115       <COND (<EMPTY? .VAL> <FAIL>)
 116             (<RESTORE .CLIPPER
 117                       <PROG1 <1 .VAL>
 118                              <SET .VAR <SET VAL <REST .VAL>>>>>)   >>  >>
 119
 120
 121 <DEFINE FULL?
 122  <FUNCTION ("STACK" FOO) <NOT <EMPTY? <RLVAL FOO>>>>>
 123
 124
 125 <DEFINE FINSPLICE
 126  <FUNCTION ACT ("STACK" CURRENTENV NEWENV)
 127    <PROG1 <SPLICE .CURRENTENV .NEWENV>
 128           <FINALIZE .ACT>>   >>
 129
 130
 131 <DEFINE ENVIRON
 132  <FUNCTION ("STACK" "BIND" FOO) .FOO>>\f<DEFINE RESET
 133  <FUNCTION ("STACK" VAR)
 134    <FAILPOINT ("STACK" (VAL <RLVAL .VAR>)) <> ("STACK")
 135       <SET .VAR <RLVAL VAL>>
 136       <FAIL>>  >>
 137
 138 <DEFINE PROG1
 139  <FUNCTION ("STACK" "REST" A) <1 .A>   >>
 140
 141
 142 <DEFINE PROG2
 143  <FUNCTION ("STACK" "REST" A) <2 .A>   >>\f<DEFINE MULTILEVEL
 144  <FUNCTION ("STACK" OBJECT)
 145    <AND <NOT <MONAD? .OBJECT>>
 146         <MEMQ <TYPE .OBJECT> '(LIST FORM VECTOR SEGMENT VECTOR)>>   >>
 147
 148 <DEFINE REVERSE
 149  <FUNCTION REV ("STACK" L "OPTIONAL" (CFUNC <CONSTRUCTOR <TYPE .L>>)
 150                 "AUX" (RESULT ()))
 151    <COND (<EMPTY? .L> <.CFUNC !.RESULT>)
 152          (T <SET RESULT (<1 .L> !.RESULT)>
 153             <SET L <REST .L>>
 154             <AGAIN .REV>)   >   >>
 155
 156
 157 <DEFINE NCONC
 158  <FUNCTION ("STACK" "REST" LSTUPL)
 159    <COND (<EMPTY? .LSTUPL> ())
 160          (T <CHTYPE <NCONC1 .LSTUPL> <TYPE <1 .LSTUPL>>>)   >>>
 161
 162
 163 <DEFINE NCONC1
 164  <FUNCTION ("STACK" LSTUPL)
 165    <COND (<EMPTY? <REST .LSTUPL>> <1 .LSTUPL>)
 166          (T <NCONC2 <1 .LSTUPL> <REST .LSTUPL>>)   >>>
 167
 168
 169 <DEFINE NCONC2
 170  <FUNCTION ("STACK" L1 LREST)
 171    <COND (<EMPTY? .L1> <NCONC1 .LREST>)
 172          (T <PUTREST .L1 <NCONC2 <REST .L1> .LREST>>)   >>>\f<DEFINE ANOTHER
 173  <FUNCTION ("STACK" OBJ BOUND)
 174    <FAILPOINT FP ("STACK")
 175      .OBJ ("STACK")
 176      <AND <==? .OBJ .BOUND> <FAIL>>
 177      <RESTORE .FP <SET OBJ <REST .OBJ>>>>  >>
 178
 179
 180 \f<DEFINE MAPCAR
 181  <FUNCTION MAPPER ("STACK" FUN "REST" EXPS "AUX" (RESULT ()) RES1 LAS)
 182    <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
 183    <COND (<EMPTY? .RESULT>
 184           <SET LAS <SET RESULT (.RES1)>>)
 185          (T <PUTREST .LAS <SET LAS (.RES1)>>)   >
 186    <AGAIN .MAPPER>   >>
 187
 188
 189 <DEFINE MAPC
 190  <FUNCTION MAPPER ("STACK" FUN "REST" EXPS "AUX" (RESULT ()))
 191    <REPEAT ("STACK") <APPLY .FUN <LISTFIRSTS .EXPS>>>   >>
 192
 193
 194 <DEFINE MAPCAN
 195  <FUNCTION MAPPER ("STACK" FUN "REST" EXPS
 196                    "AUX" (RESULT ()) RES1 LAS1)
 197    <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
 198    <COND (<EMPTY? .RESULT>
 199           <SET RESULT .RES1>)
 200          (T <PUTREST .LAS1 .RES1>)   >
 201    <SET LAS1 <LAST .RES1>>
 202    <AGAIN .MAPPER>   >>
 203
 204
 205 <DEFINE LISTFIRSTS
 206  <FUNCTION ("STACK" EXPTUPL)
 207    <COND (<EMPTY? .EXPTUPL> ())
 208          (<EMPTY? <SET RES1 <1 .EXPTUPL>>> <.MAPPER .RESULT>)
 209          ((<PROG1 <1 .RES1>
 210                   <PUT .EXPTUPL 1 <REST .RES1>>>
 211            !<LISTFIRSTS <REST .EXPTUPL>>))   >   >>
 212
 213
 214 <DEFINE LAST
 215  <FUNCTION L ("STACK" EXP)
 216    <COND (<EMPTY? .EXP> ())
 217          (<EMPTY? <REST .EXP>> .EXP)
 218          (T <SET EXP <REST .EXP>>
 219             <AGAIN .L>)   >>>\f<DEFINE BOTTOM
 220  <FUNCTION ("STACK" THING)
 221    <COND (<MONAD? .THING> .THING)
 222          (<==? <TYPE .THING> LIST> ())
 223          (T <REST .THING <LENGTH .THING>>)>  >>
 224
 225
 226
 227
 228 <DEFINE SPREAD
 229  <FUNCTION ("STACK" VEC "REST" VARS)
 230    <MAPC ,SET .VARS .VEC>   >>\f\ 3\f