MUDDLE/nactor.1

   1 <DEFINE ACTOR
   2   <FUNCTION ("STACK" "ARGS" A) <CHTYPE .A ACTOR>  >>
   3
   4 <DEFINE ACTOR-FUNCTION
   5   <FUNCTION ("STACK" "ARGS" A) <CHTYPE .A ACTOR-FUNCTION>  >>
   6
   7 <DEFINE ACTOR?
   8   <FUNCTION ("STACK" EXP)
   9    <AND <ATOM? .EXP> <SET EXP <AVAL .EXP>>>
  10    <AND <MEMQ <TYPE .EXP> '(ACTOR ACTOR-FUNCTION)>
  11         .EXP>  >>
  12
  13 <DEFINE ACTORFORM?
  14  <FUNCTION ("STACK" EXP)
  15    <AND <MEMQ <TYPE .EXP> '(FORM SEGMENT)>
  16         <NOT <EMPTY? .EXP>>
  17         <ACTOR? <1 .EXP>>>  >>
  18
  19
  20 <DEFINE PRECEDENCE
  21  <FUNCTION ("STACK" ATOM) <OR <GET .ATOM PRECEDENCE> 0>   >>
  22
  23
  24 <DEFINE INVOKE
  25  <FUNCTION INVOKER ("STACK" F OBJECT "OPTIONAL" (BOUND <BOTTOM .OBJECT>)
  26                       (OBL T) (ENV <>) (OBJENV <>) (PURE? T)
  27                       (UV1 <UARGS .F .ENV>)
  28                     "AUX" (UV2 ()))
  29    <SET F <CHTYPE .F FORM>>
  30    <COND (<OR <EMPTY? .UV1> <GET <1 .F> FACTOR>>
  31           <.INVOKER <INVOKE1 .F .OBJECT .BOUND .OBL .PURE? .ENV .OBJENV>>)
  32          (.PURE?
  33           <COND (.OBL)
  34                 (T <SET BOUND <ANOTHER .OBJECT .BOUND>>)   >)
  35          (.OBL
  36           <COND (<==? <TYPE .OBJECT> FORM>
  37                  <COND (<OR <EMPTY? <SET UV2 <UARGS .OBJECT .OBJENV>>>
  38                             <GET <1 .F> FACTOR>>
  39                         <.INVOKER <INVOKE1 .OBJECT .F '<> T <> .OBJENV .ENV .UV2>>)   >)
  40                 (T <SET UV2 <UVARS .OBJECT .BOUND .OBJENV>>)   >)
  41          (T <SET OBJECT <FRONT .OBJECT <> <LLOC BOUND> .OBJENV <LLOC UV2>>>)   >
  42    <LINKVARS .UV1 .UV2 .F .OBJECT <OR .ENV .TOPMATCH> <OR .OBJENV .TOPMATCH>>
  43    .BOUND   >>\f<DEFINE INVOKE1
  44  <FUNCTION ("STACK" "BIND" CUR
  45             F OBJECT BOUND OBL PURE? ENV OBJENV
  46             "AUX" ACTR VAL)
  47    <COND (<OR <EMPTY? .F> <NOT <SET ACTR <ACTOR? <1 .F>>>>>
  48           <SET VAL <EVAL .F .ENV>>
  49           <COND (.PURE?
  50                  <COND (.OBL
  51                         <OR <=UPTO? .VAL .OBJECT .BOUND> <FAIL>>
  52                         .BOUND)
  53                        (T <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUND>)   >)
  54                 (.OBL
  55                  <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> .BOUND>)
  56                 (T <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>)   >)
  57          (<==? <TYPE .ACTR> ACTOR-FUNCTION>
  58           <FINSPLICE .CUR .ENV>
  59           <EVAL <FORM <CHTYPE .ACTR FUNCTION>
  60                       '.OBJECT '.BOUND '.OBL '.PURE? '<OR .ENV .TOPMATCH>
  61                       '<OR .OBJENV .PURE? .TOPMATCH> !<REST .F>>>)
  62          (<==? <TYPE .ACTR> ACTOR>
  63           <FINSPLICE .CUR .ENV>
  64           <BIND .ACTR <REST .F>
  65                 ((BODY <REST .ACTR <COND (<ATOM? <1 .ACTR>> 2) (1)   >>))
  66              <APPLY <CHTYPE ,ET FUNCTION>
  67                     (.OBJECT .BOUND .OBL .PURE? <ENVIRON> .OBJENV !.BODY)>   >)
  68          (T <ERROR NON-INVOKABLE-TYPE>)   >   >>\f<DEFINE GIVEN
  69  <ACTOR-FUNCTION GA ("STACK" OBJECT BOUNDARY OBLIGATORY PURE? ENV OBJENV VAR
  70                      "AUX" (VAL <RLVAL .VAR>) RS (VALRS ()) (UV ()) PURESOFAR NEWVAL
  71                            NEWBOUND (VARLOC <LLOC .VAR>) VARFORM RS2)
  72    <COND (<ASSIGNED? .VAR>
  73           <COND (.OBLIGATORY
  74                  <COND (.PURE?
  75                         <OR <=UPTO? .VAL .OBJECT .BOUNDARY> <FAIL>>)
  76                        (T <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> T .BOUNDARY>)   >
  77                  <.GA .BOUNDARY>)
  78                 (.PURE?
  79                  <.GA <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUNDARY>>)
  80                 (T <.GA <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>>)   >)   >
  81    <SET RS <CHTYPE <RLVAL VAL> LIST>>
  82    <COND (<AND .PURE? .OBLIGATORY>
  83           <THSET .VAR <UPTO .OBJECT .BOUNDARY>>
  84           <CHECKRESTRICTS .RS () ..VAR>
  85           <.GA .BOUNDARY>)   >
  86    <COND (<AND <==? .OBJECT <SET VARFORM <FORM GIVEN .VAR>>>
  87                <==? .VARLOC
  88                     <EVAL <PUT '<LLOC VAR> 2 .VAR> .OBJENV>>>
  89           <.GA .BOUNDARY>)
  90          (<SET RS2 <MEMRES .OBJECT .BOUNDARY .OBJENV .RS>>
  91           <THPUT .RS2 1 ()>)
  92          (T
  93           <THSET .VAR ?()>
  94           <REPEAT CHECK ("STACK" RS1)
  95              <AND <EMPTY? .RS> <.CHECK <>>>
  96              <SET RS1 <1 .RS>>   <SET RS <REST .RS>>
  97              <COND (<MONAD? .RS1>)
  98                    (<==? <1 .RS1> PATTERN>
  99                     <SET BOUNDARY
 100                          <COND (.PURE?
 101                                 <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY .OBLIGATORY>)
 102                                (T
 103                                 <MATCH1 <2 .RS1> .OBJECT <3 .RS1> .OBJENV
 104                                         <BOTTOM <2 .RS1>> .BOUNDARY
 105                                         .OBLIGATORY>)   >>
 106                     <SET OBLIGATORY T>
 107                     <COND (<ASSIGNED? .VAR>
 108                             <CHECKRESTRICTS .RS .VALRS ..VAR>
 109                             <.GA .BOUNDARY>)
 110                           (<FULL? <RLVAL .VAR>>
 111                             <THSET RS <NCONC <CHTYPE <RLVAL .VAR> LIST>
 112                                             .RS>>
 113                             <THSET .VAR ?()>)   >)
 114                    (T <THSET VALRS (.RS1 !.VALRS)>)   >>)   >
 115    <THTRYSET .VARLOC .VARFORM .OBJECT .BOUNDARY .OBLIGATORY .PURE?
 116              .ENV .OBJENV .RS .VALRS>   >>
 117
 118 <PUT GIVEN PRECEDENCE 3>\f<DEFINE ALTER
 119  <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV VAR)
 120    <THTRYSET <LLOC .VAR> <FORM GIVEN .VAR> .OBJECT .BOUND .OBL?
 121              .PURE? .ENV .OBJENV>   >>
 122
 123 <PUT ALTER PRECEDENCE 4>
 124
 125
 126 <DEFINE BE
 127  <ACTOR ("STACK" PRED)
 128    <DO <OR .PRED <FAIL>>>   >>
 129
 130 <PUT BE PRECEDENCE 30>
 131
 132
 133 <DEFINE DO
 134  <ACTOR ("STACK" ACTION)
 135    <?>   >>
 136
 137 <PUT DO PRECEDENCE 29>
 138
 139
 140 <DEFINE ?
 141  <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL" (N <>)
 142                   "AUX" UV)
 143    <COND (.OBL?
 144           <COND (.PURE?
 145                  <OR <NOT .N>
 146                      <==? .N <BLENGTH .OBJECT .BOUND>>
 147                      <FAIL>>)
 148                 (<OR <PROG2 <SET OBJECT <INSTANTIATE .OBJECT UV .BOUND .OBJENV>>
 149                             .UV>
 150                      <NOT <UNCERTAINLENGTH .OBJECT>>>
 151                  <OR <NOT .N> <==? .N <LENGTH .OBJECT>> <FAIL>>)
 152                 (<EMPTY? .UV> <FAIL>)
 153                 (T <LINKVARS () .UV <SET FORM1 <FORM ? .N>> .OBJECT
 154                              <> .OBJENV .FORM1 .BOUND>)   >
 155           .BOUND)
 156          (.PURE?
 157           <COND (.N
 158                  <COND (<G? .N <BLENGTH .OBJECT .BOUND>> <FAIL>)
 159                        (T <REST .OBJECT .BOUND>)   >)
 160                 (T <ANOTHER .OBJECT .BOUND>)   >)
 161          (T
 162           <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV>>
 163           <COND (.N
 164                  <OR <==? .N <LENGTH .OBJECT>> <FAIL>>)   >
 165           .BOUND)   >   >>
 166
 167 <PUT ? PRECEDENCE 2>\f<DEFINE ET
 168  <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS)
 169    <REPEAT ACTITER ("STACK")
 170                 <COND (<EMPTY? .PATS>
 171                        <.ACTITER <COND (.OBL? .BOUND)
 172                                        (.PURE? <ANOTHER .OBJECT .BOUND>)
 173                                        (T <REAR .OBJECT .OBJENV .BOUND>)   >>)   >
 174                 <SET BOUND
 175                      <COND (.PURE?
 176                             <IS1 <1 .PATS> .OBJECT .ENV .BOUND .OBL?>)
 177                            (T <MATCH1 <1 .PATS>
 178                                       .OBJECT
 179                                       .ENV
 180                                       .OBJENV
 181                                       <BOTTOM <1 .PATS>>
 182                                       .BOUND
 183                                       .OBL?>)   >>
 184                 <SET OBL? T>
 185                 <THSET PATS <REST .PATS>>   >   >>
 186
 187 <PUT ET PRECEDENCE 10>   <PUT ET FACTOR T>
 188
 189
 190
 191 <DEFINE VEL
 192  <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS
 193                   "AUX" (PAT1 <CLIP PATS>))
 194    <COND (.PURE?
 195           <IS1 .PAT1 .OBJECT <> .BOUND .OBL?>)
 196          (T <MATCH1 .PAT1 .OBJECT <> .OBJENV <BOTTOM .PAT1> .BOUND .OBL?>)   >   >>
 197
 198
 199 <PUT VEL PRECEDENCE 20>   <PUT VEL FACTOR T>
 200
 201 <DEFINE NON
 202  <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV 'PAT)
 203    <OR .OBL?
 204        <SET OBJECT
 205             <COND (.PURE? <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>)
 206                   (T <FRONT .OBJECT <> <LLOC BOUND> .OBJENV>)   >>   >
 207    <FAILPOINT NAY-SAYER ("STACK")
 208       <PROG2 <COND (.PURE? <IS1 .PAT .OBJECT>)
 209                    (T <MATCH1 .PAT .OBJECT <> .OBJENV>)   >
 210              <FAIL <> .NAY-SAYER>>
 211       ("STACK")
 212       <.NAY-SAYER .BOUND>   >>>
 213
 214 <PUT NON PRECEDENCE 6>   <PUT NON FACTOR T>\f<DEFINE WHEN
 215  <ACTOR-FUNCTION WA ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'CLAUSES
 216                      "AUX" (CLAUSE <CLIP CLAUSES>) NEWBOUND)
 217    <SET NEWBOUND
 218         <COND (<EMPTY? .CLAUSE> <ERROR EMPTY-CLAUSE--WHEN>)
 219               (.PURE? <IS1 <1 .CLAUSE> .OBJECT <> .BOUND .OBL?>)
 220               (T <MATCH1 <1 .CLAUSE> .OBJECT <> .OBJENV
 221                          <BOTTOM <1 .CLAUSE>> .BOUND .OBL?>)   >>
 222    <FAILPOINT () <> ("STACK") <FAIL <> .WA>>
 223    <APPLY <CHTYPE ,ET FUNCTION>
 224           (.OBJECT .NEWBOUND T .PURE? .ENV .OBJENV !<REST .CLAUSE>)>
 225    .NEWBOUND   >>
 226
 227 <PUT WHEN PRECEDENCE 25>   <PUT WHEN FACTOR T>\f<DEFINE THTRYSET
 228  <FUNCTION ("STACK" VARLOC VARFORM OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL"
 229               (RS ()) (VALRS ())
 230             "AUX" VAR2)
 231    <COND (.OBL?
 232           <COND (.PURE?
 233                  <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC <UPTO .OBJECT .BOUND>>>)
 234                 (<PROG2
 235                     <SET OBJECT <INSTANTIATE .OBJECT PURE? .BOUND .OBJENV>>
 236                     .PURE?>
 237                  <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
 238
 239                 (<SET VAR2 <UVAR? .OBJECT>>
 240                  <THPSEUDOSETLOC <LLOC .VAR2> .VARFORM .ENV>
 241                  <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>)
 242                 (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>)   >)
 243          (.PURE?
 244           <THSETLOC .VARLOC <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>>)
 245          (<PROG2
 246              <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV <LLOC PURE?>>>
 247              .PURE?>
 248           <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
 249          (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>)   >
 250    .BOUND   >>
 251
 252
 253 <DEFINE THIMPURESETLOC
 254    <FUNCTION ("STACK" LOC UV VARFORM OBJECT ENV OBJENV)
 255    <COND (<MEMQ .VARLOC <LINKVARS () .UV .VARFORM .OBJECT .ENV .OBJENV>>
 256           <FAIL>)
 257          (T <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>)   >  >>
 258
 259
 260 <DEFINE THPSEUDOSETLOC
 261  <FUNCTION ("STACK" LOC OBJ OBJENV)
 262    <THSETLOC .LOC
 263              <CHTYPE ([PATTERN .OBJ .OBJENV] !<CHTYPE <IN .LOC> LIST>)
 264                      UNASSIGNED>>   >>\f<DEFINE PREFIX1
 265  <FUNCTION P ("STACK" L1 TERM1 L2 TERM2)
 266    <COND (<OR <EMPTY? .L1> <==? .L1 .TERM1>>
 267           <EXIT .P .L2>)
 268          (<==? .L2 .TERM2> <FAIL>)>
 269    <OR <=? <1 .L1> <1 .L2>> <FAIL>>
 270    <SET L1 <REST .L1>>   <SET L2 <REST .L2>>
 271    <AGAIN .P>  >>
 272
 273
 274
 275 <DEFINE FRONT
 276  <FUNCTION ("STACK" "BIND" CUR
 277             OBJECT EV? BOUNDLOC "OPTIONAL" (ENV <>)
 278                (PURELOC <>)
 279             "AUX" V P (LP <LLOC P>) (CONSTRUCT <CONSTRUCTOR <TYPE .OBJECT>>)
 280                (BOUND <IN .BOUNDLOC>))
 281    <SETLOC .BOUNDLOC .OBJECT>
 282    <AND .PURELOC <SETLOC .PURELOC ()>>
 283    <FINSPLICE .CUR .ENV>
 284    <SET RESULT
 285       <FAILPOINT EXTENDER ("STACK")
 286          <BOTTOM .OBJECT>
 287          ("STACK")
 288          <COND (<==? .OBJECT .BOUND> <FAIL>)
 289                (<==? <TYPE <1 .OBJECT>> SEGMENT>
 290                 <SET V <FORMSUBST <1 .OBJECT> .LP>>
 291                 <COND (<EMPTY? .V>
 292                        <SET OBJECT <REST .OBJECT>>
 293                        <AGAIN .EXTENDER>)   >
 294                 <SET OBJECT <BACKTO .OBJECT <REST .V> .BOUNDLOC>>
 295                 <RESTORE .EXTENDER <.CONSTRUCT !.RESULT <1 .V>>>)
 296                (.EV? <SET V <INSTANTIATE <1 .OBJECT> P>>
 297                      <AND .PURELOC <NOT .P> <SETLOC .PURELOC <NCONC .P <IN .PURELOC>>>>
 298                      <SETLOC .BOUNDLOC <SET OBJECT <REST .OBJECT>>>
 299                      <RESTORE .EXTENDER <.CONSTRUCT !.RESULT .V>>)
 300                (T <AND .PURELOC
 301                        <FULL? <SET P <UVARS <1 .OBJECT>>>>
 302                        <SETLOC .PURELOC <NCONC <CHTYPE .P FALSE> <IN .PURELOC>>>>
 303                   <RESTORE .EXTENDER
 304                            <PROG1 <.CONSTRUCT !.RESULT <1 .OBJECT>>
 305                                   <SETLOC .BOUNDLOC  <SET OBJECT <REST .OBJECT>>>>>)   >>>  >>\f<DEFINE REAR
 306  <FUNCTION ("STACK""BIND" CUR
 307             OBJECT "OPTIONAL" (ENV <>) (BOUND <BOTTOM .OBJECT>)
 308             "AUX" V P (LP <LLOC P>))
 309    <FINSPLICE .CUR .ENV>
 310    <FAILPOINT CHOPPER ("STACK")
 311       .BOUND
 312       ("STACK")
 313       <COND (<==? .OBJECT .BOUND> <FAIL>)
 314             (<==? <TYPE <1 .OBJECT>> SEGMENT>
 315              <SET V <FORMSUBST <1 .OBJECT> .LP>>
 316              <COND (<EMPTY? .V>
 317                     <SET OBJECT <REST .OBJECT>>
 318                     <AGAIN .CHOPPER>)   >
 319              <RESTORE .CHOPPER <SET OBJECT <BACKTO .OBJECT <REST .V>>>>)
 320             (T <RESTORE .CHOPPER <SET OBJECT <REST .OBJECT>>>)   >   >>>\f<DEFINE INSTANTIATE
 321  <FUNCTION ("STACK" "BIND" CUR
 322             EXP UVAR "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
 323               (LUV <LLOC .UVAR>))
 324    <FINSPLICE .CUR .ENV>
 325    <COND (<==? <TYPE .EXP> FORM>
 326           <FORMSUBST .EXP .LUV>)
 327          (<MONAD? .EXP>
 328           <SETLOC .LUV ()>
 329           .EXP)
 330          (T <INSTANTIATE1 .EXP .LUV .BOUND>)   >>>
 331
 332
 333 <DEFINE INSTANTIATE1
 334  <FUNCTION INSTLP ("STACK" EXP LUV "OPTIONAL" (BOUND <BOTTOM .EXP>)
 335                    "AUX" (RESULT ()) (P ()) P1 (LP1 <LLOC P1>) EXP1)
 336    <COND (<==? .EXP .BOUND> <SETLOC .LUV .P>
 337           <.INSTLP <REVERSE .RESULT <CONSTRUCTOR <TYPE .EXP>>>>)
 338          (<==? <TYPE <SET EXP1 <1 .EXP>>> SEGMENT>
 339           <SET RESULT (<REVERSE <FORMSUBST .EXP1 .LP1> ,CONSL>
 340                        !.RESULT)>)
 341          (T <SET RESULT (<INSTANTIATE .EXP1 P1> !.RESULT)>)   >
 342    <OR .P1 <SET P <NCONC .P1 .P>>>
 343    <SET EXP <REST .EXP>>
 344    <AGAIN .INSTLP>   >>
 345
 346
 347 <DEFINE FORMSUBST
 348  <FUNCTION ("STACK" F PURELOC "AUX" P A1 VAR)
 349    <COND (<FULL? <SET P <UARGS .F>>>
 350           <SETLOC .PURELOC <CHTYPE .P FALSE>>
 351           .F)
 352          (<OR <EMPTY? .F> <NOT <SET A1 <ACTOR? <1 .F>>>>>
 353           <SETLOC .PURELOC ()>
 354           <EVAL .F>)
 355          (<EMPTY? <REST .F>>
 356           <SETLOC .PURELOC <>>
 357           .F)
 358          (<==? .A1 ,ALTER>
 359           <THSET <SET VAR <EVAL <2 .F>>> ?()>
 360           <SETLOC .PURELOC <FALSE .VAR>>
 361           <FORM GIVEN .VAR>)
 362          (<==? .A1 ,GIVEN>
 363           <COND (<ASSIGNED? <SET VAR <EVAL <2 .F>>>>
 364                  <SETLOC .PURELOC ()>
 365                  <LVAL .VAR>)
 366                 (T <SETLOC .PURELOC <FALSE .VAR>>
 367                    .F)   >)
 368          (T <SETLOC .PURELOC <>>
 369             .F)   >>>\f<DEFINE UVARS
 370  <FUNCTION ("STACK" "BIND" CUR
 371             EXP "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
 372             "AUX" UA ACTR VAR)
 373    <FINSPLICE .CUR .ENV>
 374    <COND (<==? <TYPE .EXP> FORM>
 375           <COND (<FULL? <SET UA <UARGS .EXP>>> .UA)
 376                 (<AND <==? <LENGTH .EXP> 2>
 377                       <SET ACTR <ACTOR? <1 .EXP>>>>
 378                  <COND (<==? .ACTR ,GIVEN>
 379                         <COND (<OR <NOT <BOUND? <SET VAR <EVAL <2 .EXP>>>>>
 380                                    <UNASSIGNED? .VAR>>
 381                                (.VAR))   >)
 382                        (<==? .ACTR ,ALTER>
 383                         <THSET <SET VAR <EVAL <2 .EXP>>> ?()>
 384                         (.VAR))   >)   >)
 385          (<==? .EXP .BOUND> ())
 386          (T <NCONC <UVARS <1 .EXP>> <UVARS <REST .EXP> .BOUND>>)   >>>
 387
 388
 389 <DEFINE UARGS
 390  <FUNCTION ("STACK" "BIND" C
 391             F "OPTIONAL" (ENV <>)
 392             "AUX" VAR)
 393    <FINSPLICE .C .ENV>
 394    <COND (<MULTILEVEL .F>
 395           <COND (<AND <MEMQ <TYPE .F> '(FORM SEGMENT)>
 396                       <==? <1 .F> LVAL>
 397                       <ATOM? <SET VAR <2 .F>>>
 398                       <OR <NOT <BOUND? .VAR>> <UNASSIGNED? .VAR>>>
 399                  (.VAR))
 400                 (T <MAPCAN ,UARGS .F>)   >)   >   >>
 401
 402
 403 <DEFINE UVAR?
 404  <FUNCTION ("STACK" OBJECT "AUX" RES)
 405    <AND <==? <TYPE .OBJECT> FORM>
 406         <==? <LENGTH .OBJECT> 2>
 407         <==? <1 .OBJECT> GIVEN>
 408         <ATOM? <SET RES <EVAL <2 .OBJECT>>>>
 409         .RES>   >>
 410
 411
 412 <DEFINE UNCERTAINLENGTH
 413  <FUNCTION ("STACK" OBJECT)
 414    <OR <==? <TYPE .OBJECT> FORM>
 415        <AND <MULTILEVEL .OBJECT>
 416             <MAPC #FUNCTION (("STACK" EL) <AND <==? <TYPE .EL> SEGMENT> <.UNC T>>)
 417                   .OBJECT>
 418             <>>>   >>\f<DEFINE UPTO
 419  <FUNCTION ("STACK" OBJECT BOUNDARY)
 420    <COND (<MONAD? .OBJECT> .OBJECT)
 421          (T <REVERSE <UPTO1 .OBJECT .BOUNDARY>
 422                      <CONSTRUCTOR <TYPE .OBJECT>>>)   >   >>
 423
 424
 425 <DEFINE UPTO1
 426  <FUNCTION LOOP ("STACK" OBJ BOU "AUX" (RES ()))
 427    <COND (<==? .OBJ .BOU> .RES)
 428          (T <SET RES (<1 .OBJ> !.RES)>
 429             <SET OBJ <REST .OBJ>>
 430             <AGAIN .LOOP>)   >>>
 431
 432
 433 <DEFINE BACKTO
 434  <FUNCTION ("STACK" PAT BEG "OPTIONAL" (BOUNDLOC <>))
 435    <COND (<EMPTY? .BEG> .PAT)
 436          (<ISREST .PAT .BEG> .BEG)
 437          (T <SET PAT <REVERSE (!<REVERSEUPTO .PAT <IN .BOUNDLOC>>
 438                                !<REVERSE .BEG ,CONSL>)
 439                               <CONSTRUCTOR <TYPE .PAT>>>>
 440             <SETLOC .BOUNDLOC <BOTTOM .PAT>>
 441              .PAT)   >>>
 442
 443
 444 <DEFINE REVERSEUPTO
 445  <FUNCTION REV ("STACK" EXP1 EXP2 "AUX" (RESULT()))
 446    <COND (<==? .EXP1 .EXP2> .RESULT)
 447          (T <SET RESULT (<1 .EXP1> !.RESULT)>
 448             <SET EXP1 <REST .EXP1>>
 449             <AGAIN .REV>)   >>>
 450
 451
 452 <DEFINE ISREST
 453  <FUNCTION CHECKER ("STACK" EXP1 EXP2)
 454    <COND (<==? .EXP1 .EXP2> T)
 455          (<EMPTY? .EXP2> <>)
 456          (T <SET EXP2 <REST .EXP2>>
 457             <AGAIN .CHECKER>)   >>>\f<DEFINE CHECKRESTRICTS
 458  <FUNCTION CH ("STACK" RS VALRS OBJECT "OPTIONAL" (BOUNDARY <BOTTOM .OBJECT>))
 459    <REPEAT CR ("STACK" RS1)
 460       <AND <EMPTY? .RS> <EXIT .CR <>>>
 461       <COND (<MONAD? <SET RS1 <1 .RS>>>)
 462             (<==? <1 .RS1> PATTERN>
 463              <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY>)
 464             (<THSET VALRS (.RS1 !.VALRS)>)   >
 465       <THSET RS <REST .RS>>   >
 466    <REPEAT ("STACK" VALRS1)
 467       <AND <EMPTY? .VALRS> <EXIT .CH <>>>
 468       <SET VALRS1 <1 .VALRS>>
 469       <OR <==? <1 .VALRS1> VALUE>
 470           <ERROR MEANINGLESS-RESTRICTION--CHECKRESTRICTS>>
 471       <REPEAT REMTAGS ("STACK" (LOCS <REST .VALRS1 7>))
 472          <AND <EMPTY? .LOCS> <EXIT .REMTAGS<>>>
 473          <COND (<==? <TYPE <IN <1 .LOCS>>> UNASSIGNED>
 474                 <THSETLOC <1 .LOCS> <THDELQ .VALRS1 <IN <1 .LOCS>>>>)   >
 475          <SET LOCS <REST .LOCS>>   >
 476       <MATCH1 <2 .VALRS1> <3 .VALRS1> <4 .VALRS1> <5 .VALRS1>
 477               <6 .VALRS1> <7 .VALRS1>>
 478       <THSET VALRS <REST .VALRS>>   >   >>
 479
 480
 481 <DEFINE MEMRES
 482  <FUNCTION CHECK ("STACK" EXP BOUND ENV RESTRICTIONS "AUX" R1)
 483    <REPEAT ("STACK")
 484       <AND <EMPTY? .RESTRICTIONS> <EXIT .CHECK <>>>
 485       <SET R1 <1 .RESTRICTIONS>>
 486       <COND (<AND <NOT <MONAD? .R1>>
 487                   <==? <1 .R1> PATTERN>
 488                   <==? .ENV <3 .R1>>
 489                   <=UPTO? <2 .R1> .EXP .BOUND>>
 490              <.CHECK T>)   >
 491       <SET RESTRICTIONS <REST .RESTRICTIONS>>   >   >>
 492
 493
 494 <DEFINE =UPTO?
 495  <FUNCTION ("STACK" EXP1 EXP2 BOUND)
 496    <COND (<AND <MONAD? .EXP1> <FULL? .EXP1>>
 497           <=? .EXP1 .EXP2>)
 498          (<AND <MONAD? .EXP2> <FULL? .EXP2>> <>)
 499          (<PROG =CHECK ("STACK")
 500              <COND (<EMPTY? .EXP1> <==? .EXP2 .BOUND>)
 501                    (<==? .EXP2 .BOUND> <>)
 502                    (<=? <1 .EXP1> <1 .EXP2>>
 503                     <SET EXP1 <REST .EXP1>>   <SET EXP2 <REST .EXP2>>
 504                     <AGAIN .=CHECK>)   >>)   >>>\f<DEFINE LINKVARS
 505  <FUNCTION LINKER ("STACK" VARS1 VARS2 PAT1 PAT2 ENV1 ENV2 "OPTIONAL"
 506                      (BOUND1 <BOTTOM .PAT1>) (BOUND2 <BOTTOM .PAT2>)
 507                    "AUX" (LOCS <NCONC <GENLOCS .VARS1 .ENV1>
 508                                       <GENLOCS .VARS2 .ENV2>>))
 509   <REPEAT ("STACK" (LOCS1 .LOCS)
 510            (R [VALUE .PAT1 .PAT2 .ENV1 .ENV2 .BOUND1 .BOUND2 !.LOCS]))
 511       <AND <EMPTY? .LOCS1> <.LINKER .LOCS>>
 512       <THSETLOC <1 .LOCS1>
 513                 <CHTYPE (.R !<CHTYPE <IN <1 .LOCS>> LIST>) UNASSIGNED>>
 514       <SET LOCS1 <REST .LOCS1>>   >   >>
 515
 516
 517 <DEFINE GENLOCS
 518  <FUNCTION ("STACK" "BIND" C VARS ENV)
 519    <COND (<EMPTY? .VARS> ())
 520          (T <SPLICE .C .ENV>
 521             <REPEAT GEN ("STACK" (LOCS ()))
 522                <SET LOCS (<LLOC <1 .VARS>> !.LOCS)>
 523                <SET VARS <REST .VARS>>
 524                <AND <EMPTY? .VARS> <.GEN .LOCS>>   >)   >>>\f\f\ 3\f