ITS Muddle.
authorLars Brinkhoff <lars@nocrew.org>
Sun, 18 Feb 2018 07:14:53 +0000 (08:14 +0100)
committerLars Brinkhoff <lars@nocrew.org>
Sun, 18 Feb 2018 07:55:53 +0000 (08:55 +0100)
65 files changed:
MUDDLE/_test.plannr [new file with mode: 0644]
MUDDLE/actor.45 [new file with mode: 0644]
MUDDLE/agc.168 [new file with mode: 0644]
MUDDLE/arith.58 [new file with mode: 0644]
MUDDLE/atomhk.27 [new file with mode: 0644]
MUDDLE/book.3 [new file with mode: 0644]
MUDDLE/book.4 [new file with mode: 0644]
MUDDLE/c.ubd026 [new file with mode: 0644]
MUDDLE/comp.envr [new file with mode: 0644]
MUDDLE/create.14 [new file with mode: 0644]
MUDDLE/editor.8 [new file with mode: 0644]
MUDDLE/eval.234 [new file with mode: 0644]
MUDDLE/filtrn.5 [new file with mode: 0644]
MUDDLE/flodyn.1 [new file with mode: 0644]
MUDDLE/fopen.63 [new file with mode: 0644]
MUDDLE/graphs.ura001 [new file with mode: 0644]
MUDDLE/initm.42 [new file with mode: 0644]
MUDDLE/mapper.9 [new file with mode: 0644]
MUDDLE/match.18 [new file with mode: 0644]
MUDDLE/medcom.2 [new file with mode: 0644]
MUDDLE/meddle.3 [new file with mode: 0644]
MUDDLE/medpp.1 [new file with mode: 0644]
MUDDLE/microm.1 [new file with mode: 0644]
MUDDLE/mproc.save [new file with mode: 0644]
MUDDLE/muddle.196 [new file with mode: 0644]
MUDDLE/muddle.init [new file with mode: 0644]
MUDDLE/muddle.old [new file with mode: 0644]
MUDDLE/multi.test [new file with mode: 0644]
MUDDLE/nactor.1 [new file with mode: 0644]
MUDDLE/nagc.17 [new file with mode: 0644]
MUDDLE/neval.222 [new file with mode: 0644]
MUDDLE/neval.nostac [new file with mode: 0644]
MUDDLE/ninter.4 [new file with mode: 0644]
MUDDLE/nmain.14 [new file with mode: 0644]
MUDDLE/nmatch.1 [new file with mode: 0644]
MUDDLE/nprint.8 [new file with mode: 0644]
MUDDLE/nptest.4 [new file with mode: 0644]
MUDDLE/nread.14 [new file with mode: 0644]
MUDDLE/nuprm.8 [new file with mode: 0644]
MUDDLE/nutil.1 [new file with mode: 0644]
MUDDLE/nuuoh.12 [new file with mode: 0644]
MUDDLE/omatch.1 [new file with mode: 0644]
MUDDLE/pfunct.12 [new file with mode: 0644]
MUDDLE/pprint.1 [new file with mode: 0644]
MUDDLE/ptest.13 [new file with mode: 0644]
MUDDLE/ptrace.7 [new file with mode: 0644]
MUDDLE/putget.21 [new file with mode: 0644]
MUDDLE/readch.10 [new file with mode: 0644]
MUDDLE/reader.117 [new file with mode: 0644]
MUDDLE/revtes.4 [new file with mode: 0644]
MUDDLE/sptest.6 [new file with mode: 0644]
MUDDLE/stctst.2 [new file with mode: 0644]
MUDDLE/tentab.1 [new file with mode: 0644]
MUDDLE/tester.putget [new file with mode: 0644]
MUDDLE/testsp.4 [new file with mode: 0644]
MUDDLE/ts.midas [new file with mode: 0644]
MUDDLE/ts.muddle [new file with mode: 0644]
MUDDLE/ts.nplnnr [new file with mode: 0644]
MUDDLE/ts.omuddl [new file with mode: 0644]
MUDDLE/ts.plannr [new file with mode: 0644]
MUDDLE/ts.stink [new file with mode: 0644]
MUDDLE/util.21 [new file with mode: 0644]
MUDDLE/vers.2 [new file with mode: 0644]
MUDDLE/}msgs}.muddle [new file with mode: 0644]
README.md

diff --git a/MUDDLE/_test.plannr b/MUDDLE/_test.plannr
new file mode 100644 (file)
index 0000000..0c9b385
--- /dev/null
@@ -0,0 +1,14 @@
+STINK\v
+0MNLOAD >$
+$9B/JUMPA SETUP
+$Y PLANNR LOSS
+$G
+\16 $9B/JUMPA START
+$Y PLANNR WIN
+$G
+
+<FLOAD "PTEST" ">">
+<PATH ALPHA OMEGA>
+
+<FLOAD "MATCH" ">">
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/actor.45 b/MUDDLE/actor.45
new file mode 100644 (file)
index 0000000..4a9b75c
--- /dev/null
@@ -0,0 +1,524 @@
+<DEFINE ACTOR
+  <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR>  >>
+
+<DEFINE ACTOR-FUNCTION
+  <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR-FUNCTION>  >>
+
+<DEFINE ACTOR?
+  <FUNCTION (EXP)
+   <AND <ATOM? .EXP> <SET EXP <AVAL .EXP>>>
+   <AND <MEMQ <TYPE .EXP> '(ACTOR ACTOR-FUNCTION)>
+        .EXP>  >>
+
+<DEFINE ACTORFORM?
+ <FUNCTION (EXP)
+   <AND <MEMQ <TYPE .EXP> '(FORM SEGMENT)>
+        <NOT <EMPTY? .EXP>>
+        <ACTOR? <1 .EXP>>>  >>
+
+
+<DEFINE PRECEDENCE
+ <FUNCTION (ATOM) <OR <GET .ATOM PRECEDENCE> 0>   >>
+
+
+<DEFINE INVOKE
+ <FUNCTION INVOKER (F OBJECT "OPTIONAL" (BOUND <BOTTOM .OBJECT>)
+                      (OBL T) (ENV <>) (OBJENV <>) (PURE? T)
+                      (UV1 <UARGS .F .ENV>)
+                    "AUX" (UV2 ()))
+   <SET F <CHTYPE .F FORM>>
+   <COND (<OR <EMPTY? .UV1> <GET <1 .F> FACTOR>>
+          <.INVOKER <INVOKE1 .F .OBJECT .BOUND .OBL .PURE? .ENV .OBJENV>>)
+         (.PURE?
+          <COND (.OBL)
+                (T <SET BOUND <ANOTHER .OBJECT .BOUND>>)   >)
+         (.OBL
+          <COND (<==? <TYPE .OBJECT> FORM>
+                 <COND (<OR <EMPTY? <SET UV2 <UARGS .OBJECT .OBJENV>>>
+                            <GET <1 .F> FACTOR>>
+                        <.INVOKER <INVOKE1 .OBJECT .F '<> T <> .OBJENV .ENV .UV2>>)   >)
+                (T <SET UV2 <UVARS .OBJECT .BOUND .OBJENV>>)   >)
+         (T <SET OBJECT <FRONT .OBJECT <> <LLOC BOUND> .OBJENV <LLOC UV2>>>)   >
+   <LINKVARS .UV1 .UV2 .F .OBJECT <OR .ENV .TOPMATCH> <OR .OBJENV .TOPMATCH>>
+   .BOUND   >>\f<DEFINE INVOKE1
+ <FUNCTION ("BIND" CUR
+            F OBJECT BOUND OBL PURE? ENV OBJENV
+            "AUX" ACTR VAL)
+   <COND (<OR <EMPTY? .F> <NOT <SET ACTR <ACTOR? <1 .F>>>>>
+          <SET VAL <EVAL .F .ENV>>
+          <COND (.PURE?
+                 <COND (.OBL
+                        <OR <=UPTO? .VAL .OBJECT .BOUND> <FAIL>>
+                        .BOUND)
+                       (T <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUND>)   >)
+                (.OBL
+                 <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> .BOUND>)
+                (T <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>)   >)
+         (<==? <TYPE .ACTR> ACTOR-FUNCTION>
+          <FINSPLICE .CUR .ENV>
+          <EVAL <FORM <CHTYPE .ACTR FUNCTION>
+                      '.OBJECT '.BOUND '.OBL '.PURE? '<OR .ENV .TOPMATCH>
+                      '<OR .OBJENV .PURE? .TOPMATCH> !<REST .F>>>)
+         (<==? <TYPE .ACTR> ACTOR>
+          <FINSPLICE .CUR .ENV>
+          <BIND .ACTR <REST .F>
+                ((BODY <REST .ACTR <COND (<ATOM? <1 .ACTR>> 2) (1)   >>))
+             <APPLY <CHTYPE ,ET FUNCTION> 
+                    (.OBJECT .BOUND .OBL .PURE? <ENVIRON> .OBJENV !.BODY)>   >)
+         (T <ERROR NON-INVOKABLE-TYPE>)   >   >>\f<DEFINE GIVEN
+ <ACTOR-FUNCTION GA (OBJECT BOUNDARY OBLIGATORY PURE? ENV OBJENV VAR
+                     "AUX" (VAL <RLVAL .VAR>) RS (VALRS ()) (UV ()) PURESOFAR NEWVAL
+                           NEWBOUND (VARLOC <LLOC .VAR>) VARFORM RS2)
+   <COND (<ASSIGNED? .VAR>
+          <COND (.OBLIGATORY
+                 <COND (.PURE?
+                        <OR <=UPTO? .VAL .OBJECT .BOUNDARY> <FAIL>>)
+                       (T <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> T .BOUNDARY>)   >
+                 <.GA .BOUNDARY>)
+                (.PURE?
+                 <.GA <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUNDARY>>)
+                (T <.GA <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>>)   >)   >
+   <SET RS <CHTYPE <RLVAL VAL> LIST>>
+   <COND (<AND .PURE? .OBLIGATORY>
+          <THSET .VAR <UPTO .OBJECT .BOUNDARY>>
+          <CHECKRESTRICTS .RS () ..VAR>
+          <.GA .BOUNDARY>)   >
+   <COND (<AND <==? .OBJECT <SET VARFORM <FORM GIVEN .VAR>>>
+               <==? .VARLOC
+                    <EVAL <PUT '<LLOC VAR> 2 .VAR> .OBJENV>>>
+          <.GA .BOUNDARY>)
+         (<SET RS2 <MEMRES .OBJECT .BOUNDARY .OBJENV .RS>>
+          <THPUT .RS2 1 ()>)
+         (T
+          <THSET .VAR ?()>
+          <REPEAT CHECK (RS1)
+             <AND <EMPTY? .RS> <.CHECK <>>>
+             <SET RS1 <1 .RS>>   <SET RS <REST .RS>>
+             <COND (<MONAD? .RS1>)
+                   (<==? <1 .RS1> PATTERN>
+                    <SET BOUNDARY
+                         <COND (.PURE?
+                                <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY .OBLIGATORY>)
+                               (T
+                                <MATCH1 <2 .RS1> .OBJECT <3 .RS1> .OBJENV
+                                        <BOTTOM <2 .RS1>> .BOUNDARY
+                                        .OBLIGATORY>)   >>
+                    <SET OBLIGATORY T>
+                    <COND (<ASSIGNED? .VAR>
+                            <CHECKRESTRICTS .RS .VALRS ..VAR>
+                            <.GA .BOUNDARY>)
+                          (<FULL? <RLVAL .VAR>>
+                            <THSET RS <NCONC <CHTYPE <RLVAL .VAR> LIST>
+                                            .RS>>
+                            <THSET .VAR ?()>)   >)
+                   (T <THSET VALRS (.RS1 !.VALRS)>)   >>)   >
+   <THTRYSET .VARLOC .VARFORM .OBJECT .BOUNDARY .OBLIGATORY .PURE?
+             .ENV .OBJENV .RS .VALRS>   >>
+
+<PUT GIVEN PRECEDENCE 3>\f<DEFINE ALTER
+ <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV VAR)
+   <THTRYSET <LLOC .VAR> <FORM GIVEN .VAR> .OBJECT .BOUND .OBL?
+             .PURE? .ENV .OBJENV>   >>
+
+<PUT ALTER PRECEDENCE 4>
+
+
+<DEFINE BE
+ <ACTOR (PRED)
+   <DO <OR .PRED <FAIL>>>   >>
+
+<PUT BE PRECEDENCE 30>
+
+
+<DEFINE DO
+ <ACTOR (ACTION)
+   <?>   >>
+
+<PUT DO PRECEDENCE 29>
+
+
+<DEFINE ?
+ <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL" (N <>)
+                  "AUX" UV)
+   <COND (.OBL?
+          <COND (.PURE?
+                 <OR <NOT .N>
+                     <==? .N <BLENGTH .OBJECT .BOUND>>
+                     <FAIL>>)
+                (<OR <PROG2 <SET OBJECT <INSTANTIATE .OBJECT UV .BOUND .OBJENV>>
+                            .UV>
+                     <NOT <UNCERTAINLENGTH .OBJECT>>>
+                 <OR <NOT .N> <==? .N <LENGTH .OBJECT>> <FAIL>>)
+                (<EMPTY? .UV> <FAIL>)
+                (T <LINKVARS () .UV <SET FORM1 <FORM ? .N>> .OBJECT
+                             <> .OBJENV .FORM1 .BOUND>)   >
+          .BOUND)
+         (.PURE?
+          <COND (.N
+                 <COND (<G? .N <BLENGTH .OBJECT .BOUND>> <FAIL>)
+                       (T <REST .OBJECT .BOUND>)   >)
+                (T <ANOTHER .OBJECT .BOUND>)   >)
+         (T 
+          <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV>>
+          <COND (.N
+                 <OR <==? .N <LENGTH .OBJECT>> <FAIL>>)   >
+          .BOUND)   >   >>
+
+<PUT ? PRECEDENCE 2>\f<DEFINE ET
+ <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS)
+   <REPEAT ACTITER
+                <COND (<EMPTY? .PATS>
+                       <.ACTITER <COND (.OBL? .BOUND)
+                                       (.PURE? <ANOTHER .OBJECT .BOUND>)
+                                       (T <REAR .OBJECT .OBJENV .BOUND>)   >>)   >
+                <SET BOUND
+                     <COND (.PURE?
+                            <IS1 <1 .PATS> .OBJECT .ENV .BOUND .OBL?>)
+                           (T <MATCH1 <1 .PATS>
+                                      .OBJECT
+                                      .ENV
+                                      .OBJENV
+                                      <BOTTOM <1 .PATS>>
+                                      .BOUND
+                                      .OBL?>)   >>
+                <SET OBL? T>
+                <THSET PATS <REST .ITER>>   >   >>
+
+<PUT ET PRECEDENCE 10>   <PUT ET FACTOR T>
+
+
+
+<DEFINE VEL
+ <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS
+                  "AUX" (PAT1 <CLIP PATS>))
+   <COND (.PURE?
+         <IS1 .PAT1 .OBJECT <> .BOUND .OBL?>)
+        (T <MATCH1 .PAT1 .OBJECT <> .OBJENV <BOTTOM .PAT1> .BOUND .OBL?>)   >   >>
+
+
+<PUT VEL PRECEDENCE 20>   <PUT VEL FACTOR T>
+
+<DEFINE NON
+ <ACTOR-FUNCTION (OBJECT BOUND OBL? PURE? ENV OBJENV 'PAT)
+   <OR .OBL?
+       <SET OBJECT
+            <COND (.PURE? <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>)
+                  (T <FRONT .OBJECT <> <LLOC BOUND> .OBJENV>)   >>   >
+   <FAILPOINT NAY-SAYER ()
+      <PROG2 <COND (.PURE? <IS1 .PAT .OBJECT>)
+                   (T <MATCH1 .PAT .OBJECT <> .OBJENV>)   >
+             <FAIL <> .NAY-SAYER>>
+      ()
+      <.NAY-SAYER .BOUND>   >>>
+
+<PUT NON PRECEDENCE 6>   <PUT NON FACTOR T>\f<DEFINE WHEN
+ <ACTOR-FUNCTION WA (OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'CLAUSES
+                     "AUX" (CLAUSE <CLIP CLAUSES>) NEWBOUND)
+   <SET NEWBOUND
+        <COND (<EMPTY? .CLAUSE> <ERROR EMPTY-CLAUSE--WHEN>)
+              (.PURE? <IS1 <1 .CLAUSE> .OBJECT <> .BOUND .OBL?>)
+              (T <MATCH1 <1 .CLAUSE> .OBJECT <> .OBJENV
+                         <BOTTOM <1 .CLAUSE>> .BOUND .OBL?>)   >>
+   <FAILPOINT () <> () <FAIL <> .WA>>
+   <APPLY <CHTYPE ,ET FUNCTION>
+          (.OBJECT .NEWBOUND T .PURE? .ENV .OBJENV !<REST .CLAUSE>)>
+   .NEWBOUND   >>
+
+<PUT WHEN PRECEDENCE 25>   <PUT WHEN FACTOR T>\f<DEFINE THTRYSET
+ <FUNCTION (VARLOC VARFORM OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL"
+              (RS ()) (VALRS ()) 
+            "AUX" VAR2)
+   <COND (.OBL?
+          <COND (.PURE?
+                 <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC <UPTO .OBJECT .BOUND>>>)
+                (<PROG2
+                    <SET OBJECT <INSTANTIATE .OBJECT PURE? .BOUND .OBJENV>>
+                    .PURE?>
+                 <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
+
+                (<SET VAR2 <UVAR? .OBJECT>>
+                 <THPSEUDOSETLOC <LLOC .VAR2> .VARFORM .ENV>
+                 <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>)
+                (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>)   >)
+         (.PURE?
+          <THSETLOC .VARLOC <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>>)
+         (<PROG2
+             <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV <LLOC PURE?>>>
+             .PURE?>
+          <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
+         (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>)   >
+   .BOUND   >>
+
+
+<DEFINE THIMPURESETLOC
+   <FUNCTION (LOC UV VARFORM OBJECT ENV OBJENV)
+   <COND (<MEMQ .VARLOC <LINKVARS () .UV .VARFORM .OBJECT .ENV .OBJENV>>
+          <FAIL>)
+         (T <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>)   >  >>
+
+
+<DEFINE THPSEUDOSETLOC
+ <FUNCTION (LOC OBJ OBJENV)
+   <THSETLOC .LOC 
+             <CHTYPE ([PATTERN .OBJ .OBJENV] !<CHTYPE <IN .LOC> LIST>)
+                     UNASSIGNED>>   >>\f<DEFINE PREFIX1
+ <FUNCTION P (L1 TERM1 L2 TERM2)
+   <COND (<OR <EMPTY? .L1> <==? .L1 .TERM1>>
+          <EXIT .P .L2>)
+         (<==? .L2 .TERM2> <FAIL>)>
+   <OR <=? <1 .L1> <1 .L2>> <FAIL>>
+   <SET L1 <REST .L1>>   <SET L2 <REST .L2>>
+   <AGAIN .P>  >>
+
+
+
+<DEFINE FRONT
+ <FUNCTION ("BIND" CUR
+            OBJECT EV? BOUNDLOC "OPTIONAL" (ENV <>)
+               (PURELOC <>)
+            "AUX" V P (LP <LLOC P>) (CONSTRUCT <CONSTRUCTOR <TYPE .OBJECT>>)
+               (BOUND <IN .BOUNDLOC>))
+   <SETLOC .BOUNDLOC .OBJECT>
+   <AND .PURELOC <SETLOC .PURELOC ()>>
+   <FINSPLICE .CUR .ENV>
+   <SET RESULT
+      <FAILPOINT EXTENDER ()
+         <BOTTOM .OBJECT>
+         ()
+         <COND (<==? .OBJECT .BOUND> <FAIL>)
+               (<==? <TYPE <1 .OBJECT>> SEGMENT>
+                <SET V <FORMSUBST <1 .OBJECT> .LP>>
+                <COND (<EMPTY? .V>
+                       <SET OBJECT <REST .OBJECT>>
+                       <AGAIN .EXTENDER>)   >
+                <SET OBJECT <BACKTO .OBJECT <REST .V> .BOUNDLOC>>
+                <RESTORE .EXTENDER <.CONSTRUCT !.RESULT <1 .V>>>)
+               (.EV? <SET V <INSTANTIATE <1 .OBJECT> P>>
+                     <AND .PURELOC <NOT .P> <SETLOC .PURELOC <NCONC .P <IN .PURELOC>>>>
+                     <SETLOC .BOUNDLOC <SET OBJECT <REST .OBJECT>>>
+                     <RESTORE .EXTENDER <.CONSTRUCT !.RESULT .V>>)
+               (T <AND .PURELOC
+                       <FULL? <SET P <UVARS <1 .OBJECT>>>>
+                       <SETLOC .PURELOC <NCONC <CHTYPE .P FALSE> <IN .PURELOC>>>>
+                  <RESTORE .EXTENDER
+                           <PROG1 <.CONSTRUCT !.RESULT <1 .OBJECT>>
+                                  <SETLOC .BOUNDLOC  <SET OBJECT <REST .OBJECT>>>>>)   >>>  >>\f<DEFINE REAR
+ <FUNCTION ("BIND" CUR
+            OBJECT "OPTIONAL" (ENV <>) (BOUND <BOTTOM .OBJECT>)
+            "AUX" V P (LP <LLOC P>))
+   <FINSPLICE .CUR .ENV>
+   <FAILPOINT CHOPPER ()
+      .BOUND
+      ()
+      <COND (<==? .OBJECT .BOUND> <FAIL>)
+            (<==? <TYPE <1 .OBJECT>> SEGMENT>
+             <SET V <FORMSUBST <1 .OBJECT> .LP>>
+             <COND (<EMPTY? .V>
+                    <SET OBJECT <REST .OBJECT>>
+                    <AGAIN .CHOPPER>)   >
+             <RESTORE .CHOPPER <SET OBJECT <BACKTO .OBJECT <REST .V>>>>)
+            (T <RESTORE .CHOPPER <SET OBJECT <REST .OBJECT>>>)   >   >>>\f<DEFINE INSTANTIATE
+ <FUNCTION ("BIND" CUR
+            EXP UVAR "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
+              (LUV <LLOC .UVAR>))
+   <FINSPLICE .CUR .ENV>
+   <COND (<==? <TYPE .EXP> FORM>
+          <FORMSUBST .EXP .LUV>)
+         (<MONAD? .EXP>
+          <SETLOC .LUV ()>
+          .EXP)
+         (T <INSTANTIATE1 .EXP .LUV .BOUND>)   >>>
+
+
+<DEFINE INSTANTIATE1
+ <FUNCTION INSTLP (EXP LUV "OPTIONAL" (BOUND <BOTTOM .EXP>)
+                   "AUX" (RESULT ()) (P ()) P1 (LP1 <LLOC P1>) EXP1)
+   <COND (<==? .EXP .BOUND> <SETLOC .LUV .P>
+          <.INSTLP <REVERSE .RESULT <CONSTRUCTOR <TYPE .EXP>>>>)
+         (<==? <TYPE <SET EXP1 <1 .EXP>>> SEGMENT>
+          <SET RESULT (<REVERSE <FORMSUBST .EXP1 .LP1> ,CONSL>
+                       !.RESULT)>)
+         (T <SET RESULT (<INSTANTIATE .EXP1 P1> !.RESULT)>)   >
+   <OR .P1 <SET P <NCONC .P1 .P>>>
+   <SET EXP <REST .EXP>>
+   <AGAIN .INSTLP>   >>
+
+
+<DEFINE FORMSUBST
+ <FUNCTION (F PURELOC "AUX" P A1 VAR)
+   <COND (<FULL? <SET P <UARGS .F>>>
+          <SETLOC .PURELOC <CHTYPE .P FALSE>>
+          .F)
+         (<OR <EMPTY? .F> <NOT <SET A1 <ACTOR? <1 .F>>>>>
+          <SETLOC .PURELOC ()>
+          <EVAL .F>)
+         (<EMPTY? <REST .F>>
+          <SETLOC .PURELOC <>>
+          .F)
+         (<==? .A1 ,ALTER>
+          <THSET <SET VAR <EVAL <2 .F>>> ?()>
+          <SETLOC .PURELOC <FALSE .VAR>>
+          <FORM GIVEN .VAR>)
+         (<==? .A1 ,GIVEN>
+          <COND (<ASSIGNED? <SET VAR <EVAL <2 .F>>>>
+                 <SETLOC .PURELOC ()>
+                 <LVAL .VAR>)
+                (T <SETLOC .PURELOC <FALSE .VAR>>
+                   .F)   >)
+         (T <SETLOC .PURELOC <>>
+            .F)   >>>\f<DEFINE UVARS
+ <FUNCTION ("BIND" CUR
+            EXP "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
+            "AUX" UA ACTR VAR)
+   <FINSPLICE .CUR .ENV>
+   <COND (<==? <TYPE .EXP> FORM>
+          <COND (<FULL? <SET UA <UARGS .EXP>>> .UA)
+                (<AND <==? <LENGTH .EXP> 2>
+                      <SET ACTR <ACTOR? <1 .EXP>>>>
+                 <COND (<==? .ACTR ,GIVEN>
+                        <COND (<OR <NOT <BOUND? <SET VAR <EVAL <2 .EXP>>>>>
+                                   <UNASSIGNED? .VAR>>
+                               (.VAR))   >)
+                       (<==? .ACTR ,ALTER>
+                        <THSET <SET VAR <EVAL <2 .EXP>>> ?()>
+                        (.VAR))   >)   >)
+         (<==? .EXP .BOUND> ())
+         (T <NCONC <UVARS <1 .EXP>> <UVARS <REST .EXP> .BOUND>>)   >>>
+
+
+<DEFINE UARGS
+ <FUNCTION ("BIND" C
+            F "OPTIONAL" (ENV <>)
+            "AUX" VAR)
+   <FINSPLICE .C .ENV>
+   <COND (<MULTILEVEL .F>
+          <COND (<AND <MEMQ <TYPE .F> '(FORM SEGMENT)>
+                      <==? <1 .F> LVAL>
+                      <ATOM? <SET VAR <2 .F>>>
+                      <OR <NOT <BOUND? .VAR>> <UNASSIGNED? .VAR>>>
+                 (.VAR))
+                (T <MAPCAN ,UARGS .F>)   >)   >   >>
+
+
+<DEFINE UVAR?
+ <FUNCTION (OBJECT "AUX" RES)
+   <AND <==? <TYPE .OBJECT> FORM>
+        <==? <LENGTH .OBJECT> 2>
+        <==? <1 .OBJECT> GIVEN>
+        <ATOM? <SET RES <EVAL <2 .OBJECT>>>>
+        .RES>   >>
+
+
+<DEFINE UNCERTAINLENGTH
+ <FUNCTION (OBJECT)
+   <OR <==? <TYPE .OBJECT> FORM>
+       <AND <MULTILEVEL .OBJECT>
+            <MAPC #FUNCTION ((EL) <AND <==? <TYPE .EL> SEGMENT> <.UNC T>>)
+                  .OBJECT>
+            <>>>   >>\f<DEFINE UPTO
+ <FUNCTION (OBJECT BOUNDARY)
+   <COND (<MONAD? .OBJECT> .OBJECT)
+         (T <REVERSE <UPTO1 .OBJECT .BOUNDARY>
+                     <CONSTRUCTOR <TYPE .OBJECT>>>)   >   >>
+
+
+<DEFINE UPTO1
+ <FUNCTION LOOP (OBJ BOU "AUX" (RES ()))
+   <COND (<==? .OBJ .BOU> .RES)
+         (T <SET RES (<1 .OBJ> !.RES)>
+            <SET OBJ <REST .OBJ>>
+            <AGAIN .LOOP>)   >>>
+
+
+<DEFINE BACKTO
+ <FUNCTION (PAT BEG "OPTIONAL" (BOUNDLOC <>))
+   <COND (<EMPTY? .BEG> .PAT)
+         (<ISREST .PAT .BEG> .BEG)
+         (T <SET PAT <REVERSE (!<REVERSEUPTO .PAT <IN .BOUNDLOC>>
+                               !<REVERSE .BEG ,CONSL>)
+                              <CONSTRUCTOR <TYPE .PAT>>>>
+            <SETLOC .BOUNDLOC <BOTTOM .PAT>>
+             .PAT)   >>>
+
+
+<DEFINE REVERSEUPTO
+ <FUNCTION REV (EXP1 EXP2 "AUX" (RESULT()))
+   <COND (<==? .EXP1 .EXP2> .RESULT)
+         (T <SET RESULT (<1 .EXP1> !.RESULT)>
+            <SET EXP1 <REST .EXP1>>
+            <AGAIN .REV>)   >>>
+
+
+<DEFINE ISREST
+ <FUNCTION CHECKER (EXP1 EXP2)
+   <COND (<==? .EXP1 .EXP2> T)
+         (<EMPTY? .EXP2> <>)
+         (T <SET EXP2 <REST .EXP2>>
+            <AGAIN .CHECKER>)   >>>\f<DEFINE CHECKRESTRICTS
+ <FUNCTION CH (RS VALRS OBJECT "OPTIONAL" (BOUNDARY <BOTTOM .OBJECT>))
+   <REPEAT CR (RS1)
+      <AND <EMPTY? .RS> <EXIT .CR <>>>
+      <COND (<MONAD? <SET RS1 <1 .RS>>>)
+            (<==? <1 .RS1> PATTERN>
+             <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY>)
+            (<THSET VALRS (.RS1 !.VALRS)>)   >
+      <THSET RS <REST .RS>>   >
+   <REPEAT (VALRS1)
+      <AND <EMPTY? .VALRS> <EXIT .CH <>>>
+      <SET VALRS1 <1 .VALRS>>
+      <OR <==? <1 .VALRS1> VALUE>
+          <ERROR MEANINGLESS-RESTRICTION--CHECKRESTRICTS>>
+      <REPEAT REMTAGS ((LOCS <REST .VALRS1 7>))
+         <AND <EMPTY? .LOCS> <EXIT .REMTAGS<>>>
+         <COND (<==? <TYPE <IN <1 .LOCS>>> UNASSIGNED>
+                <THSETLOC <1 .LOCS> <THDELQ .VALRS1 <IN <1 .LOCS>>>>)   >
+         <SET LOCS <REST .LOCS>>   >
+      <MATCH1 <2 .VALRS1> <3 .VALRS1> <4 .VALRS1> <5 .VALRS1>
+              <6 .VALRS1> <7 .VALRS1>>
+      <THSET VALRS <REST .VALRS>>   >   >>
+
+
+<DEFINE MEMRES
+ <FUNCTION CHECK (EXP BOUND ENV RESTRICTIONS "AUX" R1)
+   <REPEAT ()
+      <AND <EMPTY? .RESTRICTIONS> <EXIT .CHECK <>>>
+      <SET R1 <1 .RESTRICTIONS>>
+      <COND (<AND <NOT <MONAD? .R1>>
+                  <==? <1 .R1> PATTERN>
+                  <==? .ENV <3 .R1>>
+                  <=UPTO? <2 .R1> .EXP .BOUND>>
+             <.CHECK T>)   >
+      <SET RESTRICTIONS <REST .RESTRICTIONS>>   >   >>
+
+
+<DEFINE =UPTO?
+ <FUNCTION (EXP1 EXP2 BOUND)
+   <COND (<AND <MONAD? .EXP1> <FULL? .EXP1>>
+          <=? .EXP1 .EXP2>)
+         (<AND <MONAD? .EXP2> <FULL? .EXP2>> <>)
+         (<PROG =CHECK ()
+             <COND (<EMPTY? .EXP1> <==? .EXP2 .BOUND>)
+                   (<==? .EXP2 .BOUND> <>)
+                   (<=? <1 .EXP1> <1 .EXP2>>
+                    <SET EXP1 <REST .EXP1>>   <SET EXP2 <REST .EXP2>>
+                    <AGAIN .=CHECK>)   >>)   >>>\f<DEFINE LINKVARS
+ <FUNCTION LINKER (VARS1 VARS2 PAT1 PAT2 ENV1 ENV2 "OPTIONAL"
+                     (BOUND1 <BOTTOM .PAT1>) (BOUND2 <BOTTOM .PAT2>)
+                   "AUX" (LOCS <NCONC <GENLOCS .VARS1 .ENV1>
+                                      <GENLOCS .VARS2 .ENV2>>))
+  <REPEAT ((LOCS1 .LOCS)
+           (R [VALUE .PAT1 .PAT2 .ENV1 .ENV2 .BOUND1 .BOUND2 !.LOCS]))
+      <AND <EMPTY? .LOCS1> <.LINKER .LOCS>>
+      <THSETLOC <1 .LOCS1>
+                <CHTYPE (.R !<CHTYPE <IN <1 .LOCS>> LIST>) UNASSIGNED>>
+      <SET LOCS1 <REST .LOCS1>>   >   >>
+
+
+<DEFINE GENLOCS
+ <FUNCTION ("BIND" C VARS ENV)
+   <COND (<EMPTY? .VARS> ())
+         (T <SPLICE .C .ENV>
+            <REPEAT GEN ((LOCS ()))
+               <SET LOCS (<LLOC <1 .VARS>> !.LOCS)>
+               <SET VARS <REST .VARS>>
+               <AND <EMPTY? .VARS> <.GEN .LOCS>>   >)   >>>\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/agc.168 b/MUDDLE/agc.168
new file mode 100644 (file)
index 0000000..0182add
--- /dev/null
@@ -0,0 +1,1834 @@
+TITLE AGC MUDDLE GARBAGE COLLECTOR
+;SYSTEM WIDE DEFINITIONS GO HERE
+.GLOBAL PDLBUF,VECTOP,VECBOT,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,WRONGT
+.GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,TMA,TFA,PPGROW
+
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+
+
+PDLBUF=100
+TPMAX==5000    ;PDLS LARGER THAN THIS WILL BE SHRUNK
+PMAX==1000     ;MAXIMUM PSTACK SIZE
+TPMIN==100     ;MINIMUM PDL SIZES
+PMIN==100
+TPGOOD==2000   ; A GOOD STACK SIZE
+PGOOD==1000
+
+RELOCATABLE
+.INSRT MUDDLE >
+
+TYPNT=AB       ;SPECIAL AC USAGE DURING GC
+F=TP                           ;ALSO SPECIAL DURING GC
+LPVP=SP                                ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN
+
+;FUNCTION TO CONSTRUCT A LIST
+MFUNCTION CONS,SUBR
+       ENTRY   2
+       HLRZ    A,2(AB)         ;GET TYPE OF 2ND ARG
+       CAIE    A,TLIST         ;LIST?
+       JRST    BADTYP          ;NO , COMPLAIN
+       HLRZ    A,(AB)          ;GET TYPE OF FIRST
+       PUSHJ   P,NWORDT        ;GET NO. OF WORDS NEEDED FOR DATUM
+       SOJN    A,CDEFER        ;GREATER THAN 1, MUST MAKE DEFERRED POINTER
+       MOVEI   A,2             ;SET UP CALL TO CELL
+       PUSHJ   P,CELL
+       HLLZ    A,(AB)          ;TYPE OF FIRST ARG
+       MOVE    C,1(AB)         ;GET DATUM
+CFINIS:        PUSHJ   P,CLOBIT        ;STORE
+       JRST    FINIS
+
+;HERE TO STORE IN PAIR
+
+CLOBIT:        HRR     A,3(AB)         ;GET CDR
+CLOBT1:        MOVEM   A,(B)           ;STORE FIRST
+       MOVEM   C,1(B)          ;AND SECOND
+       MOVSI   A,TLIST         ;GET FINAL TYPE
+       POPJ    P,
+
+;HERE FOR A DEFERRED CONS
+
+CDEFER:        MOVEI   A,4             ;NEED 4 CELLS
+       PUSHJ   P,CELL
+       MOVE    A,(AB)          ;GET COMPLETE 1ST WORD
+       MOVE    C,1(AB)         ;AND SECOND
+       PUSHJ   P,CLOBT1        ;STORE
+       MOVE    C,B             ;POINT TO DEFERRED PAIR WITH C
+       ADDI    B,2             ;POINT TO OTHER PAIR
+       MOVSI   A,TDEFER        ;GET TYPE
+       JRST    CFINIS
+
+\f
+;THIS ROUTINE ALLOCATES A CELL
+CELL:  MOVE    B,PARTOP        ;GET TOP OF PAIRS
+       ADD     B,A             ;FIND PROPOSED NEW TOP
+       CAMLE   B,VECBOT        ;CROSSING INTO VECTORS?
+       JRST    FULL            ;YES, GO COLLECT GARBAGE
+       EXCH    B,PARTOP        ;NO, SET NEW TOP AND RETURN POINTER
+       POPJ    P,
+
+FULL:  MOVEM   A,GETNUM        ;STORE WORDS NEEDED
+       SETZM   PARNEW          ;NO MOVEMENT NEEDED
+       PUSHJ   P,AGC           ;COLLECT GARBAGE
+       JRST    CELL            ;AND TRY AGAIN
+
+
+;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT
+
+NWORDT:        PUSHJ   P,SAT           ;GET STORAGE ALLOC TYPE
+NWORDS:        SKIPL   MKTBS(A)        ;-ENTRY IN TABLE MEANS 2 NEEDED
+       SKIPA   A,[1]           ;NEED ONLY 1
+       MOVEI   A,2             ;NEED 2
+       POPJ    P,
+
+\f
+;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+MFUNCTION LIST,SUBR
+       ENTRY
+
+       HLRE    A,AB            ;GET -NUM OF ARGS
+       MOVNS   A               ;MAKE IT +
+       JUMPE   A,LISTN         ;JUMP IF 0
+       PUSHJ   P,CELL          ;GET NUMBER OF CELLS
+       PUSH    TP,$TLIST       ;SAVE IT
+       PUSH    TP,B
+       LSH     A,-1            ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL:        ADDI    B,2             ;LOOP TO CHAIN ELEMENTS
+       HRRZM   B,-2(B)         ;CHAIN LAST ONE TO NEXT ONE
+       SOJG    A,.-2           ;LOOP TIL ALL DONE
+       CLEARM  B,-2(B)         ;SET THE  LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+       MOVE    B,(TP)          ;RESTORE LIS POINTER
+LISTLP:        HLRZ    A,(AB)          ;GET TYPE
+       PUSHJ   P,NWORDT        ;GET NUMBER OF WORDS
+       SOJN    A,LDEFER        ;NEED TO DEFER POINTER
+       HLLZ    A,(AB)          ;NOW CLOBBER ELEMENTS
+       HLLM    A,(B)
+       MOVE    A,1(AB)         ;AND VALUE..
+       MOVEM   A,1(B)
+LISTL2:        ADDI    B,2             ;STEP B
+       ADD     AB,[2,,2]       ;STEP ARGS
+       JUMPL   AB,LISTLP
+
+       POP     TP,B
+       POP     TP,A
+       JRST    FINIS
+
+; MAKE A DEFERRED POINTER
+
+LDEFER:        PUSH    TP,$TLIST       ;SAVE CURRENT POINTER
+       PUSH    TP,B
+       MOVEI   A,2             ; SET UP TO GET CELLS
+       PUSHJ   P,CELL
+       MOVE    A,(AB)          ;GET FULL DATA
+       MOVE    C,1(AB)
+       PUSHJ   P,CLOBT1
+       MOVE    C,(TP)          ;RESTORE LIST POINTER
+       MOVEM   B,1(C)          ;AND MAKE THIS BE THE VALUE
+       MOVSI   A,TDEFER
+       HLLM    A,(C)           ;AND STORE IT
+       MOVE    B,C
+       SUB     TP,[2,,2]
+       JRST    LISTL2
+
+LISTN: MOVEI   B,0
+       MOVSI   A,TLIST
+       JRST    FINIS
+\fBADTYP:       PUSH    TP,$TATOM       ;ARGUMENT OF TYPE ATOM
+       PUSH    TP,MQUOTE 2ND-ARGUMENT-NOT-A-LIST
+       JRST    CALER1          ;OFF TO ERROR HANDLER
+
+
+\f;FUNCTION WHICH CONSES ITS ARGUMENT WITH NIL
+MFUNCTION NCONS,SUBR
+       ENTRY   1
+       PUSH    TP,(AB)         ;SET UP CONS CALL
+       PUSH    TP,1(AB)
+       PUSH    TP,$TLIST
+       PUSH    TP,[0]
+       MCALL   2,CONS
+       JRST    FINIS
+
+\f;FUNCTION TO GENERATE A VECTOR IN VECTOR SPACE
+;CALLED WITH ONE FIXNUM ARGUMENT, WHICH IS THE NUMBER OF ELEMENTS DESIRED.
+
+MFUNCTION VECTOR,SUBR
+       ENTRY
+       MOVEI   C,1             ;THIS IS A GENERAL VECTOR
+VECTO3:        JUMPGE  AB,TFA          ;TOO FEW ARGS
+       CAMGE   AB,[-4,,0]      ;ASSURE NOT TOO MANY
+       JRST    TMA
+       HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
+       CAIE    A,TFIX          ;IS IT A FIXED NUMBER?
+       JRST    BDTYPV          ;NO,  GO COMPLAIN
+       SKIPGE  A,1(AB)         ;GET LENGTH
+       JRST    BADNUM          ;LOSING NUMBER
+       ASH     A,(C)           ;TIMES TWO FOR NUMBER OF WORDS IF GENERAL
+       ADDI    A,2             ;PLUS TWO FOR DOPEWDS
+VECTO2:        MOVE    B,VECBOT        ;GET CURRENT BOTTOM OF VECTORS
+       SUB     B,A             ;AND SUBTRACT THE WORDS IN THIS VECTOR
+       CAMGE   B,PARTOP        ;HAVE WE BUMPED INTO PAIR SPACE?
+       JRST    VECTO1          ;YES, GO GARBAGE COLLECT
+       EXCH    B,VECBOT        ;UPDATE VECBOT, GET OLD POINTER
+       HRLZM   A,-1(B)         ;PUT LENGTH IN DOPE WORD FIELD.
+       MOVSI   D,400000        ;PREPARE TO SET NONUNIFORM BIT
+       JUMPE   C,.+2           ;DONT SET IF UNIFORM
+       MOVEM   D,-2(B)         ;CLOBBER IT IN
+       HRRO    B,VECBOT        ;AND GET TOP OF VECTOR IN RH, -1 IN LH.
+       TLC     B,-3(A)         ;SET LH OF ANSWER TO NEGATIVE COUNT
+       MOVSI   A,TVEC          ;AND GET TYPE VECTOR TO MARK B AS AN AOBJN POINTER TO A VECTOR
+       CAML    AB,[-2,,0]      ;SKIP IF 2 ARGS SUPPLIED
+       JRST    VFINIS          ;ONLY ONE, LEAVE
+       JUMPE   C,UINIT         ;JUMP IF NOT GENERAL VECTOR
+
+       JUMPGE  B,FINIS         ;ZERO LENGTH, DONT INIT
+       PUSH    TP,A
+       PUSH    TP,B
+       PUSH    TP,A
+       PUSH    TP,B            ;SAVE THE VECTOR
+
+INLP:  PUSH    TP,2(AB)
+       PUSH    TP,3(AB)                ;PUSH FORM TO BE EVALLED
+       MCALL   1,EVAL
+       MOVE    C,(TP)          ;RESTORE VECTOR
+       MOVEM   A,(C)
+       MOVEM   B,1(C)          ;CLOBBER
+       ADD     C,[2,,2]
+       MOVEM   C,(TP)
+       JUMPL   C,INLP          ;JUMP TO DO NEXT
+
+GETVEC:        MOVE    A,-3(TP)
+       MOVE    B,-2(TP)
+       SUB     TP,[4,,4]       ;GC TP
+       JRST    FINIS
+
+UINIT: PUSH    TP,$TUVEC
+       PUSH    TP,B
+       PUSH    TP,$TUVEC
+       PUSH    TP,B
+       PUSH    P,[-1]          ;WILL HOLD TYPE
+
+UINLP: PUSH    TP,2(AB)
+       PUSH    TP,3(AB)
+       MCALL   1,EVAL
+       HLRZS   A               ;TYPE TO RH
+       SKIPGE  (P)             ;SKIP IF 1ST SEEN
+       JRST    SET1ST
+       CAME    A,(P)
+       JRST    WRNGUT
+UINLP1:        MOVE    C,(TP)
+       MOVEM   B,(C)
+       AOBJP   C,.+3
+       MOVEM   C,(TP)
+       JRST    UINLP           ;AND CONTINUE
+
+       POP     P,A             ;RESTORE TYPE
+       HRLZM   A,(C)           ;CLOBBER UNIFORM TYPE
+       JRST    GETVEC
+
+SET1ST:        MOVEM   A,(P)
+       PUSHJ   P,NWORDT
+       SOJN    A,CANTUN
+       JRST    UINLP1
+
+VFINIS:        JUMPN   C,FINIS
+       MOVSI   A,TUVEC
+       JRST    FINIS
+
+
+;FUNCTION TO GENERATE A UNIFOM VECTOR
+
+MFUNCTION UVECTOR,SUBR
+
+       MOVEI   C,0             ;SET FOR A UNIFORM HACK
+       JRST    VECTO3
+
+BADNUM:        PUSH    TP,$TATOM       ;COMPLAIN
+       PUSH    TP,MQUOTE NEGATIVE-ARGUMENT
+       JRST    CALER1
+\fBDTYPV:       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-INTEGER-ARGUMENT
+       JRST    CALER1
+
+VECTO1:        SETZM   PARNEW          ;CLEAR RELOCATION OF PAIR SPACE
+       MOVEM   A,GETNUM        ;SAVE NUMBER OF WORDS TO GET
+       PUSHJ   P,AGC           ;GARBAGE COLLECT
+       JRST    VECTO3          ;AND TRY AGAIN
+
+MFUNCTION EVECTOR,SUBR
+       ENTRY
+       HLRE    A,AB
+       MOVNS   A
+       PUSH    P,A             ;SAVE NUMBER OF WORDS
+       ASH     A,-1            ;FOR VECTOR TO WIN NEED NO. OF ELEMENTS
+       PUSH    TP,$TFIX
+       PUSH    TP,A
+       MCALL   1,VECTOR
+
+       POP     P,D             ;RESTORE NUMBER OF WORDS
+       HRLI    C,(AB)          ;START BUILDING BLT POINTER
+       HRRI    C,(B)           ;TO ADDRESS
+       ADDI    D,(B)-1         ;SET D TO FINAL ADDRESS
+       BLT     C,(D)
+       JRST    FINIS
+
+;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+MFUNCTION EUVECTOR,SUBR
+
+       ENTRY
+       HLRE    A,AB            ;-NUM OF ARGS
+       MOVNS   A
+       ASH     A,-1            ;NEED HALF AS MANY WORDS
+       PUSH    TP,$TFIX
+       PUSH    TP,A
+       GETYP   A,(AB)          ;GET FIRST ARG
+       PUSHJ   P,NWORDT                ;SEE IF NEEDS EXTRA WORDS
+       SOJN    A,CANTUN
+       MCALL   1,UVECTOR               ;GET THE VECTOR
+
+       GETYP   C,(AB)          ;GET THE FIRST TYPE
+       MOVE    D,AB            ;COPY THE ARG POINTER
+       MOVE    E,B             ;COPY OF RESULT
+
+EUVLP: GETYP   0,(D)           ;GET A TYPE
+       CAIE    0,(C)           ;SAME?
+       JRST    WRNGUT          ;NO , LOSE
+       MOVE    0,1(D)          ;GET GOODIE
+       MOVEM   0,(E)           ;CLOBBER
+       ADD     D,[2,,2]        ;BUMP ARGS POINTER
+       AOBJN   E,EUVLP
+
+       HRLM    C,(E)           ;CLOBBER UNIFORM TYPE IN
+       JRST    FINIS
+
+WRNGUT:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+       JRST    CALER1
+
+CANTUN:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+       JRST    CALER1
+
+\f
+; FUNCTION TO GROW A VECTOR
+
+MFUNCTION GROW,SUBR
+
+       ENTRY   3
+
+       MOVEI   D,0             ;STACK HACKING FLAG
+       HLRZ    A,(AB)          ;FIRST TYPE
+       PUSHJ   P,SAT           ;GET STORAGE TYPE
+       HLRZ    B,2(AB)         ;2ND ARG
+       CAIE    A,STPSTK        ;IS IT ASTACK
+       CAIN    A,SPSTK
+       AOJA    D,GRSTCK        ;YES, WIN
+       CAIE    A,SNWORD        ;UNIFORM VECTOR
+       CAIN    A,S2NWORD       ;OR GENERAL
+GRSTCK:        CAIE    B,TFIX          ;IS 2ND FIXED
+       JRST    WRONGT          ;COMPLAIN
+       HLRZ    B,4(AB)
+       CAIE    B,TFIX          ;3RD ARG
+       JRST    WRONGT          ;LOSE
+
+       MOVEI   E,1             ;UNIFORM/GENERAL FLAG
+       CAIE    A,SNWORD        ;SKIP IF UNIFORM
+       CAIN    A,SPSTK         ;DONT SKIP IF UNIFORM PDL
+       MOVEI   E,0
+
+       HRRZ    B,1(AB)         ;POINT TO START
+       HLRE    A,1(AB)         ;GET -LENGTH
+       SUB     B,A             ;POINT TO DOPE WORD
+       SKIPE   D               ;SKIP IF NOT STACK
+       ADDI    B,PDLBUF        ;FUDGE FOR PDL
+       HLLZS   (B)             ;ZERO OUT GROWTH SPECS
+       SKIPN   A,3(AB)         ;ANY TOP GROWTH?
+       JRST    GROW1           ;NO, LOOK FOR BOTTOM GROWTH
+       ASH     A,(E)           ;MULT BY 2 IF GENERAL
+       ADDI    A,77            ;ROUND TO NEAREST BLOCK
+       ANDCMI  A,77            ;CLEAR LOW ORDER BITS
+       ASH     A,9-6           ;DIVIDE BY 100 AND SHIFT TO POSTION
+       TRZE    A,400000        ;CONVERT TO SIGN MAGNITUDE
+       MOVNS   A
+       TLNE    A,-1            ;SKIP IF NOT TOO BIG
+       JRST    GTOBIG          ;ERROR
+GROW1: SKIPN   C,5(AB)         ;CHECK LOW GROWTH
+       JRST    GROW4           ;NONE, SKIP
+       ASH     C,(E)           ;GENRAL FUDGE
+       ADDI    C,77            ;ROUND
+       ANDCMI  C,77            ;FUDGE FOR VALUE RETURN
+       PUSH    P,C             ;AND SAVE
+       ASH     C,-6            ;DIVIDE BY 100
+       TRZE    C,400           ;CONVERT TO SIGN MAGNITUDE
+       MOVNS   C
+       TDNE    C,[-1,,777000]  ;CHECK FOR OVERFLOW
+       JRST    GTOBIG
+GROW2: HLRZ    E,1(B)          ;GET TOTAL LENGTH OF VECTOR
+       SUBI    E,2             ;FUDGE FOR DOPE WORDS
+       MOVNS   E
+       HRLI    E,-1(E)         ;TO BOTH HALVES
+       ADDI    E,(B)           ;POINTS TO TOP
+       SKIPE   D               ;STACK?
+       ADD     E,[PDLBUF,,0]   ;YES, FUDGE LENGTH
+       SKIPL   D,(P)           ;SHRINKAGE?
+       JRST    GROW3           ;NO, CONTINUE
+       MOVNS   D               ;PLUSIFY
+       HRLI    D,(D)           ;TO BOTH HALVES
+       ADD     E,D             ;POINT TO NEW LOW ADDR
+GROW3: IORI    A,(C)           ;OR TOGETHER
+       HRRM    A,(B)           ;DEPOSIT INTO DOPEWORD
+       PUSH    TP,(AB)         ;PUSH TYPE
+       PUSH    TP,E            ;AND VALUE
+       SKIPE   A               ;DON'T GC FOR NOTHING
+       PUSHJ   P,AGC
+       POP     P,C             ;RESTORE GROWTH
+       HRLI    C,(C)
+       POP     TP,B            ;GET VECTOR POINTER
+       SUB     B,C             ;POINT TO NEW TOP
+       POP     TP,A
+       JRST    FINIS
+
+GTOBIG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+       JRST    CALER1
+GROW4: PUSH    P,[0]           ;0 BOTTOM GROWTH
+       JRST    GROW2
+\f
+; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION STRING,SUBR
+
+       ENTRY
+
+       MOVE    B,AB            ;COPY ARG POINTER
+       MOVEI   C,0             ;INITIALIZE COUNTER
+       PUSH    TP,$TAB         ;SAVE A COPY
+       PUSH    TP,B
+       JUMPGE  B,MAKSTR                ;ZERO LENGTH
+
+STRIN2:        GETYP   D,(B)           ;GET TYPE CODE
+       CAIN    D,TCHRS         ;SINGLE CHARACTER?
+       AOJA    C,STRIN1
+       CAIE    D,TCHSTR        ;OR STRING
+       JRST    WRONGT          ;NEITHER
+
+       MOVEM   B,(TP)          ;SAVE CURRENT POINTER
+       PUSH    TP,(B)
+       PUSH    TP,1(B)
+       PUSH    P,C             ;SAVE CURRENT COUNT
+       MCALL   1,LENGTH                ;FIND THE LENGTH
+       POP     P,C
+       ADDI    C,(B)           ;BUMP COUNT
+       MOVE    B,(TP)          ;RESTORE
+
+STRIN1:        ADD     B,[2,,2]
+       JUMPL   B,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR:        PUSH    TP,$TFIX
+       ADDI    C,4             ;COMPUTE NEEDED WORDS
+       IDIVI   C,5
+       PUSH    TP,C
+       MCALL   1,UVECTOR               ;GET THE VECTOR
+
+       HRLI    B,440700                ;CONVERT B TO A BYTE POINTER
+       SKIPL   C,AB            ;ANY ARGS?
+       JRST    DONEC
+
+NXTRG1:        GETYP   D,(C)           ;GET AN ARG
+       CAIE    D,TCHRS
+       JRST    TRYSTR
+       LDB     D,[350700,,1(C)]        ;GET IT
+       IDPB    D,B             ;AND DEPOSIT IT
+       JRST    NXTARG
+
+TRYSTR:        MOVE    E,1(C)          ;GET BYTER
+       HRRZ    0,(C)           ;AND DOPE WORD POINTER
+       LDB     D,E             ;GET 1ST CHAR
+NXTCHR:        CAIG    0,1(E)          ;STILL WINNING?
+       JRST    NXTARG          ;NO, GET NEXT ARG
+       JUMPE   D,NXTARG        ;HIT 0, QUIT
+       IDPB    D,B             ;INSERT
+       ILDB    D,E             ;AND GET NEXT
+       JRST    NXTCHR
+
+NXTARG:        ADD     C,[2,,2]        ;BUMP ARG POINTER
+       JUMPL   C,NXTRG1
+       ADDI    B,1
+
+DONEC: MOVSI   C,TCHRS
+       HLLM    C,(B)           ;AND CLOBBER AWAY
+       HLRZ    C,1(B)          ;GET LENGTH BACK
+       MOVEI   A,1(B)          ;POINT TO DOPE WORD
+       HRLI    A,TCHSTR
+       SUBI    B,-2(C)
+       HRLI    B,350700                ;MAKE A BYTE POINTER
+       JRST    FINIS
+\f
+AGC":
+;SET FLAG FOR INTERRUPT HANDLER
+
+       SETOM   GCFLG
+
+;SAVE AC'S
+       IRP     AC,,[0,A,B,C,D,E,P,SP,TP,TB,AB,TVP,PP,PVP]
+       MOVEM   AC,AC!STO"+1(PVP)
+       TERMIN
+
+;SET UP E TO POINT TO TYPE VECTOR
+       HLRZ    E,TYPVEC(TVP)
+       CAIE    E,TVEC
+       JRST    AGCE1
+       HRRZ    TYPNT,TYPVEC+1(TVP)
+       HRLI    TYPNT,B
+
+;DECIDE WHETHER TO SWITCH TO GC PDL
+
+       MOVEI   A,(P)           ;POINNT TO PDL
+       HRRZ    B,GCPDL         ;POINT TO BASE OF GC PDL
+       CAIG    A,(B)           ;SKIP IF MUST CHANGE
+       JRST    CHPDL
+       HLRE    C,GCPDL         ;-LENGTH OF GC'S PDL
+       SUB     B,C             ;POINT TO END OF GC'S PDL
+       CAILE   A,(B)           ;SKIP IF WITHIN GCPDL
+CHPDL: MOVE    P,GCPDL         ;GET GC'S PDL
+
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
+
+       MOVEI   A,(TB)          ;POINT TO CURRENT FRAME IN PROCESS
+       PUSHJ   P,FRMUNG        ;AND MUNG IT
+       MOVE    A,TP            ;THEN TEMPORARY PDL
+       PUSHJ   P,PDLCHK
+       MOVE    A,PP            ;GET PLANNER PDL
+       PUSHJ   P,PDLCHK        ;AND CHECK IT FOR GROWTH
+       MOVE    A,PSTO+1(PVP)   ;AND UNMARKED P STACK
+       CAMN    P,GCPDL         ;DID PDLS CHANGE
+       PUSHJ   P,PDLCHP
+\f;MARK PHASE: MARK ALL LISTS AND VECTORS
+;POINTED TO WITH ONE BIT IN SIGN BIT
+;START AT TRANSFER VECTOR
+
+       SETZB   LPVP,VECNUM     ;CLEAR NUMBER OF VECTOR WORDS
+       SETZM   PARNUM          ;CLEAR NUMBER OF PAIRS
+       MOVSI   D,400000        ;SIGN BIT FOR MARKING
+       MOVE    A,ASOVEC+1(TVP) ;MARK ASSOC. VECTOR NOW
+       HLRE    B,A
+       SUBI    A,(B)           ;POINT TO DOPE WORD
+       IORM    D,1(A)          ;AND MARK
+       MOVE    A,PVP           ;START AT PROCESS VECTOR
+       MOVEI   B,TPVP          ;IT IS A PROCESS VECTOR
+       PUSHJ   P,MARK          ;AND MARK THIS VECTOR
+
+; ASSOCIATION FLUSHING PHASE
+
+       MOVE    A,ASOVEC+1(TVP) ;GET POINTER TO VECTOR
+       PUSHJ   P,ASOMRK        ;MARK AND FLUSH
+
+;OPTIONAL RETIMING PHASE
+
+       SKIPE   A,TIMOUT        ;ANY TIME OVERFLOWS
+       PUSHJ   P,RETIME        ;YES, RE-CALIBRATE THEM
+
+;CORE ADJUSTMENT PHASE
+       SETZM   CORSET          ;CLEAR LATER CORE SETTING
+       PUSHJ   P,CORADJ        ;AND MAKE CORE ADJUSTMENTS
+
+;RELOCATION ESTABLISHMENT PHASE
+;1 -- IN PAIR SPACE, SWAP LOW GARBAGE WITH HIGHER NON GARBAGE
+       MOVE    A,PARBOT"       ;ONE POINTER TO BOTTOM OF PAIR SPACE
+       MOVE    B,PARTOP"       ;AND ANOTHER TO TOP.
+       PUSHJ   P,PARREL        ;AND ESTABLISH THE PAIR RELOCATION
+       MOVEM   B,PARTOP        ;ESTABLISH NEW TOP OF PAIRS HERE
+
+;2 -- IN VECTOR SPACE, ESTABLISH POINTERS TO TOP OF CORE
+       MOVE    A,VECTOP"       ;START AT TOP OF VECTOR SPACE
+       MOVE    B,VECNEW"       ;AND SET TO INITIAL OFFSET
+       SUBI    A,1             ;POINT TO DOPE WORDS
+       PUSHJ   P,VECREL        ;AND ESTABLISH RELOCATION FOR VECTORS
+       MOVEM   B,VECNEW        ;SAVE FINAL OFFSET
+
+\f;POINTER UPDATE PHASE
+;1 -- UPDATE ALL PAIR POINTERS
+       MOVE    A,PARBOT        ;START AT BOTTOM OF PAIR SPACE
+       PUSHJ   P,PARUPD        ;AND UPDATE ALL PAIR POINTERS
+
+;2 -- UPDATE ALL VECTORS
+       MOVE    A,VECTOP        ;START AT TOP OF VECTOR SPACE
+       PUSHJ   P,VECUPD        ;AND UPDATE THE POINTERS
+
+;3 -- UPDATE THE PVP AC
+       MOVEI   A,PVP-1         ;SET LOC TO POINT TO PVP
+       MOVE    C,PVP           ;GET THE DATUM
+       PUSHJ   P,NWRDUP        ;AND UPDATE THIS VALUE
+;4 -- UPDATE THE MAIN PROCESS POINTER
+       MOVEI   A,MAINPR-1      ;POINT TO MAIN PROCESS POINTER
+       MOVE    C,MAINPR        ;GET CONTENTS IN C
+       PUSHJ   P,NWRDUP        ;AND UPDATE IT
+;DATA MOVEMMENT ANDCLEANUP PHASE
+
+;1 -- ADJUST FOR SHRINKING VECTORS
+       MOVE    A,VECTOP        ;VECTOR SHRINKING PHASE
+       PUSHJ   P,VECSH         ;GO SHRINK ANY SHRINKERS
+
+;2 -- MOVE VECTORS (AND LIST ELEMENTS)
+       MOVE    A,VECTOP        ;START AT TOP OF VECTOR SPACE
+       PUSHJ   P,VECMOVE       ;AND MOVE THE VECTORS
+       MOVE    A,VECNEW        ;GET FINAL CHANGE TO VECBOT
+       ADDM    A,VECBOT        ;OFFSET VECBOT TO ITS NEW PLACE
+       MOVE    A,CORTOP        ;GET NEW VALUE FOR TOP OF VECTOR SPACE
+       MOVEM   A,VECTOP        ;AND UPDATE VECTOP
+
+;3 -- CLEANUP VECTORS (NOTE A CONTAINS NEW VECTOP)
+
+       PUSHJ   P,VECZER        ;
+
+;GARBAGE ZEROING PHASE
+GARZER:        MOVE    A,PARTOP        ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE
+       HRLS    A               ;GET FIRST ADDRESS IN LEFT HALF
+       MOVE    B,VECBOT        ;LAST ADDRESS OF GARBAGE + 1
+       CLEARM  (A)             ;ZERO   THE FIRST WORD
+       ADDI    A,1             ;MAKE A A BLT POINTER
+       BLT     A,-1(B)         ;AND COPY ZEROES INTO REST OF AREA
+
+;FINAL CORE ADJUSTMENT
+       SKIPE   A,CORSET        ;IFLESS CORE NEEDED
+       PUSHJ   P,CORADL        ;GIVE SOME AWAY.
+
+;NOW REHASH THE ASSOCIATIONS BASED ON NEW VALUES
+
+       PUSHJ   P,REHASH
+
+;RESTORE AC'S
+       IRP     AC,,[0,A,B,C,D,E,P,SP,TP,TB,AB,PP,PVP,TVP]
+       MOVE    AC,AC!STO+1(PVP)
+       TERMIN
+
+       SETZM   PARNEW          ;CLEAR FOR NEXT AGC CALL
+       SETZM   GETNUM          ;ALSO CLEAR THIS
+       SETZM   GCFLG
+
+
+CPOPJ: POPJ    P,
+
+
+AGCE1: MOVEI   B,[ASCIZ /TYPVEC IS NOT OF TYPE VECTOR
+/]
+TYPSTP:        PUSHJ   P,MSGTYP"       ;TYPE OUT A HOPELESSMESSAGE
+       .VALUE          ;AND GIVE UP
+
+
+\f
+; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING
+
+PDLCHK:        JUMPGE  A,CPOPJ
+       HLRE    B,A             ;GET NEGATIVE COUNT
+       MOVE    C,A             ;SAVE A COPY OF PDL POINTER
+       SUBI    A,-1(B)         ;LOCATE DOPE WORD PAIR
+       HRRZS   A               ; ISOLATE POINTER
+       CAME    A,TPGROW        ;GROWING?
+       CAMN    A,PPGROW                ;OR PLANNER PDL
+       JRST    .+2
+       ADDI    A,PDLBUF        ;NO, POINT TO REAL DOPE WORD
+       HLRZ    D,(A)           ;GET COUNT FROM DOPE WORD
+       MOVNS   B               ;GET POSITIVE AMOUNT LEFT
+       SUBI    D,2(B)          ; PDL FULL?
+       JUMPE   D,NOFENC        ;YES NO FENCE POSTING
+       SETOM   1(C)            ;CLOBBER TOP WORD
+       SOJE    D,NOFENC        ;STILL MORE?
+       MOVSI   D,1(C)          ;YES, SET UP TO BLT FENCE POSTS
+       HRRI    D,2(C)
+       BLT     D,-2(A)         ;FENCE POST ALL EXCEPT DOPE WORDS
+
+
+NOFENC:        CAIG    B,TPMAX         ;NOW CHECK SIZE
+       CAIG    B,TPMIN
+       JRST    MUNGTP          ;TOO BIG OR TOO SMALL
+       POPJ    P,
+
+MUNGTP:        SUBI    B,TPGOOD        ;FIND DELTA TP
+MUNG3: MOVE    C,-1(A)         ;IS GROWTH ALREADY SPECIFIED
+       TRNE    C,777000        ;SKIP IF NOT
+       POPJ    P,              ;ASSUME GROWTH GIVEN WILL WIN
+
+       ASH     B,-6            ;CONVERT TO NUMBER OF BLOCKS
+       JUMPL   B,MUNGT1
+       TRO     B,400           ;TURN ON SHRINK BIT
+       JRST    MUNGT2
+MUNGT1:        MOVMS   B
+       ANDI    B,377
+MUNGT2:        DPB     B,[111100,,-1(A)]       ;STORE IN DOPE WORD
+       POPJ    P,
+
+; CHECK UNMARKED STACK (NO NEED TO FENCE POST)
+
+PDLCHP:        HLRE    B,A             ;-LENGTH TO B
+       SUBI    A,-1(B)         ;POINT TO DOPE WORD
+       HRRZS   A               ;ISOLATE POINTER
+       CAME    A,PGROW         ;GROWING?
+       ADDI    A,PDLBUF        ;NO, POINT TO REAL DOPE WORD
+       MOVMS   B               ;PLUS LENGTH
+
+       CAIG    B,PMAX          ;TOO BIG?
+       CAIG    B,PMIN          ;OR TOO LITTLE
+       JRST    .+2             ;YES, MUNG IT
+       POPJ    P,
+       SUBI    B,PGOOD
+       JRST    MUNG3
+
+;THIS ROUTINE CLOBBERS USELESS STUFF IN CURRENT FRAME
+
+FRMUNG:        SETZM   PCSAV(A)
+       SETZM   PSAV(A)
+       SETZM   SPSAV(A)
+       SETZM   PPSAV(A)
+       MOVEM   TP,TPSAV(A)     ;SAVE FOR MARKING
+       POPJ    P,
+\f
+;GENERAL MARK SUBROUTINE.  CALLED TO MARK ALL THINGS
+; A/ GOODIE TO MARK FROM
+; B/ TYPE OF A (IN RH)
+; C/ TYPE,DATUM PAIR POINTER
+
+MARK2: HLRZ    B,(C)           ;GET TYPE
+MARK1: MOVE    A,1(C)          ;GET GOODIE
+MARK:  JUMPE   A,CPOPJ         ; NEVER MARK 0
+       PUSH    P,A             ;SAVE GOODIE
+       HRLM    C,-1(P)         ;AND POINTER TO IT
+       LSH     B,1             ;TIMES 2 TO GET SAT
+       HRRZ    B,@TYPNT        ;GET SAT
+       JRST    @MKTBS(B)       ;AND GO MARK
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK]
+[SLOCID,<SETZ LOCMK>],[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK]]
+
+
+;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER
+
+DEFMK: TLOA    TYPNT,400000    ;USE SIGN BIT AS FLAG
+
+;HERE TO MARK LIST ELEMENTS
+
+PAIRMK:        TLZ     TYPNT,400000    ;TURN OF DEFER BIT
+       MOVEI   C,(A)           ;POINT TO LIST
+PAIRM1:        CAMGE   C,PARTOP        ;CHECK FOR BEING IN BOUNDS
+       CAMGE   C,PARBOT
+       JRST    BDPAIR          ;OUT OF BOUNDS,COMPLAIN
+       SKIPGE  B,(C)           ;SKIP IF NOT MARKED
+       JRST    GCRET           ;ALREADY MARKED, RETURN
+       IORM    D,(C)           ;MARK IT
+       AOS     PARNUM
+       HLRZS   B               ;TYPE TO RH OF B
+       MOVE    A,1(C)          ;DATUM TO A
+       JUMPL   TYPNT,DEFDO     ;GO HANDLE DEFERRED POINTER
+       PUSHJ   P,MARK          ;MARK THIS DATUM
+       HRRZ    C,(C)           ;GET CDR OF LIST
+       JUMPN   C,PAIRM1        ;IF NOT NIL, MARK IT
+
+GCRET: TLZ     TYPNT,400000    ;FOR PAIRMKS BENEFIT
+       HLRZ    C,-1(P)         ;RESTORE C
+       POP     P,A
+       POPJ    P,              ;AND RETURN TO CALLER
+
+;HERE TO SQUAWK WHEN A PAIR POINTER IS BAD
+
+BDPAIR:        MOVEI   B,[ASCIZ /AGC -- MARKED PAIR POINTS OUTSIDE PAIR SPACE
+/]
+
+       PUSHJ   P,MSGTYP
+       .VALUE  0
+
+;HERE TO MARK DEFERRED POINTER
+
+DEFDO: PUSHJ   P,MARK          ;MARK THE DATUM
+       JRST    GCRET           ;AND RETURN
+
+\f
+; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
+
+TPMK:  TLOA    TYPNT,400000    ;SET TP MARK FLAG
+VECTMK:        TLZ     TYPNT,400000
+       MOVEI   E,(A)           ;SAVE A POINTER TO THE VECTOR
+       HLRE    B,A             ;GET -LNTH
+       SUB     A,B             ;LOCATE DOPE WORD
+       MOVEI   A,1(A)          ;ZERO LH AND POINT TO 2ND DOPE WORD
+       CAMGE   A,VECTOP        ;CHECK BOUNDS
+       CAMGE   A,VECBOT
+       JRST    VECTB1          ;LOSE, COMPLAIN
+
+       JUMPGE  TYPNT,NOBUFR    ;IF A VECTOR, NO BUFFER CHECK
+       CAMN    A,PPGROW        ;CHECK PLANNER PDL
+       JRST    NOBUFR
+       CAME    A,PGROW         ;IS THIS THE BLOWN P
+       CAMN    A,TPGROW        ;IS THIS THE GROWING PDL
+       JRST    NOBUFR          ;YES, DONT ADD BUFFER
+       ADDI    A,PDLBUF        ;POINT TO REAL DOPE WORD
+       MOVSI   0,-PDLBUF       ;ALSO FIX UP POINTER
+       ADDM    0,1(C)
+
+NOBUFR:        HLRZ    B,(A)           ;GET LENGTH FROM DOPE WORD
+       ANDI    B,377777        ;CLOBBER POSSIBLE MARK BIT
+       MOVEI   F,(A)           ;SAVE A POINTER TO DOPE WORD
+       SUBI    F,1(B)          ;F POINTS TO START OF VECTOR
+       HRRZ    0,-1(A)         ;SEE IF GROWTH SPECIFIED
+       JUMPE   0,NOCHNG        ;NONE, JUST CHECK CURRENT SIZES
+
+       LDB     B,[001100,,0]   ;GET GROWTH FACTOR
+       TRZE    B,400           ;KILL SIGN BIT AND SKIP IF +
+       MOVNS   B               ;NEGATE
+       ASH     B,6             ;CONVERT TO NUMBER OF WORDS
+       SUB     F,B             ;BOTTOM IS LOWER IN CORE
+       LDB     0,[111100,,0]   ;GET TOP GROWTH
+       TRZE    0,400           ;HACK SIGN BIT
+       MOVNS   0
+       ASH     0,6             ;CONVERT TO WORDS
+       ADD     B,0             ;TOTAL GROWTH TO B
+       ADD     A,0             ;DOPE WORD IS HIGHER
+NOCHNG:        SKIPGE  TYPNT           ;IS THIS A PDL?
+       SUBI    F,1             ;YES, POINTER MAY POINT OUTSIDE
+
+       CAIG    E,(A)           ;IS E IN BOUNDS?
+       CAIG    E,(F)
+       JRST    VECLOS          ;NO, CLOBBER POINTER TO IT
+
+VECOK: SUB     A,0             ;A POINTS TO DOPW WORD AGAIN
+       HLRE    E,(A)           ;GET LENGTH AND MARKING
+       MOVEI   F,(E)           ;SAVE A COPY
+       ADD     F,B             ;ADD GROWTH
+       SUBI    E,2             ;- DOPE WORD LENGTH
+       IORM    D,(A)           ;MAKE SURE NOW MARKED
+       JUMPLE  E,GCRET         ;ALREADY MARKED OR ZERO LENGTH, LEAVE
+
+       SKIPGE  B,-1(A)         ;SKIP IF UNIFORM
+       TLNE    B,377777        ;SKIP IF NOT SPECIAL
+       JUMPGE  TYPNT,NOTGEN    ;JUMP IF NOT A GENERAL VECTOR
+
+GENRAL:        HLRZ    0,B             ;CHECK FOR PSTACK
+       JUMPE   0,NOTGEN        ;IT ISN'T GENERAL
+       SUBI    A,1(E)          ;POINT TO FIRST ELEMENT
+       ADDM    F,VECNUM        ;AND UPDATE VECNUM
+       MOVEI   C,(A)           ;POINT TO FIRST ELEMENT WITH C
+\f
+; LOOP TO MARK ELEMENTS IN A GENRAL VECTOR
+
+VECTM2:        HLRE    B,(C)           ;GET TYPE AND MARKING
+       JUMPL   B,GCRET         ;RETURN, (EITHER DOPE WORD OR FENCE POST)
+       MOVE    A,1(C)          ;DATUM TO A
+       CAIN    B,TENTRY        ;IS THIS A STACK FRAME
+       JRST    MFRAME          ;YES, MARK IT
+       CAIN    B,TBIND         ;OR A BINDING BLOCK
+       JRST    MBIND
+
+VECTM3:        PUSHJ   P,MARK          ;MARK DATUM
+       ADDI    C,2
+       JRST    VECTM2
+
+MFRAME:        HRROI   C,FRAMLN+SPSAV-1(C)     ;POINT TO SAVED SP
+       MOVEI   B,TSP
+       PUSHJ   P,MARK1         ;MARK THE GOODIE
+       HRROI   C,PSAV-SPSAV(C) ;POINT TO SAVED P
+       MOVEI   B,TPDL
+       PUSHJ   P,MARK1         ;AND MARK IT
+       HRROI   C,TPSAV-PSAV(C) ;POINT TO SAVED TP
+       MOVEI   B,TTP
+       PUSHJ   P,MARK1         ;MARK IT ALS
+       MOVEI   C,PPSAV-TPSAV(C)        ;POINT SAVED PP
+       MOVEI   B,TPP
+       PUSHJ   P,MARK1
+       MOVEI   C,-PPSAV+1(C)   ;POINT PAST THE FRAME
+       JRST    VECTM2          ;AND DO MORE MARKING
+
+
+MBIND: MOVEI   B,TATOM         ;FIRST MARK ATOM
+       JRST    VECTM3
+
+VECLOS:        JUMPL   C,CCRET         ;JUMP IF CAN'T MUNG TYPE
+       HLLZ    0,(C)           ;GET TYPE
+       MOVEI   B,TILLEG        ;GET ILLEGAL TYPE
+       HRLM    B,(C)
+       MOVEM   0,1(C)          ;AND STORE OLD TYPE AS VALUE
+       JRST    GCRET           ;RETURN WITHOUT MARKING VECTOR
+
+CCRET: CLEARM  1(C)            ;CLOBBER THE DATUM
+       JRST    GCRET
+\f
+; SUBROUTINE TO CHECK THE TIME FOR LOCIDS,ARGS AND FRAMES
+; A/ POINT TO FRAME C/GOODIE B/ITS TIME
+
+TIMECH:        HLRZ    0,OTBSAV(A)     ;GET THE FRAMES TIME
+       CAIN    0,(B)           ;SAME?
+       POPJ    P,              ;YES, WIN
+       SUB     P,[1,,1]        ;NO, REMOVE  RETLOC
+BADARG:
+TIMLOS:        HLLZ    0,(C)           ;GET OLD TYPE
+       MOVSI   B,TILLEG        ;ILLEGAL TYPE
+       MOVEM   B,(C)           ;AND STORE IT
+       MOVEM   0,1(C)          ;USE OLD TYPE AS DATUM
+       JRST    GCRET           ;AND STOP MARKING FROM THE LOSER
+
+; MARK ARG POINTERS (SABASE AND SARGS)
+
+ARGMK: HLRE    B,A             ;-LENGTH TO B
+       SUBI    A,(B)           ;POINT TO FRAME OR FRAME POINTER
+       HLRZ    E,(A)           ;GET TYPE
+       CAIE    E,TENTRY        ;IS TJHIS A FRAME
+       JRST    ARGMK2          ;NO, CHECK OTHER
+       MOVEI   A,FRAMLN(A)     ;POINT ABOVE FRAME
+ARGMK3:        HRRZ    B,(C)           ;GET TIME
+       PUSHJ   P,TIMECH
+       JRST    GCRET           ;DONE
+
+
+ARGMK2:        CAIE    E,TTB           ;BASE POINTER?
+       JRST    BADARG          ;LOSE
+       HRRZ    A,1(A)          ;POINT TO FRAME
+       JRST    ARGMK3          ;AND MARK IT AS SUCH
+
+; MARK FRAME POINTERS
+
+FRMK:  HLRZ    B,A             ;GET TIME IN B
+       PUSHJ   P,TIMECH        ;CHECK ITS TIME
+       SUBI    C,1             ;PREPARE TO MARK PROCESS VECTOR
+       HRRZ    A,1(C)          ;USE AS DATUM
+       SUBI    A,1             ;FUDGE FOR VECTMK
+       MOVEI   B,TPVP          ;IT IS A VECTRO
+       PUSHJ   P,MARK          ;MARK IT
+       JRST    GCRET
+
+; MARK BYTE POINTER
+
+BYTMK: HRRZ    A,(C)           ;POINT TO DOPE WD
+       SOJG    A,VECTMK        ;FUDGE DOPE WORD POINTER FOR VECTMK
+
+
+       MOVEI   B,[ASCIZ /AGC -- BYTE POINTER WITH ZERO DOPE WORD POINTER
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+
+\f
+; MARK ATOMS
+
+ATOMK: PUSHJ   P,GETLNT        ;GET LENGTH AND CHECK BOUNDS
+       MOVEI   C,(A)
+       HLRZ    B,(C)           ;GET TYPE
+       MOVE    A,1(C)          ;AND VALUE
+;******FUDGE UNTIL MIRE WINNAGE******
+
+       HRRZ    E,(C)           ;GOBBLE PROCESS ID
+       CAIN    B,TUNBOUND      ;IF NOT UNBOUND
+       JRST    GCRET           ;IS UNVOUND, IGNORE
+       SKIPN   E               ;SKIP IF NOT GLOBAL PROCESS
+       MOVEI   B,TVEC          ;IS GLOBAL, MARK AS A VECTOR
+       PUSHJ   P,MARK          ;AND MARK IT
+       JRST    GCRET           ;AND LEAVE
+
+GETLNT:        HLRE    B,A             ;GET -LNTH
+       SUB     A,B             ;POINT TO 1ST DOPE WORD
+       MOVEI   A,1(A)          ;POINT TO 2ND DOPE WORD
+       CAMGE   A,VECTOP        ;CHECK BOUNDS
+       CAMGE   A,VECBOT
+       JRST    VECTB1          ;BAD VECTOR, COMPLAIN
+
+       HLRE    B,(A)           ;GET LENGTH AND MARKING
+       IORM    D,(A)           ;MAKE SURE MARKED
+       JUMPL   B,GCRET1        ;MARKED ALREADY, QUIT
+       SUBI    A,-1(B)         ;POINT TO TOP OF ATOM
+       ADDM    B,VECNUM        ;UPDATE VECNUM
+       POPJ    P,              ;AND RETURN
+
+GCRET1:        SUB     P,[1,,1]        ;FLUSH RETURN ADDRESS
+       JRST    GCRET
+
+; MARK NON-GENERAL VECTORS
+
+NOTGEN:        CAMN    B,[GENERAL+<SPVP,,0>]   ;PROCESS VECTOR?
+       JRST    GENRAL          ;YES, MARK AS A VECTOR
+       JUMPL   B,SPECLS        ; COMPLAIN IF A SPECIAL HACK
+       SUBI    A,1(E)          ;POINT TO TOP OF A UNIFORM VECTOR
+       ADDM    F,VECNUM        ;INCREASE VECNUM
+       HLRZS   B               ;ISOLATE TYPE
+       MOVE    F,B             ; AND COPY IT
+       LSH     B,1             ;FIND OUT WHERE IT WILL GO
+       HRRZ    B,@TYPNT        ;GET SAT IN B
+       MOVEI   C,@MKTBS(B)     ;POINT TO MARK SR
+       CAIN    C,GCRET         ;IF NOT A MARKED FROM GOODIE, IGNORE
+       JRST    GCRET
+       MOVEI   C,-1(A)         ;POINT 1 PRIOR TO VECTOR START
+       PUSH    P,E             ;SAVE NUMBER OF ELEMENTS
+       PUSH    P,F             ;AND UNIFORM TYPE
+
+UNLOOP:        MOVE    B,(P)           ;GET TYPE
+       MOVE    A,1(C)          ;AND GOODIE
+       TLO     C,400000        ;CAN'T MUNG TYPE
+       PUSHJ   P,MARK          ;MARK THIS ONE
+       SOSE    -1(P)           ;COUNT
+       AOJA    C,UNLOOP        ;IF MORE, DO NEXT
+
+       SUB     P,[2,,2]        ;REMOVE STACK CRAP
+       JRST    GCRET
+
+
+SPECLS:        MOVEI   B,[ASCIZ /AGC -- UNRECOGNIZED SPECIAL VECTOR
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+\f
+;MARK LOCID TYPE GOODIES
+
+LOCMK: HRRZ    B,(C)           ;GET TIME
+       JUMPE   B,GLBSP         ;IF TIME IS 0, THIS IS THE GLOBAL SP
+       HRRZ    0,2(A)          ;GET TIME
+       CAIE    0,(B)           ;EQUAL?
+       JRST    TIMLOS          ;NO, LOSE
+       MOVE    A,3(A)          ;GOBBLE SP POINTER
+       JRST    TPMK
+
+
+GLBSP: MOVE    A,1(C)          ;MARK LIKE A VECTOR
+       JRST    VECTMK
+
+
+; MARK ASSOCIATION BLOCKS
+
+ASMRK: HRLI    A,-ASOLNT       ;LOOK LIKE A VECTOR POINTER
+       PUSHJ   P,GETLNT        ;GET LENGTH AND CHECK BOUNDS
+       GETYP   B,(A)           ;CHECK TYPE OF FIRST
+       CAIN    B,TTP
+       JRST    GCRET           ;THIS IS THE DUMMY
+       MOVEI   C,(A)           ;COPY POINTER
+       PUSHJ   P,MARK2         ;MARK ITEM CELL
+       ADDI    C,INDIC-ITEM    ;POINT TO INDICATOR
+       PUSHJ   P,MARK2
+       ADDI    C,VAL-INDIC
+       PUSHJ   P,MARK2
+       ADDI    C,NODPNT-VAL-1  ;POINT TO NODE CHAIN
+       HRRZ    A,1(C)          ;DOES IT EXIST
+       JUMPE   A,GCRET
+       MOVEI   B,TASOC
+       PUSHJ   P,MARK          ;AND MARK IT
+       JRST    GCRET
+
+\f;HERE WHEN A VECTOR POINTER IS BAD
+
+VECTB1:        MOVEI   B,[ASCIZ /AGC -- VECTOR POINTS OUTSIDE VECTOR SPACE
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE  0
+
+
+\f
+; THIS PHASE REMOVES ANY UNWANTED ASSOCIATIONS ALSO PRESERVES DATA POINTED TO ONLY BY ASSOCIATIONS
+; RECEIVES POINTER TO ASSOCIATION VECTOR IN A
+
+ASOMRK:        SKIPN   C,(A)           ;DOES BUCKET CONTAIN ANYTHING
+       JRST    ASOM3           ;NO, ;IGNORE
+
+ASOM2: HRRE    0,ASOLNT+1(C)   ;CHECK FOR CIRCULARITY
+       AOJE    0,ASOM6         ;ALREADY MARKED, LOSE
+       HLLOS   ASOLNT+1(C)
+
+       SKIPGE  ASOLNT+1(C)     ;IS THIS ONE POINTED AT?
+       JRST    ASOM4           ;YES, GOODIES ALREADY MARKED
+       PUSHJ   P,MARKQ         ;SEE IF ITS ITEM IS MARKED
+       JRST    ASOFLS          ;NO, FLUSH THIS ASSOCIATION
+       MOVEI   E,MARKQ         ;POINT TO QUESTIONER
+       SKIPE   NODPNT(C)       ;SKIP IF NOT ON A CHAIN
+       MOVEI   E,MARK23        ;ON CHAIN, MARK THE INDICATOR
+       MOVEI   C,INDIC(C)              ;POINT TO INDICATOR
+       PUSHJ   P,(E)
+       JRST    ASOFL7          ;INDICATOR NOT MARKED
+       MOVEI   C,-INDIC(C)             ;POINT BACK TO START
+
+ASOM1: PUSH    P,C             ;ITEM IS MARKED, MARK INDIC AND VAL AND ASSOC
+       PUSH    P,A
+       ADDI    C,VAL   ;POINT TO VAL
+       PUSHJ   P,MARK2
+       IORM    D,ASOLNT+1-VAL(C)       ;MARK THE ASSOCIATION BLOCK
+       POP     P,A
+       POP     P,C
+
+ASOM4: MOVEI   E,(C)           ;INCASE NEED TO FLUSH CIRCULARITY
+       HRRZ    C,ASOLNT-1(C)   ;POINT TO NEXT IN CHAIN
+       JUMPN   C,ASOM2         ;GO MARKK IT
+
+
+ASOM3: AOBJN   A,ASOMRK        ;GO ONTO NEXT BUCKET
+       POPJ    P,              ;ALL MARKED, QUIT
+
+;HERE TO FLUSH AN ASSOCIATION
+
+ASOFLS:        HRRZ    B,ASOLNT-1(C)   ;GET FORWARD AND BACKWARD POINTERS
+       HLRZ    E,ASOLNT-1(C)
+       JUMPN   E,ASOFL1        ;JUMP IF PREV EXISTS
+       HRRZM   B,(A)           ;CLOBBER VECTOR ENTRY
+       JRST    .+2
+
+ASOFL1:        HRRM    B,ASOLNT-1(E)   ;CLOBBER PREVIOUS BLOCKKS NEXT
+       JUMPE   B,ASOM4         ;IF NEXT IS 0, DONE
+       HRLM    E,ASOLNT-1(B)   ;ELSE CLOBBER NEXT'S PREVIOUS
+       JRST    ASOM4
+
+ASOM6: HLLZS   (E)             ;FORCE CIRCULARITY AWAY
+       HRRZS   (C)             ;AND THE OTHERS PREV
+       JRST    ASOM3           ;AND FINISH THIS BUCKET
+
+MARK23:        PUSH    P,A
+       PUSHJ   P,MARK2 ;MARK IT
+       POP     P,A             ;RESTORE A
+       JRST    MKD             ;MUST SKIP
+
+ASOFL7:        MOVEI   C,ITEM-INDIC(C) ;RESET C
+       JRST    ASOFLS          ;AND FLUSH
+\f
+;SUBROUTINE TO SEE IF A GOODIE IS MARKED
+;RECEIVES POINTER IN C
+;SKIPS IF MARKED NOT OTHERWISE
+
+MARKQ: MOVE    E,1(C)          ;DATUM TO C
+       HLRZ    B,(C)           ;TYPE TO B
+       LSH     B,1
+       HRRZ    B,@TYPNT        ;GOBBLE SAT
+       JRST    @MQTBS(B)       ;DISPATCH
+
+
+DISTBS MQTBS,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ]
+[STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SBYTE,BYTMK]
+[SATOM,VECMQ],[SPVP,VECMQ],[SLOCID,VECMQ],[SCHSTR,BYTMQ]]
+
+PAIRMQ:        SKIPGE  (E)             ;SKIP IF NOT MARKED
+MKD:   AOS     (P)
+       POPJ    P,
+
+BYTMQ: HRRZ    E,(C)           ;GET DOPE WORD POINTER
+       SOJA    E,VECMQ1        ;TREAT LIKE VECTOR
+
+ARGMQ: HLRE    F,E             ;CHECK AM ARG POINTER
+       SUB     E,F             ;POINT TO END OF ARG BLOCK
+       HLRZ    B,(E)           ;GET TYPE
+       CAIN    B,TENTRY        ;IS IT AN ENTRY
+       MOVEI   E,FRAMLN+1(E)   ;MAKE INTO FRAME POINTER
+       CAIN    B,TTB           ;IS IT A FRAME POINTER
+       HRRZ    E,1(E)          ;PICK IT UP
+
+FRMQ:  MOVE    E,TPSAV(E)      ;PICK UP A STACK POINTER
+
+VECMQ: HLRE    F,E             ;GET LENGTH
+       SUB     E,F             ;POINT TO DOPE WORDS
+
+VECMQ1:        SKIPGE  1(E)            ;SKIP IF NOT MARKED
+       AOS     (P)             ;MARKED, CAUSE SKIP RETURN
+       POPJ    P,
+
+
+\f
+
+
+;RETIME PHASE -- CALLED IFF A FRAME TIME HAS OVERFLOWED
+;RECEIVES POINTER TO STACK TO BE RECALIBRATED IN A
+;LEAVES HIGHEST TIME IN TIMOUT
+
+RETIME:        HLRE    B,A             ;GET LENGTH IN B
+       SUB     A,B             ;COMPUTE DOPE WORD LOCATION
+       MOVEI   A,1(A)          ;POINT TO 2D DOPE WORD AND CLEAR LH
+       CAME    A,TPGROW        ;IS THIS ONE BLOWN?
+       ADDI    A,PDLBUF        ;NO, POINT TO DOPE WORD
+       LDB     B,[222100,,(A)] ;GET LENGTH FIELD (IGNOREING MARK BIT
+       SUBI    A,-1(B)         ;POINT TO PDLS BASE
+       MOVEI   C,1             ;INITIALIZE NEW TIMES
+
+RETIM1:        SKIPGE  B,(A)           ;IF <0, HIT DOPE WORD OR FENCE POST
+       JRST    RETIM3
+       HLRZS   B               ;ISOLATE TYPE
+       CAIE    B,TENTRY        ;FRAME START?
+       AOJA    A,RETIM2        ;NO, TRY BINDING
+       HRLM    C,FRAMLN+OTBSAV(A)      ;STORE NEW TIME
+       ADDI    A,FRAMLN        ;POINT TO NEXT ELEMENT
+       AOJA    C,RETIM1        ;BUMP TIME AND MOVE ON
+
+RETIM2:        CAIN    B,TBIND         ;BINDING?
+       HRRM    C,3(A)          ;YES, STORE CURRENT TIME
+       AOJA    A,RETIM1        ;AND GO ON
+
+RETIM3:        MOVEM   C,TIMOUT        ;SAVE TIME
+       POPJ    P,              ;RETURN
+
+\f;CORE ADJUSTMENT PHASE -- SETS TOP OF CORE
+;AND TOP OF VECTOR SPACE TO SIZE NEEDED FOR SUFFICIENT FREE SPACE TO BE ADDED TO
+;ALLOW FOR "EFFICIENT" PROCESSING
+
+CORADJ:        .SUSET  [.RMEMT,,CORTOP]        ;SET CORTOP FROM SYSTEM
+       MOVE    A,PARBOT        ;GET ADDRESS OF BOTTOM OF MOVABLE CORE
+       ADD     A,PARNEW        ;AND ADDJUST TO WHERE IT WILL BE
+       ADD     A,PARNUM        ;ADD NUMBER OF PAIRS
+       ADD     A,PARNUM        ;TWICE TO GET TOP OF PAIR SPACE.
+       ADD     A,VECNUM        ;ADD NUMBER OF VECTOR WORDS
+       ADD     A,GETNUM        ;AND NUMBER OF WORDS TO BE GOTTEN THIS TIME
+       ADD     A,FREMIN        ;AND NUMBER OF FREE WORDS MINIMUM
+       SUB     A,CORTOP        ;LESS CURRENT TOP OF CORE
+       JUMPG   A,CORAD2        ;IF GREATER THAN ZERO, MORE CORE NEEDED
+       ADD     A,FREDIF        ;ADD IN DIFFERENCE BETWEEEN FREE AND GOT
+       ADDI    A,1777          ;ROUND UP TO NEXT BLOCK
+       ANDCMI  A,1777          ;AND DOWN TO A BLOCK BOUNDARY
+       JUMPGE  A,CORAD1        ;IF POSITIVE, NO CORE ADJUSTMENT NEEDED
+       ADDB    A,CORTOP        ;CALCULATE NEG TOP OF CORE
+       ASH     A,-10.          ;CONVERT TO BLOCKS
+       MOVEM   A,CORSET        ;AND SET NUMBER OF BLOCKS
+CORAD1:        MOVE    A,CORTOP        ;CALCU;ATE NEW TOP OF CORE
+       SUB     A,VECTOP        ;FIND OFFSET FROM CURRENT VECTOR TOP
+       MOVEM   A,VECNEW        ;AND SAVE AS NEW HOME OF VECTORS
+       POPJ    P,
+
+\f;HERE IF MORE CORE NEEDED, NO OF WDS IN A
+
+CORAD2:        ADD     A,CORTOP        ;FIND TOP OF CORE
+       ADDI    A,1777          ;AND ROUND UPWARDS
+       ASH     A,-10.          ;AND CONVERT TO NUMBER OF BLOCKS
+       CAMLE   A,SYSMAX        ;COMPARE TO MAXIMUM ALLOWED
+       PUSHJ   P,CORAD3
+       .CORE   (A)             ;ASK OFR THE NEW SIZE
+       PUSHJ   P,CORAD4        ;FAILURE, GO COMPLAIN
+       JRST    CORADJ          ;OK TRY AGAIN
+
+
+CORAD3:        SKIPA   B,[[ASCIZ /ATTEMPT TO EXPAND PAST MUDDLE LIMIT/]]
+CORAD4:        MOVEI   B,[ASCIZ /NO CORE AVAILABLE/]
+       PUSH    P,A             ;SAVE AMOUNT ASKED FOR
+       PUSHJ   P,MSGTYP
+       MOVEI   B,[ASCIZ /PROCEED?/]
+       PUSHJ   P,MSGTYP
+       PUSHJ   P,TYI"
+       CAIN    A,"Y
+       JRST    .+2
+       .VALUE
+       POP     P,A             ;RESTORE AMOUNT
+       POPJ    P,              ;AND GO BACK
+
+
+CORADL:        .CORE   (A)             ;SET TO NEW CORE VALUE
+       .VALUE
+       POPJ    P,
+\f
+;PARREL -- PAIR RELOCATION ESTABLISMENT
+;ESTABLISH PAIR RELOCATION. CALLED WITH
+;BOTTOM IN AC A, AND TOP IN AC B.
+
+PARRE0:        SUBI    B,2             ;MOVE POINTER BACK
+       IORM    D,(B)           ;MARK THIS PAIR AS JUNK
+PARREL:        CAIG    B,(A)           ;HAVE THE POINTERS MET?
+       POPJ    P,              ;YES -- RETURN WITH NEW PARTOP IN B
+       SKIPL   C,-2(B)         ;MARKED PAIR ON BOTTOM?
+       JRST    PARRE0          ;NO -- MOVE TOWARD BOTTOM
+PARRE1:        SKIPGE  (A)             ;JUNK ON BOTTOM?
+       JRST    PARRE2          ;NO -- MOVE FORWARD
+       MOVEM   C,(A)           ;STORE PAIR IN NEW LOCATION
+       MOVE    C,-1(B)         ;GET DATUM
+       MOVEM   C,1(A)          ;AND STORE IN NEW HOME
+       HRROM   A,-2(B)         ;SET "BROKEN HEART" TO NEW HOME
+       JRST    PARRE0          ;AND CONTINUE
+PARRE2:        ANDCAM  D,(A)           ;UNMARK PAIR
+       ADDI    A,2             ;GO ON TO NEXT PAIR
+       CAIG    B,(A)           ;TEST TO SEE IF POINTERS MET
+       POPJ    P,              ;YES -- DONE
+       JRST    PARRE1          ;KEEP LOOKING FORWARD
+
+\f;VECTOR RELOCATE --GETS VECTOP IN A
+;AND VECNEW IN B
+;FILLS IN RELOCATION FIELDS OF MARKED VECTORS
+;AND REUTRNS FINAL VECNEW IN B
+
+VECREL:        CAMG    A,VECBOT        ;PROCESSED TO BOTTOM OF VECTOR SPACE?
+       POPJ    P,              ;YES, RETURN
+       HLRE    C,(A)           ;GET COUNT FROM DOPE WD, EXTEND MARK BIT
+       JUMPL   C,VECRE1        ;IF MARKED GO PROCESS
+       HLLZS   (A)             ;CLEAR RELOC FIELD
+       ADDI    B,(C)           ;INCREMENT OFFSET
+       SUBI    A,(C)           ;MOVE ON TO NEXT VECTOR
+       SOJG    C,VECREL        ;AND KEEP SCANNING
+       JSP     D,VCMLOS        ;LOSER, LEAVE TRACKS AS TO WHO LOST
+
+VECRE1:        HRRZ    E,-1(A)         ;GOBBLE THE GROWTH FILEDS
+       HRRM    B,(A)           ;STORE RELOCATION
+       JUMPE   E,VECRE2        ;NO GROWTH (OR SHRINKAGE), GO AWAY
+       LDB     F,[111100,,E]   ;GET TOP GROWTH IN F
+       TRZN    F,400           ;CHECK AND FLUSH SIGN
+       MOVNS   F               ;WAS ON, NEGATE
+       ASH     F,6             ;CONVERT TO WORDS
+       ADD     B,F             ;UPDATE RELOCATION
+       HRRM    B,(A)           ;AND STORE IT
+       ANDI    E,777           ;ISOLATE BOTTOM GROWTH
+       TRZN    E,400           ;CHECK AND CLEAR SIGN
+       MOVNS   E
+       ASH     E,6             ;CONVERT TO WORDS
+       ADD     B,E             ;UPDATE FUTURE RELOCATIONS
+VECRE2:        SUBI    A,400000(C)     ;AND MOVE ON TO NEXT VECTOR
+       ANDI    C,377777        ;KILL MARK
+       SOJG    C,VECREL        ;AND KEEP GOING
+       JSP     D,VCMLOS        ;LOSES, LEAVE TRACKS
+
+;PAIR SPACE UPDATE
+
+;GETS PARBOT IN AC A
+;UPDATES VALUES AND CDRS UP TO PARTOP
+
+PARUPD:        CAML    A,PARTOP        ;ARE THERE MORE PAIRS TO PROCESS
+       POPJ    P,              ;NO -- RETURN
+       HRRZ    C,(A)           ;GET CURRENT CDR
+       HLRZ    B,(A)           ;GET TYPE
+       LSH     B,1             ;TIMES 2
+       HRRZ    B,@TYPNT        ;NOW GET SAT
+       SKIPGE  MKTBS(B)        ;SKIP IF IT HAS A CDR
+       JRST    PARUP1          ;NO CDR, DON'T UPDATE IT
+       JUMPE   C,PARUP1        ;IF NIL, DON'T UPDATE
+       SKIPGE  B,(C)           ;GET POINTER UPDATE AND SKIP IF THIS IS NOT A BROKEN HEART
+       HRRM    B,(A)           ;IT WAS, STORE NEW POINTER
+       SKIPE   B,PARNEW        ;IF LIST SPACE IS MOVING,
+       ADDM    B,(A)           ;THEN ADD OFFSET TO CDR
+
+;UPDATE VALUE CELL
+PARUP1:        HLRZ    B,(A)           ;SET RH OF B TO TYPE
+       MOVE    C,1(A)          ;SET C TO VALUE
+       PUSHJ   P,VALUPD        ;UPDATE THIS VALUE
+       ADDI    A,2             ;MOVE ON TO NEXT PAIR
+       JRST    PARUPD          ;AND CONTINUE
+
+\f;VECTOR SPACE UPDATE
+;GETS VECTOP IN A
+;UPDATES ALL VALUE CELLS IN MARKED VECTORS
+;ESCAPES WHEN IT GETS TO VECBOT
+
+VECUPD:        SUBI    A,1             ;MAKE A POINT TO LAST DOPE WD
+VECUP1:        CAMG    A,VECBOT        ;ANY MORE VECTORS TO PROCESS?
+       JRST    ENHACK          ;PROCESS ALL ENTRY BLOCKS NOW
+       SKIPGE  B,(A)           ;IS DOPE WORD MARKED?
+       JRST    VECUP2          ;YES -- GO PROCESS VALUES IN THIS VECTOR
+       HLLZS   -1(A)           ;MAKE SURE NO GROWTH ATTEMPTS
+       HLRZS   B               ;NO -- SET RH OF B TO SIZE OF VECTOR
+VECUP5:        SUB     A,B             ;SET A TO POINT TO DOPE WD OF NEXT VECTOR
+       JRST    VECUP1          ;AND CONTINUE
+
+VECUP2:        PUSH    P,A             ;SAVE DOPE WORD POINTER
+       HLRZ    B,(A)           ;GET LENGTH OF THIS VECTOR
+VECU11:        ANDI    B,377777        ;TURN OFF MARK BIT
+       SKIPGE  E,-1(A)         ;CHECK FOR UNIFORM OR SPECIAL
+       TLNE    E,377777        ;SKIP IF GENERAL
+       JRST    VECUP6          ;UNIFORM OR SPECIAL, GO DO IT
+VECU10:        SUB     A,B             ;SET AC A TO NEXT DOPE WORD
+       ADDI    A,1             ;AND ADVANCE TO FIRST ELEMENT OF THIS VECTOR
+VECUP3:        HLRZ    B,(A)           ;GET TYPE
+       TRNE    B,400000        ;IF MARK BIT SET
+       JRST    VECUP4          ;DONE WITH THIS VECTOR
+       CAIN    B,TENTRY        ;SPECIAL HACK FOR ENTRY
+       JRST    ENTRUP
+       CAIE    B,TBVL          ;VECTOR BINDING?
+       CAIN    B,TBIND         ;AND BINDING BLOCK
+       JRST    BINDUP
+VECU15:        MOVE    C,1(A)          ;GET VALUE
+       PUSHJ   P,VALUPD        ;UPDATE THIS VALUE
+VECU12:        ADDI    A,2             ;GO ON TO NEXT VECTOR
+       JRST    VECUP3          ;AND CONTINUE
+
+VECUP4:        POP     P,A             ;SET TO OLD DOPE WORD
+       ANDCAM  D,(A)           ;TURN OFF MARK BIT
+       HLRZ    B,(A)           ;GET LENGTH
+       JRST    VECUP5          ;GO ON TO NEXT VECTOR
+
+\f
+; ENTRY PART OF THE STACK UPDATER
+
+ENTRUP:        ADDI    A,FRAMLN-2      ;POINT PAST FRAME
+       JRST    VECU12          ;NOW REJOIN VECTOR UPDATE
+
+; UPDATE A BINDING BLOCK
+
+BINDUP:        HRRZ    C,(A)           ;POINT TO CHAIN
+       JUMPE   C,NONEXT        ;JUMP IF NO NEXT BINDING IN CHAIN
+       ADD     C,@(P)          ;ADD RELOCATION OF SELF
+       HRRM    C,(A)           ;AND STORE IT BACK
+NONEXT:        CAIE    B,TBIND         ;SKIP IF VAR BINDING
+       JRST    VECU14          ;NO, MUST BE A VECTOR BIND
+       MOVEI   B,TATOM         ;UPDATE ATOM POINTER
+       PUSHJ   P,VALPD1
+       ADDI    A,2
+       HLRZ    B,(A)           ;TYPE OF VALUE
+       PUSHJ   P,VALPD1
+       ADDI    A,2             ;POINT TO LOCATIVE POINTER
+       HLRZ    B,(A)           ;GET TYPE
+       PUSHJ   P,VALPD1
+       JRST    VECU12
+
+VECU14:        MOVEI   B,TVEC          ;NOW TREAT LIKE A VECTOR
+       JRST    VECU15
+
+; NOW SAFE TO UPDATE ALL ENTRY BLOCKS
+
+ENHACK:        HRRZ    F,TBSTO(LPVP)   ;GET POINTER TO TOP FRAME
+       HLLZS   TBSTO(LPVP)     ;CLEAR FIELD
+       JUMPE   F,LSTFRM        ;FINISHED
+
+ENHCK1:        MOVEI   A,OTBSAV-1(F)   ;POINT PRIOR TO SAVED TB
+       HRRZ    F,1(A)          ;POINT TO PRIOR FRAME
+       MOVEI   B,TTB           ;MARK  SAVED TB
+       PUSHJ   P,VALPD1
+       MOVEI   B,TAB           ;MARK ARG POINTER
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TSP           ;SAVED SP
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TPDL          ;SAVED P STACK
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TTP           ;SAVED TP
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TPP
+       PUSHJ   P,[AOJA A,VALPD1]       ;MARK THE PP
+       JUMPN   F,ENHCK1        ;MARK NEXT ONE IF IT EXISTS
+
+LSTFRM:        HRRZ    A,PROCID(LPVP)  ;NEXT PROCESS
+       HLLZS   PROCID(LPVP)    ;CLOBBER
+       MOVEI   LPVP,(A)
+       JUMPN   LPVP,ENHACK     ;DO NEXT PROCESS
+       POPJ    P,              ;ALL DONE
+\f
+; UPDATE ELEMENTS IN UNIFROM AND SPECIAL VECTORS
+
+VECUP6:        JUMPL   E,VECUP7        ;JUMP IF  SPECIAL
+       HLRZS   E               ;ISOLATE TYPE
+       EXCH    E,B             ;TYPE TO B AND LENGTH TO E
+       SUBI    A,(E)           ;POINT TO NEXT DOPE WORD
+       LSH     B,1             ;FIND SAT
+       HRRZ    B,@TYPNT
+       MOVE    B,UPDTBS(B)     ;FIND WHERE POINTS
+       CAIN    B,CPOPJ         ;UNMARKED?
+       JRST    VECUP4          ;YES, GO ON TO NEXT VECTOR
+       PUSH    P,B             ;SAVE SR POINTER
+       SUBI    E,2             ;DON'T COUNT DOPE WORDS
+
+VECUP8:        SKIPE   C,1(A)          ;GET GOODIE
+       PUSHJ   P,@(P)          ;CALL UPDATE ROUTINE
+       ADDI    A,1
+       SOJG    E,VECUP8        ;LOOP FOR ALL ELEMNTS
+
+       SUB     P,[1,,1]        ;REMOVE RANDOMNESS
+       JRST    VECUP4
+
+; SPECIAL VECTOR UPDATE
+
+VECUP7:        HLRZS   E               ;ISOLATE SPECIAL TYPE
+       CAIN    E,SATOM+400000  ;ATOM?
+       JRST    ATOMUP          ;YES, GO DO IT
+       CAIN    E,STPSTK+400000 ;STACK
+       JRST    VECU10          ;TREAT LIKE A VECTOR
+       CAIN    E,SPVP+400000   ;PROCESS VECTOR
+       JRST    PVPUP           ;DO SPECIAL STUFF
+       CAIN    E,SASOC+400000
+       JRST    ASOUP           ;UPDATE ASSOCIATION BLOCK
+
+       MOVEI   B,[ASCIZ /VECTOR UPDATE, ENCOUNTERED FUNNY SPECIAL VECTOR
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+
+; UPDATE ATOM VALUE CELLS
+
+ATOMUP:        SUBI    A,-1(B)         ; POINT TO VALUE CELL
+       HLRZ    B,(A)
+       HRRZ    0,(A)           ;GOBBLE PROCID
+       JUMPN   0,.+3           ;NOT GLOBAL
+       CAIN    B,TLOCI         ;IS IT A LOCATIVE?
+       MOVEI   B,TVEC          ;MARK AS A VECTOR
+       PUSHJ   P,VALPD1        ;UPDATE IT
+       JRST    VECUP4
+
+; UPDATE PROCESS VECTOR
+
+PVPUP: SUBI    A,-1(B)         ;POINT TO TOP
+       HRRM    LPVP,PROCID(A)  ;CHAIN ALL PROCESSES TOGETHER
+       MOVEI   LPVP,(A)
+       HRRZ    0,TBSTO+1(A)    ;POINT TO CURRENT FRAME
+       HRRM    0,TBSTO(A)      ;SAVE
+       JRST    VECUP3
+
+\f
+;THIS SUBROUTINE TAKES CARE OF UPDATING ASSOCIATION BLOCKS
+
+ASOUP: SUBI    A,-1(B)         ;POINT TO START OF BLOCK
+       HRRZ    B,ASOLNT-1(A)   ;POINT TO NEXT
+       JUMPE   B,ASOUP1
+       HRRE    C,ASOLNT+1(B)   ;AND GET ITS RELOC IN C
+       ADDM    C,ASOLNT-1(A)   ;C NOW HAS UPDATED PONTER
+ASOUP1:        HLRZ    B,ASOLNT-1(A)   ;GET PREV BLOCK POINTER
+       JUMPE   B,ASOUP2
+       HRLZ    F,ASOLNT+1(B)   ;AND ITS RELOCATION
+       ADDM    F,ASOLNT-1(A)   ;RELOCATE
+ASOUP2:        HRRZ    B,NODPNT(A)             ;UPDATE NODE CHAIN
+       JUMPE   B,ASOUP4
+       HRRE    C,ASOLNT+1(B)           ;GET RELOC
+       ADDM    C,NODPNT(A)     ;ANID UPDATE
+ASOUP4:        HLRZ    B,NODPNT(A)     ;GET PREV POINTER
+       JUMPE   B,ASOUP5
+       HRLZ    F,ASOLNT+1(B)   ;RELOC
+       ADDM    F,NODPNT(A)
+ASOUP5:        HRLI    A,-3            ;SET TO UPDATE OTHER CONTENTS
+
+ASOUP3:        HLRZ    B,(A)           ;GET TYPE
+       PUSHJ   P,VALPD1        ;UPDATE
+       ADD     A,[1,,2]        ;MOVE POINTER
+       JUMPL   A,ASOUP3
+       JRST    VECUP4          ;AND QUIT
+
+\f;VALUPD UPDATES A SINLE VALUE FROM EITHER PAIR SPACE OR VECTOR SPACE
+;GETS POINTER TO TYPE CELL IN RH OF A
+;TYPE IN RH OF B (LH MUST BE 0)
+;VALUE IN C
+
+VALPD1:        MOVE    C,1(A)          ;GET VALUE TO UPDATE
+VALUPD:        TRNN    C,-1            ;ANY POINTER PART?
+       JRST    CPOPJ           ;NO, LEAVE
+       LSH     B,1             ;SET TYPE TIMES 2
+       HRRZ    B,@TYPNT        ;GET STORAGE ALLOCATION TYPE
+       JRST    @UPDTBS(B)      ;AND DISPATCH THROUGH STORAGE ALLOCATION DISPATCH TABLE
+
+;SAT DISPATCH TABLE
+
+DISTBS UPDTBS,CPOPJ,[[S2WORD,2WDUP],[S2DEFR,2WDUP],[SNWORD,NWRDUP],[STPSTK,STCKUP]
+[SFRAME,FRAMUP],[STBASE,TBUP],[SARGS,ARGUP],[SBYTE,BYTUP],[SATOM,NWRDUP],[SPSTK,STCKUP]
+[SLOCID,LOCUP],[SPVP,NWRDUP],[S2NWORD,NWRDUP],[SABASE,ABUP],[SCHSTR,BYTUP],[SASOC,ASUP]]
+
+
+
+
+;PAIR POINTER UPDATE
+2WDUP: TRNN    C,-1            ;POINT TO NIL?
+       POPJ    P,              ;YES -- NO UPDATE NEEDED
+       SKIPGE  B,(C)           ;NO -- IS THIS A BROKEN HEART
+       HRRM    B,1(A)          ;YESS -- STORE NEW VALUE
+       SKIPE   B,PARNEW        ;IF LIST SPACE IS MOVING
+       ADDM    B,1(A)          ;THEN ADD OFFSET TO VALUE
+       POPJ    P,              ;FINISHED
+
+
+; HERE TO UPDATE ASSOCIATIONS
+
+ASUP:  HRLI    C,-ASOLNT       ;MAKE INTO VECTOR POINTER
+       JRST    NWRDUP
+\f;VECTOR, ATOM, STACK, AND BASE POINTER UPDATE
+
+LOCUP: HRRZ    B,(A)           ;CHECK IF IT IS TIMED
+       JUMPN   B,LOCUP1        ;JUMP IF TIMED, OTHERWISE TREAT LIKE VECTORE
+
+NWRDUP:        HLRE    B,C             ;EXTEND COUNT IN B
+       SUBI    C,-1(B)         ;SET C TO POINT TO DOPE WORD
+       HRRE    B,(C)           ;EXTEND RELOCATION IN B
+       ADDM    B,1(A)          ;AND ADD RELOCATION TO STORED DATUM
+       HRRZ    C,-1(C)         ;GET GROWTH SPECS
+       JUMPE   C,CPOPJ         ;NO GROWTH, LEAVE
+       LDB     C,[111100,,C]   ;GET UPWORD GROWTH
+       TRZN    C,400           ;FLUSH SIGN AN NEGATR DIRECTION
+       MOVNS   C
+       ASH     C,6+18.         ;TO LH AND TIMES 100(8)
+       ADDM    C,1(A)          ;UPDATE POINTER
+       POPJ    P,
+
+
+LOCUP1:        HRRZ    B,2(C)          ;GET TIME FROM STACK
+       HRRM    B,(A)           ;AND USE IT
+
+STCKUP:        MOVSI   B,PDLBUF        ;GET OFFSET FOR PDLS
+       ADDM    B,1(A)          ;AND ADD TO COUNT
+       JRST    NWRDUP          ;NOW TREAT LIKE VECTOR
+
+BYTUP: HRRZ    C,(A)           ;SET C TO POINT TO DOPE WD
+       HRRE    B,(C)           ;SET B TO RELOCATION FOR THIS VEC
+       ADDM    B,(A)           ;UPDATE DOPE WD POINTER
+       ADDM    B,1(A)          ;AND UPDATE VALUE
+       POPJ    P,              ;DONE WITH UPDATE
+
+ARGUP: TLOA    TYPNT,400000    ;FLAG AS AN ARGS POINTER
+ABUP:  TLZ     TYPNT,400000    ;FLAG AS NOT ARGS POINTER
+       HLRE    B,C             ;GET LENGTH
+       SUB     C,B             ;POINT TO FRAME
+       HLRZ    B,(C)           ;GET TYPE OF NEXT GOODIE
+       CAIE    B,TENTRY        ;IS IT A FRAME
+       HRRZ    C,1(C)          ;NO, POINT TO FRAME
+       CAIN    B,TENTRY        ;IF IT IS A FRAME
+       ADDI    C,FRAMLN        ;POINT TO ITS BASE
+       TLZN    TYPNT,400000    ;SKIP IF ARGS BLOCK
+       JRST    TBUP            ;NO, JUST AN AB
+       HLRZ    B,OTBSAV(C)     ;GET TIME 
+       HRRM    B,(A)           ;AND CLOBBER IT AWAY
+TBUP:  MOVE    C,TPSAV(C)      ;GET A ASTACK POINTER TO FIND DOPE WORD
+       HLRE    B,C             ;UPDATE BASED ON THIS POINTER
+       SUBI    C,(B)
+       HRRE    B,1(C)          ;GET RELOCATION
+       ADDM    B,1(A)          ;AND MUNG POINTER
+       POPJ    P,
+
+FRAMUP:        HRRZ    B,(A)           ;GET PROCESS POINTER
+       HRRE    B,(B)           ;GET    ITS RELOCATION
+       ADDM    B,(A)
+       HLLZ    B,OTBSAV(C)     ;GET FRAMES TIME
+       HLLM    B,1(A)          ;AND STORE IN FRAME POINTER
+       JRST    TBUP            ;AND CONTINUE UPDATING
+\f
+;VECTOR SHRINKING PHASE
+
+VECSH: SUBI    A,1             ;POOINT TO 1ST DOPE WORD
+VECSH1:        CAMGE   A,VECBOT        ;FINISHED
+       POPJ    P,              ;YES, QUIT
+       HRRZ    B,-1(A)         ;GET A SPEC
+       JUMPE   B,NXTSHN        ;IGNORE IF NONE
+       PUSHJ   P,GETGRO        ;GET THE SPECS
+       JUMPGE  C,SHRNBT        ;SHRINKIGN AT BOTTOM
+       MOVEI   E,(A)           ;COPY POINTER
+       ADD     A,C             ;POINT TO NEW DOPE LOCATION WITH E
+       MOVE    F,-1(E)         ;GET OLD DOPE
+       ANDCMI  F,777000        ;KILL THIS SPEC
+       MOVEM   F,-1(A)         ;STORE
+       MOVE    F,(E)           ;OTHER DOPE WORD
+       HRLZI   C,(C)           ;TO LH
+       ADD     F,C             ;CHANGE LENGTH
+       MOVEM   F,(A)           ;AND STORE
+       MOVMS   C               ;PLUSIFY
+       HLLZM   C,(E)           ;AND STORE
+       SETZM   -1(E)
+SHRNBT:        JUMPGE  B,NXTSHN        ;GROWTH, IGNOORE
+       MOVM    E,B             ;GET A POSITIVE COPY
+       HRLZI   B,(B)           ;TO LH
+       ADDM    B,(A)           ;ADD INTO DOPE WORD
+       MOVEI   0,777           ;SET TO CLOBBER GROWTH
+       ANDCAM  0,-1(A)         ;CLOBBER
+       HLRZ    B,(A)           ;GET NEW LENGTH
+       SUBI    A,(B)           ;POINT TO LOW END
+       HRLZM   E,(A)           ;STORE
+       SETZM   -1(A)
+
+NXTSHN:        HLRZ    B,(A)           ;GET LENGTH
+       JUMPE   B,VCMLOS        ;LOOSE
+       SUBI    A,(B)           ;STEP
+       JRST    VECSH1
+
+GETGRO:        LDB     C,[111100,,B]   ;GET UPWARD GROWTH
+       TRZE    C,400           ;CHECK AND MUNG SIGN
+       MOVNS   C
+       ASH     C,6             ;?IMES 100
+       ANDI    B,777           ;AND GET DOWN GROWTH
+       TRZE    B,400           ;CHECK AND MUNG SIGN
+       MOVNS   B
+       ASH     B,6
+       POPJ    P,
+\f;VECMOV -- MOVES VECTOR DATA TO WHERE RELOC FIELDS OF
+;VECTORS INDICATE.  MOVES DOPEWDS UP FOR VECTORS GROWING AT
+;THE END.
+;CALLED WITH VECTOP IN A.  CALLS PARMOV TO MOVE PAIRS
+
+VECMOV:        SUBI    A,1             ;SET A TO ADDR OF TOP DOPE WD
+       MOVSI   D,400000        ;NEGATIVE D MARKS END OF BACK CHAIN
+       MOVEI   TYPNT,0         ;CLEAR ON GOING ADDRESS FOR FORWARD RESUME
+VECMO1:        CAMGE   A,VECBOT        ;GOT TO BOTTOM OF VECTORS
+       JRST    PARMOV          ;YES, MOVE LIST ELEMENTS AND RETURN
+       MOVEI   C,(A)           ;NO, COPY ADDR OF THIS DOPEWD
+       HRRE    B,(A)           ;GET RELOCATION OF THIS VECTOR
+       JUMPL   B,VECMO5        ;IF MOVING DOWNWARD, MAKE BACK CHAIN
+       JUMPE   B,VECMO4        ;IF NON MOVER, JUST ADJUST DOPW AND MOVE ON
+
+       ADDI    C,(B)           ;SET ADDR OF LAST DESTINATION WD
+       HRLI    B,A             ;MAKE B INDEX ON A
+       HLL     A,(A)           ;COUNT TO A LEFT HALF
+
+       POP     A,@B            ;MOVE A WORD
+       TLNE    A,-1            ;REACHED END OF MOVING
+       JRST    .-2             ;NO, REPEAT
+               ;YES, NOTE A HAS ADDR OF NEXT DOPEWD
+;HERE TO ADJUST LOCATION OF DOPEWDS FOR GROWTH (FORWARDLY)
+VECMO2:        LDB     B,[111100,,-1(C)]               ;GET HIGH GROWTH FIELD
+       JUMPE   B,VECMO3        ;IF NO GROWTH, DONT MOVE
+       ASH     B,6             ;EXPRESS GROWTH IN WORDS
+       HRLI    C,2             ;SET COUNT FOR POPPING 2 DOPEWDS
+       HRLI    B,C             ;MAKE B INDEX ON C
+       POP     C,@B            ;MOVE PRIME DOPEWD
+       POP     C,@B            ;MOVE AUX DOPEWD
+VECMO3:        JUMPL   D,VECMO1        ;IF NO BACK CHAIN THEN MOVE ON
+       JRST    VECMO6          ;YES, BACKCHAINING, CONTINUE SAME
+
+;HERE TO SKIP OVER STILL VECTORS (FORWARDLY)
+VECMO4:        HLRZ    B,(A)           ;GET SIZE OF UNMOVER
+       SUBI    A,(B)           ;UPDATE A TO NEXT VECTOR
+       JRST    VECMO2          ;AND GO CLEAN UP GROWTH
+\f;HERE TO ESTABLISH A BACKWARDS CHAIN
+VECMO5:        EXCH    D,(A)           ;CHAIN FORWARD
+       HLRZ    B,D             ;GET SIZE
+       SUBI    A,(B)           ;GO ON TO NEXT VECOTR
+       CAMGE   A,VECBOT        ;HAVE WE GOT TO END OF VECTORS?
+       JRST    VECMO7          ;YES, GO MOVE PAIRS AND UNCHAIN
+       HRRE    B,(A)           ;GET RELOCATION OF THIS VECTOR
+       JUMPLE  B,VECMO5        ;IF NOT POSITIVE, CONTINUE CHAINING
+       MOVEM   A,TYPNT         ;SAVE ADDR FOR FORWARD RESUME
+
+;HERE TO UNCHAIN A VECTOR, MOVE IT, AND ADJUST DOPEWDS
+VECMO6:        HLRZ    B,D             ;GET SIZE
+       MOVEI   F,1(A)          ;GET A COPY OF BEGINNING OF VECTOR
+       ADDI    A,(B)           ;SET TO POINT TO ADDR OF DOPEWD CURRENTLY IN D
+       EXCH    D,(A)           ;AND UNCHAIN
+       HRRE    B,(A)           ;GET RELOCATION FOR THIS VECTOR
+       MOVEI   C,(A)           ;COPY A POINTER TO DOPEW
+       SKIPGE  D               ;HAVE WE REACHED THE TOP OF THE CHAIN?
+       MOVE    A,TYPNT         ;YES,   RESTORE FORWARD MOVE RESUME ADDR
+       JUMPE   B,VECMO2        ;IF STILL VECTOR,GO ADJUST DOPEWDS
+       ADDI    C,(B)           ;MAKE C POINT TO NEW DOPEW ADDR
+       ADDI    B,(F)           ;B RH NEW 1ST WORD
+       HRLI    B,(F)           ;B LH OLD 1ST WD ADDR
+       BLT     B,(C)           ;COPY THE DATA
+       JRST    VECMO2          ;AND GO ADJUST DOPEWDS
+
+;HERE TO STOP CHAINING BECAUSE OF BOTTOM OF VECTOR SPACE
+VECMO7:        MOVEM   A,TYPNT
+       PUSH    P,D
+       PUSHJ   P,PARMOV
+       POP     P,D
+       MOVE    A,TYPNT
+       JRST    VECMO6
+\f;PAIR MOVEMENT PHASE -- USES PARNEW,PARBOT, AND PARTOP TO MOVE PAIRS
+;TO NEW HOMES
+
+PARMOV:        SKIPN   A,PARNEW        ;IS THERE ANY PAIR MOVEMENT?
+       POPJ    P,              ;NO, RETURN
+       JUMPL   A,PARMO2        ;YES -- IF MOVING DOWNWARDS, GO DO A BLT
+       HRLI    A,B             ;MOVING UPWARDS SETAC A TO INDEX OFF AC B
+       MOVE    B,PARTOP        ;GET HIGH PAIR ADDREESS
+       SUB     B,PARBOT        ;AND SUBTRACT BOTTOM TO GET NUMBER OF PAIRS
+       HRLZS   B               ;PUT COUNT IN LEFT HALF
+       HRR     B,PARTOP        ;GET HIGH ADDRESS PLUS ONE IN RH
+       SUBI    B,1             ;AND SUBTRACT ONE TO POINT TO LAST WORD TO BE MOVED
+
+PARMO1:        TLNN    B,-1            ;HAS COUNT REACHED ZERO?
+       JRST    PARMO3          ;YES -- FINISH UP
+       POP     B,@A            ;NO -- TRANSFER2Y\eU NEXT WORD
+       JRST    PARMO1          ;AND REPEAT
+
+PARMO2:        MOVE    B,PARBOT        ;GET ADDRESS OF FIRST SOURCE WD
+       HRLS    B               ;IN BOTH HALVES OF AC B
+       ADD     B,A             ;MAKE RH OF B POINT TO FIRST DESTINATION WORD
+       ADD     A,PARTOP        ;MAKE RH OF A POINT TO LAST DESTINATION WORD PLUS ONE
+       BLT     B,-1(A)         ;AND TRANSFER THE BLOCK OF PAIRS
+
+PARMO3:        MOVE    A,PARNEW        ;GET OFFSET FOR PAIR SPACE
+       ADDM    A,PARBOT        ;AND CORRECT BOTTOM
+       ADDM    A,PARTOP        ;AND CORRECT TOP.
+       SETZM   PARNEW          ;CLEAR SO IF CALLED TWICE, NO LOSSAGE
+       POPJ    P,
+\f;VECZER -- CLEARS DATA IN AREAS JUST GROWN
+;UPDATES SIZE OF VECTORS
+;CLEARS RELOCATION AND GROWTH FIELDS IN DOPEWDS
+;CALLED WITH NEW VECTOP IN A (VECBOT SHOULD BE NEW TOO)
+
+VECZER:        SUBI    A,1             ;MAKE A POINT TO HIGH VECTORS
+VECZE1:        CAMGE   A,VECBOT        ;REACHED BOTTOM OF VECTORS?
+       POPJ    P,              ;YES, RETURN
+       HLLZS   F,(A)           ;NO, CLEAR RELOCATION GET SIZE
+       HLRZS   F               ;AND PUT SIZE IN RH OF F
+       HRRZ    B,-1(A)         ;GET GROWTH INTO B
+       JUMPN   B,VECZE3        ;IF THERE IS SOME GROWTH, GO DO IT
+VECZE2:        SUBI    A,(F)           ;GROWTH DONE, MOVE ON TO NEXT VECTOR
+       JRST    VECZE1          ;AND REPEAT
+
+VECZE3:        HLLZS   -1(A)           ;CLEAR GROWTH IN THE VECTOR
+       LDB     C,[111100,,B]           ;GET HIGH ORDER GROWTH IN C
+       ANDI    B,777           ;AND LIMIT B TO LOW SIDE
+       ASHC    B,6             ;EXPRESS GROWTH IN WORDS
+       JUMPE   C,VECZE4        ;IF NO HIGH GROWTH SKIP TO LOW GROWTH
+       ADDI    F,(C)           ;ADD HIGH GROWTH TO SIZE
+       SUBM    A,C             ;GET ADDR OF 2ND WD TO BE ZEROED
+       SETZM   -1(C)           ;CLEAR 1ST WORD
+       HRLI    C,-1(C)         ;MAKE C A CLEARING BLT POINTER
+       BLT     C,-2(A)         ;AND CLEAR HIGH END DATA
+\rVECZE4:       JUMPE   B,VECZE5        ;IF NO LOW GROWTH SKIP TO SIZE UPDATE
+       MOVNI   C,(F)           ;GET NEGATIVE SIZE SO FAR
+       ADDI    C,(A)           ;AND MAKE C POINT TO LAST WORD OF STUFF TO BE CLEARED
+       ADDI    F,(B)           ;UPDATE SIZE
+       SUBM    C,B             ;MAKE B POINT TO LAST WD OF NEXT VECT
+       ADDI    B,2             ;AND NOW TO 2ND DATA WD TO BE CLEARED
+       SETZM   -1(B)           ;CLEAR 1ST DATA WD
+       HRLI    B,-1(B)         ;MAKE B A CLEARING BLT POINTER
+       BLT     B,(C)           ;AND CLEAR THE LOW DATA
+\rVECZE5:       HRLZM   F,(A)           ;STORE THE NEW SIZE IN DOPEWD
+       JRST    VECZE2
+\f
+;SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE
+
+REHASH:        MOVE    TVP,TVPSTO+1(PVP)       ;RESTORE TV POINTER
+       MOVE    D,ASOVEC+1(TVP) ;GET POINTER TO VECTOR
+       MOVEI   E,(D)
+       PUSH    P,E             ;PUSH A POINTER
+       HLRE    A,D             ;GET -LENGTH
+       MOVMS   A               ;AND PLUSIFY
+       PUSH    P,A             ;PUSH IT ALSO
+
+REH3:  HRRZ    C,(D)           ;POINT TO FIRST BUCKKET
+       HLRZS   (D)             ;MAKE SURE NEW POINTER IS IN RH
+       JUMPE   C,REH1          ;B\0UCKET EMPTY, QUIT
+
+REH2:  MOVEI   E,(C)           ;MAKE A COPY OF THE POINTER
+       MOVE    A,ITEM(C)       ;START HASHING
+       XOR     A,ITEM+1(C)
+       XOR     A,INDIC(C)
+       XOR     A,INDIC+1(C)
+       MOVMS   A               ;MAKE SURE FINAL HASH IS +
+       IDIV    A,(P)           ;DIVIDE BY TOTAL LENGTH
+       ADD     B,-1(P)         ;POINT TO WINNING BUCKET
+
+       MOVE    C,[002200,,(B)] ;BYTE POINTER TO RH
+       CAILE   B,(D)           ;IF PAST CURRENT POINT
+       MOVE    C,[222200,,(B)] ;USE LH
+       LDB     A,C             ;GET OLD VALUE
+       DPB     E,C             ;STORE NEW VALUE
+       HRRZ    B,ASOLNT-1(E)   ;GET NEXT POINTER
+       HRRZM   A,ASOLNT-1(E)   ;AND CLOBBER IN NEW NEXT
+       SKIPE   A               ;SKKIP IF NOTHING PREVIOUSLY IN BUCKET
+       HRLM    E,ASOLNT-1(A)   ;OTHERWISE CLOBBER
+       SKIPE   C,B             ;SKIP IF END OF CHAIN
+       JRST    REH2
+REH1:  AOBJN   D,REH3
+
+       SUB     P,[2,,2]        ;FLUSH THE JUNK
+       POPJ    P,
+\fVCMLOS:       MOVEI   B,[ASCIZ /AGC -- VECTOR WITH ZERO IN DOPE WORD LENGTH
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+;LOCAL VARIABLES
+
+GETNUM:        0                       ;NO OF WORDS TO GET
+PARNUM:        0                       ;NO OF PAIRS MARKED
+VECNUM:        0                       ;NO OF WORDS IN MARKED VECTORS
+CORSET:        0                       ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY
+CORTOP:        0                       ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY
+
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
+;AND WHEN IT WILL GET UNHAPPY
+
+SYSMAX:        50.                     ;MAXIMUM SIZE OF MUDDLE
+FREMIN:        1000                    ;MINIMUM FREE WORDS
+FREDIF:        10000                   ;DIFFERENCE BETWEEN FREMIN AND MAXIMUM NUMBER OF FREE WORDS
+;POINTER TO GROWING PDL
+
+TPGROW:        0                       ;POINTS TO A BLOWN TP
+PPGROW:        0                       ;POINTS TO A BLOWN PP
+TIMOUT:        0                       ;POINTS TO TIMED OUT PDL
+PGROW: 0                       ;POINTS TO A BLOWN P
+
+;IN GC FLAG
+
+GCFLG: 0
+
+
+END
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/arith.58 b/MUDDLE/arith.58
new file mode 100644 (file)
index 0000000..1e1e933
--- /dev/null
@@ -0,0 +1,626 @@
+TITLE ARITHMETIC PRIMITIVES FOR MUDDLE
+
+;BKD
+
+;DEFINES MUDDLE PRIMITIVES:   FIX,FLOAT,ATAN,IEXP,LOG,
+;      G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM,
+;      TIME,SORT.
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+O=0
+
+
+DEFINE TYP1
+       (AB) TERMIN
+DEFINE VAL1
+       (AB)+1 TERMIN
+
+DEFINE TYP2
+       (AB)+2 TERMIN
+DEFINE VAL2
+       (AB)+3 TERMIN
+
+DEFINE TYP3
+       (AB)+4 TERMIN
+DEFINE VAL3
+       (AB)+5 TERMIN
+
+DEFINE TYPN
+       (D) TERMIN
+DEFINE VALN
+       (D)+1 TERMIN
+
+
+YES:   MOVSI   A,TATOM ;RETURN PATH FOR 'TRUE'
+       MOVE    B,MQUOTE T
+       JRST FINIS
+
+NO:    MOVSI   A,TFALSE        ;RETURN PATH FOR 'FALSE'
+       MOVEI   B,NIL
+       JRST FINIS
+
+\f;ERROR RETURNS AND OTHER UTILITY ROUTINES
+
+OVRFLW==10
+OVRFLD:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE OVERFLOW
+       JRST    CALER1
+
+ARGCHK:                        ;CHECK FOR SINGLE FIXED OR FLOATING
+                       ;ARGUMENT IF FIXED CONVERT TO FLOATING
+                       ;RETURN FLOATING ARGRUMENT IN B ALWAYS
+       ENTRY   1
+       HLRZ    C,TYP1  
+       MOVE    B,VAL1
+       CAIN    C,TFLOAT        ;FLOATING?
+       POPJ P, ;YES, RETURN
+       CAIE    C,TFIX  ;FIXED?
+       JRST    WTYP    ;NO, ERROR
+       JSP A,BFLOAT    ;YES, CONVERT TO FLOATING AND RETURN
+       POPJ P,
+
+OUTRNG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ARGUMENT-OUT-OF-RANGE
+       JRST    CALER1
+
+NSQRT: PUSH TP,$TATOM
+       PUSH TP,MQUOTE NEGATIVE-ARGUMENT
+       JRST CALER1"
+
+WTYP:  PUSH TP,$TATOM
+       PUSH TP,MQUOTE WRONG-TYPE
+       JRST CALER1
+
+DEFINE MFLOAT AC
+       IDIVI AC, 400000
+       FSC     AC+1,233
+       FSC     AC,254
+       FADR AC,AC+1
+       TERMIN
+
+BFLOAT:        MFLOAT  B
+       JRST    (A)
+
+OFLOAT:        MFLOAT  O
+       JRST    (C)
+
+BFIX:  MULI    B,400
+       TSC     B,B
+       ASH     C,(B)-243
+       MOVE    B,C
+       JRST    (A)
+
+\f;DISPATCH TABLES USED TO CONTROL THE FLOW OF THE VARIOUS PRIMITIVES
+
+TABLE2:        NO      ;TABLE2 (0)
+TABLE3:        YES     ;TABLE2 (1)  &  TABLE3 (0)
+       NO      ;TABLE2 (2)
+
+
+FUNC:          JSP     A,BFIX
+       JSP     A,BFLOAT
+       SUB     B,VALN
+       IDIV    B,VALN
+       ADD     B,VALN
+       IMUL    B,VALN
+       JSP     C,SWITCH
+       JSP     C,SWITCH
+
+FLFUNC==.-2
+       FSBR    B,O
+       FDVR    B,O
+       FADR    B,O
+       FMPR    B,O
+       JSP     C,FLSWCH
+       JSP     C,FLSWCH
+\f;PRIMITIVES FLOAT AND FIX
+
+MFUNCTION      FIX,SUBR
+       MOVEI   E,0
+       JRST    TRANS
+
+MFUNCTION      FLOAT,SUBR
+       MOVEI   E,1
+
+TRANS: ENTRY   1
+       MOVE    A,TYP1
+       MOVE    B,VAL1
+       CAMN    A,TYPS(E)+1     ;SAME TYPE ARGUMENT?
+       JRST    FINIS
+       CAME    A,TYPS(E)       ;correct type argument ?
+       JRST    WTYP
+       XCT     FUNC(E) ;perform appropriate operation
+       MOVE    A,TYPS(E)+1     ;save this new type
+JRST FINIS
+
+TYPS:          TFLOAT,,0
+       TFIX,,0
+       TFLOAT,,0
+
+MFUNCTION      ABS,SUBR
+       ENTRY   1
+       MOVE    A,TYP1
+       CAME    A,$TFIX
+       CAMN    A,$TFLOAT
+       JRST    MOVIT
+       JRST    WTYP
+MOVIT: MOVM    B,VAL1  ;GET ABSOLUTE VALUE OF ARGUMENT
+       JRST    FINIS
+
+MFUNCTION      MOD,SUBR
+       ENTRY   2
+       MOVSI   A,TFIX
+       CAME    A,TYP1  ;FIRST ARG FIXED ?
+       JRST    WTYP
+       CAME    A,TYP2  ;SECOND ARG FIXED ?
+       JRST    WTYP
+       MOVE    B,VAL1
+       IDIV    B,VAL2  ;FORM QUOTIENT & REMAINDER
+       JUMPGE  C,.+2   ;Only return positive remainders
+       ADD     C,VAL2
+       MOVE    B,C     ;RETURN REMAINDER
+       JRST    FINIS
+\f;PRIMITIVES PLUS, DIFFERENCE, TIMES, DIVIDE, MIN, AND MAX
+
+MFUNCTION      MIN,SUBR
+       MOVEI   E,6
+       JRST    GOPT
+
+       MFUNCTION       MAX,SUBR
+       MOVEI   E,7
+GOPT:  ENTRY
+       MOVE    D,AB    ;ARGUMENT POINTER
+       JUMPL   D,MINMAX        ;ANY ARGUMENTS AT ALL ?
+       MOVSI   A,TFLOAT        ;DEFAULT TYPE
+       MOVE    B,INFIN(E)      ;DEFAULT VALUE + OR - "LARGE NUMBER"
+       JRST    FINIS
+INFIN==.-6
+       377777,,-1
+       400000,,1
+
+MFUNCTION      DIVIDE,SUBR,[/]
+       MOVEI   E,3
+       JRST    ARITH0
+
+MFUNCTION      DIFFERENCE,SUBR,[-]
+       MOVEI   E,2
+       JRST    ARITH0
+
+MFUNCTION      TIMES,SUBR,[*]
+       MOVEI   E,5
+       JRST    ARITH0
+
+MFUNCTION      PLUS,SUBR,[+]
+       MOVEI   E,4
+
+ARITH0:        ENTRY
+       MOVE    D,AB    ;argument pointer
+       CAMGE   D,[-2,,0]       ;LESS THAN TWO ARGUMENTS ?
+       JRST    MINMAX
+       MOVSI   A,TFIX  ;initial type of result
+       MOVE    B,E     ;initial accumulator contents for zero & one argument
+       TRZ     B,-2
+       JRST    MINMAX+3
+MINMAX:        MOVE    A,TYP1
+       MOVE    B,VAL1  ;initial value of accumulator for more than one argument is first value
+       ADD     D,[2,,2]        ;UPDATE ARGUMENT POINTER
+       JUMPGE  D,FINIS ;ANY MORE ARGUMENTS ?
+       JFCL    OVRFLW,.+1
+       CAME    A,$TFIX ;WAS THE FIRST ARGUMENT FIXED ?
+       JRST    ARITH3
+ARITH1:        CAME    A,TYPN  ;next argument fixed ?
+       JRST    ARITH2
+       XCT     FUNC(E) ;PERFORM APPROPRIATE OPERATION
+       ADD     D,[2,,2]        ;UPDATE ARGUMENT POINTER
+       JUMPL   D,ARITH1        ;repeat for next argument if any
+       JFCL    OVRFLW,OVRFLD
+       JRST    FINIS
+\f;CONTINUATION OF PLUS,TIMES, ETC.
+
+ARITH3:        CAME    A,$TFLOAT       ;was the first argument floating ?
+       JRST    WTYP
+       SKIPA
+
+ARITH2:        JSP     A,BFLOAT        ;float accumulator contents
+       MOVE    C,TYPN  ;get next argument's type
+       MOVE    O,VALN  ;get next argument's value
+       CAMN    C,$TFLOAT       ;floating ?
+       JRST    OPERATE
+       CAME    C,$TFIX ;fixed ?
+       JRST    WTYP
+       JSP     C,OFLOAT        ;go float this fixed argument
+OPERATE:       XCT     FLFUNC(E)       ;perform appropriate operation
+       ADD     D,[2,,2]        ;UPDATE ARGUMENT POINTER
+       JUMPL   D,ARITH2+1      ;repeat for next argument if any
+       JFCL    OVRFLW,OVRFLD
+       MOVSI   A,TFLOAT
+       JRST FINIS
+
+SWITCH:        XCT     COMPAR(E)       ;FOR MAX & MIN TESTING
+       MOVE    B,VALN
+       JRST    (C)
+COMPAR==.-6
+       CAMLE   B,VALN
+       CAMGE   B,VALN
+
+FLSWCH:        XCT     FLCMPR(E)
+       MOVE    B,O
+       JRST    (C)
+FLCMPR==.-6
+       CAMLE   B,O
+       CAMGE   B,O
+\f;PRIMITIVES ONEP AND ZEROP
+
+MFUNCTION      ONEP,SUBR,[1?]
+       MOVEI   E,1
+       JRST    JOIN
+
+MFUNCTION      ZEROP,SUBR,[0?]
+       MOVEI   E,
+
+JOIN:  ENTRY 1
+       MOVE    A,TYP1
+       CAMN    A,$TFIX ;fixed ?
+       JRST    TESTFX
+       CAME    A,$TFLOAT       ;floating ?
+       JRST    WTYP
+       MOVE    B,VAL1
+       CAMN    B,NUMBR(E)      ;equal to correct value ?
+       JRST    YES
+       JRST    NO
+
+TESTFX:        CAMN    E,VAL1  ;equal to correct value ?
+       JRST    YES
+       JRST    NO
+
+NUMBR: 0       ;FLOATING PT  ZERO
+       201400,,0       ;FLOATING PT ONE
+\f;PRIMITIVES LESSP AND GREATERP
+
+
+MFUNCTION      LESSP,SUBR,[L?]
+       MOVEI   E,1
+       JRST    ARGS
+
+MFUNCTION      GREATERP,SUBR,[G?]
+       MOVEI   E,0
+
+ARGS:  ENTRY 2
+       MOVE    O,VAL1
+       MOVE    A,TYP1
+       MOVE    B,VAL2
+       SETO    D,      ;used for flow of control in this routine
+       CAMN    A,$TFLOAT
+       AOJA    D,CONT
+       CAME    A,$TFIX
+       JUMPL   D,WTYP
+CONT:  MOVE    A,TYP2
+       CAMN    A,$TFIX
+       AOJE    D,FIXFIX        ;are both arguments fixed
+       CAME    A,$TFLOAT
+       JRST    FLTFIX
+       JUMPE   D,FLTFLT        ;are both arguments floating ?
+       JSP     C,OFLOAT        ;go float the first argument
+FLTFLT:        FSBR    O,B     ;both arguments are floating here
+TEST:  JUMPL   O,@TABLE2(E)
+       JUMPG   O,@TABLE3(E)
+       JRST    NO
+
+FLTFIX:        JUMPLE  D,WTYP
+       JSP     A,BFLOAT        ;go float the second argument
+       JRST    FLTFLT
+
+FIXFIX:        SUB     O,B     ;both arguments are fixed here
+       JRST    TEST
+
+MFUNCTION RANDOM,SUBR
+       ENTRY
+       HLRE    A,AB
+       CAMGE   A,[-4]  ;At most two arguments to random to set seeds
+       JRST    WNA
+       JRST    RANDGO(A)
+       MOVE    B,VAL2  ;Set second seed
+       MOVEM   B,RLOW
+       MOVE    A,VAL1  ;Set first seed
+       MOVEM   A,RHI
+RANDGO:        MOVE B,RLOW     ;FREDKIN'S RANDOM NUMBER GENERATOR.
+       MOVE A,RHI
+       MOVEM A,RLOW
+       LSHC A,-43
+       XORB B,RHI
+       MOVSI A,TFIX
+       JRST FINIS
+RHI:   267762113337
+RLOW:  155256071112
+\fMFUNCTION SQRT,SUBR
+       ENTRY 1
+       MOVE B,1(AB)
+       HLRZ A,(AB)
+       CAIN A,TFLOAT
+       JRST SQ1
+       CAIE A,TFIX
+       JRST WTYP
+       JSP A,BFLOAT
+SQ1:   JUMPL B,NSQRT
+
+       MOVE A,B
+       ASH B,-1
+       FSC B,100
+SQ2:   MOVE C,B        ;NEWTON'S METHOD, SPECINER'S HACK.
+       FDVRM A,B
+       FADRM C,B
+       FSC B,-1
+       CAME C,B
+       JRST SQ2
+       MOVSI A,TFLOAT
+       JRST FINIS
+
+
+MFUNCTION COS,SUBR
+       ENTRY 1
+       MOVE B,1(AB)
+       HLRZ A,(AB)
+       CAIN A,TFLOAT
+       JRST COS1
+       CAIE A,TFIX
+       JRST WTYP
+       JSP A,BFLOAT
+COS1:  FADR B,[1.570796326]    ;COS(X)=SIN (X+PI/2)
+       PUSHJ P,.SIN
+       MOVSI A,TFLOAT
+       JRST FINIS
+
+MFUNCTION SIN,SUBR
+       ENTRY 1
+       MOVE B,1(AB)
+       HLRZ A,(AB)
+       CAIN A,TFLOAT
+       JRST SIN1
+       CAIE A,TFIX
+       JRST WTYP
+       JSP A,BFLOAT
+SIN1:  PUSHJ P,.SIN
+       MOVSI A,TFLOAT
+       JRST FINIS
+
+.SIN:  MOVM A,B
+       CAMG A,[.0001]
+       POPJ P,         ;GOSPER'S RECURSIVE SIN.
+       FDVR B,[-3.0]   ;SIN(X)=4*SIN(X/-3)**3-3*SIN(X/-3)
+       PUSHJ P,.SIN
+       FSC A,1
+       FMPR A,A
+       FADR A,[-3.0]
+       FMPRB A,B
+       POPJ P,
+MFUNCTION      LOG,SUBR
+       PUSHJ P,ARGCHK  ;LEAVES ARGUMENT IN B
+       JUMPLE  B,OUTRNG
+       LDB     D,[331100,,B]   ;GRAB EXPONENT
+       SUBI    D,201   ;REMOVE BIAS
+       TLZ     B,777000        ;SET EXPONENT
+       TLO     B,201000        ; TO 1
+       MOVE    A,B
+       FSBR    A,RT2
+       FADR    B,RT2
+       FDVB    A,B
+       FMPR    B,B
+       MOVE    C,[0.434259751]
+       FMPR    C,B
+       FADR    C,[0.576584342]
+       FMPR    C,B
+       FADR    C,[0.961800762]
+       FMPR    C,B
+       FADR    C,[2.88539007]
+       FMPR    C,A
+       FADR    C,[0.5]
+
+       MOVE    B,D
+       FSC     B,233
+       FADR    B,C
+       FMPR    B,[0.693147180] ;LOG E OF 2
+       MOVSI   A,TFLOAT
+       JRST    FINIS
+RT2:   1.41421356
+\fMFUNCTION     ATAN,SUBR
+       PUSHJ P,ARGCHK
+       MOVM    D,B
+       CAMG    D,[0.4^-8]      ;SMALL ENOUGH SO ATAN(X)=X?
+       JRST    ATAN3   ;YES
+       CAML    D,[7.0^7]       ;LARGE ENOUGH SO THAT ATAN(X)=PI/2?
+       JRST    ATAN1   ;YES
+       MOVN    C,[1.0]
+       CAMLE   D,[1.0] ;IS ABS(X)<1.0?
+       FDVM    C,D     ;NO,SCALE IT DOWN
+       MOVE    B,D
+       FMPR    B,B
+       MOVE    C,[1.44863154]
+       FADR    C,B
+       MOVE    A,[-0.264768620]
+       FDVM    A,C
+       FADR    C,B
+       FADR    C,[3.31633543]
+       MOVE    A,[-7.10676005]
+       FDVM    A,C
+       FADR    C,B
+       FADR    C,[6.76213924]
+       MOVE    B,[3.70925626]
+       FDVR    B,C
+       FADR    B,[0.174655439]
+       FMPR    B,D     ;
+       JUMPG   D,ATAN2 ;WAS ARG SCALED?
+       FADR    B,PI2   ;YES,  ATAN(X)=PI/2-ATAN(1/X)
+       JRST    ATAN2
+ATAN1: MOVE    B,PI2
+ATAN2: SKIPGE  1(AB)   ;WAS INPUT NEGATIVE?
+       MOVNS   B               ;YES,COMPLEMENT
+ATAN3: MOVSI   A,TFLOAT        
+       JRST    FINIS
+PI2:   1.57079632
+\fMFUNCTION     IEXP,SUBR,[EXP] 
+       PUSHJ P,ARGCHK  ;LEAVE FLOATING POINT ARG IN B
+       MOVM    A,B
+       SETZM   B
+       FMPR    A,[0.434294481] ;LOG BASE 10 OF E
+       MOVE    D,[1.0]
+       CAMG    A,D
+       JRST    RATEX
+       MULI    A,400
+       ASHC    B,-243(A)
+       CAILE   B,43
+       JRST    OUTRNG
+       CAILE   B,7
+       JRST    EXPR2
+EXPR1: FMPR    D,FLOAP1(B)
+       LDB     A,[103300,,C]   
+       SKIPE   A
+       TLO     A,177000
+       FADR    A,A
+RATEX: MOVEI   B,7
+       SETZM   C
+RATEY: FADR    C,COEF2-1(B)
+       FMPR    C,A
+       SOJN    B,RATEY
+       FADR    C,[1.0] 
+       FMPR    C,C
+       FMPR    D,C
+       MOVE    B,[1.0]
+       SKIPL   1(AB)   ;SKIP IF INPUT NEGATIVE
+       SKIPN   B,D
+       FDVR    B,D
+       MOVSI   A,TFLOAT
+       JRST    FINIS
+EXPR2: LDB     E,[030300,,B]   
+       ANDI    B,7
+       MOVE    D,FLOAP1(E)
+       FMPR    D,D     ;TO THE 8TH POWER
+       FMPR    D,D
+       FMPR    D,D
+       JRST    EXPR1
+
+COEF2: 1.15129278
+       0.662730884
+       0.254393575
+       0.0729517367
+       0.0174211199
+       2.55491796^-3
+       9.3264267^-4
+
+FLOAP1:        1.0
+       10.0
+       100.0
+       1000.0
+       10000.0
+       100000.0
+       1000000.0
+       10000000.0
+\f;routine to sort lists or vectors of either fixed point or floating numbers
+;the components are interchanged repeatedly to acheive the sort
+;first arg:    the structure to be sorted
+;if no second arg sort in descending order
+;second arg:   if false then sort in ascending order
+;              else sort in descending order
+
+MFUNCTION      SORT,SUBR
+       ENTRY 
+       HLRZ    A,AB
+       CAIGE   A,-4    ;Only two arguments allowed
+       JRST    WNA
+       MOVE    O,DESCEND       ;Set up "O" to test for descending order as default condition
+       CAIE    A,-4    ;Optional second argument?
+       JRST    .+4
+       HLRZ    B,TYP2  ;See if it is other than false
+       CAIN    B,TFALSE
+       MOVE    O,ASCEND        ;Set up "O" to test for ascending order
+       HLRZ    A,TYP1  ;CHECK TYPE OF FIRST ARGUMENT
+       CAIN    A,TLIST
+       JRST    LSORT
+       CAIN    A,TVEC
+       JRST    VSORT
+       JRST    WTYP
+
+
+
+
+GOBACK:        MOVE    A,TYP1  ;RETURN THE SORTED ARGUMENT AS VALUE
+       MOVE    B,VAL1
+       JRST    FINIS
+
+DESCEND:       CAMG    C,(A)+1
+ASCEND:                CAML    C,(A)+1
+\f;ROUTINE TO SORT LISTS IN NUMERICAL ORDER
+
+LSORT: MOVE    A,VAL1
+       JUMPE   A,GOBACK        ;EMPTY LIST?
+       HLRZ    B,(A)   ;TYPE OF FIRST COMPONENT
+       CAIE    B,TFIX
+       CAIN    B,TFLOAT
+       SKIPA
+       JRST    WTYP
+       MOVEI   E,0     ;FOR COUNT OF LENGTH OF LIST
+LCOUNT:        JUMPE   A,LLSORT        ;REACHED END OF LIST?
+       MOVE    A,(A)   ;NEXT COMPONENT
+       TLZ     A,(B)   ;SAME TYPE AS FIRST COMPONENT?
+       TLNE    A,-1
+       JRST    WTYP
+       AOJA    E,LCOUNT        ;INCREMENT COUNT AND CONTINUE
+
+LLSORT:        SOJE    E,GOBACK        ;FINISHED WITH SORTING?
+       HRRZ    A,VAL1  ;START THIS LOOP OF SORTING AT THE BEGINNING
+       MOVEM   E,(P)+1 ;Save the iteration depth
+CLSORT:        HRRZ    B,(A)   ;NEXT COMPONENT
+       MOVE    C,(B)+1 ;ITS VALUE
+       XCT     O       ;ARE THESE TWO COMPONENTS IN ORDER?
+       JRST    .+4
+       MOVE    D,(A)+1 ;INTERCHANGE THEM
+       MOVEM   D,(B)+1
+       MOVEM   C,(A)+1
+       MOVE    A,B     ;MAKE THE COMPONENT IN "B" THE CURRENT ONE
+       SOJG    E,CLSORT
+       MOVE    E,(P)+1 ;Restore the iteration depth
+       JRST    LLSORT
+\f;ROUTINE TO SORT VECTORS IN NUMERICAL ORDER
+
+VSORT: HLRE    D,VAL1  ;GET COUNT FIELD OF VECTOR
+       IDIV    D,[-2]  ;LENGTH
+       JUMPE   D,GOBACK        ;EMPTY VECTOR?
+       MOVE    E,D     ;SAVE LENGTH IN "E"
+       HRRZ    A,VAL1  ;POINTER TO VECTOR
+       MOVE    B,(A)   ;TYPE OF FIRST COMPONENT
+       CAME    B,$TFIX
+       CAMN    B,$TFLOAT
+       SKIPA
+       JRST    WTYP
+       SOJLE   D,GOBACK        ;IF ONLY ONE COMPONENT THEN FINISHED
+VCOUNT:        ADDI    A,2     ;CHECK NEXT COMPONENT
+       CAME    B,(A)   ;SAME TYPE AS FIRST COMPONENT?
+       JRST    WTYP
+       SOJG    D,VCOUNT        ;CONTINUE WITH NEXT COMPONENT
+
+VVSORT:        SOJE    E,GOBACK        ;FINISHED SORTING?
+       HRRZ    A,VAL1  ;START THIS LOOP OF SORTING AT THE BEGINNING
+       MOVEM   E,(P)+1 ;Save the iteration depth
+CVSORT:        MOVE    C,(A)+3 ;VALUE OF NEXT COMPONENT
+       XCT     O       ;ARE THESE TWO COMPONENTS IN ORDER?
+       JRST    .+4
+       MOVE    D,(A)+1 ;INTERCHANGE THEM
+       MOVEM   D,(A)+3
+       MOVEM   C,(A)+1
+       ADDI    A,2     ;UPDATE THE CURRENT COMPONENT
+       SOJG    E,CVSORT
+       MOVE    E,(P)+1 ;Restore the iteration depth
+       JRST    VVSORT
+
+
+MFUNCTION TIME,SUBR
+       ENTRY 0
+       .RDTIME B,      ;Get time since SYSTEM up
+       MOVSI   A,TFIX
+       JRST    FINIS
+
+
+END
+\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/atomhk.27 b/MUDDLE/atomhk.27
new file mode 100644 (file)
index 0000000..4e5f9ef
Binary files /dev/null and b/MUDDLE/atomhk.27 differ
diff --git a/MUDDLE/book.3 b/MUDDLE/book.3
new file mode 100644 (file)
index 0000000..5ade565
--- /dev/null
@@ -0,0 +1,481 @@
+V ORG P-K4 V KP P-K4 V 2W1 N-KB3 V 2B1 N-KB3 V 3W1 P-Q4 V 3B1 NXP
+V 4W1 B-Q3 V 4B1 P-Q4 V 5W1 NXP V 5B1 B-Q3 V 6W1 O-O V 6B1 O-O
+V 7W1 N-Q2 B-KB4 R-K1 BXN PXB B-N3 N-B3 E Q-K2 R-K1 E E E E E E 
+P-QB4 BXN PXB NXBP E E E E E NXN BXN N-Q2 NXN E E E E 
+N-KB3 QN-B3 N-B3 P-B3 E E N-K5 P-B4 L 7W1 P-QB4 BXN PXB 
+N-QB3 P-B4 B-B4 P-KN4 PXP E E E E B-KB4 B-K3 E E 
+PXP QXP Q-B3 B-B4 QXB QXB N-B3 N-B4 
+QXQ NXQ L 7W1 N-QB3 NXN PXN N-Q2 P-KB4 
+P-QB4 E E R-K1 Q-R5 P-N3 Q-R6 B-B1 Q-B4 N-N4 N-N3 
+N-K3 Q-B3 B-Q3 P-KR3 N-N4 BXN QXB QR-K1 
+L 7W1 R-K1 BXN PXB N-QB3 B-KB4 N-B4 N-B3 N-N5 
+B-KB1 P-Q5 N-K4 NXN L 7W1 P-KB3 N-B4 L 6B1 
+N-QB3 NXN PXN P-QB4 O-O P-B5 B-K2 N-B3 L 6B1 
+BXN PXB N-B4 N-B3 L 6W1 Q-K2 BXN PXB N-B4 
+L 6W1 N-QB3 NXN PXN O-O O-O N-Q2 P-KB4 P-QB4 L 5B1 B-K3 
+Q-K2 N-Q3 O-O B-K2 R-K1 O-O NXP E E Q-B1 N-QB3 O-O Q-R5 P-KB4 
+N-K2 E E E E E E N-Q2 B-KB4 NXN BXN O-O N-Q2 B-B3 
+Q-R5 P-KN3 Q-R6 BXB PXB N-B4 BXN BXB N-B3 
+P-KB3 N-Q4 PXP RXP L 5B1 N-QB3 NXN PXN Q-K2 
+V 7B10 P-KB4 P-KB3 B-Q3 O-O O-O 
+PXN BPXP RXR QXR BXKP PXB Q-QB4 E E E E E E E E 
+Q-K2 PXN BPXP Q-R5 P-N3 Q-R6 PXB B-N5 Q-K5 B-B6 
+L 7B10 Q-K2 O-O V 8B10 N-Q3 R-K1 QXQ RXQ 
+K-Q1 N-Q2 B-KB4 N-N3 BXB PXB L 8B10 P-N3 
+BXN PXB R-K1 P-KB4 P-KB3 E E E E QXB Q-Q2 L 5B1 N-Q2 
+Q-K2 NXN BXN E E Q-K2 BXN PXB B-B4 NXN BXN 
+P-KB3 B-N3 P-KB4 N-B3 P-B3 O-O-O B-K3 P-Q5 E E 
+Q-KN4 K-N1 B-N5 N-N5 P-B5 N-B7 K-B1 QXP B-KB4 Q-K5 
+ L 5B1 B-K2 O-O O-O 
+P-QB4 B-K3 N-QB3 N-KB3 P-B5 E E E E N-KB3 N-QB3 PXP BXBP E E E E 
+P-QB3 PXP PXP BXN PXB N-QB3 L 5W1 PXP N-B4 O-O B-K2 
+N-B3 P-QB3 N-K2 NXB QXN P-B3 E E E E 
+N-Q4 NXB QXN O-O P-B4 P-B3 B-Q2 N-R3 L 4W1 PXP P-Q4 QN-Q2 
+N-B4 N-N3 NXN RPXN N-B3 P-R3 B-K2 L 3B1 
+P-Q3 N-B3 E E P-Q4 PXQP PXP B-QN5 P-B3 PXP Q-R4 N-B3 PXP NXP PXB 
+Q-B3 E E E E E E PXP B-QB4 Q-K2 B-K2 P-B4 P-B3 L 3B1 PXP P-K5 
+N-K5 QXP P-Q4 PXG NXQP B-Q3 N-B3 Q-KB4 V 8B2 Q-K2 B-K3 P-KN3 
+N-B3 B-K3 O-O B-N2 KR-K1 O-O QB-B5 L 8B2 P-KN3 O-O B-N2 N-B3 
+O-O B-K3 B-K3 B-QB5 P-N3 B-R3 N-K2 QR-Q1 L 3W1 B-B4 NXP N-B3
+NXN QPXN P-QB3 NXP P-Q4 O-O B-Q3 R-K1 B-K3 B-Q3 N-Q2
+L 3W1 N-B3 B-N5 V 4W2 B-B4 N-B3 N-Q5 NXP Q-K2 
+N-B3 NXKP O-O E E E E E E O-O 
+O-O N-Q5 NXN BXN P-Q3 P-B3 B-R4 E E E E E E 
+P-Q3 BXN PXB P-Q4 PXP NXP Q-K1 N-N3 E E B-Q2 B-N5 
+R-K1 Q-Q3 Q-K2 QR-K1 E E R-N1 N-N3 B-QN5 QR-K1 BXN PXB 
+P-B4 BXN QXB NXP L 4W2 NXP O-O N-Q3 BXN QPXB NXP 
+B-K2 P-Q3 E E E E E E N-B3 BXN QPXB NXP B-Q3 P-Q4 
+P-KR3 N-QB3 E E E E E E E E P-Q3 P-Q4 P-QR3 BXN 
+PXB R-K1 P-KB4 PXP E E E E E E E E B-K2 
+R-K1 N-Q3 BXN QPXB NXP O-O P-Q4 B-B4 N-QB3 P-B3 
+N-B3 Q-Q2 B-B4 E E E E E E B-K3 N-Q2 N-B4 QN-B3 
+P-B4 PXP E E E E E E N-B4 P-QB3 B-K3 N-Q3 B-Q3 B-B4 
+L 3W1 NXP P-Q3 V 4W3 N-KB3 NXP V 5W2 P-Q4 P-Q4 B-Q3 B-K2 V 7W2 
+P-B4 B-QN5 QN-Q2 BXN BXB O-O O-O B-N5 B-B4 N-QB3 R-K1 
+NXQP BXN PXB QXN PXN QXQ KRXQ BXP R-Q7 L 7W2 O-O N-QB3 V 8W2 P-B4 
+N-N5 B-K2 PXP BXP O-O E E E E PXP NXB QXN QXP R-K1 B-KB4
+N-K5 P-KR3 E E  N-B3 NXN QXN P-QB3 B-Q2 B-K3 
+R-K5 Q-B5 Q-K3 Q-B7 E E E E E E R-K5 Q-Q2 P-Q5 
+O-O PXP PXP L 8W2 R-K1 B-KN5 V 9W2 BXN PXB RXP BXN PXB P-KB4 E E 
+QXB NXP Q-Q3 N-K3 L 9W2 P-B3 P-B4 P-B4 B-R5 V 11WA P-KN3
+ B-B3 PXP NXQP BXN O-O E E Q-R4 Q-Q2 QXQ KXQ 
+NXN BXN BXN QR-K1 L 11WA B-K3 O-O PXP N-N5 N-B3 BXN PXB 
+N-N4 E E E E P-Q6 NXB QXN BXN PXB NXQP E E E E E E E E 
+P-KN3 P-KB5 PXBP NXBP BXN BXB KXB RXP QN-Q2 Q-R5 K-N1 BXN NXB 
+Q-N5 K-B2 QR-KB1 R-K3 NXP B-K2 Q-R5 K-N2 R-KN5 K-R1 Q-B7
+ L 11WA R-B1 PXP BXP Q-B3 
+V 13WA Q-K1 O-O-O NXB QXN P-B3 QXQ RXQ NXP PXB N-QB7 
+R-B1 NXR N-R3 N-Q7 BXN RXB RXN PXP L 13WA B-K2 O-O-O B-K3 P-B5 NXB 
+BXB QXB QXN P-KN3 Q-R6 BXP KR-K1 L 13WA N-B3 O-O-O N-Q5 
+BXN NXQ BXQ NXN NXP L 11WA PXP BXBP K-B1 BXR PXN BXN V 14WA 
+PXB QXP Q-K2 O-O-O PXP K-N1 KXB KR-K1 PXN RXP BXR Q-N8 Q-B1 
+R-Q8 L 14WA QXQB QXP PXP R-Q1 B-QN5 P-B3 BXP K-K2 BXN PXB 
+B-N5 K-K1 Q-K3 R-KB1 L 11WA BXN QPXB P-Q5 N-K4 Q-R4
+ P-QN4 QXNP P-B3 PXP NXN PXN KBXP KXB 
+Q-R5 K-B1 O-O PXB Q-R6  L 11WA R-K2 NXQP NXN BXP E E E 
+E E E P-KR3 B-R4 P-B4 B-R5 L 9W2 
+P-B4 N-B3 N-B3 PXP E E PXP QXP N-B3 BXN NXQ BXQ NXB NXN RXB O-O-O 
+B-QB4 N/B3-Q4 L 5W2 Q-K2 Q-K2 P-Q3 N-KB3 
+V 7W5 N-B3 QXQ BXQ P-KN3 O-O B-N2 E E B-K3 P-B3 O-O B-N2 
+E E B-Q4 B-N2 E E B-B4 P-Q4 E E O-O-O B-N2 KR-K1 O-O 
+E E E E E E N-QN5 N-R3 E E B-N5 B-N2 O-O-O P-B3 KR-K1 O-O 
+L 7W5 B-N5 QN-Q2 QXQ BXQ N-B3 P-B3 O-O-O O-O E E E E E E N-B3 QXQ BXQ 
+P-KR3 B-R4 P-KN4 B-N3 B-N2 E E E E BXN NXB N-QN5 K-Q1 E E E E 
+B-Q2 P-KN3 O-O-O B-N2 E E E E B-B4 P-KN3 O-O-O B-N2 P-KR3 
+N-N3 L 5W2 N-B3 NXN QPXN B-K2 B-Q3 N-B3 B-KB4 B-N5 P-KR3 B-R4 
+P-KN4 B-N3 L 5W2 P-Q3 N-KB3 P-Q4 B-K2 L 5W2 P-B4 B-K2 P-Q4 O-O 
+B-Q3 P-Q4 O-O N-QB3 L 4W3 N-B4 NXP V 5W3 N-B3 NXN NPXN P-KN3 
+B-K2 B-N2 O-O O-O P-Q4 N-Q2 N-K3 N-N3 P-QB4 B-K3 P-QB3 P-KB4  
+L 5W3 P-Q3 N-KB3 P-Q4 B-K2 B-Q3 O-O O-O N-B3 P-QB3 R-K1 B-N5 
+P-Q4 N-K3 N-K5 BXB NXB 
+
+\fL 2B1 N-QB3 B-N5 V 3B2 P-QR3 B-R4 V 4B7 N-B3 O-O V 5B8 NXP P-Q4
+P-QN4 B-N3 P-Q4 PXP V 8BJ B-K3 P-QB3 V 9B4 B-K2 QN-Q2 V 10BH O-O Q-K2 V 11B2 
+NXN QXN Q-Q2 Q-Q3 E E N-QR4 B-B2 V 13B1 N-B5 Q-Q3 P-KN3 N-Q4 NXKP Q-KN3 
+B-Q3 P-KB4 N-B5 NXB PXN BXP PXB QXNP K-R1 Q-R6 L 11B2 N-QR4 B-B2 
+NXN QXN T 13B1 L 11B2 B-KB4 R-Q1 N-B4 N-Q4 NXN PXN B-Q6 Q-N4 NXB 
+NXN B-B7 B-R6 B-N3 B-K3 L 11B2 N-B4 N-Q4 NXN PXN NXB NXN QR-B1 B-Q2 
+E E E E E E NXB N/Q2XN NXN PXN QR-B1 B-Q2 E E E E Q-Q2 NXN QXN B-K3 
+P-KB3 PXP BXP B-Q4 E E E E B-KB4 KR-Q1 KR-Q1 P-KB3 B-KB1 Q-KB2 
+P-QR4 QR-B1 P-R5 N-Q4 Q-Q2 P-KN4 E E E E E E E E E E Q-KN3 P-KB3 P-QB3 
+KR-K1 KR-K1 Q-KB2 P-KB3 PXP BXP B-Q4 BXB PXB 
+L 10BH N-B4 B-B2 P-Q5 N-K4 E E O-O N-Q4 Q-Q2 P-KB4 E E 
+NXKP Q-R5 N-N3 P-KB4 B-Q2 P-B5 N-R1 P-B6 
+L 9B4 B-QB4 QN-Q2 O-O B-B2 V 11BH NXN QXN V 12BH R-K1 Q-B4 P-N3 N-N5 B-KB1 
+Q-N3 B-N2 P-KB4 L 12BH B-K2 Q-Q3 P-N3 B-R6 R-K1 Q-K3 Q-Q2 
+Q-B4 QR-Q1 QR-Q1 L 12BH N-K2 P-QN4 B-N3 N-N5 B-KB4 BXB NXB Q-Q3 P-KN3 Q-KR3 P-KR4 R-Q1 
+L 12BH P-KB3 P-QN4 B-N3 Q-Q3 P-N3 B-R6 R-B2 PXP B-KB4 Q-Q2 BXB QXB 
+L 11BH B-B4 N-N3 B-QN3 KN-Q4 E E B-KN5 NXB NXN R-K1 R-K1 
+B-K3 N-K3 Q-Q3 P-KN3 B-R6 E E E E E E B-R4 B-N5 BXN QXB QXB QXQP 
+E E E E Q-Q2 B-K3 N-K3 BXRP KXB N-N5
+NXN QXB E E K-N3  P-KN4 NXN PXB K-R3 P-KR4 E E K-B4 Q-Q3 N-K5 P-KB3 
+L 11BH NXKBP RXN P-B3 PXP QXP N-B1 BXR KXB 
+N-K4 B-K3 E E E E E E BXR KXB QXP K-N1 QR-K1 N-B1 N-K4 B-K3 
+NXN QXN QXQ PXQ B-R6 K-B2 E E RXP B-B2 QR-KB1 B-QB5 QR-B3 R-K1 
+E E E E B-R6 N-N3 P-N3 P-QR4 L 11BH P-KB4 N-N3 V 12BM B-R2 KN-Q4 NXN NXN 
+BXN PXB V 15B1 P-B5 P-B3 N-N4 P-KR4 N-B2 BXBP QXP Q-Q2 E E E E E E 
+N-N6 PXN PXP Q-Q3 Q-R5 QXRP QXQ BXQ KXB B-Q2 E E E E E E 
+B-B4 QXB RXQ BXR Q-R5 B-R3 QXQP K-R1 QXKP B-Q2 V 23B1 QXNP B-B4 
+P-QB4 B-K6 K-R1 BXQP QR-Q1 QR-Q1 P-B5 BXNP E E E E E E E E P-Q5 
+BXNP P-Q6 QR-Q1 Q-QB7 B-K6 K-R1 B-N3 E E E E  
+P-Q7 R-B2 R-Q1 B-B4 QXRP KRXP RXR RXR Q-R8 K-R2 P-B4 R-Q5 L 23B1 
+P-QB4 B-B3 P-Q5 QR-K1 Q-B3 B-R5 E E Q-Q3 B-Q2   L 12BM B-N3 KN-Q4 NXN NXN 
+BXN PXB T 15B1 L 9B4 N-B4 B-B2 B-N5 R-K1 V 11BJ P-Q5 P-KR3 B-R4 P-K6 
+NXKP B-K4 Q-Q2 PXP E E E E PXKP PXP BXN QXB NXQP Q-R5 P-N3 BXP 
+PXB QXR N-B7 B-R6 Q-K2 N-B3 L 11BJ N-K3 P-QR4 N-R4 PXP PXP Q-Q3 P-QB3 N-Q4 
+L 11BJ Q-Q2 QN-Q2 P-Q5 N-K4 NXN BXN PXP Q-B2 L 11BJ B-K2 QN-Q2 V 12BJ O-O 
+N-N3 N-K3 Q-Q3 P-N3 QN-Q4 E E E E N-K5 B-B4 P-KB4 PXG NXP/KB3 Q-Q3 
+N-K5 BXBP QXB QXQP E E E E E E E E E E Q-Q2 NXN BXQN Q-Q3 P-N3 B-KN5 B-K2 BXB   
+L 12BJ Q-Q2 N-B1 R-Q1 N-K3 B-R4 N-B5 N-K3 P-QR4 E E E E 
+BXN QXB NXKP Q-KN3 N-N3 N-B5 E E E E E E O-O NXB QXN B-K3 L 12BJ 
+P-Q5 N-N3 PXP NXN BXQN B-K4 Q-Q2 Q-N3 BXN PXB E E E E E E E E P-Q6 B-N1 
+NXN PXN B-KB4 B-K3 Q-Q4 N-Q4 NXN PXN B-QN5 R-KB1 Q-K5 Q-B1 O-O R-Q1 
+E E E E E E E E E E O-O N-Q4 NXN PXN B-QN5 R-KB1 P-QB4 BXQP PXP 
+B-KB4 BXB QXB Q-Q4 L 8BJ N-K2 P-QR4 R-QN1 PXP PXP N-Q4 N-QB4 B-KN5 Q-Q2  
+N-QB3 P-QB3 BXN BXB P-KB4    
+L 5B8 B-K2 BXN NPXB P-Q4 E E QPXB P-Q3 V 7BF B-Q3 QN-Q2 O-O N-B4 E E E E 
+B-KN5 P-KR3 BXN QXB O-O N-Q2 N-Q2 N-B4 E E E E Q-Q3 N-Q2 O-O-O N-B4 
+E E Q-K3 N-B4 E E E E E E B-R4 P-KN4 B-N3 NXP E E NXNP PXN BXP 
+K-R2 Q-Q3 R-KN1 Q-N3 R-N3 B-R5 NXB E E Q-R4 K-N2 B-R5 Q-R1 BXR QXQ BXQ PXB 
+L 7BF N-Q2 QN-Q2 V 8BF P-QB4 N-B4 V 9BF B-B3 P-QN3 O-O B-N2 R-K1 
+V 12WF P-KR3 P-QN4 N-K3 N-N3 P-QR4 B-Q2 P-R5 E E PXP PXP P-QR4   
+Q-Q2 B-Q2 B-B3 E E P-B5 B-B3 PXP PXP B-Q2 BXRP NXP N-Q5 N-N3 
+BXN RXR RXR PXB R-R6 R-K3 Q-R2 R-B3 Q-R3 P-KR3 R-R8 R-B1 RXR BXR Q-R8 
+K-R2 Q-QN8 P-QN4 NXKP L 9BF
+P-KB3 N-R4 O-O V 11WF P-KB4 PXP BXP R-B2 N-B5 E E P-KN4 
+N-B5 PXB Q-KN4 K-B2 N-R6 K-K1 Q-R5 R-B2 QXR
+L 8BF O-O N-B4 V 9BG B-B3 P-QN3 R-K1 B-N2 P-QB4 T 12WF 
+E E P-QB4 B-N2 R-K1 T 12WF L 9BG P-B3 N-R4 V 10BF  P-QB4
+T 11WF L 10BF R-B2 N-B5 E E P-KN3 B-R6 R-B2 P-KB4 PXP RXP P-KN4 
+N-B5 PXR Q-N4 K-R1 B-N7 K-N1 N-R6 L 10BF N-B4 N-B5 BXN PXB 
+R-K1 B-K3 P-K5 P-Q4 N-R5 P-QB3 E E E E Q-Q4 N-Q2 QR-Q1 Q-N4 K-R1 P-QN3 R-KN1 
+QR-K1 P-KN3 P-KB3 Q-Q2 PXP QXQ PXQ PXP R-B3 
+L 3B2 P-KB4 N-B3 V 4B3 N-B3 PXP B-B4 O-O O-O NXP V 7B4 N-Q5 
+V 8W3 N-B3 P-B3 NXN BXN B-R4 P-Q4 N-K2 B-N3 P-Q4 BXBP 
+B-B4 N-R4 B-K5 Q-R5 N-N3 L 7B4 NXN P-Q4 BXP QXB P-Q3 B-Q3 P-B4 
+Q-K3 KN-N5 Q-R3 NXB QXN/Q3 BXP Q-Q5 K-R1 B-B4 L 4B3 N-Q5 NXP 
+N-KB3 PXP B-B4 O-O O-O T 8W3 L 4B3 PXP QNXP P-Q4 N-N3 B-Q3 NXP 
+BXN BXN PXB Q-R5 E E E E E E B-KN5 P-KR3 BXN QXB N-B3 O-O B-K2 
+Q-K2 B-Q3 P-Q4 P-K5 P-QB4 BXN PXB O-O BXN PXB P-B5 E E E E E E 
+E E E E E E B-Q3 N-R5 NXN QXN P-KN3 Q-B3 P-QR3 B-R4 L 3B2 B-B4 
+P-B3 V 4B4 N-B3 P-Q4 V 5B3 PXP P-K5 N-Q4 O-O E E N-K5 O-O 
+PXP Q-Q5 PXP BXP BXP K-R1  P-KB4 PXG NXBP Q-N5 
+E E E E E E E E E E O-O PXP B-N3 P-Q5 E E E E P-Q4 PXG O-O 
+PXBP QXP PXP R-Q1 Q-B2 E E E E Q-B3 BXN PXB PXP B-N3 R-K1 
+B-KB4 N-B3 KR-K1 NXN BXN B-N5 BXN RXR RXR QXB QXB QXQBP R-QB1 
+Q-Q7 L 5B3 B-N3 NXP NXN PXN NXP Q-N4 BXP K-Q1 Q-R5 QXNP R-B1 
+P-QN4 P-KB3 P-K6 E E Q-R4 K-B2 B-R5 B-KR6 B-K2 N-Q2 NXN KXN 
+L 4B4 KN-K2 O-O O-O P-Q4 PXP PXP B-N3 P-Q5 N-N1 P-Q6 
+E E E E E E E E B-N3 P-Q4 PXP PXP P-Q4 PXP  KNXP R-K1 B-K3 
+B-N5 Q-Q3 QN-Q2 Q-N5 B-QR4 E E O-O N-B4 Q-N5 P-QR4 E E E E 
+P-KR3 N-K4 Q-N5 BXN NPXB Q-B2 PXB QXP K-K2 P-QR3 QXNP 
+QNXP N-B5 Q-K4 L 4B4 P-KB4 PXP P-K5 P-Q4 B-N3 B-N5 N-B3 N-K5 
+O-O N-N4 L 3B2 N-B3 O-O V 4B5 B-B4 N-B3 O-O NXP E E P-Q3 P-Q4 PXP 
+NXP B-Q2 N-B5 O-O B-N5 BXN PXB N-Q5 B-Q3 L 4B5 B-K2 N-B3 P-Q3 
+P-Q4 B-Q2 R-K1 L 4B5 P-Q3 P-Q4 B-Q2 N-B3 B-K2 R-K1 L 4B5 NXP 
+P-Q4 V 5B4 N-Q3 BXN QPXB PXP N-B4 QXQ KXQ N-B3 L 5B4 PXP R-K1
+L 5B4 P-QR3 BXN QPXB R-K1 N-B3 NXP B-K2 Q-K2 O-O NXQBP E E 
+B-K3 N-QB3 O-O NXKBP L 5B4 B-K2 Q-K2 P-KB4 PXP E E N-Q3 BXN 
+QPXB PXP N-B4 R-Q1 B-Q2 P-K6 PXP N-K5 B-Q3 Q-R5 E E E E E 
+E E E E E NPXB PXP N-B4 Q-K4 E E N-N2 N-B3 N-B4 N-Q4 B-R3 
+Q-N4 BXR QXNP E E E E E E O-O N-Q4 B-B4 R-Q1  L 3B2 P-Q3 
+P-Q4 PXP NXP E E B-Q2 N-B3 N-B3 O-O B-K2 R-K1 O-O BXN 
+BXB PXP PXP QXQ QRXQ NXP BXP NXB NXN N-Q3 P-KB4 P-KB3 B-B4 
+NXB NXN B-N5 R-Q4 B-K7 L 3B2 N-Q5 
+NXN PXN O-O P-QB3 B-R4 E E N-K2 P-QB3 N-B3 Q-R4 B-B4 N-R3 
+O-O N-B2 R-K1 P-Q3 E E E E P-QR3 N-B2 N-R2 B-K2 P-QN4 Q-N3 
+L 3B2 P-KN3 P-Q4 PXP NXP NXN QXN Q-B3 P-K5 Q-N3 Q-Q3 P-QB3 
+B-QB4 Q-R4 N-B3 QXKP B-K3 P-Q4 NXP PXN B-QN5 L 3B2 KN-K2 
+P-Q4 PXP NXP P-KN3 NXN NXN BXN QPXB QXQ KXQ B-KN5 B-K2 BXB KXB 
+N-B3 L 3B2 P-KN4 P-Q4 L 3B2 Q-B3 N-B3 L 3B2 P-B3 O-O KN-K2 
+P-Q4 N-N3 P-QR3 B-K2 B-QB4 L 3B2 B-N5 P-B3 B-R4 N-R3 P-Q3 
+N-B4 B-N3 P-Q4 
+\r\fL 2B1 P-KB4 NXP PXP Q-R5 E E N-QB3 NXN E E Q-B3 N-B4 PXP N-B3 
+V 5B5 Q-K3 P-Q3 PXP N-K3 PXP QXBP P-B3 B-Q3 E E E E E E N-KB3 
+PXP B-N5 N-K3 NXP B-B4 NXN PXN BXP B-Q2 Q-KB3 QR-N1 L 5B5 
+N-K2 N-K3 Q-K4 P-Q4 L 5B5 Q-KN3 P-Q3 PXP BXP QXP Q-R5 P-KN3 
+Q-K5 B-K2 B-K4 Q-R6 QXR E E E E E E E E E E B-N5 PXP QXKP N-K3 
+BXN PXB N-KB3 B-B4 P-Q3 O-O E E E E N-K2 B-B4 P-Q3 O-O B-K3 
+Q-R5 K-Q2 BXB QXB P-QB4 
+
+\fL 2B1 P-Q4 PXP P-K5 Q-K2 N-KB3 P-Q3 
+QXP KN-Q2 E E E E Q-K2 N-Q4 Q-K4 N-N5 B-Q3 P-Q4 Q-K2 P-QB4 
+
+\fL 2B1 P-Q3 P-Q4 V 3B3 N-Q2 B-QB4 KN-B3 N-N5 E E B-K2 PXP PXP Q-Q5 
+E E NXP NXN PXN Q-R5 E E E E E E P-KR3 PXP PXP BXBP KXB NXKP K-B3 
+Q-Q4 E E E E E E E E P-QB3 N-B3 B-K2 PXP PXP N-KN5 BXN Q-R5 
+E E N-KR3 N-K6 PXN BXN PXB Q-R5 K-B1 BXP E E E E N-N3 Q-R5 P-N3 
+Q-K2 E E K-B1 B-N3 PXB R-Q1 Q-K1 QXRP K-B2 R-Q3 B-B3 R-B3 N-Q2 
+P-KN4 L 3B3 N-KB3 N-B3 QN-Q2 B-QB4 B-K2 PXP QNXP B-K2 O-O 
+N-Q4 E E E E PXP BXBP KXB N-KN5 K-N3 P-B4 PXP N-K6 Q-N1 
+NXQBP R-N1 BXP E E E E E E E E K-N1 N-K6 Q-K1 NXBP Q-N3 
+NXR QXNP R-B1 N-B4 Q-K2 B-R6 B-K3 L 3B3 P-KB4 KPXP P-K5 
+N-N5 BXP N-QB3 N-KB3 P-B3 P-Q4 PXP 
+
+\fL 2W1 N-QB3 N-KB3 V 3W2 P-KN3 P-Q4 PXP NXP B-N2 NXN NPXN B-Q3 
+N-K2 O-O O-O N-B3 P-Q4 Q-B3 L 3W2 N-B3 B-N5 T 4W2 L 3W2 B-B4 
+NXKP V 4W4 NXN P-Q4 E E BXP KXB NXN P-Q4 L 4W4 N-B3 NXN QPXN P-QB3 
+NXP P-Q4 L 4W4 Q-R5 N-Q3 QXKP Q-K2 QXQ BXQ B-N3 N-B4 N-B3 P-QB3 
+O-O P-Q4 E E E E E E E E E E B-N3 B-K2 V 6W2 QXKP O-O P-Q4 N-B3 
+Q-B4 P-QN4 N-B3 B-N2 B-K3 N-R4 O-O-O P-N5 N-K2 N/Q3-B5 L 6W2 
+N-B3 N-B3 NXP O-O N-Q5 N-Q5 O-O NXB RPXN N-K1 P-Q4 P-Q3 N-KB3 
+B-K3 L 3W2 P-B4 P-Q4 PXQP NXP NXN QXN PXP N-B3 N-B3 B-KN5 B-K2 
+NXP E E E E E E E E E E PXKP NXP P-Q3 NXN E E Q-B3 N-QB3 NXN 
+N-Q5 Q-B4 PXN E E E E E E N-B3 B-K2 P-Q4 B-QN5 Q-Q3 P-QB4 E E 
+B-Q2 N-QB3 B-Q3 NXB QXN B-N5 Q-B4 Q-Q2 
+
+\fL 2W1 B-B4 N-KB3 V 3W3 
+N-QB3 NXP T 4W4 L 3W3 N-KB3 NXP N-B3 NXN QPXN P-QB3 NXP P-Q4 
+L 3W3 P-B4 NXP P-Q3 N-Q3 B-N3 N-B3 L 3W3 P-Q3 P-B3 P-B4 PXP QBXP 
+P-Q4 PXP NXP E E E E E E Q-K2 B-K2 P-B4 P-Q4 KPXP KPXP BXP 
+O-O E E E E BPXP NXP E E E E E E N-KB3 P-Q4 PXP PXP B-QN5 B-Q2 
+L 3W3 P-Q4 PXP N-KB3 P-Q4 PXP B-QN5 P-B3 Q-K2 
+
+\fL 2W1 P-KB4 PXP B-B4 P-Q4 BXP N-KB3 N-QB3 B-QN5 E E E E E E Q-B3 
+N-QB3 P-B3 N-B3 P-Q4 P-Q4 E E E E E E N-QB3 Q-R5 K-K2 P-Q4 NXP B-Q3 
+E E E E E E N-KB3 P-Q4 P-K5 P-KN4 P-KR3 N-KR3 P-Q4 N-B4 
+E E E E E E PXP N-KB3 V 5WZ B-N5 P-B3 PXP NXP P-Q4 B-Q3 P-Q5 
+NXP E E Q-K2 B-K3 N-K5 O-O BXN PXB BXP N-Q4 B-N3 P-B3 NXP BXB PXB Q-Q2 
+N-R5 B-N5 L 5WZ B-B4 B-Q3 N-B3 O-O O-O QN-Q2 P-QR3 N-N3 B-R2 
+B-KN5 P-Q4 Q-Q2 N-K2 QNXP P-B4 N-K6 L 5WZ B-K2 NXP N-B3 V 6BZ 
+NXN NPXN B-Q3 P-Q4 O-O O-O N-B3 P-B4 P-QN3 P-B3 B-KN5 N-K1 BXB QXB 
+L 5WZ P-B4 P-B3 PXP NXP P-Q4 B-KN5 E E E E P-Q4 B-QN5 N-B3 
+O-O B-K2 PXP O-O PXP QBXP N-B3 L 5WZ N-B3 NXP B-K2 T 6BZ NXN QXN 
+P-Q4 N-B3 B-K2 B-KN5 BXP O-O-O P-B3 Q-K5 Q-Q2 BXN PXB Q-Q4 
+R-KN1 P-KN3 P-N3 B-N2 
+
+\fL 2W1 P-Q4 PXP N-KB3 B-B4 NXP
+ N-KB3 N-QB3 P-Q4 P-K5 Q-K2 E E PXP O-O
+ E E E E E E E E P-QB3 PXP B-QB4 PXP BXNP P-Q4 
+BXQP N-KB3 BXBP KXB QXQ B-QN5 Q-Q2 BXQ NXB P-B4 
+
+\fL KP P-QB4 N-KB3 V 2B2 P-Q3 P-Q4 N-KB3 N-B3 E E PXP NXP N-KB3 
+N-QB3 V 5B6 P-KN3 B-K2 B-N2 O-O V 7B5 O-O B-K3 N-B3 
+Q-Q2 V 9B3 N-KN5 BXN BXB N-Q5 R-B1 P-QB4 NXN BXN RXP BXB KXB 
+N-K3 RXP P-B3 E E E E E E E E B-K3 P-QN3 E E E E B-Q2 P-QB4 
+N-K4 P-QN3 L 9B3 P-Q4 PXP NXP KR-Q1 NXB NXN QXQ NXKP E E E E 
+NXQN QXN NXN BXN BXB RXB L 7B5 N-B3 B-K3 O-O Q-Q2 T 9B3 L 5B6 
+P-K4 B-QN5 E E P-K3 B-K2 B-K2 B-K3 E E N-B3 B-K3 E E P-QR3 
+B-K3 L 5B6 N-B3 B-K2 P-K4 N-N3 E E P-K3 B-K3 L 5B6 P-QR3 B-K2 
+P-K3 B-K3 E E N-B3 B-K3 E E P-K4 N-N3 V 7B7 B-K3 O-O QN-Q2
+P-QR4 R-B1 P-B3 E E B-K2 B-K3 O-O P-B3 V 11B4 Q-B2 N-Q5 
+E E R-B1 R-B2 Q-B2 B-KB1 N-N3 R-Q2 N-B5 BXN L 11B4 N-N3 
+P-R5 N-B5 BXN BXB R-B2 Q-B2 R-Q2 QR-B1 N-B1 P-R3 B-N6 Q-N1 N/QB1-R2 
+N-Q2 B-K3 P-QN3 PXP NXP N-N4 L 7B7 B-K2 O-O V 8B4 O-O B-K3 V 9B6 
+B-K3 V 10W4  P-B3 QN-Q2 P-QR4 T 11B4 E Q-B2 N-Q5 E E P-Q4 PXP NXP 
+NXN BXN P-QB4 E E E E E E P-QN4 P-QR4 P-N5 N-Q5 NXN PXN B-B4 P-R5 L 9B6 
+QN-Q2 P-B3 P-QN4 P-QR4 P-N5 N-Q5 NXN QXN N-N3 Q-R5 E E QR-N1 KR-Q1 B-N2 Q-R5 
+E E E E E E E E E E Q-B2 P-QR4 P-QN3 Q-Q2 B-N2 V 13W2 KR-Q1
+V 13B2 QR-B1 B-B1 E E KR-Q1 B-B1 E E B-B3 Q-K1 P-R3 Q-B1 Q-N2 B-QB4 KR-B1 
+R-Q2 N-B1 N-B1
+N-N3 N/QB1-R2 P-QN4 PXP PXP BXNP BXB QXB QXQ NXQ R-R4 N/QN5-QB3 KR-R1 
+P-QN3 P-Q4 PXP B-N5 NXB RXR K-B2 L 13B2 KR-B1 N-B1 B-B3 N/QB1-R2 
+L 9B6 Q-B2 P-QR4  V 10B3 P-QN3 Q-Q2 V 11B5 B-N2 P-B3 QN-Q2  T 13W2 B-B3 KR-Q1 
+Q-N2 B-QB4 QN-Q2 Q-K2 KR-K1 R-Q2 B-B1 QR-Q1 N-B4 NXN QPXN B-KN5 L 11B5  
+B-K3 KR-Q1 R-B1 N-B1 E E QN-Q2 N-B1 KR-Q1 N/QB1-R2  N-B4 P-B3  
+Q-N2 N-N4 P-QR4 N/QN4-Q5 NXN NXN BXN QXB QXQ RXQ 
+L 10B3 B-K3 P-R5 Q-B3 B-B3 QN-Q2 N-Q5 BXN PXB Q-N4 Q-Q3 
+E E E E E E R-B1 Q-Q2 QN-Q2 KR-B1 E E E E E E QN-Q2 N-Q5  NXN PXN 
+B-B4 P-QB4 B-N3 R-B1 N-B4 NXN PXN P-QN4 PXP B-N6 Q-Q2 P-B5 L 10B3 
+QN-Q2 P-R5 P-QN4 PXG NXNP N-R5 
+L 9B6 P-QN4 P-QR4 P-N5 N-Q5 NXKP B-B3 L 8B4 B-K3 B-K3 O-O T 10W4 
+
+\fL 2B2 P-QR3 N-B3 P-Q3 P-Q4 E E E E P-K3 N-B3 P-QR3 P-Q4 E E 
+N-QB3 P-Q4 E E P-Q3 P-Q4 
+
+\fL 2B2 N-KB3 P-K5 N-Q4 N-B3 NXN QPXN 
+E E N-B2 P-Q4 E E P-K3 NXN PXN P-Q4 P-Q3 B-QN5 E E N-B3 PXP 
+BXP QXP Q-N3 B-QB4 BXP K-K2 O-O R-Q1 E E E E E E P-Q3 PXP 
+Q-N3 B-K3 QXP B-QB4 B-K3 P-Q7 E E E E BXB PXB QXKP B-K2 B-K3 Q-KN5 
+
+\fL 2B2 N-QB3 P-Q4 PXP NXP N-KB3 N-QB3 E E P-KN3 P-QB4  V 5B7 N-B3 
+N-QB3  NXN QXN P-Q3 B-K2 B-N2 O-O O-O Q-K3 B-K3 R-N1 P-QR3 
+B-Q2 P-QN4 PXP PXP BXP BXP NXB RXN B-B4 R-R1 P-QN4 P-Q4 
+PXP NXP Q-QN3 P-K3 KR-Q1 L 5B7
+ B-N2 B-K3 N-R3 N-QB3 O-O B-K2 E E E E N-B3 N-QB3 O-O 
+B-K2 E E N-KN5 QXN BXN BXB NXB O-O-O E E E E NXN Q-Q1 N-K3 Q-Q2 
+P-Q3 B-K2 E E E E P-K4 N-QN5 O-O Q-Q2 Q-R5 B-Q3 P-Q4 BPXP NXN 
+BXN QXKP O-O R-Q1 KR-Q1 B-K3 PXB E E E E E E E E E E E E E E 
+Q-R4 B-Q2 Q-N3 P-B5 QXP R-B1 
+
+\fL 2B2 P-KN3 P-Q4 B-N2 N-B3 PXP 
+NXP N-QB3 B-K3 N-B3 NXN NPXN P-K5 
+
+\fL KP P-K3 P-Q4 P-Q4 PXP PXP 
+B-Q3 V 4B6  N-KB3 N-KB3 N-B3 O-O E E B-KN5 O-O E E P-QB3 O-O E E 
+P-QB4 Q-K2 E E B-Q3 O-O O-O B-KN5 B-KN5 QN-Q2 QN-Q2 P-B3 
+P-B3 Q-B2 Q-B2 KR-K1 KR-K1 B-R4 L 4B6 B-Q3 N-KB3 N-KB3 O-O 
+L 4B6 P-QB3 N-KB3 B-Q3 O-O L 4B6 P-QB4 Q-K2 B-K2 PXP E E 
+Q-K2 PXP E E B-K3 N-KB3 L 4B6 N-QB3 P-QB3 N-KB3 N-KB3 B-Q3 O-O 
+E E E E B-Q3 N-K2 Q-R5 N-R3 P-QR3 Q-Q2 KN-K2 N-B2 B-KB4 
+BXB NXB Q-N5  
+
+\fL KP P-QB3 P-Q4 P-Q4 PXP PXP B-Q3 N-QB3 P-QB3 
+N-B3 B-KB4 B-N5 N-B3 P-K3 Q-N3 Q-B1 QN-Q2 B-K2 O-O O-O P-KR3 B-R4 
+Q-B2 B-N3 BXB 
+
+\fL KP N-KB3 P-K5 N-Q4 P-Q4 P-Q3 P-QB4 N-N3 PXP KPXP 
+B-Q3 E E BPXP B-Q3 
+
+\fL KP P-Q3 P-Q4 E E P-KN3 P-Q4 E E P-Q4 PXP 
+N-KB3 P-Q4 NXP N-KB3 
+
+\fL KP N-QB3 N-KB3 P-K4 B-N5 T 3B2 
+
+\fL ORG P-Q4 P-Q4 V 2W2 P-QB4 P-K3 V 3W4 N-QB3 P-QB3 V 4W5 P-K4 
+PXKP NXP B-N5 V 6W3 N-QB3 P-QB4 B-K3 N-KB3 N-KB3 N-B3 E E KN-K2 
+N-N5 E E P-QR3 BXN PXB Q-R4 B-Q2 N-K5 Q-N4 NXB QXNP QXBP QXR 
+K-Q2 E E E E E E Q-B2 NXB QXN PXP PXP QXQ KXQ N-B3 L 6W3 B-Q2 
+QXP BXB QXN V 8W4 N-K2 N-Q2 Q-Q6 P-QB4 B-B3 N-K2 E E BXP NXB QXN 
+B-Q2 P-B3 P-QN3 E E E E E E E E Q-Q2 QXBP N-B4 Q-K5 B-K2 P-QB4 
+B-QB3 KN-B3 L 8W4 B-K2 P-QB4 B-QB3 N-K2 BXP R-N1 B-B6 N-Q2 BXN 
+KXB E E E E E E E E BXP QXNP V 10W2 Q-Q4 N-Q2 B-B3 Q-N4 B-Q6 
+N-K2 E E B-QN4 Q-K4 N-K2 QXQ NXQ N-K4 O-O-O P-QR3 E E B-K2 B-Q2 
+R-KN1 N-K2 B-Q6 N/K4-N3 R-Q1 P-K4 L 10W2 Q-Q6 N-Q2 O-O-O Q-B3 
+L 10W2 B-B3 Q-N4 B-K3 Q-QR4 B-Q2 Q-B2 N-K2 N-QB3 B-B3 N-K4 N-Q4 
+B-Q2 E E E E E E E E E E Q-Q6 N-Q2 B-K3 Q-QR4 P-QN4 Q-K4 
+E E E E E E B-Q6 N-K2 N-K2 N-B4 R-KN1 Q-Q1 L 4W5 N-B3 N-B3 V 5W4 
+B-N5 PXP V 6WM P-K3 P-QN4 P-QR4 B-N5 L 6WM P-QR4 B-N5 P-K4 BXN PXB 
+Q-R4 P-K5 N-K5 B-Q2 Q-Q4 E E R-QB1 N-Q2 BXP NXB NXN NXP E E E E B-K3 N-N3 Q-B2 
+P-KB4 PXG NXP/KB3 R-R1 QN-Q4 B-Q2 P-QN4 L 6WM P-K4 P-QN4 V 7WM P-QR4 
+P-N5 N-QN1 P-KR3 BXN QXB BXP Q-N3 QN-Q2 QXNP R-KN1 Q-R6 Q-N3 P-QR4 O-O-O 
+L 7WM Q-B2 P-KR3 B-R4 P-KN4 B-N3 P-KN5 N-K5 QXQP B-K2 B-QN5 O-O BXN PXB QXKP Q-Q2 QN-Q2 
+L 7WM P-K5 P-KR3 V 8WM PXN PXB PXP BXP L 8WM BXN PXB P-QR4 B-N5 KPXP QXBP 
+ N-K5 P-B4 B-K2 N-Q2 O-O BPXP N-N4 Q-N2 NXNP P-KR4 L 8WM B-R4 P-N4 
+V 9WM B-N3 N-Q4 N-Q2 N-Q2 KN-K4 Q-R4 L 9WM KNXP PXN BXNP QN-Q2 V 11WM Q-B3 
+B-QN2 NXP Q-R4 E E N-K4 B-N5 K-K2 NXN BXQ P-QB4 E E E E E E PXN Q-R4 
+B-Q2 Q-N3 B-K3 P-QB4 PXP BXBP BXB NXB Q-K3 O-O-O E E E E E E E E E E E E   
+B-K2 Q-N3 PXN P-QB4 P-Q5 P-N5 E E E E BXN P-QB4 V 14WM 
+P-Q5 NXB QXN R-R3 Q-B3 P-N5 N-K4 PXP N-B6 RXN QXR QXQ PXQ O-O-O 
+L 14WM PXP NXBP Q-N3 P-N5 BXR PXN PXP N-K5 Q-B4 B-KR3 E E E E 
+QXP N-K5 Q-K3 B-B4 L 14WM N-K4 KR-N1 Q-B4 PXP B-R5 N-B4 NXN QXN E E 
+BXBP K-Q2 NXN BXN BXR B-QN5 E E O-O-O RXP L 11WM P-KN3 Q-N3 PXN B-QN2 B-N2 
+V 13BM O-O-O O-O N-K4 PXN RXQ KRXR P-QB4 E E QRXR P-QB4 E E E E 
+Q-K2 QXP QR-Q1 N-Q6 E E KR-Q1 N-Q6 E E B-K3 Q-Q6 KR-Q1 QXQ V 18WM 
+RXR KXR NXQ K-B1 BXRP P-QB4 P-QR4 N-B6 E E E E R-Q1 P-QB4 BXB KXB 
+R-Q8 B-N2 RXR BXR N-B3 K-B3 E E BXP BXP B-N4 N-B3 B-B3 P-K4 
+K-B1 P-N5 B-Q2 P-QR4 P-KR4 P-K5 B-B1 N-K4 P-QR3 N-Q6 PXP PXP B-K3 
+BXNP B-Q4 BXB NXB P-N6 N-N5 K-N3 N-B3 K-R4 K-K2 K-N5 N-Q5 K-R6 P-R5 
+P-N7 N-B3 K-N6 K-Q2 NXP P-R6 P-K6 K-K2 KXN E E KXP N-N5 K-Q4 NXP 
+L 18WM NXQ RXR RXR P-QB4 BXB KXB R-Q8 B-N2 RXR BXR N-B3 K-B3 E E BXP BXP 
+B-N4 N-B3 B-B3 P-K4 L 11WM PXN B-QN2 P-KN3 Q-N3 B-N2 T 13BM E E B-K2 Q-N3 
+O-O O-O-O P-QR4 P-N5 N-K4 P-B4 Q-N1 Q-B2 E E E E E E E E 
+P-QR4 O-O-O O-O P-N5 N-K4 P-B4 Q-N1 Q-B2 E E E E E E P-R5 Q-B2 P-R6 B-R1 O-O 
+Q-N3 E E E E O-O P-R3 L 9WM PXN PXB NXRP B-QN2 P-KN3 N-Q2 B-N2 Q-N3 P-R4 P-QR4 
+E E E E E E E E N-K5 QXBP V 11WMM P-KN3 N-Q2 P-B4 B-QN2 E E Q-K2 
+NXN PXN Q-Q1 B-N2 B-QN2 NXP PXN BXB B-N5 K-B1 R-QN1 B-B6 K-B1 R-Q1 Q-B2 
+L 11WM P-QR4 P-N5 N-K4 Q-B5 L 11WM B-K2 N-Q2 V 12WMM 
+NXP/QB6 B-QN2 B-B3 P-R3 Q-K2 R-B1 N-K5 BXB NXB Q-B5 P-Q5 N-B4 E E E E E E E E 
+O-O B-N2 V 15WMM P-Q5 BXN PXB N-K4 B-K4 O-O Q-K2 QR-B1 P-R4 NXP PXP N-Q5 
+L 15WMM P-R4 P-N5 N-K4 Q-B5 P-KN3 PXP RPXP Q-B2 NXNP R-Q1 
+Q-K2 BXP QR-Q1 N-K4 N-KB6 K-B1 E E RXB NXB QXN RXR Q-B6 RXN 
+QXR K-K2 R-Q1 Q-Q3 RXQ R-K8 K-R2 R-KR8 L 12WMM O-O 
+NXN PXN QXKP B-B3 B-QN2 R-K1 Q-Q3 NXP QXQ QRXQ B-N5 R-K2 K-K2  
+\rL 5W4 PXP KPXP V 6W4 B-B4 B-K2 P-K3 B-KB4 E E Q-B2 P-KN3 P-K3 
+B-KB4 L 6W4 B-N5 V 6B3 B-K2 P-K3 B-KB4 E E Q-B2 P-KN3 
+P-K3 B-KB4 B-Q3 BXB QXB QN-Q2 B-R6 N-N5 E E O-O O-O P-QR3 P-QR4 
+E E QR-B1 R-K1 N-Q2 K-N2 N-N3 B-Q3 P-KR3 P-KR3 L 5W4 Q-N3 
+QN-Q2 PXP KPXP E E B-N5 B-K2 PXP KPXP E E P-K3 O-O PXP KPXP E E 
+B-K2 PXP QXBP N-Q4 BXB QXB O-O KN-N3 Q-Q3 P-K4 L 5W4 P-K3 QN-Q2 
+V 6W5 PXP KPXP B-Q3 B-Q3 O-O O-O Q-B2 R-K1 L 6W5 B-Q2 B-Q3 
+PXP KPXP E E B-Q3 O-O PXP KPXP E E O-O PXP BXBP P-K4 L 6W5 
+P-QN3 B-N5 B-N2 N-K5 E E B-Q2 O-O P-QR3 B-Q3 E E B-K2 Q-K2 
+O-O B-Q3 PXP KPXP E E Q-B2 PXP PXP P-K4 N-KN5 R-K1 L 6W5 P-QR3 
+B-Q3 L 6W5 N-K5 NXN PXN N-Q2 P-KB4 B-QB4 P-QR3 Q-K2 P-QN4 B-N3 
+B-K2 O-O O-O P-B3 P-QB5 B-B2 PXP NXKBP P-KN4 P-K4 L 6W5 Q-B2 
+B-Q3 V 7W4 P-K4 PXKP NXP NXN QXN P-K4 PXP NXP NXN Q-QR4 E E 
+B-KB4 O-O NXN BXN BXB R-K1 E E E E BXN BXB NXB R-K1 E E E E E E E E 
+B-Q3 P-KB4 QXKBP N-B3 Q-N5 P-K5 BXP NXB QXNP Q-B3 E E E E E E E E E E  
+P-B5 B-K2 NXP NXN QXN O-O L 7W4 P-QN3 O-O B-K2 PXP PXP P-K4 
+O-O R-K1 B-N2 PXP PXP N-B1 QR-Q1 N-N3 L 7W4 PXP KPXP L 7W4 
+B-Q2 O-O PXP KPXP E E O-O-O P-QB4 P-K4 BPXP KNXP PXBP BXP 
+
+N-N3 B-K2 B-Q2 E E E E E E E E PXQP KPXP B-K1 P-B5 P-KN4 N-N3 
+E E E E K-N1 P-QR3 B-B1 P-B5 P-KN4 N-N3 P-KR3 R-K1 B-N2 B-QN5 
+L 6W5 B-Q3 PXP BXBP P-QN4 B-K2 B-K2 O-O P-QR3 P-K4 P-N5 E E E E E E 
+B-N3 P-N5 N-QR4 B-R3 E E N-K2 B-N2 O-O B-K2 N-B4 O-O E E N-N3 
+O-O P-K4 P-QB4 E E E E E E E E E E B-Q3 P-N5 N-QR4 P-QB4 
+PXP NXP B-N5 B-Q2 BXB KNXB E E E E E E E E N-K2 P-QB4 O-O 
+B-N2 N-K5 B-Q3 P-KB4 O-O E E E E E E E E N-K4 NXN BXN B-N2 
+Q-R4 Q-N3 O-O B-K2 N-Q2 R-QB1 E E E E E E Q-B2 R-B1 BXRP P-QB4 
+E E E E B-Q2 B-K2 P-QR3 P-QR4 Q-R4 Q-N3 E E E E E E O-O B-K2 
+Q-R4 O-O B-Q2 Q-N3 E E BXBP N-N3 E E E E P-QN3 O-O B-N2 N-B3 B-Q3 
+P-QB4 PXP BXP R-QB1 B-K2 N-K5 Q-Q4 E E E E E E R-QB1 R-QB1 Q-K2 
+N-K5 B-R6 Q-N3 BXB QXB PXP BXP N-K5 B-K2 N-B4 KR-Q1 L 4W5 P-K3 
+N-KB3 N-B3 QN-Q2 T 6W5 E PXP KPXP L 4W5 PXP KPXP V 5W5 N-B3 B-KB4 B-B4 
+B-Q3 BXB QXB P-K3 N-B3 B-Q3 BXB QXB QN-Q2 O-O O-O QR-N1 KR-K1 
+P-QN4 P-QR3 P-QR4 N-K5 L 3W4 PXP PXP N-QB3 P-QB3 T 5W5 L 3W4 
+N-KB3 N-KB3 V 4W6 PXP KPXP N-QB3 P-QB3 T 6W4 E E E N-B3 P-B3 T 5W4
+E B-N5 P-KR3 B-R4 PXP E E BXN QXB N-B3 P-QB3 
+V 7W3 P-K3 N-Q2 PXP KPXP E E B-Q3 B-Q3 PXP KPXP E E O-O 
+Q-K2 P-K4 PXBP BXP P-K4 E E E E PXP KPXP P-K4 PXP NXP O-O 
+R-K1 N-B3 N-K5 NXN BXN B-K3 B-B2 BXN PXB KR-Q1 Q-K2 R-Q5 
+QR-Q1 QR-Q1 P-QR3 Q-N4 RXR RXR R-Q1 B-B5 Q-K1 B-Q4 P-KN3 
+RXR BXR Q-B8 E E QXR QXKP B-N3 QXQNP BXB PXB QXP Q-B8 K-N2 
+Q-B3 L 7W3 Q-N3 PXP QXBP N-Q2 P-K4 P-K4 P-Q5 N-N3 E E E E 
+R-Q1 B-K2 P-KN3 O-O B-N2 P-K4 E E E E P-K3 O-O B-Q3 P-KN3 
+L 7W3 PXP KPXP P-K3 N-Q2 E E E E P-K4 PXKP NXP B-N5 
+K-K2 Q-B5 E E N-B3 P-B4 R-B1 O-O PXP P-K4 E E E E E E QN-Q2 
+P-B4 P-QR3 BXN QXB PXP QXQP N-B3 QXQ PXQ P-B5 B-Q2 B-N5 K-K2
+
+\fL 2W2 N-KB3 
+N-KB3 V 3WY P-QB4 P-K3 T 4W6 E P-KN3 P-QB4 PXP P-K3 P-QN4 P-QR4 P-B3 
+PXP PXP P-QN3 E E E E E E E E B-N2 P-K3 O-O N-B3 L 3WY P-K3 V 3BZ 
+P-KN3 B-Q3 B-N2 O-O O-O QN-Q2 P-B4 P-B3 KN-Q2 Q-K2 N-QB3 P-KR3 R-K1 B-N5 P-QR3 B-R4 
+P-QN4 B-B2 B-N2 L 3WY B-B4 V 3BJ P-B4 P-K3 N-B3 P-B3 Q-N3 Q-B1 B-B4 PXP QXBP QN-Q2 R-B1 N-N3 Q-N3 
+Q-Q2 P-K3 B-Q3 B-K5 E E E E E E N-Q4 NXN KPXN Q-N3 P-QR4 P-QR3 P-R5 Q-B3 
+L 3WY N-B3 P-KN3 B-B4 B-N2 P-K3 O-O P-KR3 P-B4 B-K2 P-N3 O-O B-N2 N-K5 QN-Q2 
+L 3WY B-N5 N-K5 V 4WJ B-B4 P-QB4 PXP N-QB3 P-K3 P-B3 P-B4 P-K4 B-N3 B-K3 
+QN-Q2 NXN NXN BXP P-QR3 P-Q5 N-N3 B-N3 L 4WJ B-R4 P-QB4 PXP N-QB3 P-K3 
+P-KN3 QN-Q2 NXQBP B-K2 B-N2 P-B3 O-O O-O P-QR4 
+
+\fL 2W2 P-K3 N-KB3 
+V 3WZ N-KB3 T 3BZ P-KB4 P-QB4 P-B3 Q-B2 N-B3 P-KN3 B-Q3 B-N2 E E E E B-Q3 P-KN3 
+N-B3 B-N2 L 3WZ B-Q3 N-B3 P-QB3 P-K4 E E P-KB4 N-QN5 B-K2 B-B4 E E N-KB3 NXB QXN P-KN3 
+O-O B-N2 E E E E PXN P-KN3 O-O B-N2 N-B3 O-O B-Q2 P-QN3 
+N-K5 P-QB4 
+
+\fL 2W2 P-K4 PXP P-KB3 P-K4 QPXP QXQ KXQ N-QB3 B-QN5 B-Q2 E E 
+B-KB4 KN-K2 PXP N-N3 
+
+\fL 2W2 B-B4 N-KB3 N-KB3 T 3BJ  
+
+\fL ORG P-QB4 V ENG P-K4 N-QB3 N-KB3 V 3W5 P-KN3 P-B3 V 4W7 P-Q4 
+PXP QXP P-Q4 PXP PXP E E B-N5 B-K2 N-B3 O-O B-N2 P-KR3 B-B4 P-B4 
+Q-Q3 P-Q5 N-QN5 N-B3 B-B7 Q-K1 O-O B-N5 L 4W7 B-N2 P-Q4 PXP PXP 
+Q-N3 N-B3 NXP N-Q5 E E E E P-Q3 N-B3 N-B3 B-K2 O-O O-O P-Q4 
+P-K5 N-K5 B-K3 E E E E E E E E P-B4 P-Q5 PXP N-KN5 N-K4 B-QN5 
+K-B1 KNXKP N-R3 O-O N-B4 K-R1 L 4W7 N-B3 P-K5 N-Q4 P-Q4 PXP PXP 
+P-Q3 Q-N3 N-N3 N-N5 P-Q4 B-K3 P-B3 PXP PXP N-KB3 B-K3 N-B3 E E E 
+E E E E E E E PXP B-QB4 P-K3 PXP B-N2 O-O O-O B-KN5 E E NXP NXN 
+BXN R-K1 L 3W5 N-B3 N-B3 V 4W8 P-Q4 PXP NXP B-B4 NXN NPXN 
+P-KN3 O-O L 4W8 P-K4 B-N5 P-Q3 P-Q3 B-K2 O-O O-O BXN PXB 
+Q-K2 N-K1 N-K1 N-B2 P-B4 PXP BXP L 4W8 P-KN3 P-KN3 B-N2 B-N2 
+O-O O-O R-N1 P-Q3 P-QN4 P-K5 N-K1 B-B4 P-Q3 P-Q4 PXQP NXQP E E 
+P-N5 N-K2 PXQP QNXP NXN NXN PXP N-B6 E E E E B-N2 NXN BXN R-K1 
+L 4W8 P-QR3 P-Q4 E E P-K3 B-N5 N-Q5 P-K5 NXB NXN N-Q4 O-O P-QR3 
+N-R3 B-K2 P-Q4 L 4W8 P-Q3 P-Q4 PXP NXP P-KN3 B-K3 B-N2 B-K2 
+O-O O-O P-QR3 Q-Q2 B-Q2 QR-Q1 P-QN4 NXN BXN B-B3 
+
+\fL ORG N-KB3 N-KB3 P-Q4 P-Q4 P-QB4 P-K3 T 4W6 E E E P-QB4 
+P-K3 P-Q4 P-Q4 T 4W6 E N-B3 P-Q4 PXP PXP P-Q4 P-B3 T 6W4 
+E E E E E E E P-QN3 P-Q4 B-N2 B-B4 P-K3 P-K3 B-K2 P-KR3 E E 
+E E E E E E P-KN3 P-Q4 B-N2 V 3B4 P-B4 O-O P-K3 P-Q4 B-K2 E E 
+P-Q3 N-B3 QN-Q2 B-K2 P-K4 O-O 
+V 8W5 P-K5 N-KN5 Q-K2 P-B3 PXP BXP P-B3 Q-Q3 P-Q4 PXP 
+NXP P-K4 L 8W5 Q-K2 Q-B2 P-K5 N-Q2 R-K1 V 10B1 P-QN4 
+P-KR4 P-QR4 N-B1 B-R3 N/B1-R2 P-N5 P-R5 P-R5 P-R6 
+P-N3 N-N4 P-B5 L 8W5 R-K1 Q-B2 P-K5 N-Q2 Q-K2 T 10B1 
+L 8W5 P-B3 PXP PXP Q-B2 Q-B2 P-K4 R-K1 B-K3 N-N5 B-Q2 
+N-B1 P-KR3 N-B3 B-K3 
+
+\fL ORG P-KN3 N-KB3 B-N2 P-Q4 N-KB3 T 3B4 
+
+\fL ORG P-KB4 P-Q4 P-K3 N-KB3 
+P-QN3 P-Q5 E E N-KB3 B-N5 P-KR3 BXN E E P-B4 P-K3 N-B3 
+P-B3 E E E E P-QN3 P-K3 B-N2 B-K2 E E E E B-K2 BXN BXB QN-Q2 
+P-B4 P-K3 PXP PXP N-B3 P-B3 O-O B-K2 P-Q3 N-N3 P-K4 PXP PXP 
+B-B4 
+
+
+\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/book.4 b/MUDDLE/book.4
new file mode 100644 (file)
index 0000000..7484f8a
--- /dev/null
@@ -0,0 +1,532 @@
+P-K4 V KP P-K4 V 2W1 N-KB3 V 2B1 N-KB3 V 3W1 P-Q4 V 3B1 NXP V 4W1 B-Q3 V 4B1 P-Q4 V 5W1 NXP V 5B1 B-Q3 V 6W1 O-O V 6B1 O-OV 7W1 N-Q2 B-KB4 R-K1 BXN PXB B-N3 N-B3 
+E Q-K2 R-K1 
+E E E E E E P-QB4 BXN PXB NXBP 
+E E E E E NXN BXN N-Q2 NXN 
+E E E E N-KB3 QN-B3 N-B3 P-B3 
+E E N-K5 P-B4 
+L 7W1 P-QB4 BXN PXB N-QB3 P-B4 B-B4 P-KN4 PXP 
+E E E E B-KB4 B-K3 
+E E PXP QXP Q-B3 B-B4 QXB QXB N-B3 N-B4 QXQ NXQ 
+L 7W1 N-QB3 NXN PXN N-Q2 P-KB4 P-QB4 
+E E R-K1 Q-R5 P-N3 Q-R6 B-B1 Q-B4 N-N4 N-N3 N-K3 Q-B3 B-Q3 P-KR3 N-N4 BXN QXB QR-K1 
+L 7W1 R-K1 BXN PXB N-QB3 B-KB4 N-B4 N-B3 N-N5 B-KB1 P-Q5 N-K4 NXN 
+L 7W1 P-KB3 N-B4 
+L 6B1 N-QB3 NXN PXN P-QB4 O-O P-B5 B-K2 N-B3 
+L 6B1 BXN PXB N-B4 N-B3 
+L 6W1 Q-K2 BXN PXB N-B4 
+L 6W1 N-QB3 NXN PXN O-O O-O N-Q2 P-KB4 P-QB4 
+L 5B1 B-K3 Q-K2 N-Q3 O-O B-K2 R-K1 O-O NXP 
+E E Q-B1 N-QB3 O-O Q-R5 P-KB4 N-K2 
+E E E E E E N-Q2 B-KB4 NXN BXN O-O N-Q2 B-B3 Q-R5 P-KN3 Q-R6 BXB PXB N-B4 BXN BXB N-B3 P-KB3 N-Q4 PXP RXP 
+L 5B1 N-QB3 NXN PXN Q-K2 V 7B10 P-KB4 P-KB3 B-Q3 O-O O-O PXN BPXP RXR QXR BXKP PXB Q-QB4 
+E E E E E E E E Q-K2 PXN BPXP Q-R5 P-N3 Q-R6 PXB B-N5 Q-K5 B-B6 
+L 7B10 Q-K2 O-O V 8B10 N-Q3 R-K1 QXQ RXQ K-Q1 N-Q2 B-KB4 N-N3 BXB PXB 
+L 8B10 P-N3 BXN PXB R-K1 P-KB4 P-KB3 
+E E E E QXB Q-Q2 
+L 5B1 N-Q2 Q-K2 NXN BXN 
+E E Q-K2 BXN PXB B-B4 NXN BXN P-KB3 B-N3 P-KB4 N-B3 P-B3 O-O-O B-K3 P-Q5 
+E E Q-KN4 K-N1 B-N5 N-N5 P-B5 N-B7 K-B1 QXP B-KB4 Q-K5  
+L 5B1 B-K2 O-O O-O P-QB4 B-K3 N-QB3 N-KB3 P-B5 
+E E E E N-KB3 N-QB3 PXP BXBP 
+E E E E P-QB3 PXP PXP BXN PXB N-QB3 
+L 5W1 PXP N-B4 O-O B-K2 N-B3 P-QB3 N-K2 NXB QXN P-B3 
+E E E E N-Q4 NXB QXN O-O P-B4 P-B3 B-Q2 N-R3 
+L 4W1 PXP P-Q4 QN-Q2 N-B4 N-N3 NXN RPXN N-B3 P-R3 B-K2 
+L 3B1 P-Q3 N-B3 
+E E P-Q4 PXQP PXP B-QN5 P-B3 PXP Q-R4 N-B3 PXP NXP PXB Q-B3 
+E E E E E E PXP B-QB4 Q-K2 B-K2 P-B4 P-B3 
+L 3B1 PXP P-K5 N-K5 QXP P-Q4 PXG NXQP B-Q3 N-B3 Q-KB4 V 8B2 Q-K2 B-K3 P-KN3 N-B3 B-K3 O-O B-N2 KR-K1 O-O QB-B5 
+L 8B2 P-KN3 O-O B-N2 N-B3 O-O B-K3 B-K3 B-QB5 P-N3 B-R3 N-K2 QR-Q1 
+L 3W1 B-B4 NXP N-B3NXN QPXN P-QB3 NXP P-Q4 O-O B-Q3 R-K1 B-K3 B-Q3 N-Q2
+L 3W1 N-B3 B-N5 V 4W2 B-B4 N-B3 N-Q5 NXP Q-K2 N-B3 NXKP O-O 
+E E E E E E O-O O-O N-Q5 NXN BXN P-Q3 P-B3 B-R4 
+E E E E E E P-Q3 BXN PXB P-Q4 PXP NXP Q-K1 N-N3 
+E E B-Q2 B-N5 R-K1 Q-Q3 Q-K2 QR-K1 
+E E R-N1 N-N3 B-QN5 QR-K1 BXN PXB P-B4 BXN QXB NXP 
+L 4W2 NXP O-O N-Q3 BXN QPXB NXP B-K2 P-Q3 
+E E E E E E N-B3 BXN QPXB NXP B-Q3 P-Q4 P-KR3 N-QB3 
+E E E E E E E E P-Q3 P-Q4 P-QR3 BXN PXB R-K1 P-KB4 PXP 
+E E E E E E E E B-K2 R-K1 N-Q3 BXN QPXB NXP O-O P-Q4 B-B4 N-QB3 P-B3 N-B3 Q-Q2 B-B4 
+E E E E E E B-K3 N-Q2 N-B4 QN-B3 P-B4 PXP 
+E E E E E E N-B4 P-QB3 B-K3 N-Q3 B-Q3 B-B4 
+L 3W1 NXP P-Q3 V 4W3 N-KB3 NXP V 5W2 P-Q4 P-Q4 B-Q3 B-K2 V 7W2 P-B4 B-QN5 QN-Q2 BXN BXB O-O O-O B-N5 B-B4 N-QB3 R-K1 NXQP BXN PXB QXN PXN QXQ KRXQ BXP R-Q7 
+L 7W2 O-O N-QB3 V 8W2 P-B4 N-N5 B-K2 PXP BXP O-O 
+E E E E PXP NXB QXN QXP R-K1 B-KB4N-K5 P-KR3 
+E E  N-B3 NXN QXN P-QB3 B-Q2 B-K3 R-K5 Q-B5 Q-K3 Q-B7 
+E E E E E E R-K5 Q-Q2 P-Q5 O-O PXP PXP 
+L 8W2 R-K1 B-KN5 V 9W2 BXN PXB RXP BXN PXB P-KB4 
+E E QXB NXP Q-Q3 N-K3 
+L 9W2 P-B3 P-B4 P-B4 B-R5 V 11WA P-KN3 B-B3 PXP NXQP BXN O-O 
+E E Q-R4 Q-Q2 QXQ KXQ NXN BXN BXN QR-K1 
+L 11WA B-K3 O-O PXP N-N5 N-B3 BXN PXB N-N4 
+E E E E P-Q6 NXB QXN BXN PXB NXQP 
+E E E E E E E E P-KN3 P-KB5 PXBP NXBP BXN BXB KXB RXP QN-Q2 Q-R5 K-N1 BXN NXB Q-N5 K-B2 QR-KB1 R-K3 NXP B-K2 Q-R5 K-N2 R-KN5 K-R1 Q-B7 
+L 11WA R-B1 PXP BXP Q-B3 V 13WA Q-K1 O-O-O NXB QXN P-B3 QXQ RXQ NXP PXB N-QB7 R-B1 NXR N-R3 N-Q7 BXN RXB RXN PXP 
+L 13WA B-K2 O-O-O B-K3 P-B5 NXB BXB QXB QXN P-KN3 Q-R6 BXP KR-K1 
+L 13WA N-B3 O-O-O N-Q5 BXN NXQ BXQ NXN NXP 
+L 11WA PXP BXBP K-B1 BXR PXN BXN V 14WA PXB QXP Q-K2 O-O-O PXP K-N1 KXB KR-K1 PXN RXP BXR Q-N8 Q-B1 R-Q8 
+L 14WA QXQB QXP PXP R-Q1 B-QN5 P-B3 BXP K-K2 BXN PXB B-N5 K-K1 Q-K3 R-KB1 
+L 11WA BXN QPXB P-Q5 N-K4 Q-R4 P-QN4 QXNP P-B3 PXP NXN PXN KBXP KXB Q-R5 K-B1 O-O PXB Q-R6  
+L 11WA R-K2 NXQP NXN BXP 
+E E E 
+E E E P-KR3 B-R4 P-B4 B-R5 
+L 9W2 P-B4 N-B3 N-B3 PXP 
+E E PXP QXP N-B3 BXN NXQ BXQ NXB NXN RXB O-O-O B-QB4 N/B3-Q4 
+L 5W2 Q-K2 Q-K2 P-Q3 N-KB3 V 7W5 N-B3 QXQ BXQ P-KN3 O-O B-N2 
+E E B-K3 P-B3 O-O B-N2 
+E E B-Q4 B-N2 
+E E B-B4 P-Q4 
+E E O-O-O B-N2 KR-K1 O-O 
+E E E E E E N-QN5 N-R3 
+E E B-N5 B-N2 O-O-O P-B3 KR-K1 O-O 
+L 7W5 B-N5 QN-Q2 QXQ BXQ N-B3 P-B3 O-O-O O-O 
+E E E E E E N-B3 QXQ BXQ P-KR3 B-R4 P-KN4 B-N3 B-N2 
+E E E E BXN NXB N-QN5 K-Q1 
+E E E E B-Q2 P-KN3 O-O-O B-N2 
+E E E E B-B4 P-KN3 O-O-O B-N2 P-KR3 N-N3 
+L 5W2 N-B3 NXN QPXN B-K2 B-Q3 N-B3 B-KB4 B-N5 P-KR3 B-R4 P-KN4 B-N3 
+L 5W2 P-Q3 N-KB3 P-Q4 B-K2 
+L 5W2 P-B4 B-K2 P-Q4 O-O B-Q3 P-Q4 O-O N-QB3 
+L 4W3 N-B4 NXP V 5W3 N-B3 NXN NPXN P-KN3 B-K2 B-N2 O-O O-O P-Q4 N-Q2 N-K3 N-N3 P-QB4 B-K3 P-QB3 P-KB4  
+L 5W3 P-Q3 N-KB3 P-Q4 B-K2 B-Q3 O-O O-O N-B3 P-QB3 R-K1 B-N5 P-Q4 N-K3 N-K5 BXB NXB 
+\fP-K4 P-K4 N-KB3 N-QB3 B-N5 V 3B2 P-QR3 B-R4 V 4B7 N-B3 O-O V 5B8 NXP P-Q4P-QN4 B-N3 P-Q4 PXP V 8BJ B-K3 P-QB3 V 9B4 B-K2 QN-Q2 V 10BH O-O Q-K2 V 11B2 NXN QXN Q-Q2 Q-Q3 
+E E N-QR4 B-B2 V 13B1 N-B5 Q-Q3 P-KN3 N-Q4 NXKP Q-KN3 B-Q3 P-KB4 N-B5 NXB PXN BXP PXB QXNP K-R1 Q-R6 
+L 11B2 N-QR4 B-B2 NXN QXN T 13B1 
+L 11B2 B-KB4 R-Q1 N-B4 N-Q4 NXN PXN B-Q6 Q-N4 NXB NXN B-B7 B-R6 B-N3 B-K3 
+L 11B2 N-B4 N-Q4 NXN PXN NXB NXN QR-B1 B-Q2 
+E E E E E E NXB N/Q2XN NXN PXN QR-B1 B-Q2 
+E E E E Q-Q2 NXN QXN B-K3 P-KB3 PXP BXP B-Q4 
+E E E E B-KB4 KR-Q1 KR-Q1 P-KB3 B-KB1 Q-KB2 P-QR4 QR-B1 P-R5 N-Q4 Q-Q2 P-KN4 
+E E E E E E E E E E Q-KN3 P-KB3 P-QB3 KR-K1 KR-K1 Q-KB2 P-KB3 PXP BXP B-Q4 BXB PXB 
+L 10BH N-B4 B-B2 P-Q5 N-K4 
+E E O-O N-Q4 Q-Q2 P-KB4 
+E E NXKP Q-R5 N-N3 P-KB4 B-Q2 P-B5 N-R1 P-B6 
+L 9B4 B-QB4 QN-Q2 O-O B-B2 V 11BH NXN QXN V 12BH R-K1 Q-B4 P-N3 N-N5 B-KB1 Q-N3 B-N2 P-KB4 
+L 12BH B-K2 Q-Q3 P-N3 B-R6 R-K1 Q-K3 Q-Q2 Q-B4 QR-Q1 QR-Q1 
+L 12BH N-K2 P-QN4 B-N3 N-N5 B-KB4 BXB NXB Q-Q3 P-KN3 Q-KR3 P-KR4 R-Q1 
+L 12BH P-KB3 P-QN4 B-N3 Q-Q3 P-N3 B-R6 R-B2 PXP B-KB4 Q-Q2 BXB QXB 
+L 11BH B-B4 N-N3 B-QN3 KN-Q4 
+E E B-KN5 NXB NXN R-K1 R-K1 B-K3 N-K3 Q-Q3 P-KN3 B-R6 
+E E E E E E B-R4 B-N5 BXN QXB QXB QXQP 
+E E E E Q-Q2 B-K3 N-K3 BXRP KXB N-N5NXN QXB 
+E E K-N3  P-KN4 NXN PXB K-R3 P-KR4 
+E E K-B4 Q-Q3 N-K5 P-KB3 
+L 11BH NXKBP RXN P-B3 PXP QXP N-B1 BXR KXB N-K4 B-K3 
+E E E E E E BXR KXB QXP K-N1 QR-K1 N-B1 N-K4 B-K3 NXN QXN QXQ PXQ B-R6 K-B2 
+E E RXP B-B2 QR-KB1 B-QB5 QR-B3 R-K1 
+E E E E B-R6 N-N3 P-N3 P-QR4 
+L 11BH P-KB4 N-N3 V 12BM B-R2 KN-Q4 NXN NXN BXN PXB V 15B1 P-B5 P-B3 N-N4 P-KR4 N-B2 BXBP QXP Q-Q2 
+E E E E E E N-N6 PXN PXP Q-Q3 Q-R5 QXRP QXQ BXQ KXB B-Q2 
+E E E E E E B-B4 QXB RXQ BXR Q-R5 B-R3 QXQP K-R1 QXKP B-Q2 V 23B1 QXNP B-B4 P-QB4 B-K6 K-R1 BXQP QR-Q1 QR-Q1 P-B5 BXNP 
+E E E E E E E E P-Q5 BXNP P-Q6 QR-Q1 Q-QB7 B-K6 K-R1 B-N3 
+E E E E  P-Q7 R-B2 R-Q1 B-B4 QXRP KRXP RXR RXR Q-R8 K-R2 P-B4 R-Q5 
+L 23B1 P-QB4 B-B3 P-Q5 QR-K1 Q-B3 B-R5 
+E E Q-Q3 B-Q2   
+L 12BM B-N3 KN-Q4 NXN NXN BXN PXB T 15B1 
+L 9B4 N-B4 B-B2 B-N5 R-K1 V 11BJ P-Q5 P-KR3 B-R4 P-K6 NXKP B-K4 Q-Q2 PXP 
+E E E E PXKP PXP BXN QXB NXQP Q-R5 P-N3 BXP PXB QXR N-B7 B-R6 Q-K2 N-B3 
+L 11BJ N-K3 P-QR4 N-R4 PXP PXP Q-Q3 P-QB3 N-Q4 
+L 11BJ Q-Q2 QN-Q2 P-Q5 N-K4 NXN BXN PXP Q-B2 
+L 11BJ B-K2 QN-Q2 V 12BJ O-O N-N3 N-K3 Q-Q3 P-N3 QN-Q4 
+E E E E N-K5 B-B4 P-KB4 PXG NXP/KB3 Q-Q3 N-K5 BXBP QXB QXQP 
+E E E E E E E E E E Q-Q2 NXN BXQN Q-Q3 P-N3 B-KN5 B-K2 BXB   
+L 12BJ Q-Q2 N-B1 R-Q1 N-K3 B-R4 N-B5 N-K3 P-QR4 
+E E E E BXN QXB NXKP Q-KN3 N-N3 N-B5 
+E E E E E E O-O NXB QXN B-K3 
+L 12BJ P-Q5 N-N3 PXP NXN BXQN B-K4 Q-Q2 Q-N3 BXN PXB 
+E E E E E E E E P-Q6 B-N1 NXN PXN B-KB4 B-K3 Q-Q4 N-Q4 NXN PXN B-QN5 R-KB1 Q-K5 Q-B1 O-O R-Q1 
+E E E E E E E E E E O-O N-Q4 NXN PXN B-QN5 R-KB1 P-QB4 BXQP PXP B-KB4 BXB QXB Q-Q4 
+L 8BJ N-K2 P-QR4 R-QN1 PXP PXP N-Q4 N-QB4 B-KN5 Q-Q2  N-QB3 P-QB3 BXN BXB P-KB4    
+L 5B8 B-K2 BXN NPXB P-Q4 
+E E QPXB P-Q3 V 7BF B-Q3 QN-Q2 O-O N-B4 
+E E E E B-KN5 P-KR3 BXN QXB O-O N-Q2 N-Q2 N-B4 
+E E E E Q-Q3 N-Q2 O-O-O N-B4 
+E E Q-K3 N-B4 
+E E E E E E B-R4 P-KN4 B-N3 NXP 
+E E NXNP PXN BXP K-R2 Q-Q3 R-KN1 Q-N3 R-N3 B-R5 NXB 
+E E Q-R4 K-N2 B-R5 Q-R1 BXR QXQ BXQ PXB 
+L 7BF N-Q2 QN-Q2 V 8BF P-QB4 N-B4 V 9BF B-B3 P-QN3 O-O B-N2 R-K1 V 12WF P-KR3 P-QN4 N-K3 N-N3 P-QR4 B-Q2 P-R5 
+E E PXP PXP P-QR4   Q-Q2 B-Q2 B-B3 
+E E P-B5 B-B3 PXP PXP B-Q2 BXRP NXP N-Q5 N-N3 BXN RXR RXR PXB R-R6 R-K3 Q-R2 R-B3 Q-R3 P-KR3 R-R8 R-B1 RXR BXR Q-R8 K-R2 Q-QN8 P-QN4 NXKP 
+L 9BFP-KB3 N-R4 O-O V 11WF P-KB4 PXP BXP R-B2 N-B5 
+E E P-KN4 N-B5 PXB Q-KN4 K-B2 N-R6 K-K1 Q-R5 R-B2 QXR
+L 8BF O-O N-B4 V 9BG B-B3 P-QN3 R-K1 B-N2 P-QB4 T 12WF 
+E E P-QB4 B-N2 R-K1 T 12WF 
+L 9BG P-B3 N-R4 V 10BF  P-QB4T 11WF 
+L 10BF R-B2 N-B5 
+E E P-KN3 B-R6 R-B2 P-KB4 PXP RXP P-KN4 N-B5 PXR Q-N4 K-R1 B-N7 K-N1 N-R6 
+L 10BF N-B4 N-B5 BXN PXB R-K1 B-K3 P-K5 P-Q4 N-R5 P-QB3 
+E E E E Q-Q4 N-Q2 QR-Q1 Q-N4 K-R1 P-QN3 R-KN1 QR-K1 P-KN3 P-KB3 Q-Q2 PXP QXQ PXQ PXP R-B3 
+L 3B2 P-KB4 N-B3 V 4B3 N-B3 PXP B-B4 O-O O-O NXP V 7B4 N-Q5 V 8W3 N-B3 P-B3 NXN BXN B-R4 P-Q4 N-K2 B-N3 P-Q4 BXBP B-B4 N-R4 B-K5 Q-R5 N-N3 
+L 7B4 NXN P-Q4 BXP QXB P-Q3 B-Q3 P-B4 Q-K3 KN-N5 Q-R3 NXB QXN/Q3 BXP Q-Q5 K-R1 B-B4 
+L 4B3 N-Q5 NXP N-KB3 PXP B-B4 O-O O-O T 8W3 
+L 4B3 PXP QNXP P-Q4 N-N3 B-Q3 NXP BXN BXN PXB Q-R5 
+E E E E E E B-KN5 P-KR3 BXN QXB N-B3 O-O B-K2 Q-K2 B-Q3 P-Q4 P-K5 P-QB4 BXN PXB O-O BXN PXB P-B5 
+E E E E E E 
+E E E E E E B-Q3 N-R5 NXN QXN P-KN3 Q-B3 P-QR3 B-R4 
+L 3B2 B-B4 P-B3 V 4B4 N-B3 P-Q4 V 5B3 PXP P-K5 N-Q4 O-O 
+E E N-K5 O-O PXP Q-Q5 PXP BXP BXP K-R1  P-KB4 PXG NXBP Q-N5 
+E E E E E E E E E E O-O PXP B-N3 P-Q5 
+E E E E P-Q4 PXG O-O PXBP QXP PXP R-Q1 Q-B2 
+E E E E Q-B3 BXN PXB PXP B-N3 R-K1 B-KB4 N-B3 KR-K1 NXN BXN B-N5 BXN RXR RXR QXB QXB QXQBP R-QB1 Q-Q7 
+L 5B3 B-N3 NXP NXN PXN NXP Q-N4 BXP K-Q1 Q-R5 QXNP R-B1 P-QN4 P-KB3 P-K6 
+E E Q-R4 K-B2 B-R5 B-KR6 B-K2 N-Q2 NXN KXN 
+L 4B4 KN-K2 O-O O-O P-Q4 PXP PXP B-N3 P-Q5 N-N1 P-Q6 
+E E E E E E E E B-N3 P-Q4 PXP PXP P-Q4 PXP  KNXP R-K1 B-K3 B-N5 Q-Q3 QN-Q2 Q-N5 B-QR4 
+E E O-O N-B4 Q-N5 P-QR4 
+E E E E P-KR3 N-K4 Q-N5 BXN NPXB Q-B2 PXB QXP K-K2 P-QR3 QXNP QNXP N-B5 Q-K4 
+L 4B4 P-KB4 PXP P-K5 P-Q4 B-N3 B-N5 N-B3 N-K5 O-O N-N4 
+L 3B2 N-B3 O-O V 4B5 B-B4 N-B3 O-O NXP 
+E E P-Q3 P-Q4 PXP NXP B-Q2 N-B5 O-O B-N5 BXN PXB N-Q5 B-Q3 
+L 4B5 B-K2 N-B3 P-Q3 P-Q4 B-Q2 R-K1 
+L 4B5 P-Q3 P-Q4 B-Q2 N-B3 B-K2 R-K1 
+L 4B5 NXP P-Q4 V 5B4 N-Q3 BXN QPXB PXP N-B4 QXQ KXQ N-B3 
+L 5B4 PXP R-K1
+L 5B4 P-QR3 BXN QPXB R-K1 N-B3 NXP B-K2 Q-K2 O-O NXQBP 
+E E B-K3 N-QB3 O-O NXKBP 
+L 5B4 B-K2 Q-K2 P-KB4 PXP 
+E E N-Q3 BXN QPXB PXP N-B4 R-Q1 B-Q2 P-K6 PXP N-K5 B-Q3 Q-R5 
+E E E E E 
+E E E E E NPXB PXP N-B4 Q-K4 
+E E N-N2 N-B3 N-B4 N-Q4 B-R3 Q-N4 BXR QXNP 
+E E E E E E O-O N-Q4 B-B4 R-Q1  
+L 3B2 P-Q3 P-Q4 PXP NXP 
+E E B-Q2 N-B3 N-B3 O-O B-K2 R-K1 O-O BXN BXB PXP PXP QXQ QRXQ NXP BXP NXB NXN N-Q3 P-KB4 P-KB3 B-B4 NXB NXN B-N5 R-Q4 B-K7 
+L 3B2 N-Q5 NXN PXN O-O P-QB3 B-R4 
+E E N-K2 P-QB3 N-B3 Q-R4 B-B4 N-R3 O-O N-B2 R-K1 P-Q3 
+E E E E P-QR3 N-B2 N-R2 B-K2 P-QN4 Q-N3 
+L 3B2 P-KN3 P-Q4 PXP NXP NXN QXN Q-B3 P-K5 Q-N3 Q-Q3 P-QB3 B-QB4 Q-R4 N-B3 QXKP B-K3 P-Q4 NXP PXN B-QN5 
+L 3B2 KN-K2 P-Q4 PXP NXP P-KN3 NXN NXN BXN QPXB QXQ KXQ B-KN5 B-K2 BXB KXB N-B3 
+L 3B2 P-KN4 P-Q4 
+L 3B2 Q-B3 N-B3 
+L 3B2 P-B3 O-O KN-K2 P-Q4 N-N3 P-QR3 B-K2 B-QB4 
+L 3B2 B-N5 P-B3 B-R4 N-R3 P-Q3 N-B4 B-N3 P-Q4 \r\f
+L 2B1 P-KB4 NXP PXP Q-R5 
+E E N-QB3 NXN 
+E E Q-B3 N-B4 PXP N-B3 V 5B5 Q-K3 P-Q3 PXP N-K3 PXP QXBP P-B3 B-Q3 
+E E E E E E N-KB3 PXP B-N5 N-K3 NXP B-B4 NXN PXN BXP B-Q2 Q-KB3 QR-N1 
+L 5B5 N-K2 N-K3 Q-K4 P-Q4 
+L 5B5 Q-KN3 P-Q3 PXP BXP QXP Q-R5 P-KN3 Q-K5 B-K2 B-K4 Q-R6 QXR 
+E E E E E E E E E E B-N5 PXP QXKP N-K3 BXN PXB N-KB3 B-B4 P-Q3 O-O 
+E E E E N-K2 B-B4 P-Q3 O-O B-K3 Q-R5 K-Q2 BXB QXB P-QB4 
+\f
+L 2B1 P-Q4 PXP P-K5 Q-K2 N-KB3 P-Q3 QXP KN-Q2 
+E E E E Q-K2 N-Q4 Q-K4 N-N5 B-Q3 P-Q4 Q-K2 P-QB4 
+\f
+L 2B1 P-Q3 P-Q4 V 3B3 N-Q2 B-QB4 KN-B3 N-N5 
+E E B-K2 PXP PXP Q-Q5 
+E E NXP NXN PXN Q-R5 
+E E E E E E P-KR3 PXP PXP BXBP KXB NXKP K-B3 Q-Q4 
+E E E E E E E E P-QB3 N-B3 B-K2 PXP PXP N-KN5 BXN Q-R5 
+E E N-KR3 N-K6 PXN BXN PXB Q-R5 K-B1 BXP 
+E E E E N-N3 Q-R5 P-N3 Q-K2 
+E E K-B1 B-N3 PXB R-Q1 Q-K1 QXRP K-B2 R-Q3 B-B3 R-B3 N-Q2 P-KN4 
+L 3B3 N-KB3 N-B3 QN-Q2 B-QB4 B-K2 PXP QNXP B-K2 O-O N-Q4 
+E E E E PXP BXBP KXB N-KN5 K-N3 P-B4 PXP N-K6 Q-N1 NXQBP R-N1 BXP 
+E E E E E E E E K-N1 N-K6 Q-K1 NXBP Q-N3 NXR QXNP R-B1 N-B4 Q-K2 B-R6 B-K3 
+L 3B3 P-KB4 KPXP P-K5 N-N5 BXP N-QB3 N-KB3 P-B3 P-Q4 PXP 
+\f
+L 2W1 N-QB3 N-KB3 V 3W2 P-KN3 P-Q4 PXP NXP B-N2 NXN NPXN B-Q3 N-K2 O-O O-O N-B3 P-Q4 Q-B3 
+L 3W2 N-B3 B-N5 T 4W2 
+L 3W2 B-B4 NXKP V 4W4 NXN P-Q4 
+E E BXP KXB NXN P-Q4 
+L 4W4 N-B3 NXN QPXN P-QB3 NXP P-Q4 
+L 4W4 Q-R5 N-Q3 QXKP Q-K2 QXQ BXQ B-N3 N-B4 N-B3 P-QB3 O-O P-Q4 
+E E E E E E E E E E B-N3 B-K2 V 6W2 QXKP O-O P-Q4 N-B3 Q-B4 P-QN4 N-B3 B-N2 B-K3 N-R4 O-O-O P-N5 N-K2 N/Q3-B5 
+L 6W2 N-B3 N-B3 NXP O-O N-Q5 N-Q5 O-O NXB RPXN N-K1 P-Q4 P-Q3 N-KB3 B-K3 
+L 3W2 P-B4 P-Q4 PXQP NXP NXN QXN PXP N-B3 N-B3 B-KN5 B-K2 NXP 
+E E E E E E E E E E PXKP NXP P-Q3 NXN 
+E E Q-B3 N-QB3 NXN N-Q5 Q-B4 PXN 
+E E E E E E N-B3 B-K2 P-Q4 B-QN5 Q-Q3 P-QB4 
+E E B-Q2 N-QB3 B-Q3 NXB QXN B-N5 Q-B4 Q-Q2 
+\f
+L 2W1 B-B4 N-KB3 V 3W3 N-QB3 NXP T 4W4 
+L 3W3 N-KB3 NXP N-B3 NXN QPXN P-QB3 NXP P-Q4 
+L 3W3 P-B4 NXP P-Q3 N-Q3 B-N3 N-B3 
+L 3W3 P-Q3 P-B3 P-B4 PXP QBXP P-Q4 PXP NXP 
+E E E E E E Q-K2 B-K2 P-B4 P-Q4 KPXP KPXP BXP O-O 
+E E E E BPXP NXP 
+E E E E E E N-KB3 P-Q4 PXP PXP B-QN5 B-Q2 
+L 3W3 P-Q4 PXP N-KB3 P-Q4 PXP B-QN5 P-B3 Q-K2 
+\f
+L 2W1 P-KB4 PXP B-B4 P-Q4 BXP N-KB3 N-QB3 B-QN5 
+E E E E E E Q-B3 N-QB3 P-B3 N-B3 P-Q4 P-Q4 
+E E E E E E N-QB3 Q-R5 K-K2 P-Q4 NXP B-Q3 
+E E E E E E N-KB3 P-Q4 P-K5 P-KN4 P-KR3 N-KR3 P-Q4 N-B4 
+E E E E E E PXP N-KB3 V 5WZ B-N5 P-B3 PXP NXP P-Q4 B-Q3 P-Q5 NXP 
+E E Q-K2 B-K3 N-K5 O-O BXN PXB BXP N-Q4 B-N3 P-B3 NXP BXB PXB Q-Q2 N-R5 B-N5 
+L 5WZ B-B4 B-Q3 N-B3 O-O O-O QN-Q2 P-QR3 N-N3 B-R2 B-KN5 P-Q4 Q-Q2 N-K2 QNXP P-B4 N-K6 
+L 5WZ B-K2 NXP N-B3 V 6BZ NXN NPXN B-Q3 P-Q4 O-O O-O N-B3 P-B4 P-QN3 P-B3 B-KN5 N-K1 BXB QXB 
+L 5WZ P-B4 P-B3 PXP NXP P-Q4 B-KN5 
+E E E E P-Q4 B-QN5 N-B3 O-O B-K2 PXP O-O PXP QBXP N-B3 
+L 5WZ N-B3 NXP B-K2 T 6BZ NXN QXN P-Q4 N-B3 B-K2 B-KN5 BXP O-O-O P-B3 Q-K5 Q-Q2 BXN PXB Q-Q4 R-KN1 P-KN3 P-N3 B-N2 
+\f
+L 2W1 P-Q4 PXP N-KB3 B-B4 NXP N-KB3 N-QB3 P-Q4 P-K5 Q-K2 
+E E PXP O-O 
+E E E E E E E E P-QB3 PXP B-QB4 PXP BXNP P-Q4 BXQP N-KB3 BXBP KXB QXQ B-QN5 Q-Q2 BXQ NXB P-B4 
+\f
+L KP P-QB4 N-KB3 V 2B2 P-Q3 P-Q4 N-KB3 N-B3 
+E E PXP NXP N-KB3 N-QB3 V 5B6 P-KN3 B-K2 B-N2 O-O V 7B5 O-O B-K3 N-B3 Q-Q2 V 9B3 N-KN5 BXN BXB N-Q5 R-B1 P-QB4 NXN BXN RXP BXB KXB N-K3 RXP P-B3 
+E E E E E E E E B-K3 P-QN3 
+E E E E B-Q2 P-QB4 N-K4 P-QN3 
+L 9B3 P-Q4 PXP NXP KR-Q1 NXB NXN QXQ NXKP 
+E E E E NXQN QXN NXN BXN BXB RXB 
+L 7B5 N-B3 B-K3 O-O Q-Q2 T 9B3 
+L 5B6 P-K4 B-QN5 
+E E P-K3 B-K2 B-K2 B-K3 
+E E N-B3 B-K3 
+E E P-QR3 B-K3 
+L 5B6 N-B3 B-K2 P-K4 N-N3 
+E E P-K3 B-K3 
+L 5B6 P-QR3 B-K2 P-K3 B-K3 
+E E N-B3 B-K3 
+E E P-K4 N-N3 V 7B7 B-K3 O-O QN-Q2P-QR4 R-B1 P-B3 
+E E B-K2 B-K3 O-O P-B3 V 11B4 Q-B2 N-Q5 
+E E R-B1 R-B2 Q-B2 B-KB1 N-N3 R-Q2 N-B5 BXN 
+L 11B4 N-N3 P-R5 N-B5 BXN BXB R-B2 Q-B2 R-Q2 QR-B1 N-B1 P-R3 B-N6 Q-N1 N/QB1-R2 N-Q2 B-K3 P-QN3 PXP NXP N-N4 
+L 7B7 B-K2 O-O V 8B4 O-O B-K3 V 9B6 B-K3 V 10W4  P-B3 QN-Q2 P-QR4 T 11B4 
+E Q-B2 N-Q5 
+E E P-Q4 PXP NXP NXN BXN P-QB4 
+E E E E E E P-QN4 P-QR4 P-N5 N-Q5 NXN PXN B-B4 P-R5 
+L 9B6 QN-Q2 P-B3 P-QN4 P-QR4 P-N5 N-Q5 NXN QXN N-N3 Q-R5 
+E E QR-N1 KR-Q1 B-N2 Q-R5 
+E E E E E E E E E E Q-B2 P-QR4 P-QN3 Q-Q2 B-N2 V 13W2 KR-Q1V 13B2 QR-B1 B-B1 
+E E KR-Q1 B-B1 
+E E B-B3 Q-K1 P-R3 Q-B1 Q-N2 B-QB4 KR-B1 R-Q2 N-B1 N-B1N-N3 N/QB1-R2 P-QN4 PXP PXP BXNP BXB QXB QXQ NXQ R-R4 N/QN5-QB3 KR-R1 P-QN3 P-Q4 PXP B-N5 NXB RXR K-B2 
+L 13B2 KR-B1 N-B1 B-B3 N/QB1-R2 
+L 9B6 Q-B2 P-QR4  V 10B3 P-QN3 Q-Q2 V 11B5 B-N2 P-B3 QN-Q2  T 13W2 B-B3 KR-Q1 Q-N2 B-QB4 QN-Q2 Q-K2 KR-K1 R-Q2 B-B1 QR-Q1 N-B4 NXN QPXN B-KN5 
+L 11B5  B-K3 KR-Q1 R-B1 N-B1 
+E E QN-Q2 N-B1 KR-Q1 N/QB1-R2  N-B4 P-B3  Q-N2 N-N4 P-QR4 N/QN4-Q5 NXN NXN BXN QXB QXQ RXQ 
+L 10B3 B-K3 P-R5 Q-B3 B-B3 QN-Q2 N-Q5 BXN PXB Q-N4 Q-Q3 
+E E E E E E R-B1 Q-Q2 QN-Q2 KR-B1 
+E E E E E E QN-Q2 N-Q5  NXN PXN B-B4 P-QB4 B-N3 R-B1 N-B4 NXN PXN P-QN4 PXP B-N6 Q-Q2 P-B5 
+L 10B3 QN-Q2 P-R5 P-QN4 PXG NXNP N-R5 
+L 9B6 P-QN4 P-QR4 P-N5 N-Q5 NXKP B-B3 
+L 8B4 B-K3 B-K3 O-O T 10W4 
+\f
+L 2B2 P-QR3 N-B3 P-Q3 P-Q4 
+E E E E P-K3 N-B3 P-QR3 P-Q4 
+E E N-QB3 P-Q4 
+E E P-Q3 P-Q4 
+\f
+L 2B2 N-KB3 P-K5 N-Q4 N-B3 NXN QPXN 
+E E N-B2 P-Q4 
+E E P-K3 NXN PXN P-Q4 P-Q3 B-QN5 
+E E N-B3 PXP BXP QXP Q-N3 B-QB4 BXP K-K2 O-O R-Q1 
+E E E E E E P-Q3 PXP Q-N3 B-K3 QXP B-QB4 B-K3 P-Q7 
+E E E E BXB PXB QXKP B-K2 B-K3 Q-KN5 
+\f
+L 2B2 N-QB3 P-Q4 PXP NXP N-KB3 N-QB3 
+E E P-KN3 P-QB4  V 5B7 N-B3 N-QB3  NXN QXN P-Q3 B-K2 B-N2 O-O O-O Q-K3 B-K3 R-N1 P-QR3 B-Q2 P-QN4 PXP PXP BXP BXP NXB RXN B-B4 R-R1 P-QN4 P-Q4 PXP NXP Q-QN3 P-K3 KR-Q1 
+L 5B7 B-N2 B-K3 N-R3 N-QB3 O-O B-K2 
+E E E E N-B3 N-QB3 O-O B-K2 
+E E N-KN5 QXN BXN BXB NXB O-O-O 
+E E E E NXN Q-Q1 N-K3 Q-Q2 P-Q3 B-K2 
+E E E E P-K4 N-QN5 O-O Q-Q2 Q-R5 B-Q3 P-Q4 BPXP NXN BXN QXKP O-O R-Q1 KR-Q1 B-K3 PXB 
+E E E E E E E E E E E E E E Q-R4 B-Q2 Q-N3 P-B5 QXP R-B1 
+\f
+L 2B2 P-KN3 P-Q4 B-N2 N-B3 PXP NXP N-QB3 B-K3 N-B3 NXN NPXN P-K5 
+\f
+L KP P-K3 P-Q4 P-Q4 PXP PXP B-Q3 V 4B6  N-KB3 N-KB3 N-B3 O-O 
+E E B-KN5 O-O 
+E E P-QB3 O-O 
+E E P-QB4 Q-K2 
+E E B-Q3 O-O O-O B-KN5 B-KN5 QN-Q2 QN-Q2 P-B3 P-B3 Q-B2 Q-B2 KR-K1 KR-K1 B-R4 
+L 4B6 B-Q3 N-KB3 N-KB3 O-O 
+L 4B6 P-QB3 N-KB3 B-Q3 O-O 
+L 4B6 P-QB4 Q-K2 B-K2 PXP 
+E E Q-K2 PXP 
+E E B-K3 N-KB3 
+L 4B6 N-QB3 P-QB3 N-KB3 N-KB3 B-Q3 O-O 
+E E E E B-Q3 N-K2 Q-R5 N-R3 P-QR3 Q-Q2 KN-K2 N-B2 B-KB4 BXB NXB Q-N5  
+\f
+L KP P-QB3 P-Q4 P-Q4 PXP PXP B-Q3 N-QB3 P-QB3 N-B3 B-KB4 B-N5 N-B3 P-K3 Q-N3 Q-B1 QN-Q2 B-K2 O-O O-O P-KR3 B-R4 Q-B2 B-N3 BXB 
+\f
+L KP N-KB3 P-K5 N-Q4 P-Q4 P-Q3 P-QB4 N-N3 PXP KPXP B-Q3 
+E E BPXP B-Q3 
+\f
+L KP P-Q3 P-Q4 
+E E P-KN3 P-Q4 
+E E P-Q4 PXP N-KB3 P-Q4 NXP N-KB3 
+\f
+L KP N-QB3 N-KB3 P-K4 B-N5 T 3B2 
+\f
+L ORG P-Q4 P-Q4 V 2W2 P-QB4 P-K3 V 3W4 N-QB3 P-QB3 V 4W5 P-K4 PXKP NXP B-N5 V 6W3 N-QB3 P-QB4 B-K3 N-KB3 N-KB3 N-B3 
+E E KN-K2 N-N5 
+E E P-QR3 BXN PXB Q-R4 B-Q2 N-K5 Q-N4 NXB QXNP QXBP QXR K-Q2 
+E E E E E E Q-B2 NXB QXN PXP PXP QXQ KXQ N-B3 
+L 6W3 B-Q2 QXP BXB QXN V 8W4 N-K2 N-Q2 Q-Q6 P-QB4 B-B3 N-K2 
+E E BXP NXB QXN B-Q2 P-B3 P-QN3 
+E E E E E E E E Q-Q2 QXBP N-B4 Q-K5 B-K2 P-QB4 B-QB3 KN-B3 
+L 8W4 B-K2 P-QB4 B-QB3 N-K2 BXP R-N1 B-B6 N-Q2 BXN KXB 
+E E E E E E E E BXP QXNP V 10W2 Q-Q4 N-Q2 B-B3 Q-N4 B-Q6 N-K2 
+E E B-QN4 Q-K4 N-K2 QXQ NXQ N-K4 O-O-O P-QR3 
+E E B-K2 B-Q2 R-KN1 N-K2 B-Q6 N/K4-N3 R-Q1 P-K4 
+L 10W2 Q-Q6 N-Q2 O-O-O Q-B3 
+L 10W2 B-B3 Q-N4 B-K3 Q-QR4 B-Q2 Q-B2 N-K2 N-QB3 B-B3 N-K4 N-Q4 B-Q2 
+E E E E E E E E E E Q-Q6 N-Q2 B-K3 Q-QR4 P-QN4 Q-K4 
+E E E E E E B-Q6 N-K2 N-K2 N-B4 R-KN1 Q-Q1 
+L 4W5 N-B3 N-B3 V 5W4 B-N5 PXP V 6WM P-K3 P-QN4 P-QR4 B-N5 
+L 6WM P-QR4 B-N5 P-K4 BXN PXB Q-R4 P-K5 N-K5 B-Q2 Q-Q4 
+E E R-QB1 N-Q2 BXP NXB NXN NXP 
+E E E E B-K3 N-N3 Q-B2 P-KB4 PXG NXP/KB3 R-R1 QN-Q4 B-Q2 P-QN4 
+L 6WM P-K4 P-QN4 V 7WM P-QR4 P-N5 N-QN1 P-KR3 BXN QXB BXP Q-N3 QN-Q2 QXNP R-KN1 Q-R6 Q-N3 P-QR4 O-O-O 
+L 7WM Q-B2 P-KR3 B-R4 P-KN4 B-N3 P-KN5 N-K5 QXQP B-K2 B-QN5 O-O BXN PXB QXKP Q-Q2 QN-Q2 
+L 7WM P-K5 P-KR3 V 8WM PXN PXB PXP BXP 
+L 8WM BXN PXB P-QR4 B-N5 KPXP QXBP  N-K5 P-B4 B-K2 N-Q2 O-O BPXP N-N4 Q-N2 NXNP P-KR4 
+L 8WM B-R4 P-N4 V 9WM B-N3 N-Q4 N-Q2 N-Q2 KN-K4 Q-R4 
+L 9WM KNXP PXN BXNP QN-Q2 V 11WM Q-B3 B-QN2 NXP Q-R4 
+E E N-K4 B-N5 K-K2 NXN BXQ P-QB4 
+E E E E E E PXN Q-R4 B-Q2 Q-N3 B-K3 P-QB4 PXP BXBP BXB NXB Q-K3 O-O-O 
+E E E E E E E E E E E E   B-K2 Q-N3 PXN P-QB4 P-Q5 P-N5 
+E E E E BXN P-QB4 V 14WM P-Q5 NXB QXN R-R3 Q-B3 P-N5 N-K4 PXP N-B6 RXN QXR QXQ PXQ O-O-O 
+L 14WM PXP NXBP Q-N3 P-N5 BXR PXN PXP N-K5 Q-B4 B-KR3 
+E E E E QXP N-K5 Q-K3 B-B4 
+L 14WM N-K4 KR-N1 Q-B4 PXP B-R5 N-B4 NXN QXN 
+E E BXBP K-Q2 NXN BXN BXR B-QN5 
+E E O-O-O RXP 
+L 11WM P-KN3 Q-N3 PXN B-QN2 B-N2 V 13BM O-O-O O-O N-K4 PXN RXQ KRXR P-QB4 
+E E QRXR P-QB4 
+E E E E Q-K2 QXP QR-Q1 N-Q6 
+E E KR-Q1 N-Q6 
+E E B-K3 Q-Q6 KR-Q1 QXQ V 18WM RXR KXR NXQ K-B1 BXRP P-QB4 P-QR4 N-B6 
+E E E E R-Q1 P-QB4 BXB KXB R-Q8 B-N2 RXR BXR N-B3 K-B3 
+E E BXP BXP B-N4 N-B3 B-B3 P-K4 K-B1 P-N5 B-Q2 P-QR4 P-KR4 P-K5 B-B1 N-K4 P-QR3 N-Q6 PXP PXP B-K3 BXNP B-Q4 BXB NXB P-N6 N-N5 K-N3 N-B3 K-R4 K-K2 K-N5 N-Q5 K-R6 P-R5 P-N7 N-B3 K-N6 K-Q2 NXP P-R6 P-K6 K-K2 KXN 
+E E KXP N-N5 K-Q4 NXP 
+L 18WM NXQ RXR RXR P-QB4 BXB KXB R-Q8 B-N2 RXR BXR N-B3 K-B3 
+E E BXP BXP B-N4 N-B3 B-B3 P-K4 
+L 11WM PXN B-QN2 P-KN3 Q-N3 B-N2 T 13BM 
+E E B-K2 Q-N3 O-O O-O-O P-QR4 P-N5 N-K4 P-B4 Q-N1 Q-B2 
+E E E E E E E E P-QR4 O-O-O O-O P-N5 N-K4 P-B4 Q-N1 Q-B2 
+E E E E E E P-R5 Q-B2 P-R6 B-R1 O-O Q-N3 
+E E E E O-O P-R3 
+L 9WM PXN PXB NXRP B-QN2 P-KN3 N-Q2 B-N2 Q-N3 P-R4 P-QR4 
+E E E E E E E E N-K5 QXBP V 11WMM P-KN3 N-Q2 P-B4 B-QN2 
+E E Q-K2 NXN PXN Q-Q1 B-N2 B-QN2 NXP PXN BXB B-N5 K-B1 R-QN1 B-B6 K-B1 R-Q1 Q-B2 
+L 11WM P-QR4 P-N5 N-K4 Q-B5 
+L 11WM B-K2 N-Q2 V 12WMM NXP/QB6 B-QN2 B-B3 P-R3 Q-K2 R-B1 N-K5 BXB NXB Q-B5 P-Q5 N-B4 
+E E E E E E E E O-O B-N2 V 15WMM P-Q5 BXN PXB N-K4 B-K4 O-O Q-K2 QR-B1 P-R4 NXP PXP N-Q5 
+L 15WMM P-R4 P-N5 N-K4 Q-B5 P-KN3 PXP RPXP Q-B2 NXNP R-Q1 Q-K2 BXP QR-Q1 N-K4 N-KB6 K-B1 
+E E RXB NXB QXN RXR Q-B6 RXN QXR K-K2 R-Q1 Q-Q3 RXQ R-K8 K-R2 R-KR8 
+L 12WMM O-O NXN PXN QXKP B-B3 B-QN2 R-K1 Q-Q3 NXP QXQ QRXQ B-N5 R-K2 K-K2  \rL 5W4 PXP KPXP V 6W4 B-B4 B-K2 P-K3 B-KB4 
+E E Q-B2 P-KN3 P-K3 B-KB4 
+L 6W4 B-N5 V 6B3 B-K2 P-K3 B-KB4 
+E E Q-B2 P-KN3 P-K3 B-KB4 B-Q3 BXB QXB QN-Q2 B-R6 N-N5 
+E E O-O O-O P-QR3 P-QR4 
+E E QR-B1 R-K1 N-Q2 K-N2 N-N3 B-Q3 P-KR3 P-KR3 
+L 5W4 Q-N3 QN-Q2 PXP KPXP 
+E E B-N5 B-K2 PXP KPXP 
+E E P-K3 O-O PXP KPXP 
+E E B-K2 PXP QXBP N-Q4 BXB QXB O-O KN-N3 Q-Q3 P-K4 
+L 5W4 P-K3 QN-Q2 V 6W5 PXP KPXP B-Q3 B-Q3 O-O O-O Q-B2 R-K1 
+L 6W5 B-Q2 B-Q3 PXP KPXP 
+E E B-Q3 O-O PXP KPXP 
+E E O-O PXP BXBP P-K4 
+L 6W5 P-QN3 B-N5 B-N2 N-K5 
+E E B-Q2 O-O P-QR3 B-Q3 
+E E B-K2 Q-K2 O-O B-Q3 PXP KPXP 
+E E Q-B2 PXP PXP P-K4 N-KN5 R-K1 
+L 6W5 P-QR3 B-Q3 
+L 6W5 N-K5 NXN PXN N-Q2 P-KB4 B-QB4 P-QR3 Q-K2 P-QN4 B-N3 B-K2 O-O O-O P-B3 P-QB5 B-B2 PXP NXKBP P-KN4 P-K4 
+L 6W5 Q-B2 B-Q3 V 7W4 P-K4 PXKP NXP NXN QXN P-K4 PXP NXP NXN Q-QR4 
+E E B-KB4 O-O NXN BXN BXB R-K1 
+E E E E BXN BXB NXB R-K1 
+E E E E E E E E B-Q3 P-KB4 QXKBP N-B3 Q-N5 P-K5 BXP NXB QXNP Q-B3 
+E E E E E E E E E E  P-B5 B-K2 NXP NXN QXN O-O 
+L 7W4 P-QN3 O-O B-K2 PXP PXP P-K4 O-O R-K1 B-N2 PXP PXP N-B1 QR-Q1 N-N3 
+L 7W4 PXP KPXP 
+L 7W4 B-Q2 O-O PXP KPXP 
+E E O-O-O P-QB4 P-K4 BPXP KNXP PXBP BXP N-N3 B-K2 B-Q2 
+E E E E E E E E PXQP KPXP B-K1 P-B5 P-KN4 N-N3 
+E E E E K-N1 P-QR3 B-B1 P-B5 P-KN4 N-N3 P-KR3 R-K1 B-N2 B-QN5 
+L 6W5 B-Q3 PXP BXBP P-QN4 B-K2 B-K2 O-O P-QR3 P-K4 P-N5 
+E E E E E E B-N3 P-N5 N-QR4 B-R3 
+E E N-K2 B-N2 O-O B-K2 N-B4 O-O 
+E E N-N3 O-O P-K4 P-QB4 
+E E E E E E E E E E B-Q3 P-N5 N-QR4 P-QB4 PXP NXP B-N5 B-Q2 BXB KNXB 
+E E E E E E E E N-K2 P-QB4 O-O B-N2 N-K5 B-Q3 P-KB4 O-O 
+E E E E E E E E N-K4 NXN BXN B-N2 Q-R4 Q-N3 O-O B-K2 N-Q2 R-QB1 
+E E E E E E Q-B2 R-B1 BXRP P-QB4 
+E E E E B-Q2 B-K2 P-QR3 P-QR4 Q-R4 Q-N3 
+E E E E E E O-O B-K2 Q-R4 O-O B-Q2 Q-N3 
+E E BXBP N-N3 
+E E E E P-QN3 O-O B-N2 N-B3 B-Q3 P-QB4 PXP BXP R-QB1 B-K2 N-K5 Q-Q4 
+E E E E E E R-QB1 R-QB1 Q-K2 N-K5 B-R6 Q-N3 BXB QXB PXP BXP N-K5 B-K2 N-B4 KR-Q1 
+L 4W5 P-K3 N-KB3 N-B3 QN-Q2 T 6W5 
+E PXP KPXP 
+L 4W5 PXP KPXP V 5W5 N-B3 B-KB4 B-B4 B-Q3 BXB QXB P-K3 N-B3 B-Q3 BXB QXB QN-Q2 O-O O-O QR-N1 KR-K1 P-QN4 P-QR3 P-QR4 N-K5 
+L 3W4 PXP PXP N-QB3 P-QB3 T 5W5 
+L 3W4 N-KB3 N-KB3 V 4W6 PXP KPXP N-QB3 P-QB3 T 6W4 
+E E E N-B3 P-B3 T 5W4
+E B-N5 P-KR3 B-R4 PXP 
+E E BXN QXB N-B3 P-QB3 V 7W3 P-K3 N-Q2 PXP KPXP 
+E E B-Q3 B-Q3 PXP KPXP 
+E E O-O Q-K2 P-K4 PXBP BXP P-K4 
+E E E E PXP KPXP P-K4 PXP NXP O-O R-K1 N-B3 N-K5 NXN BXN B-K3 B-B2 BXN PXB KR-Q1 Q-K2 R-Q5 QR-Q1 QR-Q1 P-QR3 Q-N4 RXR RXR R-Q1 B-B5 Q-K1 B-Q4 P-KN3 RXR BXR Q-B8 
+E E QXR QXKP B-N3 QXQNP BXB PXB QXP Q-B8 K-N2 Q-B3 
+L 7W3 Q-N3 PXP QXBP N-Q2 P-K4 P-K4 P-Q5 N-N3 
+E E E E R-Q1 B-K2 P-KN3 O-O B-N2 P-K4 
+E E E E P-K3 O-O B-Q3 P-KN3 
+L 7W3 PXP KPXP P-K3 N-Q2 
+E E E E P-K4 PXKP NXP B-N5 K-K2 Q-B5 
+E E N-B3 P-B4 R-B1 O-O PXP P-K4 
+E E E E E E QN-Q2 P-B4 P-QR3 BXN QXB PXP QXQP N-B3 QXQ PXQ P-B5 B-Q2 B-N5 K-K2
+\f
+L 2W2 N-KB3 N-KB3 V 3WY P-QB4 P-K3 T 4W6 
+E P-KN3 P-QB4 PXP P-K3 P-QN4 P-QR4 P-B3 PXP PXP P-QN3 
+E E E E E E E E B-N2 P-K3 O-O N-B3 
+L 3WY P-K3 V 3BZ P-KN3 B-Q3 B-N2 O-O O-O QN-Q2 P-B4 P-B3 KN-Q2 Q-K2 N-QB3 P-KR3 R-K1 B-N5 P-QR3 B-R4 P-QN4 B-B2 B-N2 
+L 3WY B-B4 V 3BJ P-B4 P-K3 N-B3 P-B3 Q-N3 Q-B1 B-B4 PXP QXBP QN-Q2 R-B1 N-N3 Q-N3 Q-Q2 P-K3 B-Q3 B-K5 
+E E E E E E N-Q4 NXN KPXN Q-N3 P-QR4 P-QR3 P-R5 Q-B3 
+L 3WY N-B3 P-KN3 B-B4 B-N2 P-K3 O-O P-KR3 P-B4 B-K2 P-N3 O-O B-N2 N-K5 QN-Q2 
+L 3WY B-N5 N-K5 V 4WJ B-B4 P-QB4 PXP N-QB3 P-K3 P-B3 P-B4 P-K4 B-N3 B-K3 QN-Q2 NXN NXN BXP P-QR3 P-Q5 N-N3 B-N3 
+L 4WJ B-R4 P-QB4 PXP N-QB3 P-K3 P-KN3 QN-Q2 NXQBP B-K2 B-N2 P-B3 O-O O-O P-QR4 
+\f
+L 2W2 P-K3 N-KB3 V 3WZ N-KB3 T 3BZ P-KB4 P-QB4 P-B3 Q-B2 N-B3 P-KN3 B-Q3 B-N2 
+E E E E B-Q3 P-KN3 N-B3 B-N2 
+L 3WZ B-Q3 N-B3 P-QB3 P-K4 
+E E P-KB4 N-QN5 B-K2 B-B4 
+E E N-KB3 NXB QXN P-KN3 O-O B-N2 
+E E E E PXN P-KN3 O-O B-N2 N-B3 O-O B-Q2 P-QN3 N-K5 P-QB4 A
+L 2W2 P-K4 PXP P-KB3 P-K4 QPXP QXQ KXQ N-QB3 B-QN5 B-Q2 
+E E B-KB4 KN-K2 PXP N-N3 
+L 2W2 B-B4 N-KB3 N-KB3 T 3BJ  
+
+\f
+L ORG P-QB4 V ENG P-K4 N-QB3 N-KB3 V 3W5 P-KN3 P-B3 V 4W7 P-Q4 PXP QXP P-Q4 PXP PXP 
+E E B-N5 B-K2 N-B3 O-O B-N2 P-KR3 B-B4 P-B4 Q-Q3 P-Q5 N-QN5 N-B3 B-B7 Q-K1 O-O B-N5 
+L 4W7 B-N2 P-Q4 PXP PXP Q-N3 N-B3 NXP N-Q5 
+E E E E P-Q3 N-B3 N-B3 B-K2 O-O O-O P-Q4 P-K5 N-K5 B-K3 
+E E E E E E E E P-B4 P-Q5 PXP N-KN5 N-K4 B-QN5 K-B1 KNXKP N-R3 O-O N-B4 K-R1 
+L 4W7 N-B3 P-K5 N-Q4 P-Q4 PXP PXP P-Q3 Q-N3 N-N3 N-N5 P-Q4 B-K3 P-B3 PXP PXP N-KB3 B-K3 N-B3 
+E E E 
+E E E E E E E PXP B-QB4 P-K3 PXP B-N2 O-O O-O B-KN5 
+E E NXP NXN BXN R-K1 
+L 3W5 N-B3 N-B3 V 4W8 P-Q4 PXP NXP B-B4 NXN NPXN P-KN3 O-O 
+L 4W8 P-K4 B-N5 P-Q3 P-Q3 B-K2 O-O O-O BXN PXB Q-K2 N-K1 N-K1 N-B2 P-B4 PXP BXP 
+L 4W8 P-KN3 P-KN3 B-N2 B-N2 O-O O-O R-N1 P-Q3 P-QN4 P-K5 N-K1 B-B4 P-Q3 P-Q4 PXQP NXQP 
+E E P-N5 N-K2 PXQP QNXP NXN NXN PXP N-B6 
+E E E E B-N2 NXN BXN R-K1 
+L 4W8 P-QR3 P-Q4 
+E E P-K3 B-N5 N-Q5 P-K5 NXB NXN N-Q4 O-O P-QR3 N-R3 B-K2 P-Q4 
+L 4W8 P-Q3 P-Q4 PXP NXP P-KN3 B-K3 B-N2 B-K2 O-O O-O P-QR3 Q-Q2 B-Q2 QR-Q1 P-QN4 NXN BXN B-B3 
+\f
+L ORG N-KB3 N-KB3 P-Q4 P-Q4 P-QB4 P-K3 T 4W6 
+E E E P-QB4 P-K3 P-Q4 P-Q4 T 4W6 
+E N-B3 P-Q4 PXP PXP P-Q4 P-B3 T 6W4 
+E E E E E E E P-QN3 P-Q4 B-N2 B-B4 P-K3 P-K3 B-K2 P-KR3 
+E E 
+E E E E E E P-KN3 P-Q4 B-N2 V 3B4 P-B4 O-O P-K3 P-Q4 B-K2 
+E E P-Q3 N-B3 QN-Q2 B-K2 P-K4 O-O V 8W5 P-K5 N-KN5 Q-K2 P-B3 PXP BXP P-B3 Q-Q3 P-Q4 PXP NXP P-K4 
+L 8W5 Q-K2 Q-B2 P-K5 N-Q2 R-K1 V 10B1 P-QN4 P-KR4 P-QR4 N-B1 B-R3 N/B1-R2 P-N5 P-R5 P-R5 P-R6 P-N3 N-N4 P-B5 
+L 8W5 R-K1 Q-B2 P-K5 N-Q2 Q-K2 T 10B1 
+L 8W5 P-B3 PXP PXP Q-B2 Q-B2 P-K4 R-K1 B-K3 N-N5 B-Q2 N-B1 P-KR3 N-B3 B-K3 
+\f
+L ORG P-KN3 N-KB3 B-N2 P-Q4 N-KB3 T 3B4 
+\f
+L ORG P-KB4 P-Q4 P-K3 N-KB3 P-QN3 P-Q5 
+E E N-KB3 B-N5 P-KR3 BXN 
+E E P-B4 P-K3 N-B3 P-B3 
+E E E E P-QN3 P-K3 B-N2 B-K2 
+E E E E B-K2 BXN BXB QN-Q2 P-B4 P-K3 PXP PXP N-B3 P-B3 O-O B-K2 P-Q3 N-N3 P-K4 PXP PXP B-B4 
+\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/c.ubd026 b/MUDDLE/c.ubd026
new file mode 100644 (file)
index 0000000..185ab52
--- /dev/null
@@ -0,0 +1,390 @@
+
+<PACKAGE C>
+
+<EXTERNAL TOOL!-PACKAGE>
+
+<DEFINE <ENTRY MESSAGE> (SEVERITY STR "TUPLE" TEXT)
+       <TERPRI>
+       <PRINC "*** ">
+       <PRINC .SEVERITY>
+       <PRINC "        ">
+       <PRINC .STR>
+       <REPEAT ()
+          <COND (<EMPTY? .TEXT> <RETURN 0>)
+                (<==? <TYPE <1 .TEXT>> ATOM> <PRINC <1 .TEXT>>)
+                (ELSE <PRIN1 <1 .TEXT>>)>
+          <PRINC " ">                                                  ;"Space"
+          <CHOP TEXT>>
+       <COND (<==? .SEVERITY ERROR> <EXIT .COMPILER "COMPILATION ABORTED">)
+             (<==? .SEVERITY STOP> <LISTEN>)>>
+
+<INTERNAL SETUP>
+
+<EXTERNAL OP!-PACKAGE GLOBAL!-PACKAGE>
+
+<DEFINE BLOCK:INITIAL () 0>
+
+<DEFINE BRANCH (TAG) <EMIT <INSTRUCTION JRST .TAG>>>
+
+<DEFINE SUBR:CALL (ADR ARG-NUMBER) <EMIT <INSTRUCTION MCALL .ARG-NUMBER .ADR>>>
+
+<DEFINE BINDINGS:INITIAL () 0>
+
+<DEFINE BINDINGS:FINAL () 0>
+
+<DEFINE TEST:TRUE (TAG)
+       <EMIT <INSTRUCTION HLRZ O* A>>
+       <EMIT <INSTRUCTION CAIE O* TFALSE>>
+       <EMIT <INSTRUCTION JRST .TAG>>>
+
+<SETG INSTRUCTION #SUBR *000000402161*>
+
+<DEFINE BINDING:INITIAL () 0>
+
+<DEFINE BINDING:ATOM (ATM)
+       <REFERENCE .ATM>
+       <EMIT <INSTRUCTION HRRI A* -1>>
+       <STACK:ARGUMENT>>
+
+<DEFINE TAGMAK ("OPTIONAL" (STR "TAG"))
+       <SET STR <STRING .STR <UNPARSE ,TAG:COUNT>>>
+       <SETG TAG:COUNT <+ ,TAG:COUNT 1>>
+       <OR <LOOKUP .STR <MOBLIST INITIAL>> <INSERT .STR <MOBLIST INITIAL>>>>
+
+<DEFINE VARIABLES () ((REFERENCES ()) (CODING ()) (TAGS ()))>
+
+<DEFINE STACK:ARGUMENT ()
+       <EMIT <INSTRUCTION PUSH TP* A>>
+       <EMIT <INSTRUCTION PUSH TP* B>>>
+\f
+<DEFINE BINDING:FINAL ()
+       <EMIT <INSTRUCTION PUSH TP* [0]>>
+       <EMIT <INSTRUCTION PUSH TP* [0]>>
+       <EMIT <INSTRUCTION PUSHJ P* SPECBIND>>>
+
+<DEFINE LABEL (TAG) <EMIT .TAG>>
+
+<DEFINE EMIT (INSTR)
+       <PUTREST .CODE:PTR (.INSTR)>
+       <SET CODE:PTR <REST .CODE:PTR>>>
+
+<DEFINE TEST:ARG (NUMBER TAG)
+       <EMIT <INSTRUCTION HLRE C* AB>>
+       <EMIT <INSTRUCTION MOVMS C>>
+       <EMIT <INSTRUCTION CAIGE C* <* 2 .NUMBER>>>
+       <EMIT <INSTRUCTION JRST .TAG>>>
+
+<DEFINE REFERENCE (OBJECT "EXTRA" TTYPE)
+       <COND (<AND!-  <==? <PRIMTYPE .OBJECT> WORD>
+                      <SET TTYPE
+                           <LOOKUP <STRING !"T <PNAME <TYPE .OBJECT>>>
+                                   <GET OP!-PACKAGE OBLIST>>>>
+              <EMIT <INSTRUCTION MOVSI A* .TTYPE>>
+              <EMIT <INSTRUCTION MOVE B* [.OBJECT]>>)
+             (ELSE
+              <SET OBJECT <FORM QUOTE .OBJECT>>
+              <EMIT <INSTRUCTION MOVE A* <FORM MQUOTE .OBJECT> -1>>
+              <EMIT <INSTRUCTION MOVE B* <FORM MQUOTE .OBJECT>>>)>>
+
+<DEFINE FUNCTION:FINAL (PRINFLG)
+       <EMIT <INSTRUCTION JRST FINIS>>
+       <ASSEMBLE!-CODING <REST .CODE:TOP> .PRINFLG <MOBLIST INITIAL>>>
+
+<DEFINE BINDING:VALUE () <STACK:ARGUMENT>>
+
+<DEFINE BINDING:UNBOUND ()
+       <EMIT <INSTRUCTION MOVSI A* TUNBOUND>>
+       <EMIT <INSTRUCTION SETO B*>>
+       <STACK:ARGUMENT>>
+
+<DEFINE BINDING:ARG (NUMBER)
+       <EMIT <INSTRUCTION PUSH TP* (AB) <- <* .NUMBER 2> 2>>>
+       <EMIT <INSTRUCTION PUSH TP* (AB) <- <* .NUMBER 2> 1>>>>
+
+<DEFINE TEST:FALSE (TAG)
+       <EMIT <INSTRUCTION HLRZ O* A>>
+       <EMIT <INSTRUCTION CAIN O* TFALSE>>
+       <EMIT <INSTRUCTION JRST .TAG>>>
+
+<SETG TAG:COUNT 0>
+
+<DEFINE FUNCTION:INITIAL (NAME) <EMIT <FORM TITLE .NAME>>>
+
+<DEFINE BLOCK:FINAL () 0>
+
+<FINISHUP <SETG INSTRUCTION ,FORM> <SETG TAG:COUNT 0>>
+
+<END>
+
+<INTERNAL COMPL>
+\f
+
+<DEFINE <ENTRY COMPILE> (NAME "OPTIONAL" (PFLG <>) "NAME" COMPILER)
+       <COND (<NOT <==? <TYPE .NAME> ATOM>>
+              <MESSAGE ERROR "ARGUMENT NOT ATOMIC">)
+             (<NOT <GASSIGNED? .NAME>>
+              <MESSAGE ERROR "GLOBALLY UNASSIGNED" .NAME>)
+             (<NOT <==? <TYPE ,.NAME> FUNCTION>>
+              <MESSAGE ERROR "IMPROPERLY VALUED" .NAME>)>
+       <PUT .NAME APPLY:OBJECT <GET RSUBR APPLY:TYPE>>         ;"Recursive calls"
+       <SETG .NAME <COMPILE-FUNCTION ,.NAME .NAME>>
+       <PUT .NAME APPLY:OBJECT>                                ;"Remove"
+       <EXIT .COMPILER "DONE">>
+
+<DEFINE COPY (OBJ)
+       <SUBR:CALL!-SETUP <PRIMTYPE .OBJ>
+                         <REPEAT ((I 0))
+                            <IF <EMPTY? .OBJ> <RETURN .I>>
+                            <COMP <1 .OBJ>>
+                            <STACK:ARGUMENT!-SETUP>
+                            <CHOP OBJ>
+                            <INC I>>>>
+
+
+<DEFINE BINDINGS (ARGS "OPTIONAL" (MODE INITIAL) "NAME" BINDER)
+       <IF-NOT <==? <TYPE .ARGS> LIST> <MESSAGE ERROR "ILLEGAL ARGUMENT LIST" .ARGS>>
+       <IF <EMPTY? .ARGS> <EXIT .BINDER 0>>
+       <BINDINGS:INITIAL!-SETUP>
+       <REPEAT (ITEM DEFAULT:TAG GIVEN:TAG (ARG-NUMBER 1))
+          <SET ITEM <1 .ARGS>>
+          <COND (<==? <TYPE .ITEM> ATOM>
+                 <COND (<==? .MODE INITIAL>
+                        <BINDING:INITIAL!-SETUP>
+                        <BINDING:ATOM!-SETUP .ITEM>
+                        <BINDING:ARG!-SETUP .ARG-NUMBER>
+                        <BINDING:FINAL!-SETUP>
+                        <INC ARG-NUMBER>)
+                       (<==? .MODE EXTRA>
+                        <BINDING:INITIAL!-SETUP>
+                        <BINDING:ATOM!-SETUP .ITEM>
+                        <BINDING:UNBOUND!-SETUP>
+                        <BINDING:FINAL!-SETUP>)
+                       (<==? .MODE OPTIONAL>
+                        <SET DEFAULT:TAG <TAGMAK!-SETUP>>
+                        <SET GIVEN:TAG <TAGMAK!-SETUP>>
+                        <BINDING:INITIAL!-SETUP>
+                        <BINDING:ATOM!-SETUP .ITEM>
+                        <TEST:ARG!-SETUP .ARG-NUMBER .DEFAULT:TAG>
+                        <BINDING:ARG!-SETUP .ARG-NUMBER>
+                        <BRANCH!-SETUP .GIVEN:TAG>
+                        <LABEL!-SETUP .DEFAULT:TAG>
+                        <BINDING:UNBOUND!-SETUP>
+                        <LABEL!-SETUP .GIVEN:TAG>
+                        <BINDING:FINAL!-SETUP>
+                        <INC ARG-NUMBER>)
+                       (ELSE <MESSAGE WARNING "BINDING ATTEMPTED FOR" .ITEM .MODE>)>)
+                (<AND <==? <TYPE .ITEM> LIST> <==? <LENGTH .ITEM> 2>>
+                 <COND (<==? .MODE EXTRA>
+                        <BINDING:INITIAL!-SETUP>
+                        <BINDING:ATOM!-SETUP <1 .ITEM>>
+                        <COMP <2 .ITEM>>
+                        <BINDING:VALUE!-SETUP>
+                        <BINDING:FINAL!-SETUP>)
+                       (<==? .MODE OPTIONAL>
+                        <SET DEFAULT:TAG <TAGMAK!-SETUP>>
+                        <SET GIVEN:TAG <TAGMAK!-SETUP>>
+                        <BINDING:INITIAL!-SETUP>
+                        <BINDING:ATOM!-SETUP <1 .ITEM>>
+                        <TEST:ARG!-SETUP .ARG-NUMBER .DEFAULT:TAG>
+                        <BINDING:ARG!-SETUP .ARG-NUMBER>
+                        <BRANCH!-SETUP .GIVEN:TAG>
+                        <LABEL!-SETUP .DEFAULT:TAG>
+                        <COMP <2 .ITEM>>
+                        <BINDING:VALUE!-SETUP>
+                        <LABEL!-SETUP .GIVEN:TAG>
+                        <BINDING:FINAL!-SETUP>
+                        <INC ARG-NUMBER>)
+                       (ELSE
+                        <MESSAGE ERROR "BINDING ATTEMPTED FOR" .ITEM>)>)
+                (<==? <TYPE .ITEM> STRING>
+                 <COND (<=? .ITEM "OPTIONAL"> <SET MODE OPTIONAL>)
+                       (<OR <=? .ITEM "EXTRA"> <=? .ITEM "AUX">>
+                        <SET MODE EXTRA>)
+                       (ELSE
+                        <MESSAGE UNIMPLEMENTED "BINDINGS FOR" .ITEM>
+                        <CHOP ARGS>)>)
+                (ELSE <MESSAGE UNIMPLEMENTED "BINDINGS FOR" .ITEM>)>
+          <IF <EMPTY? <CHOP ARGS>> <RETURN 0>>>
+       <BINDINGS:FINAL!-SETUP>>
+
+<DEFINE COMPILE-FUNCTION (FUNCTN
+                         "OPTIONAL" (NAME NOT-NAMED)
+                         "EXTRA" (CODE:TOP!-SETUP (()))
+                                 (CODE:PTR!-SETUP .CODE:TOP!-SETUP)
+                                 (INFO!-SETUP ()))
+       <FUNCTION:INITIAL!-SETUP .NAME>
+       <IF <EMPTY? .FUNCTN> <MESSAGE ERROR "EMPTY FUNCTION">>
+       <IF <==? <TYPE <1 .FUNCTN>> ATOM>                   ;"Activation name ?"
+           <MESSAGE UNIMPLEMENTED "ACTIVATION NAMES">
+           <CHOP FUNCTN>>
+       <IF <EMPTY? .FUNCTN> <MESSAGE ERROR "NO ARGUMENT LIST">>
+       <BINDINGS <1 .FUNCTN>>
+       <IF <EMPTY? <CHOP FUNCTN>> <MESSAGE ERROR "EMPTY FUNCTION BODY">>
+       <REPEAT ()
+          <COMP <1 .FUNCTN>>      ;"Go do the real compilation for this object"
+          <CHOP FUNCTN>                              ;"Next object in the body"
+          <IF <EMPTY? .FUNCTN> <RETURN 0>>>
+       <FUNCTION:FINAL!-SETUP .PFLG>>
+
+<DEFINE PROG-REPEAT (OB "EXTRA" (NAME <1 .OB>) AGAIN:TAG EXIT:TAG)
+       <BLOCK:INITIAL!-SETUP>
+       <IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "EMPTY" .NAME>>
+       <IF <==? <TYPE <1 .OB>> ATOM>
+           <MESSAGE UNIMPLEMENTED "ACTIVATION TAGS">
+           <CHOP OB>>
+       <IF <EMPTY? .OB> <MESSAGE ERROR "NO VARIABLE LIST" .NAME>>
+       <BINDINGS <1 .OB> EXTRA>
+       <IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "NO BODY FOR" .NAME>>
+       <LABEL!-SETUP <SET AGAIN:TAG <TAGMAK!-SETUP "AGAIN">>>
+       <SET EXIT:TAG <TAGMAK!-SETUP "EXIT">>
+       <REPEAT ()
+          <IF <==? <TYPE <1 .OB>> ATOM> <LABEL!-SETUP <1 .OB>>>
+          <COMP <1 .OB>>
+          <IF <EMPTY? <CHOP OB>> <RETURN 0>>>
+       <IF <==? .NAME REPEAT> <BRANCH!-SETUP .AGAIN:TAG>>
+       <LABEL!-SETUP .EXIT:TAG>
+       <BLOCK:FINAL!-SETUP>>
+
+<DEFINE BOOL (PREDS TEST RESULT "EXTRA" (BOOL:TAG <TAGMAK!-SETUP "BOOL">))
+       <COND (<EMPTY? .PREDS> <COMP .RESULT>)
+             (ELSE
+              <REPEAT ()
+                 <SET RESULT <1 .PREDS>>
+                 <IF <EMPTY? <CHOP PREDS>> <RETURN BOOL>>
+                 <COMP .RESULT>
+                 <TEST .BOOL:TAG>>
+              <COMP .RESULT>
+              <LABEL!-SETUP .BOOL:TAG>)>>
+\f
+<DEFINE COMP (OBJECT)
+       <<OR <GET .OBJECT THIS:OBJECT>
+                             ;"Is there some function to compile this object ?"
+            <GET <TYPE .OBJECT> THIS:TYPE>
+                                      ;"Is there some function for this type ?"
+            ,REFERENCE!-SETUP>
+        .OBJECT>>
+
+<FINISHUP <PUT VECTOR THIS:TYPE ,COPY>
+        <PUT UVECTOR THIS:TYPE ,COPY>
+        <PUT LIST THIS:TYPE ,COPY>
+        <PUT SEGMENT THIS:TYPE <FUNCTION (OBJ) <MESSAGE UNIMPLEMENTED "SEGMENT" .OBJ>>>
+        <PUT '<> THIS:OBJECT <FUNCTION (OBJ) <REFERENCE!-SETUP #FALSE ()>>>
+        <PUT FORM
+             THIS:TYPE                          ;"FORMs are compiled specially"
+             <FUNCTION (OBJ)
+                     <PROG APPLICATION
+                           ((APPLY <1 .OBJ>))
+                           <<OR <GET .APPLY APPLY:OBJECT>
+                                              ;"Do we know how to apply this ?"
+                                <GET <TYPE .APPLY> APPLY:TYPE>
+                                                           ;"Apply this type ?"
+                                <GET <PRIMTYPE .APPLY> APPLY:PRIMTYPE>
+                                                             ;"This primtype ?"
+                                <FUNCTION (OB)
+                                        <REFERENCE!-SETUP .OBJECT>
+                                              ;"Otherwise go to eval with form"
+                                        <STACK:ARGUMENT!-SETUP>
+                                        <SUBR:CALL!-SETUP EVAL 1>>>
+                            .OBJ>>>>
+        <PUT ATOM
+             APPLY:TYPE           ;"Apply an ATOM as you would apply its value"
+             <FUNCTION (OB)
+                     <COND (<GASSIGNED? .APPLY>
+                                 ;"Try again with the global value if possible"
+                            <SET APPLY ,.APPLY>
+                            <AGAIN .APPLICATION>)
+                           (<AND <BOUND? .APPLY> <ASSIGNED? .APPLY>>
+                                                       ;"Else with local value"
+                            <MESSAGE NOTE "LOCAL VALUE USED FOR" .APPLY>
+                            <SET APPLY ..APPLY>
+                            <AGAIN .COMPILE-APPLY>)
+                           (ELSE
+                            <MESSAGE NOTE "NO VALUE FOR" .APPLY>
+                            <REFERENCE!-SETUP .OB>
+                                          ;"Otherwise go to EVAL with the form"
+                            <STACK:ARGUMENT!-SETUP>
+                            <SUBR:CALL!-SETUP EVAL 1>)>>>
+        <PUT SUBR
+             APPLY:TYPE
+             <FUNCTION (OB)
+                     <SUBR:CALL!-SETUP <1 .OB>
+                                       <REPEAT ((I 0))
+                                          <IF <EMPTY? <CHOP OB>> <RETURN .I>>
+                                          <COMP <1 .OB>>
+                                          <STACK:ARGUMENT!-SETUP>
+                                          <INC I>>>>>
+        <PUT RSUBR
+             APPLY:TYPE
+             <FUNCTION (OB)
+                     <COMP <1 .OB>>                 ;"Get atomic name of RSUBR"
+                     <STACK:ARGUMENT!-SETUP>
+                     <SUBR:CALL!-SETUP GVAL 1>
+                     <STACK:ARGUMENT!-SETUP>
+                     <SUBR:CALL!-SETUP APPLY
+                                       <REPEAT ((I 1))
+                                          <IF <EMPTY? <CHOP OB>> <RETURN .I>>
+                                          <COMP <1 .OB>>
+                                          <STACK:ARGUMENT!-SETUP>
+                                          <INC I>>>>>
+        <PUT FIX
+             APPLY:TYPE       ;"Integer as function is a selector of component"
+             <FUNCTION (OB)
+                     <IF <NOT <==? <LENGTH .OB> 2>>
+                         <MESSAGE ERROR "IMPROPER SELECTOR" .OB>>
+                     <COMP <2 .OB>>                        ;"Get the structure"
+                     <STACK:ARGUMENT!-SETUP>
+                     <COMP .APPLY>                         ;"Get the indicator"
+                     <STACK:ARGUMENT!-SETUP>
+                     <SUBR:CALL!-SETUP NTH 2>>>
+        <PUT ,PROG APPLY:OBJECT ,PROG-REPEAT>
+        <PUT ,REPEAT APPLY:OBJECT ,PROG-REPEAT>
+        <PUT ,RETURN
+             APPLY:OBJECT
+             <FUNCTION (OB)
+                     <IF-NOT <==? <LENGTH .OB> 2>
+                             <MESSAGE ERROR "WRONG NUMBER OF ARGUMENTS TO RETURN">>
+                     <COMP <2 .OB>>
+                     <BRANCH!-SETUP .EXIT:TAG>>>
+        <PUT ,AGAIN
+             APPLY:OBJECT
+             <FUNCTION (OB)
+                     <COND (<EMPTY? <CHOP OB>> <BRANCH!-SETUP .AGAIN:TAG>)
+                           (<==? <LENGTH .OB> 1>
+                            <COMP <1 .OB>>
+                            <STACK:ARGUMENT!-SETUP>
+                            <SUBR:CALL!-SETUP AGAIN 1>)
+                           (ELSE <MESSAGE ERROR "TOO MANY ARGUMENTS TO AGAIN">)>>>
+        <PUT ,GO
+             APPLY:OBJECT
+             <FUNCTION (OB)
+                     <IF <NOT <==? <LENGTH .OB> 2>>
+                         <MESSAGE ERROR "NO TAG IN GO">>
+                     <BRANCH!-SETUP <2 .OB>>>>
+        <PUT ,COND
+             APPLY:OBJECT
+             <FUNCTION (OB "EXTRA" (COND:TAG <TAGMAK!-SETUP "COND">))
+                     <IF <EMPTY? <CHOP OB>> <MESSAGE ERROR "EMPTY COND">>
+                     <REPEAT (PHRASE PHRASE:TAG)
+                        <SET PHRASE:TAG <TAGMAK!-SETUP "PHRASE">>
+                        <IF <EMPTY? <SET PHRASE <1 .OB>>>
+                            <MESSAGE ERROR "MISSING PREDICATE IN COND">>
+                        <COMP <1 .PHRASE>>
+                        <TEST:FALSE!-SETUP .PHRASE:TAG>
+                        <REPEAT ()
+                           <IF <EMPTY? <CHOP PHRASE>> <RETURN 0>>
+                           <COMP <1 .PHRASE>>>
+                        <BRANCH!-SETUP .COND:TAG>
+                        <LABEL!-SETUP .PHRASE:TAG>
+                        <IF <EMPTY? <CHOP OB>> <RETURN 0>>>
+                     <LABEL!-SETUP .COND:TAG>>>
+        <PUT ,OR
+             APPLY:OBJECT
+             <FUNCTION (OB) <BOOL <REST .OB> ,TEST:TRUE!-SETUP T>>>
+        <PUT ,AND
+             APPLY:OBJECT
+             <FUNCTION (OB) <BOOL <REST .OB> ,TEST:FALSE!-SETUP #FALSE ()>>>>
+
+<END>
+
+<END>
+\f\f\ 3\f\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f\ 3\ 3\ 3\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/comp.envr b/MUDDLE/comp.envr
new file mode 100644 (file)
index 0000000..01ade44
Binary files /dev/null and b/MUDDLE/comp.envr differ
diff --git a/MUDDLE/create.14 b/MUDDLE/create.14
new file mode 100644 (file)
index 0000000..b16a28b
--- /dev/null
@@ -0,0 +1,109 @@
+
+TITLE PROCESS-HACKER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC
+
+MFUNCTION CREATE,SUBR
+
+       ENTRY 1
+       GETYP   A,(AB)          ;GET TYPE OF ARG
+                               ;MUST BE SOME APPLIABLE TYPE
+       CAIE    A,TSUBR         ;SUBR?
+       CAIN    A,TEXPR         ;EXPR?
+       JRST    OKFUN
+       CAIE    A,TFSUBR                ;FSUBR?
+       CAIN    A,TFUNARG               ;FUNARG?
+       JRST    OKFUN
+       CAIE    A,TFIX          ;CALL TO GET? (ALLOWING THIS IS QUESTIONABLE)
+       JRST    NAPT            ;NO, ERROR - NON-APPLIABLE TYPE
+OKFUN:
+
+       PUSHJ   P,ICR   ;CREATE A NEW PROCESS
+       MOVE    C,TPSTO+1(B)    ;GET ITS SRTACK
+       PUSH    C,[TENTRY,,RETPROC]
+       PUSH    C,[1,,0]        ;TIME
+       PUSH    C,[0]
+       PUSH    C,SPSTO+1(B)
+       PUSH    C,PSTO+1(B)
+       MOVE    D,C
+       ADD     D,[3,,3]
+       PUSH    C,D     ;SAVED STACK POINTER
+       PUSH    C,PPSTO+1(B)    ;
+       PUSH    C,[RETPROC]
+       MOVEM   C,TPSTO+1(B)    ;STORE NEW TP
+       HRRI    D,1(C)  ;MAKE A TB
+       HRLI    D,2     ;WITH A TIME
+       MOVEM   D,TBINIT+1(B)
+       MOVEM   D,TBSTO+1(B)    ;SAVE ALSO FOR SIMULATED START
+       MOVE    C,(AB)  ;STORE ARG
+       MOVEM   C,RESFUN(B)     ;INTO PV
+       MOVE    C,1(AB)
+       MOVEM   C,RESFUN+1(B)
+       JRST FINIS
+
+MFUNCTION      RETPROC,SUBR
+; WHO KNOWS WHAT THIS SHOULD REALLY DO
+;PROBABLY, JUST AN EXIT
+;FOR NOW, PRINT OUT AN ERROR MESSAGE
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS
+       JRST    CALER1\r
+
+
+
+
+
+
+MFUNCTION RESUME,FSUBR
+;RESUME IS CALLED WITH TWO ARGS
+;THE FIRST IS A PROCESS FORM OF THE PROCESS TO BE RESUMED
+;THE SECOND IS A FUNCTION TO BE CALLED WHEN THIS PROCESS
+;    (THE PARENT) IS ITSELF RESUMED
+;IF THE FUNCTION IS NOT GIVEN SOME STANDARD FUNCTION IS
+;PLUGGED IN
+;
+; NOTE - TYPE AND NUMBER OF ARGS CHECKS MUST BE ADDED TO BOTH RESUME AND CREATE
+
+       ENTRY   1
+       HRRZ    C,@1(AB)                ;GET CDR ADDRESS
+       JUMPE   C,NOFUN         ;IF NO SECOND ARG, SUPPLY STANDARD
+       HLLZ    A,(C)           ;GET CDR TYPE
+       CAME    A,$TATOM                ;ATOMIC?
+       JRST    RES2            ;NO, MUST EVAL TO GET FUNCTION
+       MOVE    B,1(C)          ;YES
+       PUSHJ   P,IGVAL         ;TRY TO GET GLOBAL VALUE
+       CAMN    A,$TUNBOUND     ;GLOBALLY UNBOUND?
+       JRST    LFUN            ;YES, TRY FOR LOCAL VALUE
+RES1:  MOVEM   A,RESFUN(PVP)   ;STORE IN THIS PROCESS
+       MOVEM   B,RESFUN+1(PVP)
+
+       HRRZ    C,1(AB)         ;GET CAR ADDRESS
+       PUSH    TP,(C)          ;PUSH PROCESS FORM
+       PUSH    TP,1(C)
+       JSP     E,CHKARG        ;CHECK FOR DEFERED TYPE
+                               ;INSERT CHECKS FOR PROCESS FORM
+       MCALL   1,EVAL          ;EVAL PROCESS FORM WHICH WILL SWITCH
+                               ; PROCESSES
+       JRST    FINIS
+
+RES2:  PUSH    TP,(C)          ;PUSH FUNCTION ARG
+       PUSH    TP,1(C)
+       JSP     E,CHKARG        ;CHECK FOR DEFERED
+       MCALL   1,EVAL          ;EVAL TO GET FUNCTION
+       JRST    RES1
+
+LFUN:  HRRZ    C,1(AB)         ;GET CDR ADDRESS
+       PUSH    TP,(C)
+       PUSH    TP,1(C)
+       MCALL   1,VALUE ;GET LOCAL VALUE OF ATOM FOR FUNCTION
+       JRST    RES1
+
+NOFUN: MOVSI   A,TUNBOUND      ;MAKE RESUME FUNCTION UNBOUND
+       JRST    RES1
+       
+END
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/editor.8 b/MUDDLE/editor.8
new file mode 100644 (file)
index 0000000..d38f0cb
--- /dev/null
@@ -0,0 +1,140 @@
+"MUDDLE EDITOR, PRETTY-PRINT, AND OTHER ASSORTED ROUTINES"
+
+%%<BLOCK (<ROOT>)>
+FRAMES
+LINPOS
+LINLNT
+PAGPOS
+PAGLNT
+LPT
+TPL
+1+
+1-
+INC
+DEC
+CHOP
+DEFINE
+PPRINT
+EPPRINT
+EDITOR
+%%<ENDBLOCK>
+\f"PAGE 2"
+%%<BLOCK <SETG EDITOR (<MOBLIST 7> <ROOT>)>>
+
+<SETG DEFINE <FUNCTION (NAME "ARGS" BODY "NAME" REDEF)
+       <COND (<GASSIGNED? .NAME><COND (<LISTEN
+                       DO-YOU-REALLY-WANT-TO-REDEFINE .NAME
+                       IF-SO-ERRET-TRUE-OTHERWISE-FALSE>)
+                       (ELSE <EXIT .REDEF>)>)>
+       <SETG .NAME <CHTYPE .BODY FUNCTION>>
+       .NAME >>
+
+<SETG FRAMES   <FUNCTION (I)
+       <REPEAT ((FRM <FRAME>)(SMALL 1))
+       <COND (<L? .I .SMALL >  <RETURN FUNCT---ARGS>)>
+       <SET FRM <FRAME .FRM>>
+       <PRINT .SMALL >
+       <PRINC <FUNCT .FRM>>
+       <PRINC "        ">
+       <PRINC <ARGS .FRM>>
+       <SET SMALL <+ .SMALL 1>>
+       >>>
+
+<SETG LINPOS 14>
+<SETG LINLNT 13>
+<SETG PAGPOS 16>
+<SETG PAGLNT 15>
+
+<SETG 1+ <FUNCTION (NUMBER)  <+ .NUMBER 1>>>
+<SETG 1- <FUNCTION (NUMBER)  <- .NUMBER 1>>>
+
+<SETG INC <FUNCTION (ATOM "OPTIONAL" (VAL 1))
+       <SET .ATOM <+ ..ATOM .VAL>>>>
+
+<SETG DEC <FUNCTION (ATOM "OPTIONAL" (VAL 1))
+       <SET .ATOM <- ..ATOM .VAL>>>>
+
+<SETG CHOP <FUNCTION (ATOM "OPTIONAL" (VAL 1))
+       <SET .ATOM <REST ..ATOM .VAL>>>>
+
+
+<SETG TPL <FUNCTION ()
+       <OPEN "PRINT" "" "" "TPL">>>
+
+<SETG LPT <FUNCTION ("OPTIONAL" (DEFAULT TRUE))
+       <COND (<OPEN "PRINT" "" "" "LPT">)
+               (.DEFAULT <TPL>)>>>
+\f"PAGE 3"
+<SET TABS ["" "        " "             " "                     "
+"                              " "                                     "
+"                                              "
+"                                                      "
+"                                                              "]>
+
+
+
+
+<SET SPACES ["" " " "  " "   " "    " "     " "      " "       "]>
+
+
+<SETG INDENT-TO <FUNCTION ( N "AUX" (NOW <LINPOS .OUTCHAN>))
+       <COND (<G? .N .NOW>
+               <PRINC <<- </ .N 8> </ .NOW 8 > -1> .TABS>>
+               <PRINC <<- .N <* </ .N 8> 8> -1> .SPACES>>)>>>
+
+<SETG COMPONENTS <FUNCTION (L M)
+       <REPEAT ((N <LINPOS .OUTCHAN>))
+               <FORMS <1 .L>>
+               <COND (<EMPTY? <SET L <REST .L>>><RETURN DONE>)>
+               <TERPRI>
+               <INDENT-TO .N>>>>
+
+
+\f"PAGE 4"
+<SETG FORMS <FUNCTION (L)
+       <COND (<FLATSIZE .L <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>>
+               <PRIN1 .L>)
+
+
+
+             (<==? <TYPE .L> FORM> <PRINC "<">
+               <PRIN1 <1 .L>>
+               <PRINC " ">
+               <FORM1 <REST .L> <+ .M 1>>
+               <PRINC ">">)
+             (<==? <TYPE .L> LIST><PRINC "(">
+               <FORM1 .L <+ .M 1>>
+               <PRINC ")">)
+             (<==? <TYPE .L> VECTOR><PRINC "["> 
+               <FORM1 .L <+ .M 1>>
+               <PRINC "]"> )
+             (<==? <TYPE .L> FUNCTION>
+               <PRINC "<FUNCTION " >
+               <FORM1 .L <+ .M 1>>
+               <PRINC ">" >)
+             (<MONAD? .L> <PRIN1 .L>)
+             (ELSE <PRINC "#">
+               <PRIN1 <TYPE .L>>
+               <PRINC " (">
+               <FORM1 .L <+ .M 1>>
+               <PRINC ")"> )>
+>>
+\f"PAGE 5"
+
+<SETG PPRINT <FUNCTION  (L "OPTIONAL" (OUTCHAN .OUTCHAN))
+       <COND (<GASSIGNED? .L>
+              <EPPRINT <CHTYPE (SETG .L ,.L) FORM>>)
+             (<ASSIGNED? .L>
+              <EPPRINT <CHTYPE (SET .L ..L) FORM>>)
+             (ELSE UNASSIGNED)>>>
+
+
+<SETG EPPRINT <FUNCTION ( L "AUX" (M 1))
+       <TERPRI>
+       <FORMS .L>
+       <TERPRI>
+       DONE>>
+
+%%<ENDBLOCK>
+
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/eval.234 b/MUDDLE/eval.234
new file mode 100644 (file)
index 0000000..ede3105
--- /dev/null
@@ -0,0 +1,2054 @@
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971
+
+.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME
+.GLOBAL IGVAL,CHKARG,SWAP,NXTDCL,TPOVFL,CHFRM
+.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS
+
+.INSRT MUDDLE >
+
+       MFUNCTION       EVAL,SUBR
+       INTGO
+       HLRZ    A,AB            ;GET NUMBER OF ARGS
+       CAIE    A,-2            ;EXACTLY 1?
+       JRST    AEVAL           ;EVAL WITH AN ALIST
+       HLRZ    A,(AB)          ;GET TYPE OF ARG
+       CAILE   A,NUMPRI        ;PRIMITIVE?
+       JRST    NONEVT          ;NO
+       JRST    @EVTYPT(A)      ;YES-DISPATCH
+
+SELF:  MOVE    A,(AB)          ;TYPES WHICH EVALUATE 
+       MOVE    B,1(AB)
+       JRST    FINIS           ;TO SELF-EG NUMBERS
+
+;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
+
+MFUNCTION VALUE,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IDVAL
+       JRST    FINIS
+
+IDVAL: PUSH    TP,A
+       PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE    PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER
+       CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED
+       JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN
+       JUMPN   B,UNAS          ;IF UNASSIGNED - ERROR
+       POP     TP,B            ;GET ARG BACK
+       POP     TP,A
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    UNBOU
+       POPJ    P,
+RIDVAL:        SUB     TP,[2,,2]
+       POPJ    P,
+
+
+;GETS THE LOCAL VALUE OF AN IDENTIFIER
+
+MFUNCTION LVAL,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAME    A,$TUNBOUND
+       JRST    FINIS
+       JUMPN   B,UNAS
+       JRST    UNBOU
+
+\f
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
+
+MFUNCTION LLOC,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,ILOC
+       CAMN    A,$TUNBOUND
+       JRST    UNBOU
+       MOVSI   A,TLOCD
+       HRR     A,2(B)
+       JRST    FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
+
+MFUNCTION BOUND,SUBR,[BOUND?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAMN    A,$TUNBOUND
+       JUMPE   B,IFALSE
+       JRST    TRUTH
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
+
+MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAME    A,$TUNBOUND
+       JRST    TRUTH
+       JUMPE   B,UNBOU
+       JRST    IFALSE
+
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GVAL,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    UNAS
+       JRST    FINIS
+
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GLOC,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IGLOC
+       CAMN    A,$TUNBOUND
+       JRST    UNAS
+       MOVSI   A,TLOCD
+       JRST    FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
+
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    IFALSE
+       JRST    TRUTH
+
+\f
+
+CHKAT: ENTRY   1
+       HLLZ    A,(AB)
+       CAME    A,$TATOM
+       JRST    NONATM
+       MOVE    B,1(AB)
+       JRST    2,(E)
+
+;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
+
+EVFORM:        SKIPN   C,1(AB)         ;EMPTY?
+       JRST    IFALSE
+       HLLZ    A,(C)           ;GET CAR TYPE
+       CAME    A, $TATOM       ;ATOMIC?
+       JRST    EV0             ;NO -- CALCULATE IT
+       MOVE    B,1(C)          ;GET PTR TO ATOM
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    LFUN
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    IAPPLY          ;APPLY IT
+EV0:   PUSH    TP,A            ;SET UP CAR OF FORM AND
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;EVALUATE IT
+       PUSH    TP,A            ;APPLY THE RESULT
+       PUSH    TP,B            ;AS A FUNCTION
+       JRST    IAPPLY
+
+LFUN:  MOVE    B,1(AB)
+       PUSH    TP,$TATOM
+       PUSH    TP,1(B)
+       MCALL   1,VALUE
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    IAPPLY
+
+;DISPATCH TABLE FOR EVAL
+DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
+
+\f
+
+;WATCH FOR SUBTLE BUG 43 LERR,LPROG OR PROCID
+AEVAL:
+       CAIE    A,-4            ;EXACTLY 2 ARGS?
+       JRST    WNA             ;NO-ERROR
+       HLRZ    A,2(AB)         ;CHECK THAT WE HAVE A FRAME
+       CAIN    A,TFRAME
+       JRST    .+3
+       CAIE    A,TENV
+       JRST    WTYP
+       MOVE    A,3(AB)
+       HRRZ    D,2(AB)         ;GET POINTER TO PV DOPE WORD
+       PUSHJ   P,SWAPQ         ;SEE IF SWAP NECESSARY
+       PUSH    TP,(D)
+       PUSH    TP,1(D)
+       MCALL   1,EVAL          ;NOW DO NORMAL EVALUATION
+UNSWPQ:        MOVE    D,1(TB)         ;GET SAVED PVP
+       CAMN    D,PVP           ;CHANGED?
+       JRST    FINIS           ;NO - RETURNî   PUSHJ   P,SPECSTORE     ;CLEAN UP
+       MOVE    D,1(TB)
+       JSP     C,SWAP
+       JRST    FINIS
+
+
+; ROUTINE TO CHANGE PROCID AND POSSIBLY SWAP
+
+SWAPQ: HLRZ    C,(D)           ;GET LENGTH
+       SUBI    D,-1(C)         ;POINT TO START OF PV
+       MOVNS   C               ;NEGATE LENGTH
+       HRLI    D,2(C)          ;MAKE AOBJN POINTER
+       MOVE    E,PVP           ;COPY CURRENT PROCESS VECTOR
+       POP     P,B             ;GET RET ADR SO POPJ WINS IF SWAP OCCURS
+       CAME    D,PVP           ;IS THIS IT?
+       JSP     C,SWAP          ;NO, SWAP IN NEW PROCESS
+       PUSH    P,B             ;NOW, PUT IT BACK
+       PUSH    TP,$TPVP        ;SAVE PROCESS
+       PUSH    TP,E
+       HLL     B,OTBSAV(A)     ;GET TIME FROM FRAME POINTED AT
+       HRR     B,A
+       HRRZ    C,A
+       CAIG    C,1(TP)
+       CAME    B,A             ;CHECK THAT THE FRAME IS LEGIT
+       JRST    ILLFRA
+       HLRZ    C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       CAMN    SP,SPSAV(A)
+       JRST    AEV1
+       MOVE    SP,SPSAV(A)     ;LOAD UP OLD ENVIRONMENT
+       MOVE    A,PVP
+       ADD     A,[PROCID,,PROCID]      ;GET LOCATIVE TO PROCESS ID
+       PUSH    TP,BNDV         ;BIND IT TO
+       PUSH    TP,A
+       AOSN    A,PTIME         ;A UNIQUE NUMBER
+       .VALUE  [ASCIZ /TIMEOUT/]
+       PUSH    TP,$TFIX
+       PUSH    TP,A
+       PUSHJ   P,SPECBIND
+AEV1:  MOVE    E,1(TB)         ;GET SAVED PROCESS
+       MOVE    D,AB            ;COPY CURRENT ARG POINTER
+       CAME    E,PVP           ;HAS PROCESS CHANGED?
+       MOVE    D,ABSTO+1(E)    ;GET SAV AB
+       POPJ    P,              ;RETURN TO CALLER
+
+\f
+; STACKFRAME FUNCTION (MUDDLE'S ANSWER TO APPLY)
+
+       MQUOTE STACKFORM
+
+STFRM2:        JRST    NOENV           ;FAKE OUT ENTRY
+
+MFUNCTION STACKFORM,FSUBR
+
+       ENTRY   1
+
+       GETYP   A,(AB)          ;CHECK IT IS A LIST
+       CAIE    A,TLIST
+       JRST    WTYP            ;NO, LOSE
+
+       MOVEI   A,3             ;CHECK ARG HAS AT LEAST 3 ELEMENTS
+       HRRZ    B,1(AB) ;GET ARG
+       JUMPE   B,TFA
+       HRRZ    B,(B)           ;CDR IT
+       SOJN    A,.-2           ;AND COUNT
+
+       JUMPE   B,NOENV         ;ENVIRONMENT NOT SUPPLIED
+       HRRZ    A,(B)           ;CHECK NOT TOO MANY
+       JUMPN   A,TMA
+
+       GETYP   A,(B)           ;GET TYPE OF LAST ARG
+       MOVSI   A,(A)           ;TYPE TO LH
+       PUSH    TP,A
+       PUSH    TP,1(B)         ;PUSH THE ARG
+       JSP     E,CHKARG                ;CHECK FOR DEFERRED
+       MCALL   1,EVAL
+       HLRZ    C,A             ;ISOLATE TYPE IN C
+       CAIE    C,TENV          ;ENVIRONEMNT?
+       CAIN    C,TFRAME        ;OR FRAME?
+       JRST    .+2
+       JRST    WTYP
+
+
+       MOVEI   D,(A)           ;IN B AND D
+       MOVE    A,B             ;AND TIME,,FRAME
+       PUSHJ   P,SWAPQ         ;AND CHECK FOR CHANGE
+       PUSH    TP,$TLIST       ;SAVE THE ARG
+       PUSH    TP,1(D)         ;ON TP
+       .MCALL  1,STFRM2        ;NOW CALL NON-ENV STACKFORM
+       JRST    UNSWPQ          ;AND POSSIBLY UNSWAP
+
+NOENV: HRRZ    D,1(AB)         ;GET POINTER TO FIRST
+       GETYP   A,(D)           ;GET TYPE
+       MOVSI   A,(A)
+       PUSH    TP,A
+       PUSH    TP,1(D)         ;PUSH THE ARG, (IT SHOULD BE A FUNCTION)
+       JSP     E,CHKARG        ;CHECK OUT DEFERRED
+       MCALL   1,EVAL          ;EVAL IT
+       HRRZ    C,1(AB)         ;RESTORE ARG
+       HRRZ    D,(C)           ;POINT TO LIST OF FORMS
+       PUSH    TP,A            ;SAVE FUNCTION
+       PUSH    TP,B
+       HLRZS   A               ;NOW DISPATCH ON TYPE
+       CAIN    A,TSUBR;SUBR?
+       JRST    STSUBR          ;YES, HACK IT
+       CAIN    A,TEXPR         ;FUNCTION?
+       JRST    STEXPR          ;YES DO IT
+       CAIN    A,TFUNARG               ;FUNARG
+       JRST    NOTIMP
+       JRST    NAPT
+
+\f
+; STACK FORM OF A SUBR
+
+STSUBR:        PUSH    P,[0]           ;PUSH ARG COUNTER
+
+STLOO: PUSHJ   P,EVALRG                ;EVAL THE ARGUMENT
+       JRST    MAKPTR          ;DONE, FALL INTO EVAL CODE
+       AOS     (P)             ;COUNT
+       PUSH    TP,A
+       PUSH    TP,B            ;SAVE THE ARGS
+       JRST    STLOO
+
+; STACK FRAME OF EXPR
+
+STEXPR:        MOVE    C,(TP)          ;GET FUNCTION
+       PUSHJ   P,BINDRS                ;BIND THE ARGS
+       JRST    APEXP1          ;JOIN COMMON CODE
+
+\f
+
+IAPPLY:
+       HLRZ    A,(TB)          ;GET TYPE OF FUNCTION
+       CAIN    A,TSUBR         ;SUBR?
+       JRST    APSUBR          ;YES
+       CAIN    A,TFSUBR        ;NO -- FSUBR?
+       JRST    APFSUBR         ;YES
+       CAIN    A,TEXPR         ;NO -- EXPR?
+       JRST    APEXPR          ;YES
+       CAIN    A,TFIX          ;NO -- CALL TO NTH?
+       JRST    APNUM           ;YES
+       CAIN    A,TFUNARG       ;NO -- FUNARG?
+       JRST    APFUNARG        ;YES
+       CAIN    A,TPVP          ;NO -- PROCESS TO BE RESUMED?
+       JRST    RESOMER         ;YES
+       JRST    NAPT            ;NONE OF THE ABOVE
+
+
+;APFSUBR CALLS FSUBRS
+
+APFSUBR:
+       PUSH    TP,$TLIST       ;GET THE
+       HRRZ    A,@1(AB)
+       PUSH    TP,A            ;ARGUMENT LIST
+       MCALL   1,@1(TB)
+       JRST    FINIS
+
+;APSUBR CALLS SUBRS
+
+APSUBR:        
+       HRRZ    A,@1(AB)        ;GET CDR OF FORM -- ARGLIST
+       PUSH    TP,$TLIST       ;SAVE THE ARGLIST ON
+       PUSH    TP,A            ;THE TP
+       PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
+TUPLUP:
+       SKIPN   A,3(TB)         ;IS IT NIL?
+       JRST    MAKPTR          ;YES -- DONE
+       PUSH    TP,(A)          ;NO -- GET CAR OF THE
+       HLLZS   (TP)            ;ARGLIST
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;AND EVAL IT.
+       PUSH    TP,A            ;SAVE THE RESULT IN
+       PUSH    TP,B            ;THE GROWING TUPLE
+       AOS     (P)             ;BUMP THE ARGCNT
+       HRRZ    A,@3(TB)        ;SET THE ARGLIST TO 
+       MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
+       JRST    TUPLUP
+MAKPTR:
+       POP     P,A     
+       ACALL   A,@1(TB)
+       JRST    FINIS
+
+\f
+
+;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+APNUM:
+       HRRZ    A,@1(AB)        ;GET ARGLIST
+       JUMPE   A,ERRTFA        ;NO ARGUMENT
+       PUSH    TP,(A)          ;GET CAR OF ARGL
+       HLLZS   (TP)    
+       PUSH    TP,1(A)
+       HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
+       JUMPN   A,ERRTMA
+       JSP     E,CHKARG        ;HACK DEFERRED
+       MCALL   1,EVAL
+       PUSH    TP,A
+       PUSH    TP,B
+       PUSH    TP,(TB)
+       PUSH    TP,1(TB)
+       MCALL   2,NTH
+       JRST    FINIS
+
+;APEXPR APPLIES EXPRS
+;EXPRESSION IS IN 0(AB),  FUNCTION IS IN 0(TB)
+
+APEXPR:
+
+       SKIPN   C,1(TB)         ;BODY?
+       JRST    NOBODY          ;NO, ERROR
+       HRRZ    0,1(AB)         ;GET EXPRESSION INTO 0
+       HRRZ    D,@0            ;AND ARGLIST INTO D
+       HLL     0,(AB)          ;TYPE TO LH OF 0
+
+       PUSHJ   P,BINDER        ;DO THE BINDINGS
+
+APEXP1:        HRRZ    C,@1(TB)        ;GET BODY BACK
+       JUMPE   A,DOPROG        ;NOW GO RUN IF NO ACTIVIATION
+       PUSH    TP,$TLIST       ;SAVE ANOTHER COPY FOR REACT
+       PUSH    TP,C
+       SKIPL   A               ;SKIP IF NOT NAME ALA HEWITT
+       HRRZ    C,(C)           ;ELSE CDR AGAIN
+       JRST    DOPROG
+
+\f
+
+RESOMER:
+; 0,1(TB) IS PROCESS VECTOR POINTER TO PROCESS TO BE RESUMED
+; 0,1(AB) IS A FORM CONTAINING ARGS TO SAVED FUNTION
+
+       MOVE    D,1(TB)         ;GET PVP OF PROCESS TO BE RESUMED
+       GETYP   A,RESFUN(D)     ; GET TYPE OF FUNCTION
+
+       CAIN    A,TSUBR         ;SUBR?
+       JRST    RESSUBR         ;YES
+       CAIN    A,TFSUBR        ;NO -- FSUBR?
+       JRST    RESFSUBR                ;YES
+       CAIN    A,TEXPR         ;NO -- EXPR?
+       JRST    RESEXPR         ;YES
+       CAIN    A,TFIX          ;NO -- CALL TO NTH?
+       JRST    RESNUM          ;YES
+       CAIN    A,TFUNARG       ;NO -- FUNARG?
+       JRST    NOTIMP  ;YES
+       JRST    NAPT            ;NONE OF THE ABOVE
+
+
+;RESFSUBR RESUMES FSUBRS
+
+RESFSUBR:
+       HRRZ    A,@1(AB)        ;GET THE ARG LIST
+       SUB     TP,[2,,2]       ;CLEAN UP
+       JSP     C,SWAP          ;SWAP IN NEW PROCESS
+       PUSH    TP,$TLIST
+       PUSH    TP,A            ; PUSH THE ARG LIST
+       MCALL   1,@RESFUN+1(PVP) ; RESUME WITH THE SAVED FUNCTION
+       JRST    FINIS
+
+;RESSUBR RESUMES SUBRS
+
+RESSUBR:       
+       HRRZ    A,@1(AB)        ;GET CDR OF FORM -- ARGLIST
+       PUSH    TP,$TLIST       ;SAVE THE ARGLIST ON
+       PUSH    TP,A            ;THE TP
+       PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
+RESTUPLUP:
+       SKIPN   A,3(TB)         ;IS IT NIL?
+       JRST    RESMAKPTR               ;YES -- DONE
+       PUSH    TP,(A)          ;NO -- GET CAR OF THE
+       HLLZS   (TP)            ;ARGLIST
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;AND EVAL IT.
+       MOVE    D,1(TB) ;GET PVP OF P.T.B.R.
+       MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
+       PUSH    C,A             ;SAVE THE RESULT IN THE GROWING
+       PUSH    C,B             ;TUPLE OF ARGS IN P.T.B.R.
+       MOVEM   C,TPSTO+1(D)    ;UPDATE TP OF P.T.B.R.
+       AOS     (P)             ;BUMP THE ARGCNT
+       HRRZ    A,@3(TB)        ;SET THE ARGLIST TO 
+       MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
+       JRST    RESTUPLUP
+RESMAKPTR:
+       POP     P,A             ;GET NUMBER OF ARGS IN A        
+       MOVE    D,1(TB)         ;GET PVP OF P.T.B.R.
+       SUB     TP,[4,,4]       ;GET RID OF GARBAGE
+       JSP     C,SWAP          ;SWAP IN THE NEW PROCESS
+       ACALL   A,RESFUN+1(PVP) ;CALL THE SAVED FUNCTION
+       JRST    FINIS
+
+
+
+;RESNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+RESNUM:
+       HRRZ    A,@1(AB)        ;GET ARGLIST
+       JUMPE   A,ERRTFA        ;NO ARGUMENT
+       PUSH    TP,(A)          ;GET CAR OF ARGL
+       HLLZS   (TP)    
+       PUSH    TP,1(A)
+       HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
+       JUMPN   A,ERRTMA
+       JSP     E,CHKARG        ;HACK DEFERRED
+       MCALL   1,EVAL
+       MOVE    D,1(TB)         ;GET PVP OF P.T.B.R.
+       MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
+       PUSH    C,A             ;PUSH ARG
+       PUSH    C,B
+       SUB     TP,[2,,2]       ;CLEAN UP BEFORE LEAVING
+       JSP     C,SWAP          ;BRING IN NEW PROCESS
+       PUSH    TP,RESFUN(PVP)  ;PUSH NUMBER
+       PUSH    TP,RESFUN+1(PVP)
+       MCALL   2,NTH
+       JRST    FINIS
+
+;RESEXPR RESUMES EXPRS
+;EXPRESSION IS IN 0(AB),  FUNCTION IS IN RESFUN(PVP)
+RESEXPR:
+       SKIPN   C,RESFUN+1(D);BODY?
+       JRST    NOBODY          ;NO, ERROR
+
+       MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
+       PUSH    C,BNDA          ;SPECIAL ATOM CROCK
+       PUSH    C,MQUOTE [PPROC ]INTERR ;PPROC=PARENT PROCESS
+       MOVE    B,OTBSAV(TB)
+       PUSHJ   P,MAKENV        ;MAKE ENVIRONMENT FOR THIS PROCESS
+       PUSH    C,A
+       PUSH    C,B
+       MOVEM   C,TPSTO+1(D)    ;UPDATE TP OF P.T.B.R.
+       HRRZ    0,1(AB)         ;GET EXPRESSION INTO 0
+       HRRZ    A,@0            ;AND ARGLIST INTO A
+       HLL     0,(AB)          ;TYPE TO LH OF  0
+       SUB     TP,[2,,2]       ;CLEAN UP BEFORE LEAVING
+       JSP     C,SWAP          ;SWAP IN NEW PROCESS
+       PUSH    P,0             ;SAVE 0
+       PUSH    P,A             ;SAVE A=ARGLIST
+       PUSH    TP,[0]
+       PUSH    TP,[0]          ;COMPLETE ARGS FOR PPROC BINDING
+       PUSHJ   P,SPECBIND      ;BIND THE PARENT PROCESS
+       POP     P,D             ;POP ARGLIST INTO D
+       POP     P,0             ;POP CALL HACK INTO 0
+       MOVE    C,RESFUN+1(PVP) ;GET FUNCTION
+       PUSHJ   P,BINDRR        ;CALL BINDER FOR RESUMED EXPR HACKING
+
+       HRRZ    C,@RESFUN+1(PVP) ;GET BODY BACK
+       JUMPE   A,DOPROG        ;NOW GO RUN IF NO ACTIVIATION
+       PUSH    TP,$TLIST       ;SAVE ANOTHER COPY FOR REACT
+       PUSH    TP,C
+       SKIPL   A               ;SKIP IF NOT NAME ALA HEWITT
+       HRRZ    C,(C)           ;ELSE CDR AGAIN
+       JRST    DOPROG
+
+\f
+; EVALUATE LISTS, VECTORS, UNIFROM VECTORS
+
+EVLIST:        PUSH    P,[-1]          ;-1 -- THIS IS A LIST
+       JRST    EVL1            ;GO TO HACKER
+
+EVECT: PUSH    P,[0]           ;0 -- THIS IS A GENERAL VECTOR
+       JRST    EVL1
+
+EUVEC: PUSH    P,[1]           ;1 -- THIS IS A UNIFORM VECTOR
+
+EVL1:  PUSH    P,[0]           ;PUSH A COUNTER
+       GETYPF  A,(AB)          ;GET FULL TYPE
+       PUSH    TP,A
+       PUSH    TP,1(AB)        ;AND VALUE
+
+EVL2:  INTGO                   ;CHECK INTERRUPTS
+       SKIPN   A,1(TB)         ;ANYMORE
+       JRST    EVL3            ;NO, QUIT
+       SKIPL   -1(P)           ;SKIP IF LIST
+       JUMPG   A,EVL3          ;JUMP IF VECTOR EMPTY
+       GETYPF  B,(A)           ;GET FULL TYPE
+       SKIPGE  C,-1(P)         ;SKIP IF NOT LIST
+       HLLZS   B               ;CLOBBER CDR FIELD
+       JUMPG   C,EVL7          ;HACK UNIFORM VECS
+EVL8:  PUSH    P,B             ;SAVE TYPE WORD ON P
+       CAMN    B,$TSEG         ;SEGMENT?
+       MOVSI   B,TFORM         ;FAKE OUT EVAL
+       PUSH    TP,B            ;PUSH TYPE
+       PUSH    TP,1(A)         ;AND VALUE
+       MCALL   1,EVAL          ;AND EVAL IT
+       POP     P,C             ;AND RESTORE REAL TYPE
+       CAMN    C,$TSEG         ;SEGMENT?
+       JRST    DOSEG           ;YES, HACK IT
+       AOS     (P)             ;COUNT ELEMENT
+       PUSH    TP,A            ;AND PUSH IT
+       PUSH    TP,B
+EVL6:  SKIPGE  A,-1(P) ;DONT SKIP IF LIST
+       HRRZ    B,@1(TB)        ;CDR IT
+       JUMPL   A,ASTOTB        ;AND STORE IT
+       MOVE    B,1(TB)         ;GET VECTOR POINTER
+       ADD     B,AMNT(A)       ;INCR BY APPROPRIATE AMOUNT
+ASTOTB:        MOVEM   B,1(TB)         ;AND STORE BACK
+       JRST    EVL2            ;AND LOOP BACK
+
+AMNT:  2,,2                    ;INCR FOR GENERAL VECTOR
+       1,,1                    ;SAME FOR UNIFORM VECTOR
+
+CHKARG:        GETYP   A,-1(TP)
+       CAIE    A,TDEFER
+       JRST    (E)
+       HRRZS   (TP)            ;MAKE SURE INDIRECT WINS
+       MOVE    A,@(TP)
+       MOVEM   A,-1(TP)                ;CLOBBER IN TYPE SLOT
+       MOVE    A,(TP)          ;NOW GET POINTER
+       MOVE    A,1(A)          ;GET VALUE
+       MOVEM   A,(TP)          ;CLOBBER IN
+       JRST    (E)
+
+\f
+
+EVL7:  HLRE    C,A             ;FIND TYPE OF UVECTOR
+       SUBM    A,C             ;C POINTS TO DOPE WORD
+       GETYP   B,(C)           ;GET TYPE
+       MOVSI   B,(B)           ;TO LH NOW
+       SOJA    A,EVL8          ;AND RETURN TO DO EVAL
+
+EVL3:  SKIPL   -1(P)           ;SKIP IF LIST
+       JRST    EVL4            ;EITHER VECTOR OR UVECTOR
+
+       MOVEI   B,0             ;GET A NIL
+EVL9:  MOVSI   A,TLIST         ;MAKE TYPE WIN
+EVL5:  SOSGE   (P)             ;COUNT DOWN
+       JRST    FINIS           ;DONE, RETURN
+       PUSH    TP,$TLIST       ;SET TO CALL CONS
+       PUSH    TP,B
+       MCALL   2,CONS
+       JRST    EVL5            ;LOOP TIL DONE
+
+
+EVL4:  MOVEI   B,EUVECT        ;UNIFORM CASE
+       SKIPG   -1(P)           ;SKIP IF UNIFORM CASE
+       MOVEI   B,EVECTO        ;NO, GENERAL CASE
+       POP     P,A             ;GET COUNT
+       .ACALL  A,(B)           ;CALL CREATOR
+       JRST    FINIS
+
+; PROCESS SEGMENTS FOR THESE  HACKS
+
+DOSEG: MOVEM   A,BSTO(PVP)     ;WILL BECOME INTERRUPTABLE WITH GOODIE IN B
+       HLRZS   A               ;TYPE TO RH
+       PUSHJ   P,SAT           ;GET STORAGE TYPE
+
+       CAIN    A,S2WORD        ;LIST?
+       JRST    LSTSEG
+       CAIN    A,S2NWORD       ;GENERAL VECTOR?
+       JRST    VECSEG
+       CAIN    A,SNWORD        ;UNIFORM VECTOR?
+       JRST    UVCSEG
+       CAIE    A,SARGS         ;ARGS TUPLE?
+       JRST    ILLSEG          ;NO, ERROR
+
+       PUSH    TP,BSTO(PVP)    ;PREPARE TO CHECK ARGS
+       PUSH    TP,B
+       SETZM   BSTO(PVP)       ;TYPE NOT SPECIAL
+       MOVEI   B,-1(TP)        ;POINT TO SAVED COPY
+       PUSHJ   P,CHARGS        ;CHECK ARG POINTER
+       POP     TP,B            ;AND RESTORE WINNER
+       POP     TP,BSTO(PVP)    ;AND TYPE AND FALL INTO VECTOR CODE
+
+VECSEG:        PUSH    P,[2,,2]        ;PUSH AMOUNT TO BUMP
+       JRST    SEG1            ;AND JOIN COMMON CODE
+
+UVCSEG:        PUSH    P,[1,,1]        ;AMOUNT FOR UVECTS
+       JRST    SEG1
+
+\f
+
+LSTSEG:        SKIPL   -1(P)           ;SKIP IF IN A LIST
+       JRST    SEG3            ;ELSE JOIN COMMON CODE
+       HRRZ    C,@1(TB)        ;CHECK FOR END OF LIST
+       JUMPN   C,SEG3          ;NO, JOIN COMMON CODE
+       SETZM   BSTO(PVP)       ;CLOBBER SAVED GOODIES
+       JRST    EVL9            ;AND FINISH UP
+\f
+
+
+
+SEG3:  PUSH    P,[0]           ;AMOUNT OF ADDING FOR LIST
+SEG1:  INTGO                   ;CHECK OUT INTERRUPTS
+       JUMPE   B,SEG2          ;DONE?
+       SKIPE   C,(P)           ;CHECK IF LIST OR VECTOR
+       JUMPG   B,SEG2          ;END OF VECTOR
+       CAMN    C,[1,,1]        ;SKIP IF NOT UNIFORM
+       JRST    SEG5            ;HACK UNIFORM SEGMENT
+       GETYPF  A,(B)           ;GET NEXT TYPE
+       SKIPGE  -2(P)           ;SKIP IF NOT LIST
+       HLLZS   A               ;CLEAR CDR
+       MOVE    C,1(B)          ;GET VALUE
+SEG4:  PUSH    TP,A            ;PUSH TYPE
+       PUSH    TP,C
+       PUSH    P,B             ;CAN USE P BECAUSE CHKARG NOT INTERRUPTABLE
+       JSP     E,CHKARG        ;CHECK OUT TDEFER
+       POP     P,B             ;RESTORE
+       SKIPG   (P)             ;SKIP IF NOT LIST
+       HRRZ    B,(B)           ;CDR THE LIST
+       ADD     B,(P)           ;AND BUMP IT
+       AOS     -1(P)           ;BUMP COUNT
+       JRST    SEG1            ;AND DO IT AGAIN
+
+SEG2:  SETZM   BSTO(PVP)       ;CLOBBER TYPE BACK
+       SUB     P,[1,,1]        ;POP OFF LOSSAGE
+       JRST    EVL6
+
+SEG5:  HLRE    C,B             ;FIND TYPE
+       SUBM    B,C             ;POINT TO DOPE WORD
+       GETYP   A,(C)           ;GET  TYPE 
+       MOVSI   A,(A)           ;TO LH
+       MOVE    C,(B)           ;NOW GET VALUE
+       JRST    SEG4
+
+\f
+
+;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
+
+APFUNARG:
+       HRRZ    A,@1(TB)        ;GET CDR OF FUNARG
+       JUMPE   A,FUNERR        ;NON -- NIL
+       HLRZ    B,(A)           ;GET TYPE OF CADR
+       CAIE    B,TLIST         ;BETTR BE LIST
+       JRST    FUNERR
+       PUSH    TP,$TLIST       ;SAVE IT UP
+       PUSH    TP,1(A)
+FUNLP:
+       INTGO
+       SKIPN   A,3(TB)         ;ANY MORE
+       JRST    DOF             ;NO -- APPLY IT
+       HRRZ    B,(A)
+       MOVEM   B,3(TB)
+       HLRZ    C,(A)
+       CAIE    C,TLIST
+       JRST    FUNERR
+       HRRZ    A,1(A)
+       HLRZ    C,(A)           ;GET FIRST VAR
+       CAIE    C,TATOM         ;MAKE SURE IT IS ATOMIC
+       JRST    FUNERR
+       PUSH    TP,BNDA         ;SET IT UP
+       PUSH    TP,1(A)
+       HRRZ    A,(A)
+       PUSH    TP,(A)          ;SET IT UP
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+\r      PUSH    TP,[0]
+       PUSH    TP,[0]
+       JRST    FUNLP
+DOF:
+       PUSHJ   P,SPECBIND      ;BIND THEM
+       MOVE    A,1(TB)         ;GET GOODIE
+       HLLZ    B,(A)
+       PUSH    TP,B
+       PUSH    TP,1(A)
+       HRRZ    A,@1(AB)
+       PUSH    TP,$TLIST
+       PUSH    TP,A
+       MCALL   2,CONS
+       PUSH    TP,$TFORM
+       PUSH    TP,B
+       MCALL   1,EVAL
+       JRST    FINIS
+\f
+
+;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
+;IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
+; IT IS CALLED BY PUSHJ P,ILOC.
+
+ILOC:  MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL
+       HRR     A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
+       CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?
+       JRST    SCHSP           ;NO -- SEARCH THE LOCAL BINDINGS
+       MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER
+       POPJ    P,              ;FROM THE VALUE CELL
+
+SCHSP: MOVE    C,SP            ;GET TOP OF BINDINGS
+SCHLP: JUMPE   C,UNPOPJ        ;IF NO MORE -- LOSE
+       CAMN    B,1(C)          ;ARE WE POINTING AT THE WINNER?
+       JRST    SCHFND          ;YES
+       HRRZ    C,(C)           ;FOLLOW LINK
+       JRST    SCHLP
+
+SCHFND:        EXCH    B,C             ;SAVE THE ATOM PTR IN C
+       MOVEI   B,2(B)          ;MAKE UP THE LOCATIVE
+       SUBI    B,(TP)
+       HRLI    B,-1(B)
+       ADD     B,TP
+
+       MOVEM   A,(C)           ;CLOBBER IT AWAY INTO THE
+       MOVEM   B,1(C)          ;ATOM'S VALUE CELL
+       POPJ    P,
+
+UNPOPJ:        MOVSI   A,TUNBOUND
+       MOVEI   B,0
+       POPJ    P,
+
+;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE 
+;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY
+;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
+
+\rIGLOC:        MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO
+       CAME    A,(B)           ;A PROCESS #0 VALUE?
+       JRST    SCHGSP          ;NO -- SEARCH
+       MOVE    B,1(B)          ;YES -- GET VALUE CELL
+       POPJ    P,
+
+SCHGSP:        MOVE    D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
+
+SCHG1: JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE
+       CAMN    B,1(D)          ;ARE WE FOUND?
+       JRST    GLOCFOUND       ;YES
+       ADD     D,[4,,4]        ;NO -- TRY NEXT
+       JRST    SCHG1
+
+GLOCFOUND:     EXCH    B,D             ;SAVE ATOM PTR
+       ADD     B,[2,,2]        ;MAKE LOCATIVE
+       MOVEM   A,(D)           ;CLOBBER IT AWAY
+       MOVEM   B,1(D)
+       POPJ    P,
+
+
+\f
+
+;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
+;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
+;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL
+
+ILVAL:
+       PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
+CHVAL: CAMN    A,$TUNBOUND     ;BOUND
+       POPJ    P,              ;NO -- RETURN
+       MOVE    A,(B)           ;GET THE TYPE OF THE VALUE
+       MOVE    B,1(B)          ;GET DATUM
+       POPJ    P,
+
+;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
+
+IGVAL: PUSHJ   P,IGLOC
+       JRST    CHVAL
+
+
+\f
+
+;BINDER - THIS SUBROUTINE PROCCESSES FUNCTION DECLARATIONS AND BINDS
+;      ARGUMENTS       AND TEMPORARIES APPROPRIATELY.
+;      
+;      CALL:   PUSHJ   P,BINDER OR BINDRS
+;
+;      BINDER - ASSUMES ARGS ARE ON A LIST
+;
+;      BINDRS - ASSUMES FORMS SUPPLIED FOR GETTING ARGS
+;      BINDRR - RESUME HACK - ARGS ON A LIST TO BE 
+;              EVALED IN PARENT PROCESS
+;
+
+;      C/      POINTS TO FUNCTION BEING HACKED
+;      D/      POINTS TO ARG LIST (IF <0, CALLED FROM A PROG)
+;      0/      IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
+
+BINDER:        MOVEI   A,0     
+TBINDR:        PUSH    P,[ARGCDR]      ;PUSH POINTER TO ARG GETTER
+       JRST    BIND1
+
+BINDRR:        MOVEI   A,0     
+TBNDRR: PUSH   P,[RESARG]      ; ARG GETTER FOR RESUMING FUNCTIONS
+       JRST    BIND1
+
+
+BINDRS:        MOVEI   A,0             ;NO TOP TEMPS
+TBNDRS:        PUSH    P,[SETZ EVALRG] ;FOR THE STACKFORM CASE
+BIND1: PUSH    P,[2]           ;PUSH INITIAL STATE (NO DCLS PROCESSED)
+       PUSH    P,A             ;NUMBER OF TEMPS ON TP STACK
+
+       JUMPE   C,NOBODY        ;NO BODY IN FUNCTION, ERROR
+
+       GETYP   A,(C)           ;GET FIRST THING IN FUNCTION
+       CAIE    A,TATOM         ;ATOMIC?
+       JRST    BIND2           ;NO, NO NAME ALA HEWITT GIVEN
+       PUSHJ   P,TMPUP         ;COUNT TEMPS ON TP
+       PUSH    TP,[TATOM,,1]   ;YES SAVE IT
+       PUSH    TP,1(C)
+       HRRZ    C,(C)           ;CDR THE FUNCTION TO POINT
+       JUMPE   C,NOBODY
+
+BIND2: PUSHJ   P,CARLST        ;MAKE SURE THE CAR IS A LIST
+       JRST    BNDRET          ;EXIT IMMEDIATELY
+       MOVEI   A,(C)           ;COPY FOR NXTDCL
+       JUMPL   D,AUXDO         ;PROG, HANDLE
+
+       PUSHJ   P,NXTDCL        ;GET A DECLARATION
+       JRST    BINDRG          ;NONE THERE, GO BIND ARGS
+
+       CAME    B,[ASCII /BIND/]        ;IS A BINDING NEEDED
+       JRST    BIND3           ;NO MUST BE ANOTHER FLAVOR OF DCL
+
+       HRRZ    C,(A)           ;CDR THE LIST
+       JUMPE   C,MPD           ;LOSER
+
+       PUSHJ   P,CARATM        ;GET THE CAR MAKING SURE OF ATOM
+       JRST    MPD
+       HRRZ    B,OTBSAV(TB)    ;BUILD AN ENVIRONEMNT  FOR BINDING VAR
+       PUSHJ   P,MAKENV
+
+       PUSHJ   P,PSHBND        ;PUSH THE BINDING ON THE STACK
+       HRRZ    C,(C)           ;CDR THE DCL LIST
+       JRST    BINDRG          ;GO BIND AS AN ARG
+
+\f
+
+; MAIN BINDING LOOP, DISPATCH BASED ON DECLARATION
+
+BIND4: MOVEI   A,(C)           ;COPY THE LIST POINTER
+       PUSHJ   P,NXTDCL        ;AND LOOK FOR A DECLARATION
+       JRST    CHLIST          ;ILLEGAL
+BIND3: TRZ     B,1             ;FOR OPTIONAL TO WIN
+       MOVSI   A,-DCLS         ;NOW GET SET TO SEARCH TABLE
+       HRRZ    C,(C)           ;CDR THE DCL LIST
+       JUMPE   C,MPD           ;NO, CDR, ERROR
+
+       CAMN    B,DCLST(A)      ;SKIP IF NOT FOUND
+       JRST    @DCLGO(A)       ;DISPATCH BASED ON DCL
+       AOBJN   A,.-2
+
+       JRST    MPD
+
+DCLS==0
+
+DCLST: IRP     A,,[ARGS,TUPLE,CALL,OPTIO,ACT,AUX,NAME,EXTRA]
+       DCLS==DCLS+1
+       ASCII /A/
+       TERMIN
+
+DCLS2==0
+\rDCLGO:        IRP     A,,[ARGDO,TUPLDO,CALDO,OPTDO,ACTDO,AUXDO,ACTDO,AUXDO]
+       A
+       DCLS2==DCLS2+1
+       TERMIN
+
+IFN <DCLS-DCLS2>,PRINTC /LOSSAGE AT DCLS
+/
+EXPUNGE DCLS2
+
+;HERE TO CHECK FOR LISTS WITHIN DECLARATIONS
+
+CHLIST:        GETYP   A,(C)           ;GET TYPE
+       CAIE    A,TLIST         ;LIST?
+       JRST    MPD             ;NO, LOSER
+       SKIPN   A,1(C)          ;CHECK NON-NIL
+       JRST    CALD1           ;IF NIL, IGNORE
+       PUSH    TP,[TLIST,,1]   ;SPECIAL TYPE
+       PUSH    TP,C
+       MOVEI   C,(A)           ;LIST TO C
+       PUSHJ   P,TMPUP         ;COUNT TEMPS
+       JRST    BINDRG
+
+
+\f
+
+;HANDLER FOR CALL DECLARATION
+
+CALDO: SKIPL   -2(P)           ;SKIP IF IN STACK-FORM
+       SOSG    -1(P)           ;SKIP IF FIRST DECLARATION
+       JRST    MPD             ;OTHERWISE MEANINGLESS
+
+       JUMPE   0,MPD           ;ALSO MEANINGLESS IF NO CALLSITE GIVEN
+       PUSHJ   P,CARATD        ;GOBBLE THE ATOM
+
+       HLLZ    A,0             ;SET UP CALL TO PUSH THE BINDING
+       HRRZ    B,0
+CALD2: PUSHJ   P,PSHBND        ;PUSH THAT BINDING ON TO STACK
+
+CALD1: PUSH    TP,$TLIST       ;SAVE THE DCL LIST
+       PUSH    TP,C
+       MOVEI   E,-2(TP)        ;POINT TO DCLS
+       SUB     E,(P)           ;SUBTRACT TEMPS
+CALD3: PUSHJ   P,SPCBE         ;DO THE BINDINGS NOW
+       MOVE    C,(TP)          ;RESTORE DCLS
+       SUB     TP,[2,,2]       ;AND POP
+       HRRZ    C,(C)           ;CDR THE LIST
+CALD4: SETZM   -1(P)           ;NEXT MUST BE EITHER AUX OR ACT
+       JUMPN   C,BIND4         ;LOOP AGAIN
+
+\f
+
+BNDRET:        MOVEI   A,0             ;SET SWITCH
+BNDRT2:        SKIPN   (P)             ;ANY TEMPS LEFT?
+       JRST    BNDRT1
+       MOVE    B,-1(TP)        ;GET TYPE
+       CAMN    B,[TATOM,,1]    ;SPECIAL
+       JRST    BNDRT3
+       CAME    B,[TLIST,,1]    ;STACKED LIST
+       JRST    BNDRT1          ;NO, LEAVE
+
+       PUSHJ   P,TMPDWN        ;TEMPS DOWN
+       HRRZ    C,@(TP) ;CDR THE SAVED LIST
+       SUB     TP,[2,,2]       ;POP OFF CRAP
+       JRST    CALD4           ;AND CONTINUE PROCESSING
+
+BNDRT3:        PUSHJ   P,TMPDWN
+       MOVE    E,(TP)          ;GET ATOM
+       SUB     TP,[2,,2]
+       MOVEI   C,0             ;FOR ACTDO TO WIN
+       PUSHJ   P,ACTD1
+       MOVEI   A,1             ;SAY NAME EXISTS
+
+BNDRT1:        SUB     P,[3,,3]
+       POPJ    P,
+
+\f
+
+; HERE TO ARGS DECLARATION
+
+ARGDO: SOSL    -1(P)           ;LOSE IF STATES ARE 0 OR 1
+       SKIPGE  -2(P)           ;ALSO LOSE IN STACK-FRAME
+       JRST    MPD
+
+       PUSHJ   P,CARATD        ;FIND THE ATOM
+
+       MOVSI   A,TLIST
+       MOVEI   B,(D)           ;COPY ARGL
+       JRST    CALD2           ;AND FALL INTO CALL CODE
+
+;HERE TO HANDLE THE TUPLE DCL
+
+TUPLDO:        SOSGE   -1(P)           ;CHECK STATE
+       JRST    MPD
+
+       PUSHJ   P,CARATD        ;GET ATOM
+       PUSH    TP,$TLIST       ;SAVE DCL LIST
+       PUSH    TP,C
+       PUSHJ   P,TMPUP         ;COUNT THE TEMPS
+       SETZB   A,B
+
+       PUSHJ   P,PSHBND        ;PUSH THE BINDING FOR THIS CHOMPER
+       PUSH    P,[0]           ;PUSH   ARG COUNTER
+
+TUPLP: PUSHJ   P,@-3(P)        ;CALL ARG GOBBLING SUBROUTINE
+       JRST    TUPDONE         ;LEAVE IF ALL DONE
+
+       PUSHJ   P,PSHAB         ;PUSH THE EVALED ARG
+       SOS     (P)             ;COUNT THE ARG
+       JRST    TUPLP
+
+TUPDON:        MOVSI   A,TTB           ;FENCE POST ARG BLOCK
+       MOVE    B,TB            ;WITH A FRAME POINTER
+       PUSHJ   P,PSHAB         ;ONTO THE STACK
+       POP     P,B             ;GET NUMBER OF ARGS
+       ASH     B,1             ;TIMES TWO
+       SKIPE   B               ;WATCH FOR EMPTY TUPLE
+       HRLI    B,-1(B)         ;FOR ADDING TO TOA TP
+       ADDI    B,-1(TP)        ;FUDGE POINTER
+       SUB     B,(P)           ;SUBTRACT TEMPS
+       MOVEI   E,-1(B)         ;B WIIL GET CLOBBERED, SAVE
+       MOVSI   A,TARGS         ;GET THE RIGHT TYPE
+       HLR     A,OTBSAV(TB)    ;WITH THE TIME
+       MOVEM   A,-4(B)         ;CLOBBER IT AWAY
+       MOVEM   B,-3(B)         ;AND ARG POINTER
+
+       PUSHJ   P,TMPDWN
+       JRST    CALD3
+
+; HERE TO HANDLE OPTIONAL DECLARATION
+
+OPTDO: SKIPG   -1(P)
+       JRST    MPD             ;NOT ALLOWED
+       SETZM   -1(P)           ;MUNG STATE
+       JRST    BNDRGL          ;JOIN BIND LOOP
+
+BINDRG:        SKIPG   -1(P)           ;CHECK STATE
+       JRST    MPD
+
+BNDRGL:        JUMPE   C,CHLST         ;CHECK FOR LAST
+       PUSH    TP,$TLIST       ;SAVE DCLS
+       PUSH    TP,C
+       PUSH    TP,$TLIST       ;SAVE SLOT
+       PUSH    TP,D            ;PUT ARGLIST THERE FOR AN INT CHECK
+       INTGO
+       MOVE    D,(TP)          ;INCASE INTERRUPT CLOBBERED IT
+       SETZM   (TP)            ;NOW CLEAR SLOT
+
+
+BNDRG3:        PUSHJ   P,CARATM        ;CHECK FOR ATOM
+       JRST    OPTDFL          ;NO, MAY BE LIST OR MAY BE QUOTED
+
+       PUSH    TP,$TATOM
+       PUSH    TP,E            ;AND ATOM
+
+       PUSHJ   P,@-2(P)        ;GOBBLE DOWN NEXT ARG
+       JRST    USEDF           ;CHECK FOR DEFAULT OT ENOUGH
+
+BNDRG2:        HRRZ    C,-4(TP)        ;RESTORE DCLS
+       MOVE    E,(TP)          ;AND ATOM
+       SUB     TP,[6,,6]       ;FLUSH CRAP
+
+       PUSHJ   P,PSHBND        ;PUSH THE BINDING
+BNDRG4:        HRRZ    C,(C)           ;CDR THE DCL LIST
+       JUMPN   C,BNDRGL
+
+CHLST: PUSHJ   P,@-2(P)        ;CHECK FOR LAST
+       JRST    .+2
+       JRST    TMA
+       MOVEI   E,(TP)          ;PREPARE TO BIND
+       SUB     E,(P)
+       PUSHJ   P,SPCBE         ;BIND IF STUFF EXISTS
+       JRST    BNDRET          ;AND RETURN
+
+\f
+
+CHQT:  CAIE    A,TFORM         ;IST THE ARG A FORM?
+       JRST    OPTDF2          ;NO, END OF ARGS
+
+       SKIPN   C,1(C)          ;CHECK FOR NULL BODY
+       JRST    MPD
+
+       GETYP   A,(C)           ;TYPE OF 1ST OF FORM
+       MOVE    B,1(C)          ;AND VALUE
+       CAIN    A,TATOM         ;BETTER BE ATOM
+       CAME    B,MQUOTE QUOTE
+       JRST    MPD             ;NAMED QUOTE OR LOSSAGE
+       HRRZ    C,(C)           ;CDR THE FORM
+       JUMPE   C,MPD           ;NO, ARG LOSE
+       GETYP   A,(C)
+       CAIE    A,TATOM         ;ARG MUST BE ATOM
+       JRST    MPD
+       HRRZ    A,(C)           ;AND CDR BETTER BE NIL
+       JUMPN   A,MPD
+       PUSH    TP,$TATOM       ;AND SAVE SAME
+       PUSH    TP,1(C)\r
+       SKIPGE  A,-2(P)         ;CHECK TYPE OF ARGS
+       JRST    QUOTHK          ;STACK FRAME HACK
+
+       JUMPE   D,USEDF         ;IF NO MORE ARGS, QUIT
+       GETYP   A,(D)           ;GET TYPE
+       MOVSI   A,(A)           ;TO LH
+       PUSH    TP,A            ;PUSH IT UP
+       PUSH    TP,1(D)         ;FOR DEFER CHECK
+       JSP     E,CHKARG
+       POP     TP,B            ;GET BACK
+       POP     TP,A
+       HRRZ    D,(D)           ;CDR THE ARG LIST
+       JRST    BNDRG2
+
+QUOTHK:        PUSHJ   P,(A)           ;CALL ROUTINE
+       JRST    USEDF           ;TOO FEW ARGS
+
+       PUSH    TP,$TATOM       ;QUOTE THE GOODIE
+       PUSH    TP,MQUOTE QUOTE
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,LIST          ;CONS IT UP
+       MOVSI   A,TFORM
+       JRST    BNDRG2
+
+
+\f
+
+OPTDFL:        SKIPN   -1(P)           ;SKIP IF CANT BE DEFAULT
+       CAIE    A,TLIST         ;SHOULD BE A LIST
+       JRST    CHQT            ;NO MORE OPTIONALS
+
+       SKIPE   (TP)            ;AVOID LIST OF LIST
+       JRST    MPD
+       MOVE    C,1(C)          ;GET THE CAR
+       HRRZ    A,(C)           ;CDR THE LIST
+       JUMPE   A,MPD           ;LOSER
+       HRRZ    B,(A)           ;CHECK FOR NIL CDR
+       JUMPN   B,MPD
+       MOVEM   A,(TP)          ;SAVE
+       JRST    BNDRG3
+
+OPTDF2:        JUMPN   D,OPTDF3        ;IF D NON-ZERO, DONT BIND
+       MOVEI   E,-4(TP)        ;PREPARE TO BIND
+       SUBI    E,@(P)          ;SUBTRACT TEMPS
+       PUSHJ   P,SPCBE         ;DO BINDINGS MAYBE
+       MOVEI   D,0             ;RESET D TO 0
+OPTDF3:        MOVE    C,-2(TP)        ;RESTORE DCLS
+       SUB     TP,[4,,4]       ;POP STACK
+       MOVEI   A,1             ;CLOBBER IN A NEW STATE
+       MOVEM   A,-1(P)
+       JRST    BIND4           ;AND RE-ENTER THE LOOP
+
+
+USEDF: SKIPE   -1(P)           ;SKIP IF OPTIONAL
+       JRST    TFA             ;ELSE TOO FEW ARGS
+       MOVEI   E,-6(TP)        ;SET TO DO SPECBIND
+       SUBI    E,@(P)
+       PUSHJ   P,SPCBE         ;BIND IF THEY EXIST
+       MOVNI   B,1             ;ASSUME UNASSIGNED AT FIRST
+       MOVSI   A,TUNBOU
+       SKIPN   C,-2(TP)        ;IF A FORM TO EVAL
+       JRST    OPTDF4          ;TREAT NORMALLY
+       GETYP   A,(C)           ;EVAL IT
+       MOVSI   A,(A)
+       PUSH    TP,A
+       PUSH    TP,1(C)
+       JSP     E,CHKARG        ;CHECK FOR DEFERRED POINTERS
+       MCALL   1,EVAL          ;EVAL IT
+OPTDF4:        MOVE    E,(TP)          ;GET ATOM
+       MOVE    C,-4(TP)
+       SUB     TP,[6,,6]       ;FLUSH JUNK
+       PUSHJ   P,PSHBND        ;PUSH THE BINDING
+       MOVEI   D,0             ;MUNG ARG LIST
+       JRST    BNDRG4
+
+\f
+
+AUXDO: SKIPGE  -1(P)           ;CHECK STATE
+       JRST    MPD
+       SETOM   -1(P)           ;NOTHING BUT ACT MAY FOLLOW
+
+AUXBND:        JUMPE   C,BNDRET        ;DONE
+       PUSHJ   P,CARATM        ;LOOK FOR ATOM
+       JRST    AUXIN           ;COULD BE LIST
+
+       MOVSI   A,TUNBOU
+       MOVNI   B,1
+AUXB1: PUSHJ   P,PSHBND        ;PUSH THE BINDING UP
+
+       MOVEI   E,(TP)          ;PREPARE TO BIND
+       PUSH    TP,$TLIST       ;SAVE DCLS
+       PUSH    TP,C
+       SUB     E,(P)           ;FUDGE FOR TEMPS
+       PUSHJ   P,SPCBE
+
+       INTGO
+       HRRZ    C,@(TP)         ;CDR THE LIST
+       SUB     TP,[2,,2]       ;AND POP
+       JRST    AUXBND
+
+AUXIN: CAIE    A,TLIST         ;IS IT A LIST
+       JRST    BIND4
+       PUSH    TP,$TLIST       ;SAVE  DCLS
+       PUSH    TP,C
+       SKIPN   C,1(C)          ;NIL?
+       JRST    MPD             ;YES, LOSE
+       PUSHJ   P,CARATD        ;MAKE SURE ITS AN ATOM
+       PUSH    TP,$TATOM
+       PUSH    TP,E
+       HRRZ    C,(C)           ;CDR
+       JUMPE   C,MPD
+       HRRZ    A,(C)           ;GET NEXT CDR
+       JUMPN   A,MPD           ;BETTER BE NIL
+       GETYP   A,(C)
+       MOVSI   A,(A)           ;TYPE TO LH
+       PUSH    TP,A
+       PUSH    TP,1(C)         ;PREPARE TO EVAL
+       MCALL   1,EVAL
+       MOVE    E,(TP)          ;RESTORE ATOM
+       MOVE    C,-2(TP)        ;AND DCLS
+       SUB     TP,[4,,4]
+       JRST    AUXB1
+
+\f
+
+ACTDO: PUSHJ   P,CARATD        ;MUST BE ATOMIC
+       HRRZ    C,(C)           ;MUST BE END OF DCLS
+       JUMPN   C,MPD
+       PUSH    P,CBNDRE        ;PUSH THE RIGHT RETURN
+
+ACTD1: MOVE    B,TB            ;MAKE ENV
+       PUSHJ   P,MAKENV
+       HRLI    A,TACT          ;AND CHANGE TO ACTIVATION
+       POP     P,D             ;RESTORE RET ADR, BECAUSE PSHBND NEEDS NICE STATE
+       PUSHJ   P,PSHBND        ;PUSH UP THE BINDING
+       PUSH    P,D             ;NOW PUT IT BACK
+       MOVEI   E,(TP)
+       SUBI    E,@-1(P)        ;NOW READY TO BIND
+       PUSHJ   P,SPCBE
+       MOVNI   A,1             ;SET SW
+CBNDRE:        POPJ    P,BNDRT2
+
+
+;INTERNAL ROUTINES FOR THE BINDER
+
+TMPUP: AOS     -1(P)           ;ADDS 2 TO TOP OF STACK
+       AOS     -1(P)
+       POPJ    P,
+
+TMPDWN:        SOS     -1(P)           ;SUBTRACTS 2 FROM STACK
+       SOS     -1(P)
+       POPJ    P,
+
+CARATD:        PUSHJ   P,CARATM        ;LOOK FOR ATOM
+       JRST    MPD             ;ERROR IF NONE
+       POPJ    P,
+
+CARATM:        GETYP   A,(C)           ;GETS ARG IN C, GET TYPE
+       CAIE    A,TATOM         ;ATOM?
+       POPJ    P,              ;NO, DONT SKIP
+       MOVE    E,1(C)          ;RETRUN ATOM IN E
+CPOPJ1:        AOS     (P)             ;SKIP RET
+CPOPJ: POPJ    P,
+
+CARLST:        GETYP   A,(C)           ;GETS LIST IN CAR, POPS TO 2D ON STACK IF NIL
+       CAIE    A,TLIST
+       JRST    MPD             ;NOT A LIST, FATAL
+       SKIPE   C,1(C)
+       AOS     (P)
+       POPJ    P,
+
+
+MAKENV:        PUSH    P,C             ;SAVE AN AC
+       HLRE    C,PVP           ;GET -LNTH OF PROC VECTOR
+       MOVEI   A,(PVP)         ;COPY PVP
+       SUBI    A,-1(C)         ;POINT TO DOPWD WITH A
+       HRLI    A,TENV          ;MAKE INTO AN ENVIRONMENT
+       HLL     B,OTBSAV(B)     ;TIME TO B
+       POP     P,C
+       POPJ    P,
+
+
+\f
+
+; ARGCDR - NORMAL ARG GETTER FOR OTHER THAN STACKFORM
+
+ARGCDR:        JUMPE   D,CPOPJ         ;DONT SKIP IF NIL
+       PUSH    TP,$TLIST
+       PUSH    TP,D
+       GETYP   A,(D)           ;GET TYPE OF ARG
+       MOVSI   A,(A)           ;TO LH OF A
+       PUSH    TP,A
+       PUSH    TP,1(D)         ;PUSH TYPE AND VALUE
+       JSP     E,CHKARG        ;CHECK FOR TDEFER
+       MCALL   1,EVAL
+       HRRZ    D,@(TP)         ;CDR THE LIST
+       SUB     TP,[2,,2]       ;POP STACK
+       JRST    CPOPJ1          ;SKIP RETURN
+
+;EVALRG - USED TO EVAL ARGS IN STACKFORM HACK
+
+EVALRG:        JUMPE   D,CPOPJ         ;LEAVE IMMEDIATELY
+       PUSH    TP,$TLIST       ;SAVE ARG LIST
+       PUSH    TP,D
+       HRRZ    C,(D)           ;AND CDR IT
+       GETYP   B,(C)           ;GET TYPE OF CONDITIONAL FORM
+       MOVSI   B,(B)           ;TO LH
+       PUSH    TP,B
+       PUSH    TP,1(C)         ;AND VALUE
+       JSP     E,CHKARG        ;CHECK DEFERRED
+       MCALL   1,EVAL          ;AND EVAL IT
+       CAMN    A,$TFALSE       ;FALSE?
+       JRST    EVALR2          ;YES, LEAVE
+       HRRZ    D,(TP)          ;GET ARGS BACK
+       GETYP   A,(D)           ;GET TYPE
+       MOVSI   A,(A)           ;TO LH
+       PUSH    TP,A
+       PUSH    TP,1(D)         ;PUSH IT
+       JSP     E,CHKARG        ;CHECK DEFERRED
+       MCALL   1,EVAL
+       AOS     (P)             ;CAUSE A SKIP RETURN
+EVALR2:        MOVE    D,(TP)          ;RESTORE ARGS
+       SUB     TP,[2,,2]       ;POP STACK
+       POPJ    P,              ;AND RETURN
+
+;RESARG - USED TO GET ARGS FOR RESUMING FUNCTIONS
+
+
+RESARG:
+       JUMPE   D,CPOPJ ;DONT SKIP IF NIL - NO MORE ARGS
+       PUSH    TP,$TLIST       ; SAVE ARG LIST
+       PUSH    TP,D
+       GETYP   A,(D)           ; GET TYPE OF ARG
+       MOVSI   A,(A)           ;TO LH
+       PUSH    TP,A            ;PUSH TYPE
+       PUSH    TP,1(D)         ;AND VALUE
+       JSP     E,CHKARG        ;CHECK FOR DEFERED TYPE
+       MOVE    B,MQUOTE [PPROC ]INTERR
+       PUSHJ   P,ILVAL         ;GET ENV OF PARENT PROCESS      
+       PUSH    TP,A
+       PUSH    TP,B            ;SET UP FOR AEVAL CALL
+       MCALL   2,EVAL          ;CALL EVAL WITH THE ENV
+       HRRZ    D,@(TP)         ;CDR ARG LIST
+       SUB     TP,[2,,2]       ;REMOVE SAVED ARG LIST
+       JRST    CPOPJ1          ;SKIP 1 AND RETURN
+
+\f
+
+;SUBROUTINE TO PUSH A BINDING ON THE STACK
+;      E/      ATOM
+;      A/      TYPE
+;      B/      VALUE
+
+PSHBND:        PUSH    P,D             ;SAVE TEMPS
+       PUSH    P,E
+       MOVE    D,-3(P)         ;GOBBLE # OF TEMPS ON STACK
+       ADD     TP,[6,,6]       ;ALOCATE SPACE
+       JUMPGE  TP,TPLOSE       ;HACK IF OVERFLOW
+PSHBN1:        HRROI   E,-6(TP)        ;SET UP E
+       JUMPE   D,NOBLT         ;IF NO TEMPS, LESS WORK
+       POP     E,6(E)          ;USE POP TP MOVE THEM UP
+       SOJN    D,.-1
+NOBLT: MOVSI   D,TATOM         ;SET UP BINDING
+       HLLOM   D,1(E)          ;CLOBBER
+       POP     P,2(E)          ;ATOM INTO SLOT
+       MOVEM   A,3(E)
+       MOVEM   B,4(E)
+       SETZM   5(E)            ;CLEAR EXTRA SLOTS
+       SETZM   6(E)
+       POP     P,D
+       POPJ    P,
+
+TPLOSE:        PUSHJ   P,TPOVFL        ;GO TO INT HANDLER
+       JRST    PSHBN1
+
+; DO A SPECBIND IF NEEDED
+
+SPCBE: MOVE    A,-5(E)         ;GET TYPE
+       CAME    A,BNDA
+       POPJ    P,
+       MOVEI   A,(TP)          ;COPY POINTER
+       SUBI    A,(E)           ;FIND DISTANCE TO TOP
+       MOVSI   A,(A)           ;TO LH
+       HLL     E,TP
+       SUB     E,A             ;FIX UP POINTER
+       JRST    SPECBE          ;YES, GO DO IT
+
+;ROUTINE TO SQUEEZE A PAIR ON THE STACK
+
+PSHAB: PUSH    P,D
+       PUSH    P,E
+       PUSH    TP,[0]          ;ALLOCATE SPACE
+       PUSH    TP,[0]
+       MOVE    D,-4(P)         ;GET TEMPS COUNT
+       HRROI   E,-2(TP)        ;POINT TO TOP
+       JUMPE   D,NOBLT1
+       POP     E,2(E)
+       SOJN    D,.-1
+
+NOBLT1:        MOVEM   A,1(E)          ;CLOBBER
+       MOVEM   B,2(E)
+       POP     P,E
+       POP     P,D
+       POPJ    P,
+
+\f
+
+;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
+;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.  
+;EACH TRIPLET IS AS FOLLOWS:
+;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
+;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
+;AND THE THIRD IS A PAIR OF ZEROES.
+
+BNDA:  TATOM,,-1
+BNDV:  TVEC,,-1
+
+SPECBIND:      MOVE    E,TP            ;GET THE POINTER TO TOP
+SPECBE:        ADD     E,[1,,1]        ;BUMP POINTER ONCE
+       SETZB   0,D             ;CLEAR TEMPS
+
+BINDLP:        MOVE    A,-6(E)         ;GET TYPE
+       CAME    A,BNDA          ;NORMAL ID BIND?
+       JRST    NONID           ;NO TRY BNDV
+
+       SUB     E,[6,,6]        ;MOVE PTR
+       SKIPE   D               ;LINK?
+       HRRM    E,(D)           ;YES --  LOBBER
+       SKIPN   0               ;UPDATED?
+       MOVE    0,E             ;NO -- DO IT
+
+       MOVE    A,0(E)          ;GET ATOM PTR
+       MOVE    B,1(E)  
+       PUSHJ   P,ILOC          ;GET LAST BINDING
+       HLR     A,OTBSAV (TB)   ;GET TIME
+       MOVEM   A,4(E)          ;CLOBBER IT AWAY
+       MOVEM   B,5(E)          ;IN RESTORE CELLS
+
+       HRRZ    A,PROCID+1(PVP) ;GET PROCESS NUMBER
+       HRLI    A,TLOCI         ;MAKE LOC PTR
+       MOVE    B,E             ;TO NEW VALUE
+       ADD     B,[2,,2]
+       MOVE    C,1(E)          ;GET ATOM PTR
+       MOVEM   A,(C)           ;CLOBBER ITS VALUE
+       MOVEM   B,1(C)          ;CELL
+       MOVEI   A,TBIND
+       HRLM    A,(E)           ;IDENTIFY AS BIND BLOCK
+       MOVE    D,E             ;REMEMBER LINK
+       JRST    BINDLP          ;DO NEXT
+
+NONID: MOVE    A,-4(E)         ;TRY TYPE BEFORE
+       CAME    A,BNDV          ;IS IT A SPECIAL HACK?
+       JRST    SPECBD          ;NO  -- DONE
+       SUB      E,[4,,4]
+       SKIPE   D
+       HRRM    E,(D)
+       SKIPN   0
+       MOVE    0,E
+
+       MOVE    D,1(E)          ;GET PTR TO VECTOR
+       MOVE    C,(D)           ;EXCHANGE TYPES
+       EXCH    C,2(E)
+       MOVEM   C,(D)
+
+       MOVE    C,1(D)          ;EXCHANGE DATUMS
+       EXCH    C,3(E)
+       MOVEM   C,1(D)
+
+       MOVEI   A,TBVL  
+       HRLM    A,(E)           ;IDENTIFY BIND BLOCK
+       MOVE    D,E             ;REMEMBER LINK
+       JRST    BINDLP
+
+SPECBD:        SKIPE   D
+       HRRM    SP,(D)
+       MOVE    SP,0
+       POPJ    P,
+
+\f
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN 
+;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+       HRRZ    E,SPSAV (TB)    ;GET TARGET POINTER
+
+STLOOP:
+       CAIL    E,(SP)          ;ARE WE DONE?
+       JRST    STPOPJ
+       HLRZ    C,(SP)          ;GET TYPE OF BIND
+       CAIE    C,TBIND         ;NORMAL IDENTIFIER?
+       JRST    ISTORE          ;NO -- SPECIAL HACK
+
+
+       MOVE    C,1(SP)         ;GET TOP ATOM
+       MOVE    D,4(SP)         ;GET STORED LOCATIVE
+\r      HRR     D,PROCID+1(PVP) ;STORE SIGNATURE
+       MOVEM   D,(C)           ;CLOBBER INTO ATOM
+       MOVE    D,5(SP)
+       MOVEM   D,1(C)
+       SETZM   4(SP)
+SPLP:  HRRZ    SP,(SP)         ;FOLOW LINK
+       JUMPN   SP,STLOOP       ;IF MORE
+       JUMPE   E,STPOPJ        ;ONLY OK IF E=0
+       .VALUE  [ASCIZ /SPOVERPOP/]
+
+ISTORE:        CAIE    C,TBVL
+       .VALUE  [ASCIZ /BADSP/]
+       MOVE    C,1(SP)
+       MOVE    D,2(SP)
+       MOVEM   D,(C)
+       MOVE    D,3(SP)
+       MOVEM   D,1(C)
+       JRST    SPLP
+
+STPOPJ:
+       MOVE    SP,SPSAV(TB)
+       POPJ    P,
+
+
+\f
+
+MFUNCTION REP,FSUBR,[REPEAT]
+       JRST    PROG
+MFUNCTION PROG,FSUBR
+       ENTRY   1
+       GETYP   A,(AB)          ;GET ARG TYPE
+       CAIE    A,TLIST         ;IS IT A LIST?
+       JRST    WTYP            ;WRONG TYPE
+       SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT
+       JRST    ERRTFA          ;TOO FEW ARGS
+       PUSH    TP,$TLIST       ;PUSH GOODIE
+       PUSH    TP,C
+       PUSH    TP,BNDA         ;BIND FUNNY ATOM
+       PUSH    TP,MQUOTE [LPROG ]INTERR
+       PUSH    TP,$TTB
+       PUSH    TP,TB           ;CURRENT TB POINTER
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       PUSHJ   P,SPECBI        ;BIND THE ATOM
+       MOVE    C,1(AB)         ;PROG BODY
+       MOVNI   D,1             ;TELL BINDER WE ARE APROG
+       PUSHJ   P,BINDER
+       HRRZ    C,1(AB)         ;RESTORE PROG
+       SKIPLE  A               ;SKIP IF NO NAME ALA HEWITT
+       HRRZ    C,(C)
+       JUMPE   C,NOBODY
+       PUSH    TP,$TLIST
+       PUSH    TP,C            ;SAVE FOR REPEAT, AGAIN ETC.
+       HRRZ    C,(C)           ;SKIP DCLS
+
+; HERE TO RUN PROGS FUNCTIONS ETC.
+
+DOPROG:
+       HRRZM   C,1(TB)         ;CLOBBER AWAY BODY
+       PUSH    TP,(C)          ;EVALUATE THE
+       HLLZS   (TP)
+       PUSH    TP,1(C)         ;STATEMENT
+       JSP     E,CHKARG
+       MCALL   1,EVAL  
+       HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY
+       JUMPN   C,DOPROG        ;IF MORE -- DO IT
+ENDPROG:
+       HRRZ    C,FSAV(TB)
+       MOVE    C,@-1(C)
+       CAME    C,MQUOTE REP,REPEAT
+       JRST    FINIS
+       SKIPN   C,(TP)          ;CHECK IT
+       JRST    FINIS
+       MOVEM   C,1(TB)
+       JRST    CONTINUE
+
+\f
+
+MFUNCTION RETURN,SUBR
+       ENTRY   1
+       PUSHJ   P,PROGCH        ;CKECK IN A PROG
+       HRR     TB,B            ;YES, SET TB
+       MOVE    A,(AB)
+       MOVE    B,1(AB)
+       JRST    FINIS
+
+
+MFUNCTION AGAIN,SUBR
+       ENTRY   
+       HLRZ    A,AB            ;GET # OF ARGS
+       CAIN    A,-2            ;1 ARG?
+       JRST    NLCLA           ;YES
+       JUMPN   A,WNA           ;0 ARGS?
+       PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG
+       JRST    AGAD
+NLCLA: HLRZ    A,(AB)
+       CAIE    A,TACT
+       JRST    WTYP
+       MOVE    A,1(AB)
+       HRR     B,A
+       HLL     B,OTBSAV (B)
+       HRRZ    C,A
+       CAIG    C,1(TP)
+       CAME    A,B
+       JRST    ILLFRA
+       HLRZ    C,FSAV (C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+AGAD:  HRR     TB,B
+       MOVE    B,TPSAV(B)      ;POINT TO TOP OF STACK
+       MOVE    B,(B)
+       MOVEM   B,1(TB)
+       JRST    CONTIN
+
+MFUNCTION GO,SUBR
+       ENTRY   1
+       PUSHJ   P,PROGCH        ;CHECK FOR A PROG
+       PUSH    TP,A            ;SAVE
+       PUSH    TP,B
+       MOVE    A,(AB)
+       CAME    A,$TATOM
+       JRST    NLCLGO
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+       MOVE    B,TPSAV(B)      ;GET SAVED TOP OF STACK
+       PUSH    TP,-1(B)
+       PUSH    TP,(B)
+       MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?
+       JUMPE   B,NXTAG         ;NO -- ERROR
+FNDGO: MOVE    TB,(TP)         ;RE-GOBBLE
+       SUB     TP,[2,,2]       ;POP TP
+       MOVEM   B,1(TB)
+       JRST    GODON
+
+NLCLGO:        CAME    A,$TTAG         ;CHECK TYPE
+       JRST    WTYP
+       MOVE    A,1(AB)         ;GET ARG
+       HRR     B,3(A)
+       HLL     B,OTBSAV(B)
+       HRRZ    C,B
+       CAIG    C,1(TP)
+       CAME    B,3(A)          ;CHECK TIME
+       JRST    ILLFRA
+       HLRZ    C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       HRR     TB,3(A)         ;GET NEW FRAME PTR
+       MOVE    A,1(A)          ;GET PLACE TO START
+       MOVEM   A,1(TB)         ;CLOBBER IT AWAY
+GODON: MOVE    A,(AB)
+       MOVE    B,1(AB)
+       JRST    CONTIN
+
+\f
+
+
+MFUNCTION TAG,SUBR
+       ENTRY   1
+       HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
+       CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM
+       JRST    WTYP
+       PUSHJ   P,PROGCH        ;CHECK PROG
+       PUSH    TP,A            ;SAVE VAL
+       PUSH    TP,B
+       MOVE    A,TPSAV(B)      ;GET STACK TOP
+       PUSH    TP,0(AB)
+       PUSH    TP,1(AB)
+       PUSH    TP,-1(A)
+       PUSH    TP,(A)
+       MCALL   2,MEMQ
+       JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR
+       MOVEM   A,-1(TP)        ;SAVE PLACE
+       EXCH    B,(TP)  
+       MOVEI   A,1(PVP)
+       HLRE    C,PVP
+       SUB     A,C
+       HRLI    A,TFRAME
+       PUSH    TP,A
+       HLL     B,OTBSAV (B)
+       PUSH    TP,B
+       MCALL   2,EVECTOR
+       MOVSI   A,TTAG
+       JRST    FINIS
+
+PROGCH:        MOVE    B,MQUOTE [LPROG ]INTERR
+       PUSHJ   P,ILVAL         ;GET VALUE
+       CAME    A,$TTB          ;CHECK TYPE
+       JRST    NXPRG
+       POPJ    P,
+
+MFUNCTION EXIT,SUBR
+       ENTRY   2
+       HLRZ    A,(AB)
+       CAIE    A,TACT
+       JRST    WTYP
+       MOVE    A,1(AB)
+       HRR     B,A
+       HLL     B,OTBSAV(B)
+       HRRZ    C,A
+       CAIG    C,1(TP)
+       CAME    A,B
+       JRST    ILLFRA
+       HLRZ    C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       HRR     TB,A
+       MOVE    A,2(AB)
+       MOVE    B,3(AB)
+       JRST    FINIS
+
+MFUNCTION COND,FSUBR
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP
+CLSLUP:        SKIPN   B,1(AB)         ;IS THE CLAUSELIST NIL?
+       JRST    IFALSE          ;YES -- RETURN NIL
+       HLRZ    A,(B)           ;NO -- GET TYPE OF CAR
+       CAIE    A,TLIST         ;IS IT A LIST?
+       JRST    BADCLS          ;
+       MOVE    A,1(B)          ;YES -- GET CLAUSE
+       JUMPE   A,BADCLS
+       PUSH    TP,(A)          ;EVALUATION OF
+       HLLZS   (TP)
+       PUSH    TP,1(A)         ;THE PREDICATE
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       CAMN    A,$TFALSE       ;IF THE RESULT IS
+       JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE
+       MOVE    C,1(AB)         ;IF NOT, GET
+       MOVE    C,1(C)          ;THE CLAUSE
+       HRRZ    C,(C)           ;GET ITS REST
+       JUMPE   C,FINIS         ;IF ONLY A PREDICATE --- RETURN ITS VALUE
+       PUSH    TP,$TLIST       
+       PUSH    TP,C            ;EVALUATE THE REST OF THE CLAUSE
+       JRST    DOPROG
+NXTCLS:        HRRZ    A,@1(AB)        ;SET THE CLAUSLIST
+       HRRZM   A,1(AB)         ;TO CDR OF THE CLAUSLIST
+       JRST    CLSLUP
+       
+IFALSE:
+       MOVSI   A,TFALSE        ;RETURN FALSE
+       MOVEI   B,0
+       JRST    FINIS
+
+
+\f
+
+;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
+;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS
+; ITS SECOND ARGUMENT.
+
+MFUNCTION SETG,SUBR
+       ENTRY   2
+       HLLZ    A,(AB)          ;GET TYPE OF FIRST ARGUMENT
+       CAME    A,$TATOM        ;CHECK THAT IT IS AN ATOM
+       JRST    NONATM          ;IF NOT -- ERROR
+       MOVE    B,1(AB)         ;GET POINTER TO ATOM
+       PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE
+       CAMN    A,$TUNBOUND     ;IF BOUND
+       PUSHJ   P,BSETG         ;IF NOT -- BIND IT
+       MOVE    C,B             ;SAVE PTR
+       MOVE    A,2(AB)         ;GET SECOND ARGUMENT
+       MOVE    B,3(AB)         ;INTO THE RETURN POSITION
+       MOVEM   A,(C)           ;DEPOSIT INTO THE 
+       MOVEM   B,1(C)          ;INDICATED VALUE CELL
+       JRST    FINIS
+
+BSETG: HRRZ    A,GLOBASE+1(TVP)
+       HRRZ    B,GLOBSP+1(TVP)
+       SUB     B,A
+       CAIL    B,6
+       JRST    SETGIT
+       PUSH    TP,GLOBASE(TVP)
+       PUSH    TP,GLOBASE+1 (TVP)
+       PUSH    TP,$TFIX
+       PUSH    TP,[0]
+       PUSH    TP,$TFIX
+       PUSH    TP,[100]
+       MCALL   3,GROW
+       MOVEM   A,GLOBASE(TVP)
+       MOVEM   B,GLOBASE+1(TVP)
+SETGIT:
+       MOVE    B,GLOBSP+1(TVP)
+       SUB     B,[4,,4]
+       MOVE    C,(AB)
+       MOVEM   C,(B)
+       MOVE    C,1(AB)
+       MOVEM   C,1(B)
+       MOVEM   B,GLOBSP+1(TVP)
+       ADD     B,[2,,2]
+       MOVSI   A,TLOCI
+       POPJ    P,
+
+\f
+
+
+;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
+;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.
+
+MFUNCTION SET,SUBR
+       ENTRY   2
+       HLLZ    A,(AB)          ;GET TYPE OF FIRST
+       CAME    A,$TATOM        ;ARGUMENT -- 
+       JRST    WTYP            ;BETTER BE AN ATOM
+       MOVE    B,1(AB)         ;GET PTR TO IT
+       PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
+       CAMN    A,$TUNBOUND     ;BOUND?
+       PUSHJ   P, BSET         ;BIND IT
+       MOVE    C,B             ;SAVE PTR
+       MOVE    A,2(AB)         ;GET SECOND ARG
+       MOVE    B,3(AB)         ;INTO RETURN VALUE
+       MOVEM   A,(C)           ;CLOBBER IDENTIFIER
+       MOVEM   B,1(C)
+       JRST    FINIS
+BSET:
+       HRRZ    A,TPBASE+1(PVP) ;GET ACTUAL STACK BASE
+       HRRZ    B,SPBASE+1(PVP) ;AND FIRST BINDING
+       SUB     B,A             ;ARE THERE 6
+       CAIL    B,6             ;CELLS AVAILABLE?
+       JRST    SETIT           ;YES
+       PUSH    TP,TPBASE(PVP)  ;NO -- GROW THE TP
+       PUSH    TP,TPBASE+1(PVP)        ;AT THE BASE END
+       PUSH    TP,$TFIX
+       PUSH    TP,[0]
+       PUSH    TP,$TFIX
+       PUSH    TP,[100]
+       MCALL   3,GROW
+       MOVEM   A,TPBASE(PVP)   ;SAVE RESULT
+       MOVEM   B,TPBASE+1(PVP)
+SETIT: MOVE    B,SPBASE+1(PVP)
+       MOVEI   A,-6(B)         ;MAKE UP BINDING
+       HRRM    A,(B)           ;LINK PREVIOUS BIND BLOCK
+       MOVSI   A,TBIND
+       MOVEM   A,-6(B)
+       MOVE    A,1(AB)
+       MOVEM   A,-5(B)
+       MOVSI   A,TLOCI
+       HRR     A,PROCID+1(PVP)
+       SUB     B,[6,,6]
+       MOVEM   B,SPBASE+1(PVP)
+       ADD     B,[2,,2]
+       POPJ    P,
+
+\f
+
+MFUNCTION NOT,SUBR
+       ENTRY   1
+       HLRZ    A,(AB)          ; GET TYPE
+       CAIE    A,TFALSE        ;IS IT FALSE?
+       JRST    IFALSE          ;NO -- RETURN FALSE
+
+TRUTH:
+       MOVSI   A,TATOM         ;RETURN T (VERITAS) 
+       MOVE    B,MQUOTE T
+       JRST    FINIS
+
+MFUNCTION ANDA,FSUBR,AND
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP            ;IF ARG DOESN'T CHECK OUT
+       SKIPN   C,1(AB)         ;IF NIL
+       JRST    TRUTH           ;RETURN TRUTH
+ANDLP:
+       JUMPE   C,FINIS         ;ANY MORE ARGS?
+       MOVEM   C,1(AB)         ;STORE CRUFT
+       PUSH    TP,(C)          ;EVALUATE THE
+       HLLZS   (TP)            ;FIRST REMAINING
+       PUSH    TP,1(C)         ;ARGUMENT
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       CAMN    A,$TFALSE       
+       JRST    FINIS           ;IF FALSE -- RETURN
+       HRRZ    C,@1(AB)        ;GET CDR OF ARGLIST
+       JRST    ANDLP
+
+MFUNCTION OR,FSUBR
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST         ;CHECK OUT ARGUMENT
+       JRST    WTYP
+       MOVE    C,1(AB)         ;PICK IT UP TO ENTER LOOP
+ORLP:
+       JUMPE   C,IFALSE        ;IF NO MORE OPTIONS -- FALSE
+       MOVEM   C,1(AB)         ;CLOBBER IT AWAY
+       PUSH    TP,(C)  
+       HLLZS   (TP)
+       PUSH    TP,1(C)         ;EVALUATE THE FIRST REMAINING
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;ARGUMENT
+       CAME    A,$TFALSE       ;IF NON-FALSE RETURN
+       JRST    FINIS
+       HRRZ    C,@1(AB)        ;IF FALSE -- TRY AGAIN
+       JRST    ORLP
+
+MFUNCTION FUNCTION,FSUBR
+       PUSH    TP,(AB)
+       PUSH    TP,1(AB)
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FUNCTION
+       MCALL   2,CHTYPE
+       JRST    FINIS
+
+\f
+
+MFUNCTION CLOSURE,SUBR
+       ENTRY
+       SKIPL   A,AB            ;ANY ARGS
+       JRST    ERRTFA          ;NO -- LOSE
+       ADD     A,[2,,2]        ;POINT AT IDS
+       PUSH    TP,$TAB
+       PUSH    TP,A
+       PUSH    P,[0]           ;MAKE COUNTER
+
+CLOLP: SKIPL   A,1(TB)         ;ANY MORE IDS?
+       JRST    CLODON          ;NO -- LOSE
+       PUSH    TP,(A)          ;SAVE ID
+       PUSH    TP,1(A)
+       PUSH    TP,(A)          ;GET ITS VALUE
+       PUSH    TP,1(A)
+       ADD     A,[2,,2]        ;BUMP POINTER
+       MOVEM   A,1(TB)
+       AOS     (P)
+       MCALL   1,VALUE
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,LIST          ;MAKE PAIR
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    CLOLP
+
+CLODON:        POP     P,A
+       ACALL   A,LIST          ;MAKE UP LIST
+       PUSH    TP,(AB)         ;GET FUNCTION
+       PUSH    TP,1(AB)
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,LIST          ;MAKE LIST
+       MOVSI   A,TFUNARG
+       JRST    FINIS
+
+
+MFUNCTION FALSE,SUBR
+       ENTRY
+       JUMPGE  AB,IFALSE
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP
+       MOVSI   A,TFALSE
+       MOVE    B,1(AB)
+       JRST    FINIS
+\f
+
+;ERROR COMMENTS FOR EVAL
+
+UNBOU: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE UNBOUND-VARIABLE
+       JRST    ER1ARG
+
+UNAS:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE UNASSIGNED-VARIABLE
+       JRST    ER1ARG
+
+TFA:
+ERRTFA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+       JRST    CALER1
+
+TMA:
+ERRTMA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+       JRST    CALER1
+
+BADENV:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-ENVIRONMENT
+       JRST    CALER1
+
+FUNERR:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-FUNARG
+       JRST    CALER1
+
+WRONGT:
+WTYP:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WRONG-TYPE
+       JRST    CALER1
+
+MPD:   PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
+       JRST    CALER1
+
+NOBODY:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE HAS-EMPTY-BODY
+       JRST    CALER1
+
+BADCLS:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-CLAUSE
+       JRST    CALER1
+
+NXTAG: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-EXISTENT-TAG
+       JRST    CALER1
+
+NXPRG: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NOT-IN-PROG
+       JRST    CALER1
+
+NAPT:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-APPLICABLE-TYPE
+       JRST    CALER1
+
+NONEVT:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-EVALUATEABLE-TYPE
+       JRST    CALER1
+
+
+NONATM:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
+       JRST    CALER1
+
+
+ILLFRA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
+       JRST    CALER1
+
+NOTIMP:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NOT-YEST-IMPLEMENTED
+       JRST    CALER1
+
+ILLSEG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ILLEGAL-SEGMENT
+       JRST    CALER1
+
+ER1ARG:        PUSH    TP,(AB)
+       PUSH    TP,1(AB)
+       MOVEI   A,2
+       JRST    CALER
+CALER1:        MOVEI   A,1
+CALER:
+       HRRZ    C,FSAV(TB)
+       PUSH    TP,$TATOM
+       PUSH    TP,@-1(C)
+       ADDI    A,1
+       ACALL   A,ERROR
+       JRST    FINIS
+  
+END
+***\f\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/filtrn.5 b/MUDDLE/filtrn.5
new file mode 100644 (file)
index 0000000..d78c405
--- /dev/null
@@ -0,0 +1,121 @@
+
+TITLE FILTRN
+
+TYIC==1
+TYOC==2
+INC==3
+
+A=1
+B=2
+C=3
+D=4
+E=5
+F=6
+G=7
+P=17
+
+NCHRS==60.
+
+BFLNT==200
+LPDL==40
+
+
+FILTRN:        MOVE    P,[-LPDL,,PDL]  ;GET A PDL
+       .OPEN   TYIC,[SIXBIT /  $TTY/]
+       .VALUE  [ASCIZ /:LOGOUT /]
+       .OPEN   TYOC,[SIXBIT /  %TTY/]
+       .VALUE  [ASCIZ /:LOGOUT /]
+
+       .IOT    TYOC,["\]       ;ACKNOLEDGE
+
+       MOVEI   B,4*6           ;PREPARE TO READ FILE STUFF
+       MOVE    A,[440600,,PTRF]        ;GET POINT BYTER
+
+GETIF: .IOT    TYIC,C
+       SUBI    C,40                    ;CONVERT TO SIXBIT
+       IDPB    C,A             ;INTO BUFFER
+       SOJN    B,GETIF         ;DO ALL CHARS
+
+       SKIPE   PTRF+3          ;SYSNAME GIVEN?
+       .SUSET  [.SSNAM,,PTRF+3]        ;NO USE CURRENT
+       MOVSI   A,6             ;GET BLOCK IMAGE INPUT MODE
+       HLLM    A,PTRF          ;AND CLOBBER IN
+
+       .OPEN   INC,PTRF                ;OPEN THE FILE
+       SKIPA   A,["/]          ;NEGATIVE ACK
+       MOVEI   A,"\                    ;POS ACKN
+
+       .IOT    TYOC,A                  ;SEND DOWN
+       CAIE    A,"\            ;SKIP IF A WIINER
+
+       .VALUE  [ASCIZ /:LOGOUT
+/]
+
+       .IOT    TYIC,A          ;WAIT FOR HIM TO RE-ACK
+       CAIE    A,"\
+       .VALUE  [ASCIZ /:LOGOUT /]
+
+
+NXTBB: MOVE    A,[-BFLNT,,BUFR]        ;SETUP ITO POINTER
+       .IOT    INC,A
+       MOVEI   B,6*BFLNT       ;NUMBER OF 6 BIT CHRS
+       JUMPGE  A,GOTIT         ;NOT EOF YET, JUMP
+       SETOM   EOF             ;AT END OF FILE
+       MOVEI   B,(A)           ;COMPUTE REMAINING
+       SUBI    B,BUFR
+       IMULI   B,6             ;CONVERT TO 6 BIT CHRS
+
+GOTIT: MOVE    C,[440600,,BUFR]        ;POINT TO BUFFER
+NXTB:  MOVEI   G,NCHRS         ;GET MAX MESSAGE LNT
+       CAIL    G,(B)           ;IF GRT THAN LEFT
+       MOVEI   G,(B)           ;USE REMAINS
+       SUBI    B,(G)           ;AND SHRINK TOTAL
+       ADDI    G,40            ;CONVERT TO ASCII
+       .IOT    TYOC,G
+       SUBI    G,40
+
+       MOVEI   D,0             ;INIT CHECKSUM
+
+LOOP:  ILDB    A,C             ;READ A CHAR
+       ADDI    D,(A)           ;UPDATE CKS
+       ADDI    A,40            ;CONV TO ASCII
+       .IOT    TYOC,A          ;TO NEXT MACHINE
+       SOJN    G,LOOP          ;COUNT DOWN
+
+       ANDI    D,77            ;CUT CKS
+       ADDI    D,40
+       .IOT    TYOC,D          ;SEND THE CKS
+       .IOT    TYIC,D          ;WAIT FOR ACK
+
+       CAIE    A,"\
+       .VALUE  [ASCIZ /:LOGOUT /]
+
+       JUMPN   B,NXTB          ;STILL MORE IN BUFFER
+
+       SKIPN   EOF
+       JRST    NXTBB           ;MORE IN FILE, READ IT
+
+       .IOT    TYOC,[40]               ;SEND EOF HACK
+
+       SETZM   EOF
+       .VALUE  [ASCIZ /:LOGOUT /]
+
+PTRF:  0
+       0
+       0
+       0
+
+BUFR:  BLOCK   BFLNT
+
+PDL:   BLOCK   LPDL
+
+EOF:   0
+FOO:
+0
+PAT:
+PATCH: BLOCK 30
+
+END FILTRN
+
+
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/flodyn.1 b/MUDDLE/flodyn.1
new file mode 100644 (file)
index 0000000..4afe42a
--- /dev/null
@@ -0,0 +1,89 @@
+               "DYNAMIC LOADER - USES 2 LIBRARY FILES AND RELATIVE ACCESS POINTERS"
+
+"Expects ERROR to have been SETGd to the proper thing.  See FLODYN bootstrapper."
+
+
+<BLOCK <SETG NDYN!- (<MOBLIST NDYN!- 37> <ROOT>)>>
+
+
+"Each library specification is a vector of four elements."
+
+<SETG MLIB <EVAL <SETG ULIB [  []              ;"Vector of PNAMEs"
+                               ![]             ;"Uvector of relative access pointers."
+                               #FALSE ()       ;"Channel to library."
+                               0               ;"Base of access." ]>>>
+
+"Library setup."
+
+<DEFINE NEWLIB OUTNEW (WHERE "AUX" (LIBVEC <IVECTOR 4>))
+       <PUT .LIBVEC 3 <OPEN "READ" !.WHERE>>
+       <COND (<3 .LIBVEC>
+               <PUT .LIBVEC 1 <READ '<EXIT .OUTNEW <ERROR NO-PNAME-VECTOR!-ERRORS NEWLIB>>
+                                     <3 .LIBVEC>>>
+               <PUT .LIBVEC 2 <READ '<EXIT .OUTNEW <ERROR NO-ACCESS-VECTOR!-ERRORS NEWLIB>>
+                                     <3 .LIBVEC>>>
+               <PUT .LIBVEC 4 <17 <3 .LIBVEC>>>)>
+       .LIBVEC>
+
+"Initializer."
+
+<DEFINE LIBINIT ()
+       <AND <3 ,ULIB> <NOT <0? <1 <3 ,ULIB>>>> <CLOSE <3 ,ULIB>>>
+       <SETG ULIB <NEWLIB ("NMUDLI")>>
+       <AND <3 ,MLIB> <NOT <0? <1 <3 ,MLIB>>>> <CLOSE <3 ,MLIB>>>
+       <SETG MLIB <NEWLIB ("NMUDLI" ">" "DSK" "MUDDLE")>>
+       "DONE">
+
+<LIBINIT>
+
+"Error checker. Calls dynamic loader."
+
+<SETG RERR <FUNCTION (TR)
+        <COND (<AND <==? 3 <LENGTH .TR>>
+                    <==? UNBOUND-VARIABLE!-ERRORS <1 .TR>>
+                    <==? VALUE <3 .TR>>
+                    <FLODYN <2 .TR>>>)
+             (ELSE <FORM REAL.ERROR !.TR>)>>>
+
+
+"Real dynamic loader."
+
+<DEFINE FLODYN (ATM "AUX" (PNAM <PNAME .ATM>) T1)
+       <COND (<AND <SET T1 <LOOKUP .PNAM <1 ,NDYN>>>
+                   <GASSIGNED? .T1>>
+               <EXIT .ERRACT <SETG .ATM ,.T1>>)
+             (<SET T1 <OR <DIRLOAD .PNAM '()>
+                          <SET T1 <LIBLOAD .PNAM ,ULIB>>
+                          <DIRLOAD .PNAM '("DSK" "MUDDLE")>
+                          <SET T1 <LIBLOAD .PNAM ,MLIB>>
+                          <SPECLOAD .ATM>>>
+               <COND (<GASSIGNED? .ATM> <EXIT .ERRACT ,.ATM>)
+                     (<ASSIGNED? .ATM> <EXIT .ERRACT ..ATM>)
+                     (ELSE <EXIT .ERRACT <SETG .ATM .T1>>)>)>>
+
+"Loader from directories."
+
+<DEFINE DIRLOAD (PN WHERE "AUX" (THERE <OPEN "READ" .PN ">" !.WHERE>))
+       <AND .THERE <LOAD .THERE> <CLOSE .THERE>>>
+
+"Loader from libraries"
+"Expects USEROB to have been given a GVAL by BOOT."
+
+<DEFINE LIBLOAD (PN LIBR "OPTIONAL" (ROBL ,USEROB) "AUX" TLS)
+       <COND (<AND <3 .LIBR> <NOT <0? <1 <3 .LIBR>>>> <SET TLS <MEMBER .PN <1 .LIBR>>>>
+               <ACCESS <3 .LIBR>
+                       <+ <4 .LIBR> <<- <LENGTH <1 .LIBR>> <LENGTH .TLS> -1> <2 .LIBR>>>>
+               <SET TLS <EVAL <READ '<ERROR OVERRAN-END-OF-FILE!-ERRORS LIBLOAD><3 .LIBR> .ROBL>>>
+               <COND (<==? <TYPE .TLS> ATOM> ,.TLS) (ELSE .TLS)>)>>
+
+<SETG SPECR ![PPRINF!- FRM!- PF!- TRACEF!- ]>
+
+<SETG SPECF <UVECTOR   ("TRACE" ">" "DSK" "MUDDLE")
+                       ("LF" ">" "DSK" "MUDDLE")
+                       ("FRAMES" ">" "DSK" "MUDDLE")
+                       ("PPRINT" ">" "DSK" "MUDDLE")>>
+
+<DEFINE SPECLOAD (ATM "AUX" (T <MEMQ .ATM ,SPECR>)) <AND .T <FLOAD !<<LENGTH .T> ,SPECF>>>>
+
+<ENDBLOCK>
+\f\ 3\f\ 3ð`Á\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ð`Á\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ð`Á\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
\ No newline at end of file
diff --git a/MUDDLE/fopen.63 b/MUDDLE/fopen.63
new file mode 100644 (file)
index 0000000..f1ae706
--- /dev/null
@@ -0,0 +1,545 @@
+TITLE OPEN - CHANNEL OPENER FOR MUDDLE
+
+RELOCATABLE
+
+;C. REEVE  JAN 1971
+
+.INSRT MUDDLE >
+
+;THIS PROGRAM HAS TWO ENTRIES.  FOPEN,FCLOSE AND FDELETE.
+;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM.
+
+;      FOPEN   - OPENS A FILE FOR EITHER READING OR WRITING.  IT TAKES
+;              FIVE OPTINAL ARGUMENTS AS FOLLOWS:
+
+;              FOPEN (<DIR>,<FILE NAME1>,<FILE NAME2>,<DEVICE>,<SYSTEM NAME>)
+;
+;              <DIR> - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ
+
+;              <FILE NAME1> - FIRST FILE NAME.  DEFAULT INPUT OR OUTPUT.
+
+;              <FILE NAME2> - SECOND FILE NAME.  DEFAULT MUDDLE.
+
+;              <DEVICE> - DEVICE FROM WHICH TO OPEN.  DEFAULT IS DSK.
+
+;              <SNAME> - SYSTEM (DIRECTORY) NAME. DEFAULT UNAME.
+
+;      FOPEN   RETURNS AN OBJECT OF TYPE CHANNEL IF IT SUCCEEDS OTHERWISE NIL
+
+
+;      FCLOSE  - CLOSES A FILE.  TAKES A CHANNEL OBJECT AS ITS ARGUMENT.  IT ALSO TAKES
+
+
+;A CHANNEL OBJECT IS A VECTOR CONTAINIG THE FOLLOWING INFORMATION
+
+;      CHANNO==1                       ;ITS I/O CHANNEL NUMBER.  0 MEANS NOT A REAL CHANNEL.
+;      DIRECT==3       ;DIRECTION (EITHER READ OR PRINT)
+;      DEVICE==5       ;DEVICE UPON WHICH THE CHANNEL IS OPEN
+;      NAME1==7        ;FIRST NAME OF FILE AS OPENED.
+;      NAME2==11       ;SECOND NAME OF FILE
+;      SNAME==13       ;DIRECTORY NAME
+;      RDEVIC==15      ;REAL DEVICE
+;      RNAME1=17       ;REAL FIRST NAME (AS RETURNED BY READING CHANNEL STATUS)
+;      RNAME2==21      ;REAL SECOND NAME
+;      RSNAME==23      ;SYSTEM OR DIRECTORY NAME
+;      STATUS==25      ;VARIOUS STATUS BITS
+;      IOINS==27       ;INSTRUCTION EXECUTED TO INPUT OR OUTPUT ONE CHARACTER
+;      ACCESS==31      ;ACCESS POINTER FOR RAND ACCESS
+;      RADX==33        ;RADIX FOR CHANNELS NUMBER CONVERSION
+;      *** THE FOLLOWING FIELDS FOR OUTPUT ONLY ***
+
+;      LINLN==35                       ;LENGTH OF A LINE IN CHARACTERS FOR THIS DEVICE
+;      CHRPOS==37      ;CURRENT POSITION ON CURRENT LINE
+;      PAGLN==41       ;LENGTH OF A PAGE
+;      LINPOS==43      ;CURRENT LINE BEING WRITTEN ON
+;      *** THE FOLLOWING FILEDS FOR INPUT ONLY ***
+
+;      EOFCND==35                      ;GETS EVALUATED  ON EOF
+;      LSTCHR==37      ;BACKUP CHARACTER
+;      BUFRIN==41      ;POINTER TO BUFFER FOR TTY FLAVOR DEVICES
+
+
+;CHANLNT==42   ;LENGTH OF A CHANNEL OBJECT
+
+;THIS IRP DEFINES THE FIELDS AT ASSEMBLY TIME
+
+       CHANLNT==1                      ;INITIAL CHANNEL LENGTH
+
+; BUILD A PROTOTYPE CHANNEL AND DEFINE FILEDS
+
+PROCHN:
+
+IRP A,,[[CHANNO,FIX],[DIRECT,CHSTR],[DEVICE,CHSTR],[NAME1,CHSTR],[NAME2,CHSTR]
+[SNAME,CHSTR],[RDEVIC,CHSTR],[RNAME1,CHSTR],[RNAME2,CHSTR],[RSNAME,CHSTR]
+[STATUS,FIX],[IOINS,FIX],[LINLN,FIX],[CHRPOS,FIX],[PAGLN,FIX],[LINPOS,FIX]
+[ACCESS,FIX],[RADX,FIX]]
+
+       IRP     B,C,[A]
+               B==CHANLNT
+               T!C,,0
+               0
+               .ISTOP
+               TERMIN
+       CHANLNT==CHANLNT+2
+TERMIN
+
+
+; EQUIVALANCES FOR INPUT CHANNELS
+
+EOFCND==LINLN
+LSTCH==CHRPOS
+BUFRIN==PAGLN
+
+;PRESET LINE LENGTH AND PAGE LENGTH
+
+ZZZ==. ;SAVE CURRENT LOCATION
+
+LOC PROCHN+RADX
+10.
+
+LOC PROCHN+LINLN
+TTYLNL                         ;USE TTY LINE LENGTH
+
+LOC PROCHN+PAGLN
+TTYPGL ;USE TTY PAGE LENGTH
+
+LOC ZZZ        ;RESET LOCATIN
+CHANLNT==CHANLNT-1
+
+
+INBIT==0       ;LH BITS FOR INPUT
+OUTBIT==1      ;AND FOR OUTPUT
+
+;PAGE AND LINE LENGTH FOR TTY
+
+TTYLNL==80.
+TTYPGL==60.
+
+;DEFINE VARIABLES ASSOCIATED WITH TTY BUFFERS
+
+IRP A,,[IOIN2,ECHO,CHRCNT,ERASCH,KILLCH,BRKCH,ESCAP,SYSCHR,BRFCHR,BYTPTR]
+A==.IRPCNT
+TERMIN
+
+EXTBFR==BYTPTR+1+<100./5>      ;LENGTH OF ADD'L BUFFER
+
+
+
+
+.GLOBAL IPNAME,OPEN,CLOSE,IOT,ILOOKU,6TOCHS,ICLOS,OCLOS
+.GLOBAL OPNCHN,CHMAK,READC,TYO,RADX,SYSCHR,BRFCHR,LSTCH
+.GLOBAL CHRWRD
+
+.GLOBAL DISOPN,DISCLS,DCHAR,DISLNL,DISPGL,CHANL0,BUFRIN,IOIN2
+.GLOBAL ECHO,ERASCH,KILLCH,BRKCH,BYTPTR,SYSCHR,CHRCNT,ESCAP
+
+\f;SUBROUTINE TO DO OPENING BEGINS HERE
+
+MFUNCTION FOPEN,SUBR,[OPEN]
+
+       ENTRY
+       PUSHJ   P,MAKCHN        ;MAKE THE CHANNEL
+       PUSHJ   P,OPNCHN        ;NOW OPEN IT
+       JRST    FINIS
+
+; SUBROUTINE TO JUST CREATE A CHANNEL
+
+MFUNCTION CHANNEL,SUBR
+
+       ENTRY
+       PUSHJ   P,MAKCHN
+       JRST    FINIS
+;INTERNAL CHANNEL CREATOR
+
+
+MAKCHN:
+
+; CYCLE THROUGH THE GIVEN ARGUMENTS
+
+       MOVSI   A,-5            ;NUMBER OF ARGUMENTS INTO A
+ARGLP: JUMPGE  AB,ARGDON       ;IF AB>=0, NO MORE ARGS
+       HLRZ    C,(AB)          ;CHECK THE TYPE
+       CAIN    C,TCHRS         ;MUST BE AN CHRS
+       JRST    ARGWIN
+       CAIE    C,TCHSTR
+       JRST    WRONGT
+ARGWIN:        PUSH    TP,(AB)         ;NOW TO TEMPS
+       PUSH    TP,1(AB)
+       ADD     AB,[2,,2]       ;BUMP ARGG POINTER
+       AOBJN   A,ARGLP         ;CYCLE
+
+;NOW PUSH ANY MORE GOODIES FOR DEFAULTS
+
+ARGDON:
+       MOVEI   A,(A)           ;GET NUMBER DONE
+       CAIN    A,5             ;FINISHED?
+       JRST    GETCHN          ;YES
+       LSH     A,1
+       CAIE    A,2             ;WASONLY DIRECTION GIVEN?
+       JRST    DFLTAB(A)       ;NO
+       MOVEI   B,-1(TP)        ;PICK UP DIRECTION
+       PUSHJ   P,CHRWRD        ;GET WORD
+       JRST    WRONGT
+       CAMN    B,CHQUOTE READ
+       JRST    DFLTB1          ;YES,GO PUSH 'INPUT'
+       PUSH    TP,$TCHSTR
+       PUSH    TP,CHQUOTE OUTPUT
+       JRST    DFLTB2
+
+DFLTAB:        PUSH    TP,$TCHSTR      ;DEFAULT DIRECTION
+       PUSH    TP,CHQUOTE READ
+DFLTB1:        PUSH    TP,$TCHSTR      ;DEFAULT NAME1
+       PUSH    TP,CHQUOTE INPUT
+DFLTB2:        PUSH    TP,$TCHSTR      ;DEFAULT NAME2
+       PUSH    TP,CHQUOTE MUDDLE
+       PUSH    TP,$TCHSTR      ;DEFAULT DEVICE
+       PUSH    TP,CHQUOTE DSK
+       .SUSET  [.RSNAM,,A]
+       PUSHJ   P,6TOCHS
+       PUSH    TP,A
+       PUSH    TP,B            ;AND DEFAULT SYS NAME
+
+GETCHN:        PUSH    TP,$TFIX        ;SETUP CALL TO VECTOR
+       PUSH    TP,[CHANLN_-1]
+       MCALL   1,VECTOR        ;GO GET STORAGE
+       HRLI    C,PROCHN        ;SETUP FOR BLT
+       HRRI    C,(B)
+       BLT     C,CHANLNT-1(B)  ;BLT IN THE TYPES
+       MOVE    A,(TB)          ;GET TYPE
+       MOVEM   A,DIRECT-1(B)   ;AND CLOBBER
+       MOVE    A,1(TB)         ;GET THE DIRECTION
+       MOVEM   A,DIRECT(B)     ;STORE IT
+       MOVE    A,2(TB)         ;TYPE FIRST
+       MOVEM   A,NAME1-1(B)
+       MOVEM   A,RNAME1-1(B)
+       MOVE    A,3(TB)         ;GET NAME1
+       MOVEM   A,NAME1(B)
+       MOVEM   A,RNAME1(B)     ;ALSO REAL NAME 1
+       MOVE    A,4(TB)         ;TYPE
+       MOVEM   A,NAME2-1(B)
+       MOVEM   A,RNAME2-1(B)
+       MOVE    A,5(TB)         ;MAME 2
+       MOVEM   A,NAME2(B)
+       MOVEM   A,RNAME2(B)     ;ALSO REAL NAME 2
+       MOVE    A,6(TB)
+       MOVEM   A,DEVICE-1(B)
+       MOVEM   A,RDEVICE-1(B)
+       MOVE    A,7(TB)         ;GET DEVICE NAME
+       MOVEM   A,DEVICE(B)
+       MOVEM   A,RDEVIC(B)
+       MOVE    A,10(TB)
+       MOVEM   A,SNAME-1(B)
+       MOVEM   A,RSNAME-1(B)
+       MOVE    A,11(TB)        ;FINALLY UNAME
+       MOVEM   A,SNAME(B)
+       MOVEM   A,RSNAME(B)
+       SUB     TP,[10.,,10.]   ;GARBAGE COLLECT TP
+       MOVSI   A,TCHAN         ;MAKE TYPE INTO CHANNEL
+       POPJ    P,              ;RETURN
+
+\f;OPEN THE CHANNEL POINTED TO BY B
+
+OPNCHN:        PUSH    TP,$TCHAN       ;SAVE THE CHANNEL
+       PUSH    TP,B
+       MOVEI   B,DIRECT-1(B)   ;POINT TO DIRECTION
+       PUSHJ   P,CHRWRD        ;PUT INTO A WORD
+       JFCL
+       MOVE    E,B             ;TO E
+       MOVE    B,(TP)
+       MOVE    A,DEVICE-1(B)   ;GET DEVICE
+       MOVE    B,DEVICE(B)
+       PUSHJ   P,STRTO6        ;CONVERT TO 6-BIT
+       HLRZS   A,(P)           ;DEVICE TO RH
+       CAIN    A,(SIXBIT /E&S/)        ;DISPLAY HACK?
+       JRST    DISCHK          ;YES, GO HACK
+       MOVE    B,(TP)          ;RESTORE B
+       MOVE    A,NAME1-1(B)    ;TYPE OF NAME1
+       MOVE    B,NAME1(B)      ;GET THE FIRST NAME
+       PUSHJ   P,STRTO6        ;TO 6-BIT
+       MOVE    B,(TP)          ;RESTORE B
+       MOVE    A,NAME2-1(B)
+       MOVE    B,NAME2(B)      ;SECOND NAME
+       PUSHJ   P,STRTO6        ;ALSO TO 6 BIT
+       MOVE    B,(TP)
+       MOVSI   A,INBIT         ;GET BIT FOR INPUT OPEN
+       CAME    E,[ASCII /READ/]        ;REALLY INPUT?
+       MOVSI   A,OUTBIT        ;NO GET OUTPUT BIT
+       IORM    A,-2(P)         ;INTO OPEN STUFF
+       MOVE    A,SNAME-1(B)
+       MOVE    B,SNAME(B)      ;GOBBLE SNAME
+       PUSHJ   P,STRTO6        ;6 BIT
+       POP     P,A             ;RESTORE RESULT
+       .SUSET  [.SSNAM,,A]     ;SET THE SYSTEM NAME
+       MOVEI   A,-2(P)         ;POINT TO OPEN BLOCK
+       PUSHJ   P,OPEN          ;DO THE OPEN
+       JRST    OPNFAI          ;OPEN FAILED, LOSE
+       MOVE    B,(TP)          ;RESTORE B
+       PUSHJ   P,DOSTAT        ;GOBBLE THE STATUS
+       LDB     C,[600,,STATUS(B)]      ;GOBBLE STATUS
+       CAMN    E,[ASCII /PRINT/]
+       CAIE    C,2             ;SKIP IF DATAPOINT CROCK
+       JRST    OPNCH2          ;NOT SAME FOR OUTPUT
+
+       PUSHJ   P,CLOSE         ;CLOSE THE FILE
+       MOVSI   A,OUTBIT+20     ;AND RE-OPEN IN DISPLAY MODE
+       HLLM    A,-2(P)
+       MOVEI   A,-2(P)         ;POINT TO OPEN BLOCK
+       PUSHJ   P,OPEN          ;NOW OPEN THE DEVICE
+       JRST    OPNFAI          ;CANT OPEN
+
+OPNCH2:        SUB     P,[3,,3]        ;REMOVE OPEN BLOCK
+       MOVEM   A,CHANNO(B)     ;RESTORE CHANNEL NUMBER
+       MOVEI   D,(A)           ;COPY CHANNEL NO.
+       LSH     D,1
+       ADDI    D,CHANL0+1(TVP) ;POINT TO THIS CHANNELS TV ENTRY
+       MOVEM   B,(D)
+       HRLZS   A               ;CHANNEL NO. TO LH
+       MOVE    C,A             ;COPY TO C
+       ROT     C,5             ;INTO C'S AC FILED
+       IOR     C,[.IOT 0,A]    ;AND AN I/O INSTRUCTION
+       MOVEM   C,IOINS(B)      ;SAVE IN CHANNEL
+; THIS CODES SETS THE 'REAL' NAMES, DEVICES AND SNAMES
+
+       HRRI    A,1(P)          ;POINT INTO P
+       MOVEI   C,(A)           ;C ALSO POINTS
+       ADD     P,[5,,5]        ;ALLOCATE SOME P
+       JUMPGE  P,[.VALUE [ASCIZ 'P/']] ;DIE ON PDL LOSSAGE
+       .RCHST  A,              ;READ THE STATUS
+       HRLZS   (C)             ;FOR NOW KILL LH OF DEVICE
+       HRLI    C,-5            ;5 GOODIES
+       PUSH    P,C
+       PUSH    P,[0]           ;USED AS A COUNTER
+NXTREL:        MOVEM   C,-1(P)         ;SAVE C
+       SKIPN   A,(C)           ;WAS THIS ONE GIVEN?
+       JRST    NXTLOK          ;NO, SKIP CHANGE
+       PUSHJ   P,6TOCHS        ;YES, MAKE INTO ATOM
+       MOVEI   C,RDTBL         ;FIND OUT WHERE
+       ADD     C,(P)           ;FOR THIS ONE
+       MOVE    C,(C)           ;NOW HAVE TH OFFSET TO USE
+       ADD     C,(TP)          ;ADD TO POINTER
+       MOVEM   A,-1(C)
+       MOVEM   B,(C)           ;CLOBBER THE NEW ATOM IN
+       MOVE    C,-1(P)         ;RESTORE C
+NXTLOK:        AOS     (P)             ;COUNT THE GOODIES
+       AOBJN   C,NXTREL
+
+       SUB     P,[7,,7]        ;GC ON P
+
+; DETERMIN EIF THIS IS A TTY FLAVOR DEVICE
+
+       MOVE    B,(TP)          ;RESTORE CHANEL POINTER
+       MOVE    A,STATUS(B)     ;GET STATUS
+       ANDI    A,77            ;ISOLATE DEVICE SPEC
+       CAMN    E,[ASCIZ /READ/]
+       CAILE   A,2             ;NOT A TTY, NO FURTHER ACTION
+       JRST    OPNRET
+
+       PUSH    TP,$TFIX        ;CALL UVECTOR FOR BUFFER
+       PUSH    TP,[EXTBFR]
+       MCALL   1,UVECTOR       ;GET VECTOR
+       MOVE    C,[PUSHJ P,READC]       ;GET NEW IOINS
+       MOVE    D,(TP)          ;RESTORE CHANNEL POINTER
+       EXCH    C,IOINS(D)      ;STORE NEW ONE AND GE OLD
+       MOVEM   C,IOIN2(B)      ;STORE
+       MOVEM   B,BUFRIN(D)     ;STORE IN CHANNEL
+       MOVSI   A,TUVEC         ;MAKE SURE TYPE IS UNIFORM VECTOR
+       MOVEM   A,BUFRIN-1(D)
+       MOVEI   A,177           ;SET ERASER TO RUBOUT
+       MOVEM   A,ERASCH(B)
+       SETOM   KILLCH(B)       ;NO KILL CHARACTER NEEDED
+       MOVEI   A,33            ;BREAKCHR TO C.R.
+       MOVEM   A,BRKCH(B)
+       MOVEI   A,"\            ;ESCAPER TO \
+       MOVEM   A,ESCAP(B)
+       MOVE    A,[010700,,BYTPTR(B)]   ;RELATIVE BYTE POINTER
+       MOVEM   A,BYTPTR(B)
+       MOVEI   A,14            ;BARF BACK CHARACTER FF
+       MOVEM   A,BRFCHR(B)
+
+OPNRET:        POP     TP,B            ;GET CHANNEL POINTER BACK
+
+       POP     TP,A            ;RESTORE TYPE OF CHANNEL
+       POPJ    P,
+
+
+;TABLE USED TO DO THE 'REAL GOODIES'
+
+RDTBL: RDEVIC
+       RNAME1
+       RNAME2
+       RSNAME
+       ACCESS
+
+
+;HERE TO DO STATUS FOR OPEN LOSSAGE ETC.
+
+DOSTAT:        PUSH    P,A             ;SAVE CHANNEL
+       ROT     A,23.           ;INTO AC FILED
+       IOR     A,[.STATUS STATUS(B)]   ;GOBBLE THE STATUS
+       XCT     A               ;DO IT
+       POP     P,A
+       POPJ    P,
+
+
+;MAKE THE DISPLAY DEVICE  A PSEUDO DEVICE HANDLED BY "DCHAR" ROUTINE
+DISCHK:        SUB     P,[1,,1]        ;POP OFF JUNK
+       MOVE    B,(TP)          ;GET POINTER TO CHANNEL
+       SETZM   CHANNO(B)       ;A PSEUDO CHANNEL NUMBER
+       MOVE    C,[PUSHJ  P,DCHAR]
+       MOVEM   C,IOINS(B)      ;GO TO THIS ROUTINE TO HANDLE I/O
+       MOVEI   C,DISLNL
+       MOVEM   C,LINLN(B)
+       MOVEI   C,DISPGL
+       MOVEM   C,PAGLN(B)
+       PUSHJ   P,DISOPN        ;GO INITIALIZE THE DISPLAY
+       JRST    OPNFAI
+       JRST    OPNRET
+\f
+;ARRIVE HERE IF FOPEN CALLED WITH WRONG TYPES OF ARGUMENTS
+
+WRONGT:        PUSH    TP,$TATOM       ;SET UP CALL TO ERROR
+       PUSH    TP,MQUOTE WRONG-TYPE
+       JRST    CALER1
+
+
+;THIS ROTINE CONVERTS MUDDLE CHARACTER STRINGS TO SIXBIT FILE NAMES
+STRTO6:        PUSH    TP,A
+       PUSH    TP,B
+       PUSH    P,E             ;SAVE USEFUL FROB
+       MOVEI   E,-1(A)         ;GET END+1 OF TCHSTR
+       HLRZS   A               ;CHECK THE TYPE(ONE WORD OR VECTOR)
+       CAIE    A,TCHRS         ; IS IT ONE WORD?
+       JRST    CHREAD          ;NO
+       MOVEI   B,(TP)          ;YES, CREATE DUMMY VECTOR POINTER
+       HRLI    B,350700
+       MOVEI   E,1(TP)         ;AND DUMMY VECTOR END+1
+CHREAD:        MOVEI   A,0             ;INITIALIZE OUTPUT WORD
+       MOVE    D,[440600,,A]   ;AND BYTE POINTER TO IT
+       LDB     0,B             ;PICK UP FIRST CHARACTER
+NEXCHR:
+       JUMPE   0,SIXDON        ;IF NULL, WE ARE FINISHED
+       CAIL    0,141           ;IF IT IS GREATER OR EQUAL TO LOWER A
+       CAILE   0,172           ;BUT LESS THAN OR EQUAL TO LOWER Z
+       JRST    .+2             ;THEN
+       SUBI    0,40            ;CONVERT TO UPPER CASE
+       SUBI    0,40            ;NOW TO SIX BIT
+       JUMPLE  0,BAD6          ;CHECK FOR A WINNER
+       CAILE   0,77
+       JRST    BAD6
+       IDPB    0,D             ;DEPOSIT INTO SIX BIT
+       TRNE    A,77            ;IS OUTPUT FULL
+       JRST    SIXDON          ;YES, LEAVE
+       ILDB    0,B             ;GET NEXT CHAR AND INC POINTER
+       HRRZ    C,B             ;GET ADDRESS PART OF BYTE POINTER
+       CAME    C,E             ;HAS POINTER REACHED LIMIT?
+       JRST    NEXCHR          ;NO, GOBBLE NEXT CHARACTER
+SIXDON:        SUB     TP,[2,,2]       ;FIX UP TP
+       POP     P,E
+       EXCH    A,(P)           ;LEAVE RESULT ON P-STACK
+       JRST    (A)             ;NOW RETURN
+
+
+;SUBROUTINE TO CONVERT SIXBIT TO ATOM
+
+6TOCHS:        PUSH    P,E
+       MOVEI   B,6             ;MAX NUMBER OF CHARACTERS
+       PUSH    P,[0]           ;STRING WILL GO ON P SATCK
+       MOVEI   E,-1(P)         ;WILL BE BYTE POINTER
+       HRLI    E,10700         ;SET IT UP
+       PUSH    P,[0]           ;SECOND POSSIBLE WORD
+       MOVE    D,[440600,,A]   ;INPUT BYTE POINTER
+6LOOP: ILDB    0,D             ;START CHAR GOBBLING
+       JUMPE   0,GETATM        ;IF ZERO, FINISHED
+       ADDI    0,40            ;CHANGET TOASCII
+       IDPB    0,E             ;AND STORE IT
+       SOJG    B,6LOOP         ;KEEP LOOKING
+       PUSH    P,[2]           ;IF ARRIVE HERE, STRING IS 2 WORDS
+       JRST    .+2
+GETATM:        AOS     (P)             ;SET STRING LENGTH=1
+       PUSHJ   P,CHMAK         ;MAKE A MUDDLE STRING
+       POP     P,E
+       POPJ    P,
+
+\f
+;HERE IF OPEN FAILS
+
+OPNFAI:        MOVE    B,(TP)          ;RESTORE CHANNEL POINTER
+       SETOM   STATUS(B)       ;SET TO -1
+       JUMPL   A,.+2           ;A<0 MEANS NO CHANNELS
+       PUSHJ   P,DOSTAT        ;GOBBLE STATUS
+       SUB     TP,[2,,2]       ;PATCH UP TP
+       SUB     P,[3,,3]        ;REMOVE CRAP
+RETNIL:        MOVSI   A,TFALSE        ;RETURN A FALSE
+       MOVEI   B,0
+       POPJ    P,
+
+;ERROR FOR BAD CHARACTER IN SIX BIT STRING
+
+BAD6:  PUSH    TP,$TATOM       ;SETUP ERROR CALL
+       PUSH    TP,MQUOTE FILE-NAME-NOT-6-BIT
+       JRST    CALER1
+
+
+; FUNCTION TO LIST ALL CHANNELS
+
+MFUNCTION CHANLIST,SUBR
+
+       ENTRY   0
+
+       MOVEI   A,16.           ;MAX # OF CHANNELS
+       MOVEI   C,0
+       MOVEI   B,CHANL0(TVP)   ;POINT TO FIRST
+
+CHNLP: SKIPN   1(B)            ;OPEN?
+       JRST    NXTCHN          ;NO, SKIP
+       PUSH    TP,(B)
+       PUSH    TP,1(B)
+       ADDI    C,1             ;COUNT WINNERS
+NXTCHN:        ADDI    B,2
+       SOJN    A,CHNLP
+
+       ACALL   C,LIST
+       JRST    FINIS
+
+\f
+;THIS PROGRAM CLOSES THE SPECIFIED CHANNEL
+
+MFUNCTION FCLOSE,SUBR,[CLOSE]
+
+       ENTRY   1               ;ONLY ONE ARG
+       HLRZ    A,(AB)          ;CHECK ARGS
+       CAIE    A,TCHAN         ;IS IT A CHANNEL
+       JRST    WRONGT
+       MOVE    B,1(AB)         ;PICK UP THE CHANNEL
+       CLEARM  IOINS(B)        ;CLOBBER THE IO INS
+       MOVEI   B,DEVICE-1(B)   ;GE THE NAME OF THE DEVICE
+       PUSHJ   P,CHRWRD
+       JFCL
+       MOVE    A,B
+       MOVE    B,1(AB)
+       CAMN    A,[ASCIZ /TTY/] ;IS IT THE TTY?
+       JRST    TTYCLS          ;YES, DO SPECIAL  HACK
+       CAMN    A,[ASCIZ /DIS/]
+       PUSHJ   P,DISCLS        ;GO RELEASE THE DISPLAY SPACE
+       SKIPE   A,CHANNO(B)     ;IS THERE A CHANNEL NO.?
+       PUSHJ   P,CLOSE         ;YES, CLOSE IT
+CFIN:  SKIPN   A,CHANNO(B)     ;ANY CHANNEL?
+       JRST    CFIN2
+       LSH     A,1
+       ADDI    A,CHANL0+1(TVP) ;POINT TO THIS CHANNELS LSOT
+       SETZM   CHANNO(B)
+       SETZM   (A)             ;AND CLOBBER IT
+CFIN2: MOVSI   A,TCHAN         ;RETURN THE CHANNEL
+       JRST    FINIS
+
+TTYCLS:        MOVE    A,DIRECT(B)     ;GET THE DIRECTION OF THE CHANNEL
+       CAMN    A,CHQUOTE READ, ;IS IT READ
+       PUSHJ   P,ICLOS         ;YES, CLOSE THAT
+       CAMN    A,CHQUOTE PRINT,        ;IS IT PEINT
+       PUSHJ   P,OCLOS         ;YES CLOSE TTY OUT CHANNEL
+       JRST    CFIN
+
+
+END
+
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/graphs.ura001 b/MUDDLE/graphs.ura001
new file mode 100644 (file)
index 0000000..20a73fc
--- /dev/null
@@ -0,0 +1,227 @@
+         
+\r<SET FNCTG <FUNCTION (XL XH FNCT "OPTIONAL" (SCALE (0 0)) (XYDIS (0 0))
+\r    (P 60) );"THIS FUNCTION WILL PLOT ANY FUNCTION OF THE FORM
+\r              Y=F(X),FOR X = .XL TO .XH WITH P POINTS IN IT.
+\r              SCALE,XYDIS, AND P ARE OPTIONAL, AND IF OMITTED
+\r              THE PROGRAM WILL AUTOMATICALLY SCALE F(X)."
+\r    <PROG (X Y DX X1 YM HPTS N SX SY)
+\r        <SET DX </ <FLOAT <- .XH .XL>> .P>> <SET X1 .XL>
+\r        <SET X <SET Y ()>>
+\r     LFX <SET X (!.X .X1)>
+\r        <SET Y (!.Y <.FNCT .X1>)>
+\r        <SET X1 <+ .X1 .DX>>
+\r        <COND (<NOT <G? .X1 .XH>> <GO LFX>)>
+\r        <COND (<NOT <==? <+ !.SCALE> 0>> <SET HPTS .XYDIS>
+\r            <GO NAS>)>
+\r        <SET YM <MINIMAX .Y>>
+\r        <SET SCALE (</ 800.0 <- .XH .XL>> </ -800.0 <- !.YM>>)>
+\r        <SET HPTS (<* 0.5 <+ .XL .XH>> <* 0.5 <+ !.YM>>)>
+\r    NAS <SET N 1>
+\r    LSC <PUT .X .N <FIX <+ <* <1 .SCALE> <- <.N .X> <1 .HPTS> >>
+\r           500>>>
+\r       <PUT .Y .N <FIX <+ <* <2 .SCALE> <- <.N .Y> <2 .HPTS> >>
+\r           400>>>
+\r        <SET N <+ .N 1>>
+\r         <COND (<NOT <G? .N <LENGTH .X>>> <GO LSC>)>
+\r         <PLOTV .X .Y>
+\r         <COND ( <NOT <G? 100 <SET SX <FIX <+ <* <1 .SCALE>
+\r              <- 0.0 <1 .HPTS>>> 500>>> >>
+\r                  <COND ( <NOT <G? .SX 900>> <LINE .SX 00 .SX 800> )> )>
+\r         <COND ( <NOT <G? 0 <SET SY <FIX <+ <* <2 .SCALE>
+\r              <- 0.0 <2 .HPTS>>> 400>>> >>
+\r                  <COND ( <NOT <G? .SY 800 >> <LINE 100 .SY 900 .SY> )> )>
+\r         <MOVE 0 800>
+\r         <RETURN ("XMIN
+\r" .XL "
+\rXMAX
+\r" .XH "
+\rYMIN
+\r" <1 .YM> "
+\rYMAX
+\r" <2 .YM> "
+\rSCALE
+\r" .SCALE )>
+\r>>>
+\r<SET MINIMAX <FUNCTION (X)
+\r    <REPEAT ((N 2) (L <LENGTH .X>) (BIG <1 .X>) (SMALL <1 .X>))
+\r       <COND ( <G? <.N .X> .BIG> <SET BIG <.N .X>> )>
+\r       <COND ( <L? <.N .X> .SMALL> <SET SMALL <.N .X>> )>
+\r       <SET N <+ .N 1>>
+\r       <COND ( <G? .N .L> <RETURN (.SMALL .BIG)> )>
+\r>>>
+\r<SET MTRIANGLE <FUNCTION ()
+\r    <MOVE 170 285><DRAW 170 650><DRAW 200 670>
+\r    <DRAW 515 485><DRAW 515 450><DRAW 200 260>
+\r    <DRAW 170 285>
+\r
+\r    <DRAW 200 300><DRAW 200 670><MOVE 200 630>
+\r    <DRAW 515 450><MOVE 480 470><DRAW 480 505>
+\r    <MOVE 480 470><DRAW 200 300><DRAW 230 280>
+\r
+\r    <MOVE 235 360><DRAW 235 605><MOVE 235 570>
+\r    <DRAW 445 445><MOVE 410 465><DRAW 200 340>
+\r
+\r    <MOVE 0 200> "MOBIUS TRANGLE"
+\r>>
+\r
+\r<SET ELIPSE <FUNCTION (X Y A B P) ;"THIS FUNCTION WILL DRAW AN
+\r                                    ELIPSE WITH CENTER AT (X Y)
+\r                                    ,(A B),AND P POINTS IN IT."
+\r     <PROG (I)
+\r        <MOVE <+ .X .A > .Y>
+\r        <SET I </ 6.283 .P>>
+\r        <REPEAT ((Q .I))
+\r            <DRAW <FIX <+ .X <* .A <COS .Q>>>>
+\r                  <FIX <+ .Y <* .B <SIN .Q>>>>>
+\r            SET Q <+ .Q .I>>
+\r            <COND ( <G? .Q <+ .I  6.283>> <RETURN "DONE"> )>
+\r>>>><SET CIRCLE <FUNCTION (X Y R P) ;"THIS FUNCTION WILL DRAW
+\r                                   A CIRLE WITH CENTER AT (X Y)
+\r                                  ,RADIUS R,AND P POINTS IN IT."
+\r   <PROG (I)
+\r       <MOVE <+ .X .R> .Y>
+\r       <SET I </ 6.283 .P>>
+\r       <REPEAT ((Q .I))
+\r           <DRAW <FIX <+ .X <* .R <COS .Q>>>>
+\r                 <FIX <+ .Y <* .R <SIN .Q>>>>>
+\r           <SET Q <+ .Q .I>>
+\r           <COND ( <G? .Q <+ .I 6.283>>  <RETURN "DONE"> )>
+\r>>>>
+\r<SET PLVTEST <FUNCTION ()
+\r    <PROG (X Y XY)
+\r    <SET X ( <+ 500 <1 <WITCH .2>>> )>
+\r        <SET Y ( <2 <WITCH .2>> )>
+\r        <LINE 0 0 1000 0>
+\r        <LINE 500 0 500 800>
+\r        <REPEAT ((P .2))
+\r            <SET XY <WITCH .P>>
+\r            <SET X ( !.X <1 .XY> )>
+\r            <SET Y (!.Y <2 .XY>)>
+\r            <SET P <+ .P .04>>
+\r            <COND ( <G? .P 2.9> <RETURN <PLOTV .X .Y>>)>
+\r>>>>
+\r<SET WITCH <FUNCTION (P)
+\r    ( <FIX <+ 500 <* 100.0 </ <COS .P> <SIN .P>>>>> 
+\r      <FIX <* 200.0 <- 1.0 <COS <* 2.0 .P>>>>> )
+\r>>
+\r<SET PLOTV <FUNCTION (X Y) "THIS FUNCTION PLOTS VECTOR X AGAINST
+\r                             VECTOR Y,IT WORKS FOR LISTS TOO.
+\r                             IT MOVES TO THE FIRST POINT AND DRAWS
+\r                             TO THE REST."
+\r    <PROG (L LIST N)
+\r        <COND ( <NOT <==? <LENGTH .X> <LENGTH .Y>>>
+\r            <RETURN "ERROR...LENGTHS NOT EQUAL."> )>
+\r        <SET L <LENGTH .X>>
+\r        <SET LIST (29)>
+\r        <SET N 1>
+\r LOOP   <SET LIST (!.LIST !<TRANS <.N .X> <.N .Y>> )>
+\r        <SET N <+ .N 1>>
+\r        <COND ( <G? .N .L>
+\r            <GO ZAP>)>
+\r        <GO LOOP>
+\r  ZAP   <SEND .LIST>
+\r        <RETURN "DONE">
+\r>>>
+\r<SET SINCURV <FUNCTION ()
+\r                        <MOVE 0 400>
+\r                       <REPEAT ((X 0)<F <* 400.0 <+ 1.0
+\r                                       <SIN </ .X 100.0>>>>>>
+\r                                       <COND (<G? .X 625> <RETURN
+\r                                       "DONE"> )> <SET X <+ .X 5>>
+\r>>>
+\r<SET TEST3 <FUNCTION ()
+\r                      <LINE 0 0 0 800>
+\r                      <LINE 0 400 1000 400>
+\r                      <TEST>
+\r                      <SINCURV>
+\r>>
+\r<SET MOVE <FUNCTION (X Y) ;"THIS FUNCTION WILL MOVE THE BEAM
+\r                             OF THE SCOPE TO (X Y). IT MUST BE CALLED
+\r                             BEFORE DRAW BECAUSE IT SETS THE SCOPE IN
+\r                             GRAPHICS MODE."
+\r                     <SEND (29 !<TRANS .X .Y> )>
+\r>>
+\r
+\r<SET DRAW <FUNCTION (X Y) ;"THIS FUNCTION DRAWS FROM WHERE THE BEAM
+\r                           WAS TO (X Y).MOVE MUST BE USED BEFORE THE
+\r                           FIRST DRAW, ALSO DON'T GO BACK INTO
+\r                           ALPHA MODE INBETWEEN DRAWS."
+\r                    <SEND <TRANS .X .Y>>
+\r>>
+\r<SET TEST2 <FUNCTION () <PROG (X Y Z)
+\r                               <SET Z <LINE 300 0 700 0>>
+\r                               <SET Z <LINE 500 0 500 780>>
+\r                               <SET X 300>
+\r                          LOOP <SET Y </ <* <- .X 500> <- .X 500>> 40>>
+\r                               <SET Z <POINT .X .Y>>
+\r                               <COND (<G? .X 699> <RETURN "DONE">)>
+\r                               <SET X <+ .X 1>>
+\r                               <GO LOOP>
+\r>>>
+\r<SET LINE <FUNCTION (X1 Y1 X2 Y2) <PROG (A B)
+\r                      ;"THIS PROGRAM WILL DRAW A LINE FROM (X1,Y1)
+\r                         TO (X2,Y2) ON THE SCOPE. AGAIN THE RANGE
+\r                         OF THE X'S AND Y'S IS 0 TO 1024."
+\r                       <SET A <TRANS .X1 .Y1>>
+\r                       <SET B <TRANS .X2 .Y2>>
+\r                       <RETURN <SEND (29 !.A !.B)>>
+\r>>>
+\r<SET TEST1 <FUNCTION () <PROG (X Y Z D)
+\r                                 <SET X 400>
+\r                            LOOP <SET Y </ <* <- .X 500> <- .X 500>> 10>>
+\r                                 <SET Z <POINT .X .Y>>
+\r                                 <SET D <POINT .X 0>>
+\r                                 <SET D <POINT 500 .Y>>
+\r                                 <COND (<G? .X 599> <RETURN "DONE"> )>
+\r                                 <SET X <+ .X 1>>
+\r                                 <GO LOOP>
+\r>>>
+\r<SET TEST <FUNCTION () <PROG (X Y Z D)
+\r                              <SET X 0>
+\r                         LOOP <SET Y </ <* .X .X> 10>>
+\r                              <SET Z <POINT .X .Y>>
+\r                             <COND (<==? .X 100> <RETURN "DONE">)>
+\r                             <SET X <+ .X 1>>
+\r                     <GO LOOP>
+\r>>>
+\r<SET POINT <FUNCTION (X Y) <PROG (D LIST) ;"THIS PROGRAMM DISPLAYS A 
+\r                                            POINT ON THE 4010'S SCREEN
+\r                                           THE X AND Y CO-ORDINENTS
+\r                                            SHOULD BE IN THE RANGE OF
+\r                                            0 THRU 1024."
+\r                                 <SET D <TRANS .X .Y>>
+\r                                 <SET LIST (29 !.D !.D)>
+\r                                 <RETURN <SEND .LIST>>
+\r>>>
+\r<SET SEND <FUNCTION (LIST) ;"THIS FUNCTION TRANSMITS THE CHARACTERS TO
+\r                              THE TECKRONIX 4010.TO WORK RIGHT YOU MUST
+\r                              HAVE TYPED (^_)S(CR) AT MONIT."
+\r                     <PROG (L N D) ;"D IS A DUMMY VAR. THAT HOLDS THE
+\r                                     UNWANTED THINGS THAT IMAGE RETURNS"
+\r                           <SET L <LENGTH .LIST>>
+\r                           <SET N 1>
+\r                      LOOP <COND ( <G? .N .L> <RETURN 1> )>
+\r                                  ;"ALL GOOD FUNCTIONS RETURN SOMETHING
+\r                                    THEREFORE SEND RETURNS 1."
+\r                           <SET D <IMAGE <.N .LIST>>>
+\r                           <SET N <+ .N 1>>
+\r                           <GO LOOP>
+\r>>>
+\r<SET PAGE <FUNCTION () ;"THIS FUNCTION ERASES THE SCREEN ON THE 4010."
+\r                     <SEND (27 12)>
+\r>>
+\r<SET TRANS <FUNCTION (X Y) ;"THIS FUNCTION TAKES THE X,Y CO-ORDINANTS
+\r                              AND TRANSLATES THEM INTO 4 ASCII CHARATERS
+\r                             FOR THE 4010"
+\r                      <PROG (LX HX LY HY)
+\r                            <SET HX <FIX </ .X 32>>>
+\r                            <SET HY <FIX </ .Y 32>>>
+\r                            <SET LX <- .X <* .HX 32>>>
+\r                            <SET LY <- .Y <* .HY 32>>>
+\r                            <SET HY <+ .HY 32>>
+\r                            <SET LY <+ .LY 96>>
+\r                            <SET HX <+ .HX 32>>
+\r                            <SET LX <+ .LX 64>>
+\r                            <RETURN (.HY .LY .HX .LX)>
+\r>>>
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/initm.42 b/MUDDLE/initm.42
new file mode 100644 (file)
index 0000000..72cacb1
--- /dev/null
@@ -0,0 +1,423 @@
+
+TITLE INITIALIZATION FOR MUDDLE
+
+RELOCATABLE
+
+LAST==1        ;POSSIBLE CHECKS DONE LATER
+
+.INSRT MUDDLE >
+
+.LIFL <TVLNT-TVLOC>
+.LOP .VALUE
+.ELDC
+
+
+.GLOBAL SETUP,TPBAS,GCPDL,GCPVP,PVBASE,PVLNT,PARNEW,AGC,ICR,SWAP,OBLNT,MSGTYP
+.GLOBAL ICLOS,OCLOS,GLOBASE,GLOBSP,PARBOT,PARTOP,CODTOP,START,VECBOT,VECTOP,TPBASE
+.GLOBAL LISTEN,ROOT,TBINIT,TOPLEV,INTOBL,ERROBL,TTYOPE
+.GLOBAL IOINS,BUFRIN,IOIN2,ECHO,TYI,TYO
+
+SETUP: MOVE    P,GCPDL         ;GET A PUSH DOWN STACK
+       MOVE    TVP,[-TVLNT,,TVBASE]    ;GET INITIAL TRANSFER VECTOR
+       PUSHJ   P,TTYOPE                ;OPEN THE TTY
+       MOVEI   B,[ASCIZ /MUDDLE INITIALIZATION.
+/]
+       PUSHJ   P,MSGTYP        ;PRINT IT
+       MOVE    A,CODTOP        ;CHECK FOR A WINNING LOAD
+       CAML    A,VECBOT        ;IT BETTER BE LESS
+       JRST    DEATH1          ;LOSE COMPLETELY
+       MOVE    B,PARBOT        ;CHECK FOR ANY PAIRS
+       CAME    B,PARTOP        ;ANY LOAD/ASSEMBLE TIME PAIRS?
+       JRST    PAIRCH          ;YES CHECK THEM
+       ADDI    A,1             ;BUMP UP
+       MOVEM   A,PARBOT        ;UPDATE PARBOT AND TOP
+       MOVEM   A,PARTOP
+SETTV: MOVE    PVP,[-PVLNT*2,,GCPVP]   ;AND A PROCESS VECTOR
+       MOVEI   A,(PVP)         ;SET UP A BLT
+       HRLI    A,PVBASE        ;FROM PROTOTYPE
+       BLT     A,PVLNT*2-1(PVP)        ;INITIALIZE
+       MOVE    TP,[-ITPLNT,,TPBAS]     ;GET A STACK FOR THIS PROCCESS
+       MOVEI   TB,(TP)         ;AND A BASE
+       HRLI    TB,1
+       SUB     TP,[1,,1]       ;POP ONCE
+
+; ALLOCATE SOME OBLISTS FOR INITIAL ATOMS
+
+       PUSH    P,[3]           ;COUNT INITIAL OBLISTS
+
+MAKEOB:        MCALL   0,MOBLIST       ;GOBBLE AN OBLIST
+       PUSH    TP,$TOBLS       ;AND SAVE THEM
+       PUSH    TP,B
+       SOS     A,(P)           ;COUNT DOWN
+       MOVEM   B,@OBTBL(A)     ;STORE
+       JUMPN   A,MAKEOB
+
+       MOVE    C,TVP           ;MAKE 2 COPIES OF XFER VECTOR POINTER
+       MOVE    D,TVP
+
+;MAIN INITIALIZE LOOP - SCAN XFER VECTOR FOR ATOMS, UPDATE
+;OFFSETS IN CODE, UNIQUIFY ATOMS AND COMPACT XFER VECTOR
+
+ILOOP: HLRZ    A,(C)           ;FIRST TYPE
+       JUMPE   A,TVEXAU        ;USEFUL STUFF EXHAUSTED
+       CAIN    A,TCHSTR        ;CHARACTER STRING?
+       JRST    CHACK           ;YES, GO HACK IT
+       CAIN    A,TATOM         ;ATOM?
+       JRST    ATOMHK          ;YES, CHECK IT OUT
+       MOVE    A,(C)           ;MOVE TO NEW HOME (MAY BE SAME)
+       MOVEM   A,(D)
+       MOVE    A,1(C)
+       MOVEM   A,1(D)
+SETLP: AOS     (P)             ;COUNT NUMBER OF PAIRS IN XFER VECTOR
+       ADD     D,[2,,2]        ;OUT COUNTER
+SETLP1:        ADD     C,[2,,2]        ;AND IN COUNTER
+       JUMPL   C,ILOOP         ;JUMP IF MORE TO DO
+\f
+;NEW XFER VECTOR FINISHED, NOW GIVE AWAY THE REST
+
+TVEXAU:        HLRE    B,C             ;GET -LENGTH
+       SUBI    C,(B)           ;POIT TO DOPE WORD
+       ANDI    C,-1            ;NO LH
+       HLRZ    A,1(C)          ;INTIAL LENGTH TO A
+       MOVEI   E,(C)           ;COPY OF POINTER TO DOPW WD
+       SUBI    E,(D)           ;AMOUNT LEFT OVER TO E
+       HRLZM   E,1(C)          ;CLOBBER INTO DOPE WORD FOR GARBAGE
+       MOVSI   E,(E)           ;PREPARE TO UPDATE TVP
+       ADD     TVP,E           ;NOW POINTS TO THE RIGHT AMOUNT
+       HLRE    B,D             ;-AMOUNT LEFT TO B
+       ADD     B,A             ;AMOUNT OF GOOD STUFF
+       HRLZM   B,1(D)          ;STORE IT IN GODD DOPE WORD
+       MOVSI   E,400000        ;CLOBBER TO GENERAL IN BOTH CASES
+       MOVEM   E,(C)
+       MOVEM   E,(D)
+
+
+; FIX UP TYPE VECTOR
+
+       MOVE    A,TYPVEC+1(TVP) ;GET POINTER
+       MOVEI   0,0             ;FOR POSSIBLE NULL SLOTS
+       MOVSI   B,TATOM         ;SET TYPE TO ATOM
+
+TYPLP: HLLM    B,(A)           ;CHANGE TYPE TO ATOM
+       MOVE    C,@1(A)         ;GET ATOM
+       MOVEM   C,1(A)
+       ADD     A,[2,,2]                ;BUMP
+       JUMPL   A,TYPLP
+\f
+;GENERAT THE LOGICAL TTY IN AND OUT CHANNELS
+
+;SETUP CALL TO OPEN OUTPUT TTY CHANNNEL
+
+       IRP     A,,[[PRINT,TCHSTR],[OUTPUT,TCHSTR],[MUDDLE,TCHSTR],[TTY,TCHSTR]]
+       IRP     B,C,[A]
+       PUSH    TP,$!C
+       PUSH    TP,CHQUOTE B
+       .ISTOP
+       TERMIN
+       TERMIN
+
+       MCALL   4,FOPEN         ;OPEN THE OUT PUT CHANNEL
+       MOVEM   B,TTOCHN+1(TVP) ;SAVE IT
+
+;ASSIGN AS GLOBAL VALUE
+
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE OUTCHAN
+       PUSH    TP,A
+       PUSH    TP,B
+       MOVE    A,[PUSHJ P,TYO] ;MORE WINNING INS
+       MOVEM   A,IOINS(B)      ;CLOBBER
+       MCALL   2,SETG
+
+;SETUP A CALL TO OPEN THE TTY CHANNEL
+
+       IRP     A,,[[READ,TCHSTR],[INPUT,TCHSTR],[MUDDLE,TCHSTR],[TTY,TCHSTR]]
+       IRP     B,C,[A]
+       PUSH    TP,$!C
+       PUSH    TP,CHQUOTE B
+       .ISTOP
+       TERMIN
+       TERMIN
+
+       MCALL   4,FOPEN         ;OPEN INPUTCHANNEL
+       MOVEM   B,TTICHN+1(TVP) ;SAVE IT
+       PUSH    TP,$TATOM       ;ASSIGN AS A GLOBAL VALUE
+       PUSH    TP,MQUOTE INCHAN
+       PUSH    TP,A
+       PUSH    TP,B
+       MOVE    C,BUFRIN(B)     ;GET AUX BUFFER PTR
+       MOVE    A,[PUSHJ P,TYI]
+       MOVEM   A,IOIN2(C)      ;MORE OF A WINNER
+       MOVE    A,[PUSHJ P,TYO]
+       MOVEM   A,ECHO(C)       ;ECHO INS
+       MCALL   2,SETG
+
+;GENERATE AN INITIAL PROCESS AND SWAP IT IN
+
+       PUSHJ   P,ICR   ;CREATE IT
+       MOVE    D,B     ;SET UP TO CALL SWAP
+       JSP     C,SWAP  ;AND SWAP IN
+       MOVEM   PVP,MAINPR"     ;SAVE AS THE MAIN PROCESS
+       PUSH    TP,[TENTRY,,TOPLEV]     ;BUILD DUMMY FRAME
+       PUSH    TP,[1,,0]
+       PUSH    TP,[0]
+       PUSH    TP,SP
+       PUSH    TP,P
+       MOVE    C,TP    ;COPY TP
+       ADD     C,[3,,3]        ;FUDGE
+       PUSH    TP,C    ;TPSAV PUSHED
+       PUSH    TP,PP
+       PUSH    TP,[TOPLEV]
+       HRRI    TB,(TP) ;SETUP TB
+       HRLI    TB,2
+       ADD     TB,[1,,1]
+       MOVEM   TB,TBINIT+1(PVP)
+
+; CREATE LIST OF ROOT AND NEW OBLIST
+
+       MCALL   0,MOBLIST       ;MAKE OBLIST
+       PUSH    TP,A    ;SAVE RESULTS
+       PUSH    TP,B
+       PUSH    TP,ROOT(TVP)
+       PUSH    TP,ROOT+1(TVP)
+       MCALL   2,LIST  ;MAKE LIST
+       MOVEM   A,ROOT(TVP)
+       MOVEM   B,ROOT+1(TVP)
+       PUSH    TP,$TATOM       ;ASSIGN TO GLOBAL VALUE
+       PUSH    TP,MQUOTE OBLIST
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,SETG
+
+
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE QUITTER
+       MCALL   1,LIST
+       PUSH    TP,$TCHAN               ;SET UP CNTL-G INT
+       PUSH    TP,TTICHN+1(TVP)
+       PUSH    TP,$TFORM
+       PUSH    TP,B
+       MCALL   2,ONCHAR                ;TURN ON INTERRUPT
+       MOVEI   A,SETUP         ;POINT TO START
+       MOVEM   A,CODTOP
+       ADDI    A,1
+       SUB     A,PARBOT        ;FIND WHERE PAIRS SHOULD GO
+       MOVEM   A,PARNEW
+       PUSH    P,[14.,,14.]    ;PUSH A SMALL PRGRM ONTO P
+       MOVEI   A,1(P)  ;POINT TO ITS START
+       PUSH    P,[JRST AGC]    ;GO TO AGC
+       PUSH    P,[MOVE B,PSTO+1(PVP)]  ;GET SAVED P
+       PUSH    P,[SUB B,-13.(P)]       ;FUDGE TO POP OFF PROGRAM
+       PUSH    P,[MOVEM B,PSAV(TB)]    ;INTO FRAME
+       PUSH    P,[MOVE B,TPSTO+1(PVP)] ;GET TP
+       PUSH    P,[MOVEM B,TPSAV(TB)]   ;STORE IT
+       PUSH    P,[MOVE B,SPSTO+1(PVP)] ;SP
+       PUSH    P,[MOVEM B,SPSAV(TB)]
+       PUSH    P,[MOVEI B,TOPLEV]      ;WHERE TO GO
+       PUSH    P,[MOVEM B,PCSAV(TB)]
+       PUSH    P,[MOVSI B,(.VALUE )]
+       PUSH    P,[HRRI B,C]
+       PUSH    P,[JRST B]      ;GO DO VALRET
+       PUSH    P,[A]   ;RETURN ADDRESS FOR AGC
+       PUSH    P,A     ;SAVE A
+       MOVE    A,[JRST -11.(P)]        ;WHEER TO START
+       SUB     P,[1,,1]        ;REMOVE LOSSAGE
+       MOVE    0,[JUMPA START]
+       MOVE    B,[.VALUE C]    ;SETUP VALRET
+       MOVE    C,[ASCII \\170/\e9\]
+       MOVE    D,[ASCII \B!\eQî\]
+       MOVE    E,[ASCIZ \\16*\]          ;TERMINATE
+       JRST    @1(P)           ;GO DO IT
+\f
+; CHECK PAIR SPACE
+
+PAIRCH:        CAMG    A,B
+       JRST    SETTV           ;O.K.
+
+DEATH1:        MOVEI   B,[ASCIZ /LOSSAGE--CODE AND DATA OVERLAP
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+
+;CHARACTER STRING HACKER
+
+CHACK: MOVE    A,(C)           ;GET TYPE
+       HLLZM   A,(D)           ;STORE IN NEW HOME
+       MOVE    B,1(C)          ;GET POINTER
+       HLRE    E,B             ;-LENGHT
+       SUBM    B,E             ;E POINTS TO DOPE WORDS
+       ADDI    E,1             ;POINT TO 2ND
+       HRRM    E,(D)           ;INTO PE CELL
+       HRLI    B,350700        ;MAKE POINT BYTER
+       MOVEM   B,1(D)          ;AND STORE IT
+       ANDI    A,-1    ;CLEAR LH OF A
+       JUMPE   A,SETLP ;JUMP IF NO REF
+       MOVE    E,(P)           ;GET OFFSET
+       LSH     E,1
+       HRRZ    B,-1(A) ;SEE IF PREVIOUS INSTRUCTION REFERS TO $TCHSTR
+       CAIE    B,$TCHSTR       ;SKIP IF IT DOES
+       JRST    CHACK1  ;NO, JUST DO CHQUOTE PART
+       HRRM    E,-1(A) ;CLOBBER
+       MOVEI   B,TVP
+       DPB     B,[220400,,-1(A)]       ;CLOBBER INDEX FIELD
+CHACK1:        ADDI    E,1
+       HRRM    E,(A)           ;STORE INTO REFERENCE
+       JRST    SETLP
+\f
+; PROCESS AN ATOM AND ADD IT TO AN APPROPRIATE OBLIST IF IT ISN'T
+; ALREADY THERE
+
+ATOMHK:        PUSH    TP,$TVEC        ;SAVE TV POINTERS
+       PUSH    TP,C
+       PUSH    TP,$TVEC
+       PUSH    TP,D
+       MOVE    B,1(C)          ;GET THE ATOM
+       PUSH    TP,$TATOM       ;AND SAVE
+       PUSH    TP,B
+       HRRZ    A,(B)           ;GET OBLIST SPEC FROM ATOM
+       LSH     A,1
+       ADDI    A,1(TB)         ;POINT TO ITS HOME
+       PUSH    TP,$TOBLS
+       PUSH    TP,(A)          ;AND SAV IT
+
+       ADD     B,[2,,2]        ;POINT TO ATOM'S PNAME
+       MOVEI   A,0             ;FOR HASHING
+       XOR     A,(B)
+       AOBJN   B,.-1
+       MOVMS   A               ;FORCE POSITIVE RESULT
+       IDIV    A,OBLNT
+       HRLS    B               ;REMAINDER IN B IS BUCKET
+       ADDB    B,(TP)          ;UPDATE POINTER
+
+       SKIPN   C,(B)           ;GOBBLE BUCKET CONTENTS
+       JRST    USEATM          ;NONE, LEAVE AND USE THIS ATOM
+OBLOO3:        MOVE    E,-2(TP)        ;RE-GOBBLE ATOM
+       ADD     E,[2,,2]        ;POINT TO PNAME
+       SKIPN   D,1(C)          ;CHECK LIST ELEMNT
+       JRST    NXTBCK          ;0, CHECK NEXT IN THIS BUCKET
+       ADD     D,[2,,2]        ;POINT TO PNAME
+OBLOO2:        MOVE    A,(D)           ;GET A WORD
+       CAME    A,(E)           ;COMPARE
+       JRST    NXTBCK          ;THEY DIFFER, TRY NEX
+OBLOOP:        AOBJP   E,CHCKD         ;COULD BE A MATCH, GO CHECK
+       AOBJN   D,OBLOO2        ;HAVEN'T LOST YET
+
+NXTBCK:        HRRZ    C,(C)           ;CDR THE LIST
+       JUMPN   C,OBLOO3        ;IF NOT NIL, KEEP TRYING
+
+;HERE IF THIS ATOM MUST BE PUT ON OBLIST
+
+USEATM:        MOVE    B,(TP)          ;POINTER TO BUCKET
+       HRRZ    C,(B)           ;POINTER TO LIST IN THIS BUCKET
+       PUSH    TP,$TATOM       ;GENERATE CALL TO CONS
+       PUSH    TP,-3(TP)
+       PUSH    TP,$TLIST
+       PUSH    TP,C
+       MCALL   2,CONS          ;CONS IT UP
+       MOVE    C,(TP)          ;REGOBBLE BUCKET POINTER
+       HRRZM   B,(C)           ;CLOBBER
+       MOVE    B,-2(TP)        ;POINT TO ATOM
+       PUSHJ   P,VALMAK        ;MAKE A GLOBAL VALUE FOR THIS LOSER
+       MOVE    C,-6(TP)        ;RESET POINTERS
+       MOVE    D,-4(TP)
+       SUB     TP,[8,,8]
+       MOVE    B,(C)           ;MOVE THE ENTRY
+       HLLZM   B,(D)           ;DON'T WANT REF POINTER STORED
+       MOVE    A,1(C)          ;AND MOVE ATOM
+       MOVEM   A,1(D)
+       MOVE    A,(P)           ;GET CURRENT OFFSET
+       LSH     A,1
+       ADDI    A,1
+       ANDI    B,-1            ;CHECKFOR REAL REF
+       JUMPE   B,SETLP
+       HRRM    A,(B)           ;CLOBBER CODE
+       JRST    SETLP
+
+\f
+; A POSSIBLE MATCH ARRIVES HERE
+
+CHCKD: AOBJN   D,NXTBCK        ;SIZES DIFFER, JUMP
+       MOVE    D,1(C)          ;THEY MATCH!,  GET EXISTING ATOM
+       HLRZ    A,(D)           ;GET TYPE OF IT
+       CAIE    A,TUNBOU        ;UNBOUND?
+       JRST    A1VAL           ;YES, CONTINUE
+       MOVE    B,-2(TP)        ;GET NEW ATOM
+       MOVE    A,(B)           ;MOVE VALUE
+       MOVEM   A,(D)
+       MOVE    A,1(B)
+       MOVEM   A,1(D)
+       MOVE    B,D             ;EXISTING ATOM TO B
+       PUSHJ   P,VALMAK        ;MAKE A VALUE
+
+;NOW FIND ATOMS OCCURENCE IN XFER VECTOR
+
+OFFIND:        MOVE    D,-4(TP)        ;GET CURRENT POINTER INTO TP
+       MOVE    C,TVP           ;AND A COPY OF TVP
+       MOVEI   A,0             ;INITIALIZE COUNTER
+ALOOP: CAMN    B,1(C)          ;IS THIS IT?
+       JRST    AFOUND
+       ADD     C,[2,,2]        ;BUMP COUNTER
+       CAMGE   C,D             ;HAVE WE HIT END
+       AOJA    A,ALOOP         ;NO, KEEP LOOKING
+
+       MOVEI   B,[ASCIZ /LOSSAGE--ATOM DISAPPEARED
+/]
+TYPIT: PUSHJ   P,MSGTYP
+       .VALUE
+
+AFOUND:        LSH     A,1             ;FOUND ATOM, GET REAL OFFSET
+       ADDI    A,1
+       MOVE    C,-6(TP)        ;GET TV POINTER TO NEW ATOM
+       HRRZ    B,(C)           ;POINT TO REFERENCE
+       SKIPE   B               ;ANY THERE?
+       HRRM    A,(B)           ;YES, CLOBBER AWAY
+       SUB     TP,[8,,8]
+       JRST    SETLP1          ;AND GO ON
+
+A1VAL: MOVE    B,-2(TP)        ;GET NEW ATOM POINTER
+       HLRZ    C,(B)           ;GET VALUE'S TYPE
+       MOVE    B,D             ;NOW PUT EXISTING ATOM IN B
+       CAIN    C,TUNBOU        ;UNBOUND?
+       JRST    OFFIND          ;YES, WINNER
+
+       MOVEI   B,[ASCIZ /LOSSAGE--ATOM TRIES TO HAVE 2 VALUES
+/]
+       JRST    TYPIT
+
+\f
+;MAKE A VALUE IN SLOT ON GLOBAL SP
+
+VALMAK:        HLRZ    A,(B)           ;TYPE OF VALUE
+       CAIN    A,TUNBOU        ;VALUE?
+       POPJ    P,              ;NO, ALL DONE
+       MOVE    A,GLOBSP+1(TVP) ;GET POINTER TO GLOBAL SP
+       SUB     A,[4,,4]        ;ALLOCATE SPACE
+       CAMG    A,GLOBAS+1(TVP) ;CHECK FOR OVERFLOW
+       JRST    SPOVFL
+       MOVEM   A,GLOBSP+1(TVP) ;STORE IT BACK
+       MOVE    C,(B)           ;GET TYPE CELL
+       HLLZM   C,2(A)          ;INTO TYPE CELL
+       MOVE    C,1(B)          ;GET VALUE
+       MOVEM   C,3(A)          ;INTO VALUE SLOT
+       MOVSI   C,TATOM         ;GET TATOM,,0
+       MOVEM   C,(A)
+       MOVEM   B,1(A)          ;AND POINTER TO ATOM
+       MOVSI   C,TLOCI         ;NOW CLOBBER THE ATOM
+       MOVEM   C,(B)           ;INTO TYPE CELL
+       ADD     A,[2,,2]        ;POINT TO VALUE
+       MOVEM   A,1(B)
+       POPJ    P,
+
+SPOVFL:        MOVEI   B,[ASCIZ /LOSSAGE--GLOBAL SP OVERFLOW
+/]
+       JRST    TYPIT
+
+
+OBTBL: INTOBL+1(TVP)
+       ERROBL+1(TVP)
+       ROOT+1(TVP)
+
+END SETUP
+
+
+\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/mapper.9 b/MUDDLE/mapper.9
new file mode 100644 (file)
index 0000000..153fb0f
--- /dev/null
@@ -0,0 +1,80 @@
+
+<DEFINE ID (X) .X>
+
+<DEFINE ENTROPY ("ARGS" L) ()>
+
+<DEFINE IG ("TUPLE" M) <1 .L>>
+
+"LIST SPLICER NCONC"
+
+<DEFINE NCONC1 (L1 L2)
+       <COND   (<EMPTY? .L1> .L2)
+               (<EMPTY? .L2> .L1)
+               (T <RPLACD
+                       <REST .L1 <- <LENGTH .L1> 1>>
+                       .L2>
+                 .L1)>>
+
+
+"MULTIPLE LIST SPLICER"
+
+<DEFINE NCONC ("TUPLE" L)
+       <COND   (<EMPTY? .L> ())
+               (T  <REPEAT ((T <LENGTH .L>) (ANS <.T .L>))
+                       <COND (<0? <SET T <- .T 1>>> <RETURN .ANS>)>
+                       <SET ANS <NCONC1 <.T .L> .ANS>>>)>>>
+
+
+
+<DEFINE HACK ("TUPLE" L)
+       <COND (<EMPTY? .L> 'NONE-OF-YOUR-BUSINESS)
+               (<==? <TYPE <1 .L>> FIX> <<1 .L> .L>)
+               (T <<LENGTH .L> .L>)>>
+
+"GENERALIZED MAPPER FUNCTION ACCORDING TO THE GOSPEL OF SUSSMAN"
+
+
+<DEFINE *MAP (F L INMAP OUTMAP "AUX" L1 M (DONEF 1)"ACT" G)
+
+"THE ARGUMENTS ARE AS FOLLOWS
+
+       F - THE FUNCTION TO APPLY
+       L - A TUPLE OF LISTS WHOSE ELEMTS ARE TO BE USED AS ARGS
+       INMAP - FUNCTION USED TO GET EACH ELEMENT
+       OUTMAP - FUNCTION TO PROCESS THE VALUES
+"
+
+       <STACKFORM .OUTMAP
+               <HACK <SET M .L>
+                 <STACKFORM .F
+                       <HACK 3 <COND (<EMPTY? <SET L1 <1 .M>>>
+                                       <EXIT .G ()>)>
+                          <.INMAP .L1>
+                          <COND (<AND <EMPTY? <SETLOC <AT .M 1> <REST .L1>>>
+                                       <G? .DONEF 0>>
+                                 <SET DONEF -1>)>
+                         <SET M <REST .M>>>
+                       <NOT <EMPTY? .M>>>>
+               <NOT <0? <SET DONEF <+ .DONEF 1>>>>>>
+
+
+"SPECIFIC INVOCATIONS OF *MAP"
+
+<DEFINE MAPLIST (F "TUPLE" L)
+       <*MAP .F .L ,ID ,LIST>>
+
+<DEFINE MAP (F "TUPLE" L)
+       <*MAP .F .L ,ID ,IG>>
+
+<DEFINE MAPCAR (F "TUPLE" L)
+       <*MAP .F .L 1 ,LIST>>
+
+<DEFINE MAPC (F "TUPLE" L)
+       <*MAP .F .L 1 ,IG>>
+
+<DEFINE MAPCON (F "TUPLE" L)
+       <*MAP .F .L  ,ID ,NCONC>>
+
+<DEFINE MAPCAN (F "TUPLE" L)
+       <*MAP .F .L 1 ,NCONC>>
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/match.18 b/MUDDLE/match.18
new file mode 100644 (file)
index 0000000..f1810e5
--- /dev/null
@@ -0,0 +1,216 @@
+<DEFINE IS
+ <FUNCTION ("BIND" TOPMATCH
+            'PAT EXP)
+   <IS1 .PAT .EXP>
+   T   >>
+
+
+<DEFINE IS?
+ <FUNCTION ("BIND" TOPMATCH
+            'PAT EXP)
+   <FAILPOINT ()
+      <PROG2 <IS1 .PAT .EXP> T>
+      ()
+      <>   >>>
+
+
+<DEFINE MATCH
+ <FUNCTION ("BIND" TOPMATCH
+            'PAT1 'PAT2)
+   <MATCH1 .PAT1 .PAT2>
+   T   >>
+
+
+<DEFINE MATCH?
+ <FUNCTION ("BIND" TOPMATCH
+            'PAT1 'PAT2)
+   <FAILPOINT ()
+      <PROG2 <MATCH1 .PAT1 .PAT2> T>
+      ()
+      <>   >>>
+
+
+<DEFINE ASSIGN
+ <FUNCTION ("BIND" TOPMATCH
+            'PAT EXP)
+  <FAILPOINT ()
+      <PROG2 <IS1 .PAT .EXP> .EXP>
+      ()
+      <ERROR IMPOSSIBLE-ASSIGNMENT>   >>>\f<DEFINE IS1
+ <FUNCTION S ("BIND" C
+              PAT EXP "OPTIONAL" (ENV <>) (BOUND <BOTTOM .EXP>)
+                (OBLIGATORY T) (PBOUND <BOTTOM .PAT>)
+              "AUX" PURE ENDP K BETA ENDE)
+   <COND (<==? <TYPE .PAT> FORM>
+          <.S <INVOKE .PAT .EXP .BOUND .OBLIGATORY .ENV>>)
+         (<EMPTY? .PAT>
+          <OR <==? .EXP .BOUND> <FAIL>>
+          .BOUND)
+         (<MONAD? .PAT>
+          <.S <OR <=? .PAT .EXP> <FAIL>>>)
+         (<MONAD? .EXP>
+          <OR <EMPTY? .EXP> <FAIL>>)   >
+   <FINSPLICE .C .ENV>
+   <HACKPAT .PAT .PBOUND ENDP K BETA>
+   <SET ENDE <POST .EXP .BOUND .K .BETA>>
+   <REPEAT R ()
+      <COND (<==? .PAT .ENDP> <.R <GOTEND .EXP .ENDE .OBLIGATORY>>)
+            (<==? <TYPE <1 .PAT>> SEGMENT>
+             <THSET EXP <INVOKE <1 .PAT> .EXP .ENDE <AND <==? .PAT .ENDP> .OBLIGATORY>>>)
+            (<==? .EXP .ENDE> <FAIL>)
+            (T <IS1 <1 .PAT> <1 .EXP>>
+               <THSET EXP <REST .EXP>>)   >
+      <THSET PAT <REST .PAT>>   >
+   <REPEAT ()
+      <COND (<==? .PAT .PBOUND>
+             <.S .EXP>)
+            (T <IS1 <1 .PAT> <1 .EXP>>)   >
+      <THSET PAT <REST .PAT>>
+      <THSET EXP <REST .EXP>>   >  >>\f<DEFINE MATCH1
+ <FUNCTION MATCHER (PAT1 PAT2 "OPTIONAL" (ENV1 <>) (ENV2 <>)
+                      (BOUND1 <BOTTOM .PAT1>) (BOUND2  <BOTTOM .PAT2>)
+                      (OBL T))
+   <COND (<==? <TYPE .PAT1> FORM>
+          <COND (<AND <==? <TYPE .PAT2> FORM>
+                      <G? <PRECEDENCE <1 .PAT2>> <PRECEDENCE <1 .PAT1>>>>
+                 <.MATCHER <INVOKE .PAT2 .PAT1 .BOUND1 T .ENV2 .ENV1 <>>>)   >
+          <.MATCHER <INVOKE .PAT1 .PAT2 .BOUND2 .OBL .ENV1 .ENV2 <>>>)
+         (<==? <TYPE .PAT2> FORM>
+          <.MATCHER <INVOKE .PAT2 .PAT1 .BOUND1 T .ENV2 .ENV1 <>>>)
+         (<AND <MONAD? .PAT1> <FULL? .PAT1>>
+          <.MATCHER <OR <=? .PAT1 .PAT2> <FAIL>>>)
+         (<AND <MONAD? .PAT2> <FULL? .PAT2>>
+          <FAIL>)
+         (<AND <EMPTY? .PAT1> <EMPTY? .PAT2>>
+          <.MATCHER .PAT2>)   >
+   <PROG (END1 END2 K1 K2 ALPHA1 ALPHA2 BETA1 BETA2 S1 S2 SEG1 SEG2 FORM1 INC)
+      <SPREAD <PATSOFTEN .PAT1 .BOUND1> ALPHA1 SEG1>
+      <SPREAD <PATSOFTEN .PAT2 .BOUND2> ALPHA2 SEG2>
+      <COND (<G? .ALPHA1 .ALPHA2>
+             <COND (<==? .SEG2 .BOUND2>
+                    <FAIL>)
+                   (<SET SEG1 <REST .PAT1 <SET ALPHA1 .ALPHA2>>>)   >)
+            (<G? .ALPHA2 .ALPHA1>
+             <COND (<AND .OBL <==? .SEG1 .BOUND1>>
+                    <FAIL>)
+                   (<SET SEG2 <REST .PAT2 <SET ALPHA2 .ALPHA1>>>)   >)   >
+      <REPEAT R ()
+         <COND (<==? .PAT1 .SEG1> <.R <>>)
+               (T <MATCH1 <1 .PAT1> <1 .PAT2> .ENV1 .ENV2>)   >
+         <THSET PAT1 <REST .PAT1>>
+         <THSET PAT2 <REST .PAT2>>   >
+      <SPREAD <PATHACK .SEG1 .BOUND1 .ENV1> END1 K1 BETA1 S1>
+      <SPREAD <PATHACK .SEG2 .BOUND2 .ENV2> END2 K2 BETA2 S2>
+      <COND (<G? .BETA1 .BETA2>
+             <OR .OBL <FAIL>>
+             <SET END1 <REST .END1 <SET INC <- .BETA1 .BETA2>>>>
+             <SET K1 <+ .K1 .INC>>
+             <SET BETA1 .BETA2>)
+            (<G? .BETA2 .BETA1>
+             <COND (.OBL
+                    <SET END2 <REST .END2 <SET INC <- .BETA2 .BETA1>>>>
+                    <SET K2 <+ .K2 .INC>>
+                    <SET BETA2 .BETA1>)
+                   (T <OR <==? .PAT2 .END2> <FAIL>>
+                      <SET END2 <POST .END2 .BOUND2 .K1 .BETA1 .BETA2>>)   >)   >
+      <COND (<AND <==? .S1 1> <0? .K1>>
+             <COND (<AND <==? .S2 1> <0? .K2>>
+                    <SET FORM1 <CHTYPE <1 .SEG2> FORM>>
+                    <INVOKE <1 .SEG1> .FORM1 .FORM1 T .ENV1 .ENV2 <>>)
+                   (T <INVOKE <1 .SEG1> .SEG2 .END2 T .ENV1 .ENV2 <>>)  >)
+            (<AND <==? .S2 1> <0? .K2>>
+             <INVOKE <1 .SEG2> .SEG1 .END1 T .ENV1 .ENV2 <>>)
+            (<0? .S2>
+             <COND (<G? .K1 .K2> <FAIL>)
+                   (T <THSET END2
+                             <SEGMATCH .SEG1 .SEG2 .ENV1 .ENV2 .END1 .END2 .OBL>>)   >)
+            (<0? .S1>
+             <COND (<G? .K2 .K1> <FAIL>)
+                   (<SEGMATCH .SEG2 .SEG1 .ENV2 .ENV1 .END2 .END1>)   >)
+            (T <#FUNCTION ((UV1 UV2) 
+                           <AND <EMPTY? .UV1> <EMPTY? .UV2> <FAIL>>
+                           <LINKVARS .UV1 .UV2 .SEG1 .SEG2 .ENV1 .ENV2 .END1 .END2>)
+                <UVARS .SEG1 .END1 .ENV1>
+                <UVARS .SEG2 .END2 .ENV2>>)   >
+      <REPEAT ()
+         <COND (<==? .END1 .BOUND1> <EXIT .MATCHER .END2>)   >
+         <MATCH1 <1 .END1> <1 .END2> .ENV1 .ENV2>
+         <THSET END1 <REST .END1>>
+         <THSET END2 <REST .END2>>   >   >   >>\f<DEFINE SEGMATCH
+ <FUNCTION SMATCHER (PAT1 PAT2 ENV1 ENV2 "OPTIONAL" (BOUND1 <BOTTOM .PAT1>)
+                       (BOUND2 <BOTTOM .PAT2>) (OBL T)
+                     "AUX" FORM1)
+   <REPEAT ()
+      <COND (<==? .PAT1 .BOUND1>
+             <.SMATCHER .PAT2>)
+            (<==? <TYPE <1 .PAT1>> SEGMENT>
+             <THSET PAT2
+                    <INVOKE <1 .PAT1> .PAT2 .BOUND2 <AND <==? <REST .PAT1> .BOUND1> .OBL> .ENV1 .ENV2 <>>>)
+            (<==? .PAT2 .BOUND2> <FAIL>)
+            (T <MATCH1 <1 .PAT1> <1 .PAT2> .ENV1 .ENV2>
+               <THSET PAT2 <REST .PAT2>>)   >
+      <THSET PAT1 <REST .PAT1>>   >   >>\f<DEFINE HACKPAT
+ <FUNCTION P (PAT PBOUND ENDV KV BETAV)
+   <REPEAT ((END .PAT) (KS 0) (BETAS 0))
+      <COND (<==? .PAT .PBOUND>
+             <SET .KV .KS> <SET .BETAV .BETAS>
+             <SET .ENDV .END>  <EXIT .P <>>)
+            (<==? <TYPE <1 .PAT>> SEGMENT>
+             <SET KS <+ .KS .BETAS>>
+             <SET BETAS 0>
+             <SET END <REST .PAT>>)
+            (T <SET BETAS <+ .BETAS 1>>)>
+      <SET PAT <REST .PAT>>  >  >>
+
+
+<DEFINE POST
+ <FUNCTION (L LBOUND K BETA "OPTIONAL" (KOUNT <BLENGTH .L .LBOUND>))
+   <AND <G? <+ .K .BETA> .KOUNT>
+        <FAIL>>
+   <REST .L <- .KOUNT .BETA>>  >>
+
+
+
+<DEFINE BLENGTH
+ <FUNCTION BL (L LB "AUX" (K 0))
+   <COND (<==? .L .LB> .K)
+         (T <SET L <REST .L>>
+            <SET K <+ .K 1>>
+            <AGAIN .BL>)>  >>
+
+
+<DEFINE GOTEND
+ <FUNCTION (EXP BOUND OBLIGATORY)
+   <OR <==? .EXP .BOUND>
+       <NOT .OBLIGATORY>
+       <FAIL>>
+   .EXP  >>
+\f<DEFINE PATSOFTEN
+ <FUNCTION SOFTENER (PAT BOUND "AUX" (ALPHA 0))
+   <REPEAT ()
+      <COND (<OR <==? .PAT .BOUND> <==? <TYPE <1 .PAT>> SEGMENT>>
+             <.SOFTENER [.ALPHA .PAT]>)   >
+      <SET ALPHA <+ .ALPHA 1>>
+      <SET PAT <REST .PAT>>   >   >>
+
+
+<DEFINE PATHACK
+ <FUNCTION HACKER ("BIND" CURENV
+                   PAT PBOUND ENV
+                   "AUX" (END .PAT) (K 0) (BETA 0) (S 0)
+                         PAT1)
+   <FINSPLICE .CURENV .ENV>
+   <REPEAT ()
+      <COND (<==? .PAT .PBOUND>
+             <.HACKER [.END .K .BETA .S]>)
+            (<==? <TYPE <SET PAT1 <1 .PAT>>> SEGMENT>
+             <COND (<OR <FULL? <UARGS .PAT1>>
+                        <AND <FULL? .PAT1>
+                             <SET ACTR <ACTOR? <1 .PAT1>>>>>
+                    <SET S <+ .S 1>>)   >
+             <SET K <+ .K .BETA>>
+             <SET BETA 0>
+             <SET END <REST .PAT>>)
+            (T <SET BETA <+ .BETA 1>>)   >
+      <SET PAT <REST .PAT>>   >   >>
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/medcom.2 b/MUDDLE/medcom.2
new file mode 100644 (file)
index 0000000..33f861f
--- /dev/null
@@ -0,0 +1,41 @@
+Commands:
+NAME   ARGS    MEANING
+?      none    Type this summary out.
+O      1       Open object; takes ATOM, LOCATIVE, or CURSOR.
+HERE   1,ATOM  save your current CURSOR as the LVAL of ARG.
+UT     none    Up Top -- go to the place you were just after O.
+&      none    "Ampersand print" (normally done automatically).
+       none    (Empty command) equivalent to &.
+Q      none    Quit -- return to MUDDLE.
+^K     1       Exit from MUDDLE and VALRET arg (STRING or ATOM).
+P      none    (P)PRINT the next object.
+PA     1,FIX   (P)PRINT the object arg levels above position.
+PT     none    (P)PRINT the whole object open.
+V      none    toggle Verbosity.
+R      1,FIX   move Right arg objects.
+L      1,FIX   move Left arg objects.
+B      none    move to the Back of the object.
+F      none    move to the Front of the object.
+U      1,FIX   move Up arg levels (and to the left).
+D      1,FIX   move Down arg levels (and to the right).
+UR     1,FIX   move Up arg levels (and to the right).
+DL     1,FIX   move Down arg levels (and to the left).
+S      1,any   Search -- tree-walk right until you find arg.
+-S     1,any   Search left -- tree-walk left until you find arg.
+WR     1,FIX   Walk Right arg positions.
+WL     1,FIX   Walk Left arg positions.
+C      1,any   Change the next object to arg.
+I      any,any Insert args to the left of the cursor.
+K      1,FIX   Kill (delete) the next arg objects.
+K:     none    Remove the "brackets" around the next object.
+I:     2       Make the next (arg 2) objects into a TYPE (arg 1).
+C:     1,TYPE  Change the Type of the next object to arg.
+SC     1,any   Put arg on next object as a comment.
+PC     none    Print comment on next object.
+BK     any,any BreaKpoint on next object; args typed at break.
+KB     none    Kill all Breakpoints in open object.
+OB     any,ATOM        BLOCK to list of OBLISTs whose names are given.
+EB     none    ENDBLOCK.
+OB?    none    type names of OBLISTs in current list of OBLISTs.
+<MERDE> returns you to MEDDLE from a higher level.
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/meddle.3 b/MUDDLE/meddle.3
new file mode 100644 (file)
index 0000000..99c0a70
--- /dev/null
@@ -0,0 +1,370 @@
+<FLOAD "MICROM" ">" "DSK" >
+<PRINC "/XMED">
+
+XMED!-
+MMED!-
+MEDDLE!-
+
+<BLOCK (<MOBLIST MM!- 13> <ROOT>)>
+O UT ? HERE OB EB OB?
+P PA PT PC
+S -S I C R L K U D UR DL WR WL B F
+C: I: K:
+SC V & Q \v
+BK KB
+<ENDBLOCK>
+
+<BLOCK (<MOBLIST IMM!-MM 23> <GET MM OBLIST> <ROOT>)>
+
+<NEWTYPE OBANDCURS LIST>
+
+<SETG INITOB ("NOTHING OPEN")>
+
+<DEFINE MMED MMEDACT   ("AUX"  (CI!-M 1) (CO!-M ,INITOB)
+                               (CL+1!-M 2) (LST!-M ())
+                               (LOC!-M <GLOC INITOB>)
+                               (CLLN <- <13 .OUTCHAN> 4>)
+                               (OBPDL ())
+                               (VERBSW #FALSE ()))
+       <PRINC "
+MEDDLE 2 Running.">
+       <RDBRAK (<GET MM!- OBLIST><GET M!- OBLIST>)>>
+
+<SETG MEDDLE <SETG XMED ,MMED>>
+
+<DEFINE O (IT "AUX" (HOW <GET <TYPE .IT> O>))
+       <COND (.HOW
+               <COND (<SET HOW <EVAL .HOW>>
+                       <OR <==? <TYPE .IT> OBANDCURS> <==? <TYPE .IT> CURSOR> <D>>)
+                     (ELSE .HOW)>)
+             (ELSE #FALSE ("BAD TYPE"))>>
+
+<PUT LOCD O '<O!-M .IT>>
+
+<PUT CURSOR O '<NC!-M .IT>>
+
+<PUT OBANDCURS O '<PROG ((LOBS ()) (NOBPDL <1 .IT>))
+                       <UNOB>
+                       <SET OBPDL <REST .NOBPDL>>
+                       <NC!-M <2 .IT>>
+                       <REPEAT () <AND <EMPTY? <REST .NOBPDL>> <RETURN T>>
+                               <SET LOBS (<1 .NOBPDL> !.LOBS)>
+                               <SET NOBPDL <REST .NOBPDL 4>>>
+                       <REPEAT () <AND <EMPTY? .LOBS> <RETURN T>>
+                               <BLOCK <1 .LOBS>>
+                               <SET LOBS <REST .LOBS>>>
+                       <SET NOB .OBLIST>
+                       <SET UTOP <1 .NOB>>
+                       <SET ROB (.UTOP !.NOB)>> >
+
+<PUT ATOM O '<COND (<GASSIGNED? .IT> <O!-M <GLOC .IT>>)
+                  (<ASSIGNED? .IT> <O!-M <LLOC .IT>>)
+                  (ELSE '#FALSE ("UNASSIGNED"))>>
+
+
+<DEFINE UT () <O!-M .LOC!-M> <D>>
+\f<DEFINE PT () <PRIMP <IN .LOC!-M>> <AGAIN .RDBRAKEXIT>>
+
+<DEFINE PA ("OPTIONAL" (N 0) "AUX" (QUICKPRINT!- #FALSE ()) (RI <- <* .N 3> 2>))
+       <PUTCURS>
+       <PRIMP  <COND (<L? .RI 0> <COND (<EMPTY? .LST!-M> <1 .CO!-M>) (T .CO!-M)>)
+                     (<G? .RI <- <LENGTH .LST!-M> 3>> <IN .LOC!-M>)
+                     (ELSE <.RI .LST!-M>)>>
+       <REMCURS>
+       <AGAIN .RDBRAKEXIT>>
+
+<DEFINE P ()
+       <PRIMP <COND (<==? .CI!-M .CL+1!-M> '#FALSE ("RIGHT-EDGE")) (ELSE <.CI!-M .CO!-M>)>>
+       <AGAIN .RDBRAKEXIT>>
+
+<DEFINE PRIMP (NP)
+       <COND (<GASSIGNED? EPRINT!->
+               <COND (<LOOKUP "MEDSW" <GET PP!- OBLIST>>)
+                     (T <FLOAD "MEDPP" ">" "DSK" "MUDDLE">)>
+               <EPRINT!- .NP>
+               <SETG PRIMP ,EPRINT!->)
+             (ELSE <PRINT .NP>)>>
+
+<SET MEDDLE_CURSOR!- "/\\">
+
+<DEFINE PUTCURS ()
+       <COND   (<==? .CI!-M .CL+1!-M> <SET SPECAFT!- <REST .CO!-M <- .CI!-M 2>>>)
+               (ELSE <SET SPECBEF!- <REST .CO!-M <- .CI!-M 1>>>)>>
+
+<DEFINE REMCURS () <SET SPECBEF <SET SPECAFT 0>>>
+
+<DEFINE Q () <UNOB> <EXIT .MMEDACT "muddle">>
+
+<DEFINE UNOB ()
+       <REPEAT ()      <AND <EMPTY? .OBPDL> <RETURN T>>
+                       <ENDBLOCK>
+                       <SET OBPDL <REST .OBPDL 4>> >>
+
+<DEFINE \v (ARG)
+       <VALRET <COND (<==? <TYPE .ARG> STRING> .ARG) (ELSE <UNPARSE .ARG>)>>>
+
+<DEFINE ? ("AUX" (FIL <OPEN "READ" "MEDCOM" ">" "DSK" "MUDDLE">))
+       <COND (.FIL
+               <REPEAT () <PRINC <READCHR '<RETURN T> .FIL>>>
+               <CLOSE .FIL>
+               <AGAIN .RDBRAKEXIT>)
+             (ELSE #FALSE("Where's my file???"))>>
+
+<DEFINE HERE (ATM)
+       <COND (<==? <TYPE .ATM> ATOM>
+               <SET .ATM <CHTYPE ((.OBLIST !.OBPDL) <GETC!-M>) OBANDCURS>>)
+             (ELSE #FALSE ("ARG NOT ATOM"))>>
+
+<DEFINE OB EOB ("TUPLE" BLOK)
+       <REPEAT ((BLK .BLOK))
+               <AND <EMPTY? .BLK> <RETURN T>>
+               <PUT .BLK 1 <COND (<==? <TYPE <1 .BLK>> OBLIST> <1 .BLK>)
+                                 (<GET <1 .BLK> OBLIST>)
+                                 (ELSE <EXIT .EOB #FALSE ("ARG NOT OBLIST OR OBLIST NAME")>)>>
+               <SET BLK <REST .BLK>> >
+       <SET OBPDL (.NOB .UTOP .ROB .OBLIST !.OBPDL)>
+       <SET NOB (!.BLOK !<COND (<MEMQ <ROOT> .BLOK> '()) (ELSE (<ROOT>))>)>
+       <BLOCK .NOB>
+       <SET UTOP <1 .NOB>>
+       <SET ROB (.TOB !.NOB)>
+       <AGAIN .RDBRAKEXIT>>
+
+<DEFINE EB ()
+       <COND (<EMPTY? .OBPDL> #FALSE ("NO MORE BLOCKS"))
+             (ELSE
+               <SET NOB <1 .OBPDL>>
+               <SET UTOP <2 .OBPDL>>
+               <SET ROB <3 .OBPDL>>
+               <SET OBPDL <REST .OBPDL 4>>
+               <ENDBLOCK>
+               <AGAIN .RDBRAKEXIT>)>>
+
+<DEFINE OB? ()
+       <REPEAT ((FOB .OBLIST))
+               <AND <EMPTY? .FOB> <AGAIN .RDBRAKEXIT>>
+               <TERPRI>
+               <PRIN1 <GET <1 .FOB> OBLIST>>
+               <SET FOB <REST .FOB>> >>
+\f<DEFINE V () <SET VERBSW <NOT .VERBSW>> T>
+
+<DEFINE & () <AMPERSAND> <AGAIN .RDBRAKEXIT>>
+
+<SETG CLOBOT <REST <IVECTOR 5 '(1)> 5>>
+<SETG FSLBOT <REST <IUVECTOR 5 -1> 5>>
+
+<DEFINE AMPERSAND ()
+       <COND (<FLATSIZE .CO!-M .CLLN>  <TERPRI>
+                                       <BRACK OPENBRAK .CO!-M>
+                                       <REPEAT ((IX 0))
+                                               <AND <==? <SET IX <+ .IX 1>> .CI!-M>
+                                                       <PRINC "/\\">>
+                                               <AND <==? .IX .CL+1!-M> <RETURN T>>
+                                               <PRIN1 <.IX .CO!-M>>
+                                               <PRINC !" >>
+                                       <BRACK CLOSEBRAK .CO!-M>)
+             (ELSE
+              <PROG ((CLOB ,CLOBOT) (FSL ,FSLBOT) FS BEGIN STOP
+                       (LLN <COND (<GET OPENBRAK <TYPE .CO!-M>> .CLLN)
+                                  (ELSE <- .CLLN 2 <FLATSIZE <TYPE .CO!-M> .CLLN>>)>))
+               <COND (<G? .CL+1!-M 5>
+                       <COND (<L? .CI!-M 4> <SET BEGIN .CO!-M> <SET LLN <- .LLN 1>>)
+                             (<L? <- .CL+1!-M .CI!-M> 4> <SET BEGIN <REST .CO!-M <- .CL+1!-M 5>>>
+                                                         <SET LLN <- .LLN 4>>)
+                             (ELSE <SET BEGIN <REST .CO!-M <- .CI!-M 3>>>
+                                   <SET LLN <- .LLN 9>>)>
+                       <SET STOP <REST .BEGIN <MIN 4 <LENGTH .BEGIN>>>>
+                       <AND <L? <FSZ> .LLN> <RETURN <EP1>>>)
+                     (ELSE <SET BEGIN .CO!-M>
+                           <SET STOP <REST .CO!-M <- .CL+1!-M 1>>>
+                           <AND <L? <FSZ> .LLN> <RETURN <EP1>>>)>
+               <REPEAT ()
+                   <REPEAT ((FL <REST .FSL>) (VIC .FSL))
+                       <COND (<G? <1 .FL> <1 .VIC>> <SET VIC .FL>)
+                             (<EMPTY? <SET FL <REST .FL>>>
+                               <SET CLOB <PUT <BACK .CLOB> 1
+                                           <REST .BEGIN <- <LENGTH .VIC> 1>>>>
+                               <SET FS <- .FS <1 .VIC> -4>>
+                               <PUT .VIC 1 4>
+                               <RETURN T>)>>
+                   <AND <L? .FS .LLN> <EP1> <RETURN T>>>>)>>
+
+<DEFINE FSZ ()
+       <REPEAT ((OBJ <REST .BEGIN 0>))
+               <SET FSL <PUT <BACK .FSL> 1
+                               <COND (<FLATSIZE <1 .OBJ> .LLN>)
+                                     (ELSE <SET CLOB <PUT <BACK .CLOB> 1 .OBJ>> 4)>>>
+               <AND <==? <SET OBJ <REST .OBJ>> .STOP> <RETURN <SET FS <+ !.FSL>>>>>>
+
+<DEFINE EP1 ()
+       <TERPRI>
+       <BRACK OPENBRAK .CO!-M>
+       <OR <==? .BEGIN .CO!-M> <PRINC "...& ">>
+       <SET BEGIN <REST .BEGIN 0>>
+       <REPEAT ((CP <REST .CO!-M <- .CI!-M 1>>))
+               <AND <==? .BEGIN .CP> <PRINC "/\\">>
+               <COND (<==? .BEGIN .STOP> <RETURN T>)
+                     (<MEMQ .BEGIN .CLOB> <BRACK OPENBRAK <1 .BEGIN>>
+                                          <PRINC !"&>
+                                          <BRACK CLOSEBRAK <1 .BEGIN>>)
+                     (ELSE <PRIN1 <1 .BEGIN>>)>
+               <PRINC !" >
+               <SET BEGIN <REST .BEGIN>>>
+       <OR <EMPTY? .STOP> <PRINC "&...">>
+       <BRACK CLOSEBRAK .CO!-M>>
+
+<DEFINE BRACK (WHICH WHAT "AUX" (BK <GET .WHICH <TYPE .WHAT>>))
+       <COND (.BK <PRINC .BK>)
+             (<MEMQ <TYPE .WHAT> '![ATOM FIX FLOAT]>)
+             (<==? .WHICH CLOSEBRAK> <PRINC <GET CLOSEBRAK <PRIMTYPE .WHAT> !"?>>)
+             (ELSE
+              <PRINC !"#>
+              <PRIN1 <TYPE .WHAT>>
+              <PRINC !" >
+              <PRINC <GET OPENBRAK <PRIMTYPE .WHAT> !"?>>)>>
+
+<PUT OPENBRAK LIST !"(>                <PUT CLOSEBRAK LIST !")>
+<PUT OPENBRAK FORM !"<>                <PUT CLOSEBRAK FORM !">>
+<PUT OPENBRAK VECTOR !"[>      <PUT CLOSEBRAK VECTOR !"]>
+<PUT OPENBRAK UVECTOR "![">    <PUT CLOSEBRAK UVECTOR "!]">
+<PUT OPENBRAK STRING !"">      <PUT CLOSEBRAK STRING !"">
+<PUT OPENBRAK TUPLE !"[>       <PUT CLOSEBRAK TUPLE !"]>
+<PUT OPENBRAK SEGMENT "!<">    <PUT CLOSEBRAK SEGMENT "!>">
+\f<DEFINE I ("ARGS" L) <I!-M .L>>
+<DEFINE C ('IT) <C!-M .IT> T>
+<DEFINE R ("OPTIONAL" (N 1) "AUX" (OCI .CI!-M))
+       <COND (<R!-M .N>) (T <SET CI!-M .OCI> #FALSE ("RIGHT-EDGE"))>>
+<DEFINE L ("OPTIONAL" (N 1) "AUX" (OCI .CI!-M))
+       <COND (<L!-M .N>) (T <SET CI!-M .OCI> #FALSE ("LEFT-EDGE"))>>
+<DEFINE B () <SET CI!-M .CL+1!-M>>
+<DEFINE F () <SET CI!-M 1>>
+<DEFINE K ("OPTIONAL" (N 1) "AUX" (OCI .CI!-M))
+       <COND (<L? .N 0> <L!-M <- .N>> <SET N <- .OCI .CI!-M>>)>
+       <K!-M .N> >
+<DEFINE U ("OPTIONAL" (N 1)) <PRIMREP ,UL!-M .N>>
+<DEFINE D ("OPTIONAL" (N 1)) <PRIMREP ,DR!-M .N>>
+<DEFINE UR ("OPTIONAL" (N 1)) <PRIMREP ,UR!-M .N>>
+<DEFINE DL ("OPTIONAL" (N 1)) <PRIMREP ,DL!-M .N>>
+<DEFINE WR ("OPTIONAL" (N 1)) <PRIMREP ,WR!-M .N>>
+<DEFINE WL ("OPTIONAL" (N 1)) <PRIMREP ,WL!-M .N>>
+
+<DEFINE PRIMREP (WHAT MANY "AUX" (OLDC <GETC!-M>))
+       <REPEAT (T1)
+               <COND (<L? .MANY 1> <RETURN T>)
+                     (<SET T1 <.WHAT>>)
+                     (ELSE <NC!-M .OLDC> <RETURN .T1>)>
+               <SET MANY <- .MANY 1>> >>
+
+<DEFINE S ('IT) <AND <PS .IT ,SR!-M> <R!-M 1>>>
+<DEFINE -S ('IT)<AND <PS .IT ,SL!-M>>>
+
+<DEFINE PS (WHAT HOW "AUX" (T <GETC!-M>))
+       <COND (<.HOW .WHAT>)
+             (ELSE <NC!-M .T> #FALSE ("NOT-FOUND"))>>
+
+<DEFINE C: (NTYP) <C!-M <SETYPE <.CI!-M .CO!-M> .NTYP>> T>
+
+<DEFINE I: (NTYP "OPTIONAL" (N 1) "AUX" (T <G!-M .N>))
+       <K .N>
+       <I!-M (<SETYPE .T .NTYP>)>
+       <L!-M 1>>
+
+<DEFINE K: ("AUX" (T <G!-M 1>) LINS)
+       <COND (<MONAD? <1 .T>> #FALSE ("NOT-STRUCTURED"))
+             (ELSE  <SET LINS <LENGTH <1 .T>>> <K!-M 1> <I!-M <1 .T>> <L!-M .LINS>)>>
+
+<DEFINE SETYPE (OBJ NTYPE)
+       <COND (<MONAD? .OBJ> <SET OBJ (.OBJ)>)>
+       <CHTYPE <APPLY ,<TYPEPRIM .NTYPE> !.OBJ> .NTYPE>>
+
+<DEFINE SC ("OPTIONAL" COMM)
+       <COND (<==? .CL+1!-M .CI!-M> #FALSE ("RIGHT-EDGE"))
+             (<ASSIGNED? COMM> <PUT <REST .CO!-M <- .CI!-M 1>> COMMENT .COMM> "put.")
+             (T <PUT <REST .CO!-M <- .CI!-M 1>> COMMENT> "Removed.")>>
+\f<DEFINE BK ("ARGS" L)
+       <COND   (<==? .CI!-M .CL+1!-M> '#FALSE ("RIGHT-EDGE"))
+               (ELSE <C!-M <CHTYPE (M_B .L <.CI!-M .CO!-M>) FORM>>
+                     "busted")>>
+
+<DEFINE KB ()
+       <UT>
+       <REPEAT (SV)
+               <COND (<SR!-M M_B> <SET SV <3 .CO!-M>>
+                               <UL!-M> <C!-M .SV>)
+                     (ELSE <RETURN 1>)>>
+       <UT>
+       "DONE">
+
+<DEFINE M_B ("BIND" CENV 'DOLIST 'SAVE
+                       "AUX"   (OUTCHAN ,OUTCHAN)
+                               (INCHAN ,INCHAN))
+       <TERPRI>
+       <PRINC "*BREAK*">
+       <REPEAT ()  <COND (<EMPTY? .DOLIST> <RETURN T>)
+                         (ELSE <TERPRI>
+                               <PRIN1 <1 .DOLIST>>
+                               <PRINC " = ">
+                               <PRIN1 <EVAL <1 .DOLIST> .CENV>>
+                               <SET DOLIST <REST .DOLIST>>)>>
+       <LISTEN>
+       <EVAL .SAVE .CENV>>
+\fMERDE!-
+
+<DEFINE OMERDE () <COND (<ASSIGNED? RDBRAKEXIT> <AGAIN .RDBRAKEXIT>) ("Not in MEDDLE.")>>
+
+<SETG GOFORM '<EXIT .RDBRAKEXIT "out of reader">>
+
+<SETG SPECS ![
+       !"              ;"SPACE"
+       !"              ;"TAB"
+       !"
+                       ;"CARRIAGE-RETURN"
+       !"\r             ;"LINE-FEED"
+       !"\e             ;"ALTMODE"
+]>
+
+<SETG ALTGETTER <MEMQ !"\e ,SPECS>>
+
+<DEFINE RDBRAK ("BIND" UENV COB "OPTIONAL" (NOB .OBLIST)
+                       "AUX"   (TOB <MOBLIST TOB 1>)
+                               (ROB (.TOB !.NOB))
+                               (UTOP <1 .NOB>)
+                               FRST CMND FLIST EFLIST)
+       <READCHR>       ;"FLUSH THE CRETINOUS INITIAL ALTMODE."
+       <REPEAT RDBRAKEXIT ()
+               <SET MERDE <CLOSURE ,OMERDE RDBRAKEXIT>>
+       P2GO    <TERPRI>
+               <PRINC !"*>
+        P1GO   <COND (<==? <NEXTCHR> <1 ,ALTGETTER>>
+                       <READCHR>
+                       <AMPERSAND>
+                       <GO P2GO>)>
+               <COND (<NOT <==? ATOM <TYPE <SET FRST <READ ,GOFORM .INCHAN .ROB>>>>>
+                       <REPEAT ((TTOB <1 .TOB>))
+                               <AND <EMPTY? .TTOB> <RETURN T>>
+                               <INTERN <REMOVE <1 .TTOB>> .UTOP>
+                               <SET TTOB <REST .TTOB>>>
+                       <PRINT <EVAL .FRST .UENV>>
+                       <AND <==? <NEXTCHR> !"\e> <READCHR>>
+                       <GO P2GO>)
+                     (<NOT <SET CMND <OR <LOOKUP <SET FLIST <PNAME .FRST>> <1 .COB>>
+                                         <LOOKUP .FLIST <2 .COB>>>>>
+                       <AND <==? <OBLIST? .FRST> .TOB> <INTERN <REMOVE .FRST> .UTOP>>
+                       <PRINT .FRST>
+                       <GO P2GO>)>
+               <AND <==? <OBLIST? .FRST> .TOB> <REMOVE .FRST>>
+               <SET FLIST <SET EFLIST <FORM .CMND>>>
+               <REPEAT (TEM)
+                       <COND (<SET TEM <MEMQ <NEXTCHR ,GOFORM> ,SPECS>>
+                               <READCHR>
+                               <AND <==? .TEM ,ALTGETTER> <RETURN T>>)
+                             (ELSE <SET EFLIST <REST <PUTREST .EFLIST (<READ ,GOFORM>)>>>)>>
+               <COND (<SET FLIST <EVAL .FLIST>>)
+                     (ELSE <PRIN1 .FLIST>)>
+               <AND .VERBSW <GO P1GO>>
+               <AMPERSAND>>>
+
+
+<ENDBLOCK>
+
+<COND (<LOOKUP "XMED" <1 .OBLIST>> <SETG <LOOKUP "XMED" <1 .OBLIST>> ,XMED!-> <REMOVE XMED>)>
+\f\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/medpp.1 b/MUDDLE/medpp.1
new file mode 100644 (file)
index 0000000..78c0eab
--- /dev/null
@@ -0,0 +1,81 @@
+<PRINC "/MEDPP">
+"File to convert a PPRINT with comments to a MEDPP."
+"PPRINT MUST!!! be loaded FIRST!!!"
+
+"Add the ATOMs needed for intercommunication with MEDDLE."
+<BLOCK (<ROOT>)>
+"Cursor arrangements."
+MEDDLE_CURSOR
+SPECBEF
+SPECAFT
+"Other."
+PRINE
+<ENDBLOCK>
+\f"Now add and change things within PPRINT."
+<BLOCK (<GET PP OBLIST> <ROOT>)>
+
+MEDSW  ;"The existence of this atom in PP shows that MEDPP has been loaded."
+
+<SET SPECBEF 0>
+<SET SPECAFT 0>
+
+<SETG PRINMED <FUNCTION ()     ;"Print the cursor and speed things up."
+       <PRINC .MEDDLE_CURSOR>
+       <SETG FORMS ,FASTFORMS>>>
+
+<SETG COMPONENTS       ;"Print the components of a structure in a column" 
+      <FUNCTION (L "OPTIONAL" (OM <+ .M 1>) (STOP 0))
+       <SET L <REST .L 0>>             ;"So cursor point can be recognized."
+       <REPEAT ((N <LINPOS .OUTCHAN>) (M 0))
+               <AND <EMPTY? <REST .L>> <SET M .OM>>
+               <AND <==? .L .SPECBEF> <PRINMED>>
+               <FORMS <1 .L>>
+               <AND <==? .L .SPECAFT> <PRINMED>>
+               <COMMENTS>
+               <AND <OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN DONE>>
+               <TERPRI>
+               <INDENT-TO .N>>>>
+
+
+<SETG ELEMENTS         ;"Print the components of a structure in a line."
+      <FUNCTION (L "OPTIONAL" (M <+ .M 1>) (STOP 0))
+       <COND (<EMPTY? .L>)
+             (ELSE
+               <SET L <REST .L 0>>             ;"So cursor point can be recognized."
+               <REPEAT ((N <LINPOS .OUTCHAN>) COM)
+                       <AND <==? .L .SPECBEF> <PRINMED>>
+                       <FORMS <1 .L>>
+                       <AND <==? .L .SPECAFT> <PRINMED>>
+                       <SET COM <COMMENTS>>
+                       <AND <OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN DONE>>
+                       <COND (.COM <TERPRI> <INDENT-TO .N>)>
+                       <PRINC !" >>)>>>
+
+<SETG PRINE <FUNCTION (L "OPTIONAL" (OUTCHAN .OUTCHAN)
+                        "AUX" (M 0) (COMELE ,COMPONENTS))
+       <SPEEDSEL>
+       <COND   (<MONAD? .L>)
+               (<==? <TYPE .L> STRING> <TERPRI> <PRINC .L> <TERPRI>)
+               (<FLATSIZE .L <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN>>>
+                       <TERPRI> <ELEMENTS .L>)
+               (ELSE <TERPRI><COMPONENTS .L>)>
+       ,NULL>> ;"The rubout atom is there."
+
+
+<SETG NORMFORM <FUNCTION ("AUX" (PN <+ 1 <LINPOS .OUTCHAN>>))
+                       <PRINC "<" >
+                       <AND <==? <REST .L 0> .SPECBEF> <PRINMED>>
+                       <FORMS <1 .L>>
+                       <AND <==? .L .SPECAFT> <PRINMED>>
+                       <COND (<==? .COMELE ,ELEMENTS> <COMEND>)
+                             (<FORMAHEAD .L> <COMMENTS> <TERPRI> <INDENT-TO .PN>
+                               <COND (<FLATSIZE <REST .L> <- <LINLNT .OUTCHAN>
+                                                               <LINPOS .OUTCHAN>
+                                                               .M 3>>
+                                               <ELEMENTS <REST .L>>)
+                                     (T <COMPONENTS <REST .L>>)>)
+                             (T <COMEND>)>
+                       <PRINC ">">>>
+
+<ENDBLOCK>
+\f\f\f\ 3\f\ 3\ 3\ 3\ 3ð`Á\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
\ No newline at end of file
diff --git a/MUDDLE/microm.1 b/MUDDLE/microm.1
new file mode 100644 (file)
index 0000000..ba64793
--- /dev/null
@@ -0,0 +1,165 @@
+<PRINC "/MICROMED">
+<BLOCK (<MOBLIST M!- 13> <ROOT>)>
+CO CI CL+1 LST LOC
+O GETC NC
+PUSHO POPO
+L R DR DL UR UL
+I K G C
+SR SL WR WL
+CWR CWL
+<ENDBLOCK>
+
+<BLOCK (<MOBLIST IM!-M!- 23> <GET M!- OBLIST> <ROOT>)>
+
+<SETG O <FUNCTION (IT)
+       <SET LOC .IT>
+       <SET LST ()>
+       <SET CL+1 2>
+       <SET CI 1>
+       <SET CO (<IN .IT>)>
+       T>>
+
+<NEWTYPE CURSOR!- VECTOR>
+
+<SET OPDL ()>
+
+<SETG GETC <FUNCTION () <CHTYPE [.CO .CI .CL+1 .LST .LOC] CURSOR>>>
+
+<SETG PUSHO <FUNCTION (IT) <PUSH!- OPDL <GETC>> <O .IT>>>
+
+<SETG POPO <FUNCTION () <NC <POP!- OPDL>>>>
+
+<SETG NC <FUNCTION (IT)
+       <SET CO <1 .IT>>
+       <SET CI <2 .IT>>
+       <SET CL+1 <3 .IT>>
+       <SET LST <4 .IT>>
+       <SET LOC <5 .IT>>
+       T>>
+\f<SETG L <FUNCTION (N "AUX" (T <- .CI .N>))
+               <==? .T <SET CI <MAX 1 .T>>>>>
+
+<SETG R <FUNCTION (N "AUX" (T <+ .CI .N>))
+               <==? .T <SET CI <MIN .CL+1 .T>>>>>
+
+
+<SETG DR <FUNCTION ()
+               <COND   (<==? .CI .CL+1> #FALSE("NO-RIGHT"))
+                       (ELSE <PRID .CI T>)>>>
+
+
+<SETG DL <FUNCTION ()
+               <COND   (<1? .CI> #FALSE("NO-LEFT"))
+                       (ELSE <PRID <- .CI 1> #FALSE()>)>>>
+
+<SETG PRID <FUNCTION (N T)
+               <COND (<MONAD? <.N .CO>> #FALSE("MONAD"))
+                     (ELSE
+                       <SET LST (.CO .N .CL+1 !.LST)>
+                       <SET CO <.N .CO>>
+                       <SET CL+1 <+ 1 <LENGTH .CO>>>
+                       <SET CI <COND (.T 1) (ELSE .CL+1)>>)>>>
+
+<SETG UL <FUNCTION ()
+               <COND (<EMPTY? .LST> #FALSE("TOP"))
+                     (ELSE <SET CI <2 .LST>> <PRIU>)>>>
+
+<SETG UR <FUNCTION ()
+               <COND (<EMPTY? .LST> #FALSE("TOP"))
+                     (ELSE <SET CI <+ 1 <2 .LST>>> <PRIU>)>>>
+
+<SETG PRIU <FUNCTION ()
+       <SET CO <1 .LST>>
+       <SET CL+1 <3 .LST>>
+       <SET LST <REST .LST 3>>
+       T>>
+\f<SETG WR <FUNCTION () <OR <DR> <R 1> <UR>>>>
+<SETG WL <FUNCTION () <OR <DL> <L 1> <UL>>>>
+
+<SETG SR <FUNCTION (IT) <PRIMS .IT ,DR ,R ,UR>>>
+<SETG SL <FUNCTION (IT) <PRIMS .IT ,DL ,L ,UL>>>
+
+<SETG PRIMS <FUNCTION (IT DOWN ACROSS UP)
+     <REPEAT ()
+       <COND (<AND <L? .CI .CL+1> <=? .IT <.CI .CO>>>
+               <RETURN T>)
+             (<.DOWN>) (<.ACROSS 1>) (<.UP>)
+             (ELSE <RETURN #FALSE ("NOT-FOUND")>)>>>>
+
+<SETG CWR <FUNCTION (C) <PRIMCW .C ,DR ,R ,UR>>>
+<SETG CWL <FUNCTION (C) <PRIMCW .C ,DL ,L ,UL>>>
+
+<SETG PRIMCW <FUNCTION (C DOWN ACROSS UP)
+     <REPEAT ()
+       <COND   (<EVAL .C> <RETURN T>)
+               (<.DOWN>) (<.ACROSS 1>) (<.UP>)
+               (ELSE <RETURN #FALSE ("END")>)>>>>
+\f<SETG I <FUNCTION (IT "AUX" (RCI <- .CI 1>) (LIT <LENGTH .IT>) (OCI .CI))
+       <SET CI <+ .CI .LIT>>
+       <SET CL+1 <+ .CL+1 .LIT>>
+       <COND (<==? <PRIMTYPE .CO> LIST>
+               <COND   (<EMPTY? .IT> T)
+                       (ELSE   <SET IT (!.IT)>
+                               <PUTREST <REST .IT <- .LIT 1>> <REST .CO .RCI>>
+                               <LIPSTIC .IT>)>)
+             (ELSE
+               <SET CO <CHTYPE <NEWSTRUC ,<PRIMTYPE .CO>
+                                       (.CO .IT <REST .CO .RCI>)
+                                       (.RCI .LIT <- .CL+1 .CI>)>
+                               <TYPE .CO>>>
+               <UPDATE>)>>>
+
+
+<SETG K <FUNCTION (N "AUX" (RCO <REST .CO <MIN <- .CL+1 1> <+ .CI .N -1>>>) 
+                               (LCO <LENGTH .RCO>) (OCI .CI))
+       <SET CL+1 <+ .CI .LCO>>
+       <COND (<==? <PRIMTYPE .CO> LIST> <LIPSTIC .RCO>)
+             (ELSE
+               <SET CO <CHTYPE <NEWSTRUC ,<PRIMTYPE .CO>
+                                       (.CO .RCO)
+                                       (<- .CI 1> .LCO)>
+                               <TYPE .CO>>>
+               <UPDATE>)>>>
+
+<SETG LIPSTIC <FUNCTION (L)
+       <COND (<1? .OCI> <SET CO <CHTYPE .L <TYPE .CO>>> <UPDATE>)
+             (ELSE <PUTREST <REST .CO <- .OCI 2>> .L> T)>>>
+
+
+
+<SETG UPDATE <FUNCTION ("AUX" (LLST <LENGTH .LST>))
+       <COND (<0? .LLST>
+               <SETLOC .LOC
+                       <COND (<AND <NOT <MONAD? .CO>> <1? <LENGTH .CO>>> <1 .CO>)
+                             (ELSE .CO)>>)
+             (ELSE <COND (<==? 3 .LLST> <SETLOC .LOC .CO>)>
+                  <SETLOC <AT <1 .LST> <2 .LST>> .CO>)>
+       T>>
+
+<SETG G <FUNCTION (N "AUX" (M <MIN .N <- .CL+1 .CI>>) (N <- .CI 1>))
+       <ILIST .M '<<SET N <+ .N 1>> .CO>>>>
+
+<SETG C <FUNCTION (N)
+       <COND   (<==? .CI .CL+1> #FALSE ("RIGHT-EDGE"))
+               (ELSE <SETLOC <AT .CO .CI> .N>)>>>
+\f
+<SETG NEWSTRUC
+      <FUNCTION (FN OL NL "AUX" T (O <1 .OL>) (N <1 .NL>) (IX 0))
+  ;"Actual structure hacker.  STACKFORMs FN, gobbling <1 .NL> members from <1 .OL> 'till gone."
+               <STACKFORM .FN
+                          .T
+                          <COND (<==? .N .IX>
+                                 <REPEAT ()
+                                         <COND (<EMPTY? <SET OL <REST .OL>>>
+                                                <RETURN #FALSE ()>)
+                                               (ELSE
+                                                <COND (<0? <SET N
+                                                                <1 <SET NL
+                                                                        <REST .NL>>>>>
+                                                       <AGAIN>)>
+                                                <SET IX 1>
+                                                <SET T <1 <SET O <1 .OL>>>>
+                                                <RETURN <SET O <REST .O>>>)>>)
+                                (ELSE <SET T <1 .O>> <SET IX <+ .IX 1>> <SET O <REST .O>>)>>>>
+<ENDBLOCK>
+\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
\ No newline at end of file
diff --git a/MUDDLE/mproc.save b/MUDDLE/mproc.save
new file mode 100644 (file)
index 0000000..cd09743
--- /dev/null
@@ -0,0 +1,208 @@
+;THESE SECTIONS OF CODE HAVE BEEN ABLATED FROM NEVAL 114
+;SO THAT THE TIDE OF HISTORY MAY WASH OVER THE BONES OF THE MULTI-
+;PROCESSED AGGRESSORS
+
+
+;THE FIRST IS THE WAY THE SYSTEM USED TO DO EVALUATIONS WITH
+;RESPECT TO FRAMES-- NOW CALLED EWRTFM.
+
+\r      MOVE    A,3(AB)
+       HRRZ    D,2(AB)         ;GET POINTER TO PV DOPE WORD
+       PUSHJ   P,SWAPQ         ;SEE IF SWAP NECESSARY
+       PUSH    TP,(D)
+       PUSH    TP,1(D)
+       MCALL   1,EVAL          ;NOW DO NORMAL EVALUATION
+UNSWPQ:        MOVE    D,1(TB)         ;GET SAVED PVP
+       CAMN    D,PVP   ;CHANGED?
+       JRST    FINIS           ;NO - RETURN
+       PUSHJ   P,SPECSTORE     ;CLEAN UP
+       MOVE    D,(TB)
+       JSP     C,SWAP          ;SWAP OUT AND BACK
+       JRST    FINIS
+
+
+; ROUTINE TO CHANGE PROCID AND POSSIBLY SWAP
+
+SWAPQ: HLRZ    C,(D)           ;GET LENGTH
+       SUBI    D,-1(C)         ;POINT TO START OF PV
+       MOVNS   C               ;NEGATE LENGTH
+       HRLI    D,2(C)          ;MAKE AOBJN POINTER
+       MOVE    E,PVP           ;COPY CURRENT PROCESS VECTOR
+       POP     P,B             ;GET RET ADR SO POPJ WINS IF SWAP OCCURS
+       CAME    D,PVP           ;IS THIS IT?
+       JSP     C,SWAP          ;NO, SWAP IN NEW PROCESS
+       PUSH    P,B             ;NOW, PUT IT BACK
+       PUSH    TP,$TPVP        ;SAVE PROCESS
+       PUSH    TP,E
+       HLL     B,OTBSAV(A)     ;GET TIME FROM FRAME POINTED AT
+       HRR     B,A
+       HRRZ    C,A
+       CAIG    C,1(TP)
+       CAME    B,A             ;CHECK THAT THE FRAME IS LEGIT
+       JRST    ILLFRA
+       HLRZ    C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       CAMN    SP,SPSAV(A)
+       JRST    AEV1
+       MOVE    SP,SPSAV(A)     ;LOAD UP OLD ENVIRONMENT
+       MOVE    A,PVP
+       ADD     A,[PROCID,,PROCID]      ;GET LOCATIVE TO PROCESS ID
+       PUSH    TP,BNDV         ;BIND IT TO
+       PUSH    TP,A
+       AOSN    A,PTIME         ;A UNIQUE NUMBER
+       .VALUE  [ASCIZ /TIMEOUT/]
+       PUSH    TP,$TFIX
+       PUSH    TP,A
+       PUSHJ   P,SPECBIND
+AEV1:  MOVE    E,1(TB)         ;GET SAVED PROCESS
+       MOVE    D,AB            ;COPY CURRENT ARG POINTER
+       CAME    E,PVP           ;HAS PROCESS CHANGED?
+       MOVE    D,ABSTO+1(E)    ;GET SAV AB
+       POPJ    P,              ;RETURN TO CALLER
+
+
+
+;THIS FRAGMENT FROM THE EVALUATOR IS WHERE THE SYSTEM USED TO
+;COME TO DO "RESUME."  SOME DAY, NO DOUBT, IT WILL AGAIN.
+
+
+RESOMER:
+; 0,1(TB) IS PROCESS VECTOR POINTER TO PROCESS TO BE RESUMED
+; 0,1(AB) IS A FORM CONTAINING ARGS TO SAVED FUNTION
+
+       MOVE    D,1(TB)         ;GET PVP OF PROCESS TO BE RESUMED
+       GETYP   A,RESFUN(D)     ; GET TYPE OF FUNCTION
+
+       CAIN    A,TSUBR         ;SUBR?
+       JRST    RESSUBR         ;YES
+       CAIN    A,TFSUBR        ;NO -- FSUBR?
+       JRST    RESFSUBR                ;YES
+       CAIN    A,TEXPR         ;NO -- EXPR?
+       JRST    RESEXPR         ;YES
+       CAIN    A,TFIX          ;NO -- CALL TO NTH?
+       JRST    RESNUM          ;YES
+       CAIN    A,TFUNARG       ;NO -- FUNARG?
+       JRST    NOTIMP  ;YES
+       JRST    NAPT            ;NONE OF THE ABOVE
+
+
+;RESFSUBR RESUMES FSUBRS
+
+RESFSUBR:
+       HRRZ    A,@1(AB)        ;GET THE ARG LIST
+       SUB     TP,[2,,2]       ;CLEAN UP
+       JSP     C,SWAP          ;SWAP IN NEW PROCESS
+       PUSH    TP,$TLIST
+       PUSH    TP,A            ; PUSH THE ARG LIST
+       MCALL   1,@RESFUN+1(PVP) ; RESUME WITH THE SAVED FUNCTION
+       JRST    FINIS
+
+;RESSUBR RESUMES SUBRS
+
+RESSUBR:       
+       HRRZ    A,@1(AB)        ;GET CDR OF FORM -- ARGLIST
+       PUSH    TP,$TLIST       ;SAVE THE ARGLIST ON
+       PUSH    TP,A            ;THE TP
+       PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
+RESTUPLUP:
+       SKIPN   A,3(TB)         ;IS IT NIL?
+       JRST    RESMAKPTR               ;YES -- DONE
+       PUSH    TP,(A)          ;NO -- GET CAR OF THE
+       HLLZS   (TP)            ;ARGLIST
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;AND EVAL IT.
+       MOVE    D,1(TB) ;GET PVP OF P.T.B.R.
+       MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
+       PUSH    C,A             ;SAVE THE RESULT IN THE GROWING
+       PUSH    C,B             ;TUPLE OF ARGS IN P.T.B.R.
+       MOVEM   C,TPSTO+1(D)    ;UPDATE TP OF P.T.B.R.
+       AOS     (P)             ;BUMP THE ARGCNT
+       HRRZ    A,@3(TB)        ;SET THE ARGLIST TO 
+       MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
+       JRST    RESTUPLUP
+RESMAKPTR:
+       POP     P,A             ;GET NUMBER OF ARGS IN A        
+       MOVE    D,1(TB)         ;GET PVP OF P.T.B.R.
+       SUB     TP,[4,,4]       ;GET RID OF GARBAGE
+       JSP     C,SWAP          ;SWAP IN THE NEW PROCESS
+       ACALL   A,RESFUN+1(PVP) ;CALL THE SAVED FUNCTION
+       JRST    FINIS
+
+
+
+;RESNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+RESNUM:
+       HRRZ    A,@1(AB)        ;GET ARGLIST
+       JUMPE   A,ERRTFA        ;NO ARGUMENT
+       PUSH    TP,(A)          ;GET CAR OF ARGL
+       HLLZS   (TP)    
+       PUSH    TP,1(A)
+       HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
+       JUMPN   A,ERRTMA
+       JSP     E,CHKARG        ;HACK DEFERRED
+       MCALL   1,EVAL
+       MOVE    D,1(TB)         ;GET PVP OF P.T.B.R.
+       MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
+       PUSH    C,A             ;PUSH ARG
+       PUSH    C,B
+       SUB     TP,[2,,2]       ;CLEAN UP BEFORE LEAVING
+       JSP     C,SWAP          ;BRING IN NEW PROCESS
+       PUSH    TP,RESFUN(PVP)  ;PUSH NUMBER
+       PUSH    TP,RESFUN+1(PVP)
+       MCALL   2,NTH
+       JRST    FINIS
+
+;RESEXPR RESUMES EXPRS
+;EXPRESSION IS IN 0(AB),  FUNCTION IS IN RESFUN(PVP)
+RESEXPR:
+       SKIPN   C,RESFUN+1(D);BODY?
+       JRST    NOBODY          ;NO, ERROR
+
+       MOVE    C,TPSTO+1(D)    ;GET TP OF P.T.B.R.
+       PUSH    C,BNDA          ;SPECIAL ATOM CROCK
+       PUSH    C,MQUOTE [PPROC ],INTRUP ;PPROC=PARENT PROCESS
+       MOVE    B,OTBSAV(TB)
+       PUSHJ   P,MAKENV        ;MAKE ENVIRONMENT FOR THIS PROCESS
+       PUSH    C,A
+       PUSH    C,B
+       MOVEM   C,TPSTO+1(D)    ;UPDATE TP OF P.T.B.R.
+       HRRZ    0,1(AB)         ;GET EXPRESSION INTO 0
+       HRRZ    A,@0            ;AND ARGLIST INTO A
+       HLL     0,(AB)          ;TYPE TO LH OF  0
+       SUB     TP,[2,,2]       ;CLEAN UP BEFORE LEAVING
+       JSP     C,SWAP          ;SWAP IN NEW PROCESS
+       PUSH    P,0             ;SAVE 0
+       PUSH    P,A             ;SAVE A=ARGLIST
+       PUSH    TP,[0]
+       PUSH    TP,[0]          ;COMPLETE ARGS FOR PPROC BINDING
+       PUSHJ   P,SPECBIND      ;BIND THE PARENT PROCESS
+       POP     P,D             ;POP ARGLIST INTO D
+       POP     P,0             ;POP CALL HACK INTO 0
+       MOVE    C,RESFUN+1(PVP) ;GET FUNCTION
+       PUSHJ   P,BINDRR        ;CALL BINDER FOR RESUMED EXPR HACKING
+
+       HRRZ    C,@RESFUN+1(PVP) ;GET BODY BACK
+       JUMPE   A,DOPROG        ;NOW GO RUN IF NO ACTIVIATION
+       PUSH    TP,$TLIST       ;SAVE ANOTHER COPY FOR REACT
+       PUSH    TP,C
+       SKIPL   A               ;SKIP IF NOT NAME ALA HEWITT
+       HRRZ    C,(C)           ;ELSE CDR AGAIN
+       JRST    DOPROG
+
+;THE FOLLOWING FRAGMENT (INCLUDING COMMENT), IS
+;FROM THE BINDER, WHICH USED TO ATTEMPT TO BIND RESUMED FUNCTIONS, 
+;OR SOME SUCH THING, AND, I HAVE FAITH, WILL RISE FROM THE
+;ASHES TO ATTEMPT IT AGAIN.
+
+;THIS ONE IS FOR MULTI-PROCESSING
+
+RSRGEV:        JSP     E,CHKARG
+       MOVE    B,MQUOTE [PPROC ],INTRUP
+       PUSHJ   P,ILVAL
+       PUSH    TP,A
+       PUSH    TP,B
+\r      MCALL   2,EVAL
+       POPJ    P,\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/muddle.196 b/MUDDLE/muddle.196
new file mode 100644 (file)
index 0000000..f73305a
--- /dev/null
@@ -0,0 +1,916 @@
+;CONVENTIONS USED IN ALL  INTERNAL MUDDLE PROGRAMS
+
+;FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE
+;WITH EXPLICIT CHECKS
+;FOR PENDING INTERRUPTS
+
+
+; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST
+;BE ABSOLUTELY PURE.
+;BETWEEN ANY TWO INSTRUCTIONS OF
+;INTERRUPTABLE CODE THERE MAY
+;BE AN INTERUPT IN WHICH
+;A COMPACTING GARBAGE COLLECTION IS CALLED
+;AND THEN THE PROCESS WHICH WAS RUNNING IS
+;PASSIVATED AND ANOTHER RESUMED.
+
+; ALL ATOM HEADERS WILL BE REFERRED TO IN ASSEMBLED CODE BY
+; MQUOTE <PNAME>
+; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING:
+
+;      MCALL N,<PNAME> ;SEE MCALL MACRO
+
+; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE FUNINESS
+
+
+
+\f; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT)
+
+;     20:      SPECIAL CODE FOR UUO AND INTERUPTS
+
+;CODBOT:       WORD CONTAINING LOCATION OFBOTTOMMOST WORD OF CODE
+
+;              --CODE--
+
+;CODTOP:       WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE
+
+;PARBOT:       WORD CONTAINING LOCATION OFBOTTOMMOST LIST
+
+;              --PAIRSS--
+
+;PARTOP:       WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD
+
+;VECBOT:       WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS
+
+;              --VECTORS--
+
+;VECTOP:       WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR
+;              THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR
+
+
+\f;BASIC DATA TYPES PRE-DEFINED IN MUDDLE
+
+; PRIMITIVE DATA TYPES
+; IF T IS A DATA TYPE THEN $T=[T,,0]
+
+; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER
+
+
+;TLOSE         ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS)
+;TFIX          ;FIXED POINT
+;TFLOT         ;FLOATING POINT
+;TCHRS         ;WORD OF UP TO 5 ASCII CHARACTERS
+;TLIST         ;LIST ELEMENT
+;TVEC          ;VECTOR  (AOBJN POINTER TO GENERALIZED VECTOR)
+;TAP           ;SAVED AP
+;TAB           ;SAVED AB (CANT APPEAR IN LISTS)
+;TTP           ;SAVED TP
+;TTB           ;SAVED TP
+;TATOM         ;ATOM WHICH IS REALLY A SPECIAL TYPE OF VECTOR BUT MAY CHANGE
+;TEXPR         ;FUNCTIONS CORRESPONDING TO THE STANDARD LISP FUNCTIONS
+;TSUBR         ;MACHINE LANGUAGE 'EXPR'
+;TFSUBR                ;MACHINE LANGUAGE PROGRAM (TAKES LIST AS ARG)
+;TENTRY                ;RETURN ADDRESS FROM MCALL MACRO
+;TPDL          ;SAVE "P"
+;TUNBOU                ;UNBOUND VALUE
+;TLOCI                 ;IDENTIFIER LOCATIVE
+;TFUNARG       ;FUNCTIONAL ARGUMENT
+;TTIME                 ;SPECIAL TIME POINTER-NOT MARKED (USER CAN'T SEE OR CHANGE)
+;TSKIP                 ;SKIP WORD ON SPECIAL PDL
+;TCHVEC                ;VECTOR OF UNIFORM CHARACTERS NOT MARKED
+;TCHSTR                ;GENERAL VECTOR OF CHARACTERS
+;TTVP          ;SAVE TRANSFER VEVTOR POINTER
+;TPVP          ;SAVED PROCESS VECTOR POINTER
+;TCHAN         ;CHANNEL VECTOR (SEE FOPEN FOR FULL DOCUMENTATION)
+;TENV          ;ENVIRONMENT POINTER
+;TOBL          ;OBLIST TYPE
+;TLMNT         ;ELEMENT CALL
+;TSEG          ;SEGMENT CALL
+
+;STORAGE ALLOCATION TYPES SAT (ALLOCATED VALUES BY AN IRP)
+
+;1WORD         ;UNMARKED ONE WORD ENTITIES
+;2WORD         ;LIST STRUCTURE GOODIES
+;2NWORD                ;VECTOR STRUCTURE GOODIES
+;STACK         ;PUSH DOWN STACKS
+;BASE          ;ONE MEMBER, NAMELY AB
+\f; FORMAT OF LIST ELEMENT
+
+;      WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR
+;               BITS 1-17 TYPE OF FIRST ELEMENT OF LIST
+;               BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0)
+;
+;      WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED
+
+
+
+;FORMAT OF GENERAL VECTOR (OF N ELEMENTS)
+;POINTED INTO BY AOBJN POINTER
+;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS
+
+
+;      TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO)
+;      OBJ<1>  OBJECT OF SPECIFIED TYPE
+;      TYPE<2>
+;      OBJ<2>
+;      .
+;      .
+;      .
+;      TYPE<N>
+;      OBJ<N>
+;      VD-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN
+
+
+\f;SPECIAL VECTORS IN THE INITIAL SYSTEM
+
+;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES
+;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER
+;FOUND IN THE TYPE FIELD OF ANY GOODIE.
+
+;THE INFORMATION MAY BE ACCESSED WITH FUNCTIONS "SAT" AND "TYPE"
+
+
+;TYPE TO NAME OF TYPE TRANSLATION TABLE
+
+;      TATOM,,<STORAGE ALLOCATION TYPE>
+;      ATOMIC NAME
+
+;AN ATOM IS A VECTOR WITH 3 ELEMENTS AS FOLLOWS
+
+;      TYPE OF VALUE   TYPES ARE FULL WORD QUANTITIES
+;      VALUE
+;      TLIST,,<PROCESS I.D.>
+;      PLIST (PROPERTY LIST)
+;      TVEC (OR TCHRS IF LESS THAN 6 CHARS)
+;      PNAME (VECTOR OF ELEMENTS OF TYPE TCHRS)
+;      7,,0    (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION)
+
+;WARNING  THE FORMAT OF ATOMS WILL CHANGE
+;USE THE INTERNAL FUNCTIONS IVCELL,IGVALU,ILVALU,IPNAME,IPLIST
+;AND THE EXTERNALS VCELL,GVALUE,LVALUE,PNAME,PLIST
+
+;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE
+;WILL BE POINTED TO BY THE TRANSFER VECTOR
+;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP
+;THE FORMAT OF THIS VECTOR IS:
+
+;      TYPE,,0
+;      VALUE
+;      .
+;      .
+;      .
+;      TV DOPE WORD
+
+
+;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR
+;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP
+;THE FORMAT OF A PROCESS VECTOR IS:
+
+;      TFIX,,0
+;      PROCID  ;UNIQUE ID OF THIS PROCESS
+
+;      20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS
+;      CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS
+;      OF THE FORM AC!STO(PVP)
+
+;      TTP,,0
+;      <TP AT LAST ERROR CALL> ;CAN BE REFERENCED SYMBOLICALLY AS LERR(PVP)
+
+;      TTB,,0
+;      <LAST PROG>     ;LPROG(PVP)
+;      .
+;      .
+;      .
+;      PV DOPE WORD
+
+
+
+
+;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS
+
+;SPECIAL PDL (SP)
+
+;      .
+;      .
+;      .
+;      TYPE OF VALUE
+;      OLD CONTENTS OF VALUE CELL
+;      $TATOM
+;      LOCATION OF VALUE CELL
+;      .
+;      .
+;      VD (FOR PDL)
+
+
+
+
+
+;THE FORMAT FOR TP (TEMPORARY PDL MARKED) AND AP (ARGUMENT PDL) ARE NOW THE SAME
+;EVENTUALLY THIS MAY
+;CHANGE BY BLOCKING THE AP WITH
+;VECTOR DESCRIPTORS AT THE HEAD OF EACH BLOCK
+
+
+
+
+;      .
+;      .
+;      .
+;      TYPE
+;      GOODIE
+;      .
+;      .
+;      VD (VECTOR DOPE FOR THE VECTOR  WHICH IS PDL)
+
+
+
+\fIF1 [
+PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS
+/
+]
+
+IF2 [PRINTC /MUDDLE
+/
+]
+;AC ASSIGNMNETS
+
+P"=17  ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE)
+SP"=15 ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS) (NOT USED NOW)
+TP"=14 ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS 
+       ;AND MARKED TEMPORARIES)
+TB"=13 ;MARKED PDL BASE POINTER 
+R"=12  ;RELOCATION INDEX FOR LOCATION INSENSITIVE SUBRS
+AB"=11 ;ARGUMENT PDL BASE (MARKED)
+       ;AB IS AN AOBJN POINTER TO THE ARGUMENTS
+PP"=10 ;PLANNER PDL (MAY NOT BE IN DYNAMIC MODELLING)
+TVP"=7 ;TRANSFER VECTOR POINTER
+PVP"=6 ;PROCESS VECTOR POINTER
+
+;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE
+
+A"=1
+B"=2
+C"=3
+D"=4
+E"=5
+
+NIL"=0 ;END OF LIST MARKER
+
+;MACRO TO DEFINE MAIN IF NOT DEFINED
+
+DEFINE DEFMAI ARG,\D
+       D==.TYPE ARG
+       IFE <D-17>,ARG==0
+       EXPUNGE D
+       TERMIN
+
+DEFMAI MAIN
+DEFMAI READER
+
+EXPUNGE DEFMAI
+
+; DEFINE SYMBLOS FOR VARIOUS OBLISTS
+
+SYSTEM==0      ;MAIN SYSTEM OBLIST
+ERRORS==1      ;ERROR COMMENT OBLIST
+INTRUP==2      ;INERRUPT OBLIST
+
+\f;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS
+
+NUMPRI==-1     ;NUMBER OF PRIMITIVE TYPES
+
+
+DEFINE TYPMAK  SAT,LIST
+IRP A,,[LIST]
+NUMPRI==NUMPRI+1
+IRP B,C,[A]
+T!B==NUMPRI
+.GLOBAL $!T!B
+IFN MAIN,[$!T!B=[T!B,,0]
+]
+.ISTOP
+TERMIN
+IFN MAIN,[
+RMT [ADDTYP [A]SAT
+]]
+TERMIN
+IFE MAIN,[RMT [EXPUN [LIST]
+]
+]
+TERMIN
+
+;MACRO TO ADD STUFF TO TYPE VECTOR
+
+IFN MAIN,[
+DEFINE ADDTYP TYPE,SAT,\LOCN
+       IRP TYP,NAME,[TYPE]
+       TFIX,,SAT
+       IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL
+               IFSN [NAME]IN,MQUOTE [NAME]
+               ]
+       IFSE [NAME],MQUOTE TYP
+       .ISTOP
+       TERMIN
+       TERMIN
+]
+
+;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD
+
+
+NUMSAT==0
+GENERAL==400000,,0     ;FLAG FOR BEING A GENERAL VECTOR
+
+IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS
+ABASE,TBASE,FRAME,BYTE,ATOM,PVP,CHSTR,ASOC,INFO]
+NUMSAT==NUMSAT+1
+S!A==NUMSAT
+TERMIN
+
+
+;MACRO FOR SAVING STUFF TO DO LATER
+
+.GSSET 4
+
+DEFINE HERE G00002,G00003
+G00002!G00003!TERMIN
+
+DEFINE RMT A
+HERE [DEFINE HERE G00002,G00003
+G00002!][A!G00003!TERMIN]
+TERMIN
+
+
+RMT [EXPUNGE SYSTEM,ERRORS,INTRUP
+]
+\f;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE)
+
+IFN MAIN,[RMT [SAVE==.
+       LOC TYPVLC
+       ]
+       ]
+
+TYPMAK S1WORD,[LOSE,FIX,FLOAT,[CHRS,CHARACTER],[ENTRY,IN],SUBR,FSUBR,UNBOUND,[BIND,IN],ILLEGAL]
+TYPMAK S1WORD,[TIME]
+TYPMAK S2WORD,[LIST,FORM,[SEG,SEGMENT],[EXPR,FUNCTION],[FUNARG,CLOSURE],LOCL,FALSE]
+TYPMAK S2DEFRD,[[DEFER,IN]]
+TYPMAK SNWORD,[[UVEC,UVECTOR],[OBLS,OBLIST]]
+TYPMAK S2NWORD,[[VEC,VECTOR],[CHAN,CHANNEL],LOCV,[TVP,IN],[BVL,IN],TAG]
+TYPMAK SPVP,[[PVP,IN]]
+TYPMAK S2NWORD,[[LOCI,IN]]
+TYPMAK STPSTK,[[TP,IN]]
+TYPMAK S2NWORD,[[SP,IN]]
+TYPMAK STPSTK,[[LOCS,IN],[PP,IN]]
+TYPMAK SPSTK,[[PDL,IN]]
+TYPMAK SARGS,[[ARGS,ARGUMENTS]]
+TYPMAK SABASE,[[AB,IN]]
+TYPMAK STBASE,[[TB,IN]]
+TYPMAK SFRAME,[FRAME]
+TYPMAK SCHSTR,[[CHSTR,STRING]]
+TYPMAK SATOM,[ATOM]
+TYPMAK S2NWORD,[LOCD]
+TYPMAK SBYTE,[BYTE]
+TYPMAK S2NWORD,[[ENV,ENVIRONMENT]]
+TYPMAK SFRAME,[[ACT,ACTIVATION]]
+TYPMAK S2WORD,[[PIC,PICTURE],[MOVTO,MOVE-TO],[MOVREL,MOVE-REL],[DRWTO,DRAW-TO],[DRWREL,DRAW-REL],TEXT]
+TYPMAK SASOC,[ASOC]
+TYPMAK SNWORD,[LOCU]
+TYPMAK SCHSTR,[LOCC]
+TYPMAK SARGS,[LOCA]
+TYPMAK S1WORD,[[ENTS,IN],[TBS,IN],[PDLS,IN],[PC,IN]]
+TYPMAK SINFO,[[INFO,IN]]
+TYPMAK S2WORD,[[UNAS,UNASSIGNED],[AF,ACTORFORM],[SAF,SACTORFORM]]
+TYPMAK S2WORD,[ACTOR,[ACTF,ACTOR-FUNCTION]]
+
+
+IFN MAIN,[RMT [LOC SAVE
+       ]
+       ]
+EXPUNGE TYPMAK
+
+RMT [EQUALS XP EXPUNGE
+]
+
+DEFINE EXPUN LIST
+       IRP A,,[LIST]
+       IRP B,,[A]
+       EXPUNGE T!B
+       .ISTOP
+       TERMIN
+       TERMIN
+       TERMIN
+
+
+DEFINE GETYP AC,ADR
+       LDB AC,[221500,,ADR]
+       TERMIN
+
+DEFINE GETYPF AC,ADR
+       LDB AC,[003700,,ADR]
+       TERMIN
+\f
+
+;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL
+
+IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AP,AB,P,PB,SP,PP]
+.GLOBAL A!STO
+TERMIN
+
+;MUDDLE WIDE GLOBALS
+
+
+.GLOBAL FOPEN,VECTOR,EVECTOR,CALER1,IVAL,SPECBIND,6TOCHS,CHMAK
+.GLOBAL ILOOKU
+
+
+.GLOBAL PROCID,LPROG,LERR,FINIS,PARTOP,VECTOP,TVLNTH,PVLNTH,SAT
+.GLOBAL CODTOP
+
+.GLOBAL SAVCAL,RESCAL,SAVCN,RESCN,LCKINT,SAVEUP,WNA,NOTATOM,INTFLG,TYPVEC
+
+;PRINTER GLOBALS NEEDED (WILL GO WHEN CHANNLES USED)
+
+.GLOBAL POSIT,CHRLIN
+
+;GLOBALS ASSOCIATED WITH CHANNELS (SEE 'FOPEN >' FOR DETAILS)
+
+.GLOBAL CHANNO,DIRECT,DEVICE,NAME1,NAME2,SNAME,RNAME1,RNAME2,STATUS,IOINS,LINLN
+.GLOBAL CHRPOS,PAGLN,LINPOS,UNAME,FDIR,CALER1,ROOT,TTICHN,TTOCHN
+
+
+;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE
+
+.GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE
+.GLOBAL PARTOP,VECTOP,TVLNTH,PVLNTH
+
+
+;STORAGE ALLOCATIN SPECIFICATION GLOBALS
+
+PROLOC=10      ;NUMBER OF INITIAL LOCALS PER PROCESS
+PPLNT==150.            ;PLANNER PDL LENGTH
+TPLNT"=1500.   ;TEMP PDL LENGTHH
+GSPLNT==2000   ;INITIAL GLOBAL SP
+SPLNT"=300.    ;SPECIAL LENGTH
+GCPLNT"=1000.  ;GARBAGE COLLECTOR'S PDL LENGTH
+PVLNT"=100     ;LENGTH OF INITIAL PROCESS VECTOR
+TVLNT"==2000   ;MAX TRANSFER VECTOR
+IAPLNT"=100    ;AP FOR GC
+ITPLNT"=100    ;TP FOR GC
+PLNT"=300.     ;PDL FOR USER PROCESS
+
+;LOCATIONS OF VARIOUS STORAGE AREAS
+
+
+
+PARBASE"=26000 ;START OF PAIR SPACE
+VECBASE"=40000 ;START OF VECTOR SPACE
+IFN MAIN,[PARLOC"=PARBASE
+VECLOC"=VECBASE
+]
+\f
+;INITIAL MACROS
+
+
+
+;STANDARD SUBROUTINE CALL TO F WITH N ARGUMENTS
+;VALUE COMES BACK IN B WITH TYPE IN A
+;IN ORDER TO BE ABLE TO BUM CALLS IN THE FUTURE, ALL CALLS SHOULD BE
+;COMMENTED AS TO WHICH STACK POINTERS THEY ASSUME ARE SAVED.
+
+;SYMBLOS ASSOCIATED WITH STACK FRAMES
+FRAMLN==10     ;LENGTH OF A FRAME
+FSAV==-8       ;POINT TO CALLED FUNCTION
+OTBSAV==-7     ;POINT TO PREVIOUS FRAME AND CONTAINS TIME
+ABSAV==-6      ;ARGUMENT POINTER
+SPSAV==-5      ;BINDING POINTER
+PSAV==-4       ;SAVED P-STACK
+TPSAV==-3      ;TOP OF STACK POINTER
+PPSAV==-2      ;SAVED PLANNER PDL
+PCSAV==-1      ;PCWORD
+
+RMT [EXPUNGE FRAMLN
+]
+IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV TBSAV
+]
+]
+
+;STANDARD SUBROUTINE RETURN
+;      JRST FINIS"
+;CALL MACRO
+
+.GLOBAL .MCALL,.ACALL,FINIS,CONTIN
+
+DEFINE MCALL N,F
+       .GLOBAL F
+       IFGE <17-N>,.MCALL N,F
+       IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS
+/
+       .MCALL F
+       ]
+       TERMIN
+
+DEFINE ACALL N,F
+       .GLOBAL F
+       .ACALL N,F
+       TERMIN
+
+.GLOBAL TBINIT
+
+
+
+
+
+
+;INTERRUPT IF THERE IS A WAITING INTERRUPT
+
+DEFINE INTGO
+       SKIPGE INTFLG
+       JSR LCKINT
+TERMIN
+
+
+;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS
+;AND SEE IF THERE ARE PENDING INTERRUPTS
+;THEN PROBABLY WANT TO SAVE TB WITH GENTEM (BELOW)
+
+DEFINE ENTRY N
+       IFSN N,,[
+               HLRZ A,AB
+               CAIE A,-2*N
+               JRST WNA]
+TERMIN
+
+
+;TO BECOME INTERRUPTABLE
+
+DEFINE ENABLE
+       AOSN INTFLG
+       JSR LCKINT
+TERMIN
+
+
+;TO BECOME UNITERRUPTABLE
+
+DEFINE DISABLE
+       SETZM INTFLG
+TERMIN
+\f;MACRO TO BUILD TYPE DISPATCH TABLES EASILY
+
+DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH
+
+NAME:
+       REPEAT LNTH+1,DEFAULT
+       IRP A,,[LIST]
+               IRP TYPE,LOCN,[A]
+               LOC NAME+TYPE
+               LOCN
+               .ISTOP
+               TERMIN
+       TERMIN
+       LOC NAME+LNTH+1
+TERMIN
+
+; DISPATCH FOR NUMPRI GOODIES
+
+DEFINE DISTBL NAME,DEFAULT,LIST
+       TBLDIS NAME,DEFAULT,[LIST]NUMPRI
+       TERMIN
+
+DEFINE DISTBS NAME,DEFAULT,LIST
+       TBLDIS NAME,DEFAULT,[LIST]NUMSAT
+       TERMIN
+
+\f
+
+VECFLG==0
+PARFLG==0
+
+;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE
+
+;CHAR STRING MAKER, RETURNS POINTER AND TYPE
+
+DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST
+               TYPE==TCHSTR
+               VECTGO WHERE
+               ASCII \NAME!\
+               LAST==$."
+               TCHRS,,0
+               $."-WHERE+1,,0
+               VAL==-<LAST-WHERE>,,WHERE
+               VECRET
+
+TERMIN
+;MACRO TO DEFINE ATOMS
+
+DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST
+       FIRST==.
+       TYAT,,OBLIS
+       VALU
+       ASCII \NAME!\
+       400000+SATOM,,0
+       .-FIRST+1,,0
+       TVENT==FIRST-.+2,,FIRST
+       IFSN [LOCN],LOCN==TVENT
+       ADDTV TATOM,TVENT,REFER
+       TERMIN
+
+
+
+\f;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE
+;GENERAL SWITCHER
+
+DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW
+
+       IFE F1,[SAVE==.
+               LOC NEWLOC
+               SAVEF2==F2
+               IFN F2,OTHLOC==SAVE
+               F2==0
+               DEFINE RETNAM
+                       F1==F1-1
+                       IFE F1,[NEWLOC==.
+                       F2==SAVEF2
+                       LOC TOPWRD
+                       NEWLOC
+                       LOC SAVE
+                       ]
+                       TERMIN
+               ]
+
+       IFN F1,[F1==F1+1
+               ]
+
+       IFSN LOCN,,LOCN==.
+       IFE F1,F1==1
+
+TERMIN
+
+
+DEFINE VECTGO LOCN
+       LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP
+       TERMIN
+
+DEFINE PARGO LOCN
+       LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP
+       TERMIN
+
+DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE
+       SAVE==.
+       LOC TVLOC
+       TVOFF==.-TVBASE+1
+       TYPE,,REFER
+       GOODIE
+       TVLOC==.
+       LOC SAVE
+       TERMIN
+
+;MACRO TO ADD TO PROCESS VECTOR
+
+DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE
+       SAVE==.
+       LOC PVLOC
+       PVOFF==.-PVBASE
+       IFSN OFFS,,OFFS==PVOFF
+       TYPE,,0
+       GOODIE
+       PVLOC==.
+       LOC SAVE
+       TERMIN
+
+
+
+
+\f;MACRO TO DEFINE A FUNCTION ATOM
+
+DEFINE MFUNCTION NAME,TYPE,PNAME
+       (TVP)
+NAME":
+       VECTGO DUMMY1
+       IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM,<NAME-1>
+       IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM,<NAME-1>
+       VECRET
+       TERMIN
+
+;MACRO TO DEFINE QUOTED GOODIE
+
+DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN
+       (TVP)
+
+       LOCN==.-1
+       VECTGO DUMMY1
+       IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN
+       IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN
+       VECRET
+       TERMIN
+
+
+
+
+DEFINE CHQUOTE NAME,\LOCN,TYP,VAL
+       (TVP)
+       LOCN==.-1
+       MACHAR [NAME]TYP,VAL
+       ADDTV TYP,VAL,LOCN
+
+       TERMIN
+
+\f
+CHRWD==5
+
+IFN READER,[
+NCHARS==177
+;CHARACTER TABLE GENERATING MACROS
+
+DEFINE SETSYM WRDL,BYTL,COD
+       WRD!WRDL==<WRD!WRDL>&<MSK!BYTL>
+       WRD!WRDL==<WRD!WRDL>\<<COD&177>_<<4-BYTL>*7+1>>
+       TERMIN
+
+DEFINE INIWRD N,INIT
+       WRD!N==INIT
+       TERMIN
+
+DEFINE OUTWRD N
+       WRD!N
+       TERMIN
+
+;MACRO TO KILL THESE SYMBOLS LATER
+
+DEFINE KILLWD N
+       EXPUNGE WRD!N
+       TERMIN
+DEFINE SETMSK N
+       MSK!N=<177_<<4-N>*7+1>>#<-1>
+       TERMIN
+
+;MACRO TO KILL MASKS LATER
+
+DEFINE KILMSK N
+       EXPUNGE MSK!N
+       TERMIN
+
+NWRDS==<NCHARS+CHRWD-1>/CHRWD
+
+REPEAT CHRWD,SETMSK \.RPCNT
+
+REPEAT NWRDS,INIWRD \.RPCNT,004020100402
+
+DEFINE OUTTBL
+       REPEAT NWRDS,OUTWRD \.RPCNT
+       TERMIN
+
+
+;MACRO TO GENERATE THE DUMMIES EASLILIER
+
+DEFINE INITCH \DUM1,DUM2,DUM3
+
+
+DEFINE SETCOD  COD,LIST
+       IRP CHAR,,[LIST]
+       DUM1==CHAR/5
+       DUM2==CHAR-DUM1*5
+       SETSYM \DUM1,\DUM2,COD
+       TERMIN
+       TERMIN
+
+DEFINE SETCHR COD,LIST
+       IRPC CHAR,,[LIST]
+       DUM3=="CHAR
+       DUM1==DUM3/5
+       DUM2==DUM3-DUM1*5
+       SETSYM \DUM1,\DUM2,COD
+       TERMIN
+       TERMIN
+
+DEFINE INCRCO OCOD,LIST
+       IRP CHAR,,[LIST]
+       DUM1==CHAR/5
+       DUM2==CHAR-DUM1*5
+       SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
+       TERMIN
+       TERMIN
+
+DEFINE INCRCH OCOD,LIST
+       IRPC CHAR,,[LIST]
+       DUM3=="CHAR
+       DUM1==DUM3/5
+       DUM2==DUM3-DUM1*5
+       SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
+       TERMIN
+       TERMIN
+       RMT [EXPUNGE DUM1,DUM2,DUM3
+       REPEAT NWRDS,KILLWD \.RPCNT
+       REPEAT CHRWD,KILMSK \.RPCNT
+]
+
+TERMIN
+
+INITCH
+]
+\f
+;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY)
+
+EQUALS E.END END
+
+DEFINE END ARG
+       EQUALS END E.END
+       CONSTANTS
+       VARIABLES
+       HERE
+       .LNKOT
+       IFP GEXPUN
+       CONSTANTS
+       VARIABLES
+       CODEND==.
+       LOC CODTOP
+       CODEND
+       LOC CODEND
+       END ARG
+       TERMIN
+
+
+;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY
+
+DEFINE NUMGEN SYM,\REST,N
+       NN==NN-1
+       N==<SYM_-30.>&77
+       REST==<SYM_6>
+       IFN N,IFGE <31-N>,IFGE <N-20>,TOTAL==TOTAL*10.+<N-20>
+       IFN NN,NUMGEN REST
+       EXPUNGE N,REST
+       TERMIN
+
+DEFINE VERSIO N
+       PRINTC /VERSION = N
+/
+       TERMIN
+
+TOTAL==0
+NN==7
+
+NUMGEN .FNAM2
+
+IF1 [
+RADIX 10.
+
+VERSIO \TOTAL
+
+RADIX 8
+PROGVN==TOTAL
+
+
+]
+
+DEFINE VATOM SYM,\LOCN,TV,A,B
+       VECTGO
+       LOCN==.
+       TFIX,,ERRORS
+       PROGVN
+       A==<<<<SYM_-30.>&77>+40>_29.>
+       B==<<SYM_-24.>&77>
+       IFN B,A==A+<<B+40>_22.>
+       B==<<SYM_-18.>&77>
+       IFN B,A==A+<<B+40>_15.>
+       B==<<SYM_-12.>&77>
+       IFN B,A==A+<<B+40>_8.>
+       B==<<SYM_-6.>&77>
+       IFN B,A==A+<<B+40>_1.>
+       A
+       IFN <SYM&77>,<<SYM&77>+40>_29.
+       400000+SATOM,,
+       .-LOCN+1,,0
+       TV==LOCN-.+2,,LOCN
+       ADDTV TATOM,TV,0
+       VECRET
+       TERMIN
+
+VATOM .FNAM1
+
+
+;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX"
+
+DEFINE GEXPUN \SYM
+       NN==7
+       TOTAL==0
+       NUMGEN \<SIXBIT /SYM!/>
+       RADIX 10.
+       .GSSET 0
+       REPEAT TOTAL,XXP
+       RADIX 8
+TERMIN
+
+DEFINE XXP \A
+       EXPUNGE A
+       TERMIN
+\f;MACRO TO SET A FAILPOINT WITH ADDRESS PC, GIVEN N WORDS PUSHED ABOVE -1(TB)
+
+DEFINE FPOINT PC,N
+       PUSH    PP,$TPC         ;PUSH PC MARKER
+       PUSH    PP,[PC]
+       PUSH    PP,[TTP,,ON]    ;PUSH FRAME LOCATION
+       MOVE    A,TP
+       SUB     A,[<N-1>,,<N-1>]
+       PUSH    PP,A
+       MOVEM   TP,TPSAV(TB)    ;MAKE SURE TP SLOT IS CORRECT
+       MOVE    E,TB
+       PUSHJ   P,BCKTRE        ;COPY FRAME
+TERMIN\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/muddle.init b/MUDDLE/muddle.init
new file mode 100644 (file)
index 0000000..b475959
--- /dev/null
@@ -0,0 +1,40 @@
+       "BOOTSTRAP FOR DYNAMIC FLOADER"
+
+"Expects floader to be FLOADYN > DSK:MUDDLE;
+FLODYN must SETG RERR to the function it must be
+for real floading.  The RERR here calls the new one
+after FLOADing it."
+
+
+ELSE!- MUTS!- PPRINT!- FRAMES!- FRM!- PPRINF!- MMED!- XMED!- MEDDLE!-
+
+<BLOCK <SETG NDYN!- (<MOBLIST NDYN!- 37> <ROOT>)>>
+
+<SETG REAL.ERROR ,ERROR>
+
+<DEFINE DYNERROR ERRACT ("TUPLE" TUPP) <EVAL <RERR .TUPP>>>
+
+<DEFINE RERR (TR)
+        <COND (<AND <==? 3 <LENGTH .TR>>
+                    <==? UNBOUND-VARIABLE!-ERRORS <1 .TR>>
+                    <==? VALUE <3 .TR>>>
+               <FLOAD "FLODYN" ">" "DSK" "MUDDLE">
+               <RERR .TR>)
+             (ELSE <FORM REAL.ERROR !.TR>)>>
+
+"Function to allow user library OBLIST specification.
+In here so INIT files can use it."
+
+<DEFINE FLOB!- ("OPTIONAL" (OBL ,NDYN)) <SETG USEROB .OBL>>
+
+<FLOB>
+
+<SETG ERROR ,DYNERROR>
+
+<ENDBLOCK>
+<TERPRI>
+<PRINC "ARDS? ">
+<COND (<MEMQ <READCHR> '![!"Y !"y]> <READCHR> <PUT .OUTCHAN 13 75>)
+       (<PUT .OUTCHAN 13 98>)>
+
+\f\ 3\f\ 3\ 3\ 3ð`Á\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ð`Á\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
\ No newline at end of file
diff --git a/MUDDLE/muddle.old b/MUDDLE/muddle.old
new file mode 100644 (file)
index 0000000..f585ac3
--- /dev/null
@@ -0,0 +1,899 @@
+;CONVENTIONS USED IN ALL  INTERNAL MUDDLE PROGRAMS
+
+;FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE
+;WITH EXPLICIT CHECKS
+;FOR PENDING INTERRUPTS
+
+
+; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST
+;BE ABSOLUTELY PURE.
+;BETWEEN ANY TWO INSTRUCTIONS OF
+;INTERRUPTABLE CODE THERE MAY
+;BE AN INTERUPT IN WHICH
+;A COMPACTING GARBAGE COLLECTION IS CALLED
+;AND THEN THE PROCESS WHICH WAS RUNNING IS
+;PASSIVATED AND ANOTHER RESUMED.
+
+; ALL ATOM HEADERS WILL BE REFERRED TO IN ASSEMBLED CODE BY
+; MQUOTE <PNAME>
+; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING:
+
+;      MCALL N,<PNAME> ;SEE MCALL MACRO
+
+; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE FUNINESS
+
+
+
+\f; ORGANIZATION OF CORE STORAGE IN THE MUDDLE SYSTEM (ENVIRONMENT)
+
+;     20:      SPECIAL CODE FOR UUO AND INTERUPTS
+
+;CODBOT:       WORD CONTAINING LOCATION OFBOTTOMMOST WORD OF CODE
+
+;              --CODE--
+
+;CODTOP:       WORD CONTAINING LOCATION OFWORD AFTER LAST WORD OF CODE
+
+;PARBOT:       WORD CONTAINING LOCATION OFBOTTOMMOST LIST
+
+;              --PAIRSS--
+
+;PARTOP:       WORD CONTAINING LOCATION OFWORD AFTER LAST PAIR WORD
+
+;VECBOT:       WORD CONTAINING LOCATION OFFIRST WORD OF VECTORS
+
+;              --VECTORS--
+
+;VECTOP:       WORD CONTAINING LOCATION OFWORD AFTER TOPMOST VECTOR
+;              THE WORD BEFORE VECTOP IS THE DOPE FOR THE LAST VECTOR
+
+
+\f;BASIC DATA TYPES PRE-DEFINED IN MUDDLE
+
+; PRIMITIVE DATA TYPES
+; IF T IS A DATA TYPE THEN $T=[T,,0]
+
+; DATA TYPES ARE ASSIGNED BY THE TYPMAK MACRO IN SOME ARBITRARY ORDER
+
+
+;TLOSE         ;ILLEGAL TYPE (USED PRIMARILY FOR ERRORS)
+;TFIX          ;FIXED POINT
+;TFLOT         ;FLOATING POINT
+;TCHRS         ;WORD OF UP TO 5 ASCII CHARACTERS
+;TLIST         ;LIST ELEMENT
+;TVEC          ;VECTOR  (AOBJN POINTER TO GENERALIZED VECTOR)
+;TAP           ;SAVED AP
+;TAB           ;SAVED AB (CANT APPEAR IN LISTS)
+;TTP           ;SAVED TP
+;TTB           ;SAVED TP
+;TATOM         ;ATOM WHICH IS REALLY A SPECIAL TYPE OF VECTOR BUT MAY CHANGE
+;TEXPR         ;FUNCTIONS CORRESPONDING TO THE STANDARD LISP FUNCTIONS
+;TSUBR         ;MACHINE LANGUAGE 'EXPR'
+;TFSUBR                ;MACHINE LANGUAGE PROGRAM (TAKES LIST AS ARG)
+;TENTRY                ;RETURN ADDRESS FROM MCALL MACRO
+;TPDL          ;SAVE "P"
+;TUNBOU                ;UNBOUND VALUE
+;TLOCI                 ;IDENTIFIER LOCATIVE
+;TFUNARG       ;FUNCTIONAL ARGUMENT
+;TTIME                 ;SPECIAL TIME POINTER-NOT MARKED (USER CAN'T SEE OR CHANGE)
+;TSKIP                 ;SKIP WORD ON SPECIAL PDL
+;TCHVEC                ;VECTOR OF UNIFORM CHARACTERS NOT MARKED
+;TCHSTR                ;GENERAL VECTOR OF CHARACTERS
+;TTVP          ;SAVE TRANSFER VEVTOR POINTER
+;TPVP          ;SAVED PROCESS VECTOR POINTER
+;TCHAN         ;CHANNEL VECTOR (SEE FOPEN FOR FULL DOCUMENTATION)
+;TENV          ;ENVIRONMENT POINTER
+;TOBL          ;OBLIST TYPE
+;TLMNT         ;ELEMENT CALL
+;TSEG          ;SEGMENT CALL
+
+;STORAGE ALLOCATION TYPES SAT (ALLOCATED VALUES BY AN IRP)
+
+;1WORD         ;UNMARKED ONE WORD ENTITIES
+;2WORD         ;LIST STRUCTURE GOODIES
+;2NWORD                ;VECTOR STRUCTURE GOODIES
+;STACK         ;PUSH DOWN STACKS
+;BASE          ;ONE MEMBER, NAMELY AB
+\f; FORMAT OF LIST ELEMENT
+
+;      WORD 1: SIGN BIT, RESERVED FOR GARBAGE COLLECTOR
+;               BITS 1-17 TYPE OF FIRST ELEMENT OF LIST
+;               BITS 18-35 POINTS TO REST OF LIST (ALWAYS ANOTHER LIST OR 0)
+;
+;      WORD 2: DATUM OF FIRST ELEMENT OF LIST OF TYPE SPECIFIED
+
+
+
+;FORMAT OF GENERAL VECTOR (OF N ELEMENTS)
+;POINTED INTO BY AOBJN POINTER
+;A GENERAL VECTOR HAS FEWER THAN 2^16 ELEMENTS
+
+
+;      TYPE<1> TYPE OF FIRST OBJECT (THE RIGHT HALF OF THE TYPE WORD MIGHT BE NONZERO)
+;      OBJ<1>  OBJECT OF SPECIFIED TYPE
+;      TYPE<2>
+;      OBJ<2>
+;      .
+;      .
+;      .
+;      TYPE<N>
+;      OBJ<N>
+;      VD-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN
+
+
+\f;SPECIAL VECTORS IN THE INITIAL SYSTEM
+
+;THE SYSTEM KEEPS RELEVANT INFORMATION CONCERNING ALL TYPES
+;IN A TYPE VECTOR, TYPVEC, WHICH MAY BE INDEXED BY THE TYPE NUMBER
+;FOUND IN THE TYPE FIELD OF ANY GOODIE.
+
+;THE INFORMATION MAY BE ACCESSED WITH FUNCTIONS "SAT" AND "TYPE"
+
+
+;TYPE TO NAME OF TYPE TRANSLATION TABLE
+
+;      TATOM,,<STORAGE ALLOCATION TYPE>
+;      ATOMIC NAME
+
+;AN ATOM IS A VECTOR WITH 3 ELEMENTS AS FOLLOWS
+
+;      TYPE OF VALUE   TYPES ARE FULL WORD QUANTITIES
+;      VALUE
+;      TLIST,,<PROCESS I.D.>
+;      PLIST (PROPERTY LIST)
+;      TVEC (OR TCHRS IF LESS THAN 6 CHARS)
+;      PNAME (VECTOR OF ELEMENTS OF TYPE TCHRS)
+;      7,,0    (SIGN BIT FOR G.C. RH FOR G.C. RELOCATION)
+
+;WARNING  THE FORMAT OF ATOMS WILL CHANGE
+;USE THE INTERNAL FUNCTIONS IVCELL,IGVALU,ILVALU,IPNAME,IPLIST
+;AND THE EXTERNALS VCELL,GVALUE,LVALUE,PNAME,PLIST
+
+;POINTERS TO INITIAL STRUCTURES AND ATOMS NEEDED BY COMPILED CODE
+;WILL BE POINTED TO BY THE TRANSFER VECTOR
+;A POINTER TO THIS VECTOR ALWAYS EXISTS IN AC TVP
+;THE FORMAT OF THIS VECTOR IS:
+
+;      TYPE,,0
+;      VALUE
+;      .
+;      .
+;      .
+;      TV DOPE WORD
+
+
+;INFORMATION CONCERNING EACH PROCESS IS KEPT IN THE PROCESS VECTOR
+;A POINTER TO THE CURRENT PROCESS ALWAYS EXISTS IN AC PVP
+;THE FORMAT OF A PROCESS VECTOR IS:
+
+;      TFIX,,0
+;      PROCID  ;UNIQUE ID OF THIS PROCESS
+
+;      20 ELEMENTS (I.E. 40 WORDS) CONTAINIG SAVED ACS
+;      CAN BE REFERENCED SYMBOLICALLY USING SYMBOLS
+;      OF THE FORM AC!STO(PVP)
+
+;      TTP,,0
+;      <TP AT LAST ERROR CALL> ;CAN BE REFERENCED SYMBOLICALLY AS LERR(PVP)
+
+;      TTB,,0
+;      <LAST PROG>     ;LPROG(PVP)
+;      .
+;      .
+;      .
+;      PV DOPE WORD
+
+
+
+
+;FORMAT OF PUSH DOWN STACKS USED AND CONVENTIONS
+
+;SPECIAL PDL (SP)
+
+;      .
+;      .
+;      .
+;      TYPE OF VALUE
+;      OLD CONTENTS OF VALUE CELL
+;      $TATOM
+;      LOCATION OF VALUE CELL
+;      .
+;      .
+;      VD (FOR PDL)
+
+
+
+
+
+;THE FORMAT FOR TP (TEMPORARY PDL MARKED) AND AP (ARGUMENT PDL) ARE NOW THE SAME
+;EVENTUALLY THIS MAY
+;CHANGE BY BLOCKING THE AP WITH
+;VECTOR DESCRIPTORS AT THE HEAD OF EACH BLOCK
+
+
+
+
+;      .
+;      .
+;      .
+;      TYPE
+;      GOODIE
+;      .
+;      .
+;      VD (VECTOR DOPE FOR THE VECTOR  WHICH IS PDL)
+
+
+
+\fIF1 [
+PRINTC /MUDDLE - INSERT FILE FOR ALL PROGRAMS
+/
+]
+
+IF2 [PRINTC /MUDDLE
+/
+]
+;AC ASSIGNMNETS
+
+P"=17  ;THE UNMARKED PDL POINTER (USED BY THE OUTSIDE WORLD AND MUDDLE)
+SP"=15 ;SPECIAL PDL (USED BY MUDDLE FOR VARIABLE BINDINGS) (NOT USED NOW)
+TP"=14 ;MARKED PDL (USED BY MUDDLE FOR ARGS TO FUNCTIONS 
+       ;AND MARKED TEMPORARIES)
+TB"=13 ;MARKED PDL BASE POINTER 
+R"=12  ;RELOCATION INDEX FOR LOCATION INSENSITIVE SUBRS
+AB"=11 ;ARGUMENT PDL BASE (MARKED)
+       ;AB IS AN AOBJN POINTER TO THE ARGUMENTS
+PP"=10 ;PLANNER PDL (MAY NOT BE IN DYNAMIC MODELLING)
+TVP"=7 ;TRANSFER VECTOR POINTER
+PVP"=6 ;PROCESS VECTOR POINTER
+
+;THE FOLLOWING ACS ARE 'SCRATCH' FOR MUDDLE
+
+A"=1
+B"=2
+C"=3
+D"=4
+E"=5
+
+NIL"=0 ;END OF LIST MARKER
+
+;MACRO TO DEFINE MAIN IF NOT DEFINED
+
+DEFINE DEFMAI ARG,\D
+       D==.TYPE ARG
+       IFE <D-17>,ARG==0
+       EXPUNGE D
+       TERMIN
+
+DEFMAI MAIN
+DEFMAI READER
+
+EXPUNGE DEFMAI
+
+; DEFINE SYMBLOS FOR VARIOUS OBLISTS
+
+SYSTEM==0      ;MAIN SYSTEM OBLIST
+ERRORS==1      ;ERROR COMMENT OBLIST
+INTRUP==2      ;INERRUPT OBLIST
+
+RMT [EXPUNGE SYSTEM,ERRORS,INTRUP
+]
+\f;DEFINE TYPES AND $TYPES AND IF MAIN NOT 0, MAKE THE $TYPE WORDS
+
+NUMPRI==-1     ;NUMBER OF PRIMITIVE TYPES
+
+
+DEFINE TYPMAK  SAT,LIST
+IRP A,,[LIST]
+NUMPRI==NUMPRI+1
+IRP B,C,[A]
+T!B==NUMPRI
+.GLOBAL $!T!B
+IFN MAIN,[$!T!B=[T!B,,0]
+]
+.ISTOP
+TERMIN
+IFN MAIN,[
+RMT [ADDTYP [A]SAT
+]]
+TERMIN
+IFE MAIN,[RMT [EXPUN [LIST]
+]
+]
+TERMIN
+
+;MACRO TO ADD STUFF TO TYPE VECTOR
+
+IFN MAIN,[
+DEFINE ADDTYP TYPE,SAT,\LOCN
+       IRP TYP,NAME,[TYPE]
+       TFIX,,SAT
+       IFSN [NAME],[IFSE [NAME]IN,MQUOTE INTERNAL
+               IFSN [NAME]IN,MQUOTE [NAME]
+               ]
+       IFSE [NAME],MQUOTE TYP
+       .ISTOP
+       TERMIN
+       TERMIN
+]
+
+;DEFINE THE STORAGE ALLOCATION TYPES IN THE WORLD
+
+
+NUMSAT==0
+GENERAL==400000,,0     ;FLAG FOR BEING A GENERAL VECTOR
+
+IRP A,,[1WORD,2WORD,2DEFRD,NWORD,2NWORD,TPSTK,PSTK,ARGS
+ABASE,TBASE,FRAME,BYTE,ATOM,LOCID,PVP,CHSTR,ASOC,INFO]
+NUMSAT==NUMSAT+1
+S!A==NUMSAT
+TERMIN
+
+
+;MACRO FOR SAVING STUFF TO DO LATER
+
+.GSSET 4
+
+DEFINE HERE G00002,G00003
+G00002!G00003!TERMIN
+
+DEFINE RMT A
+HERE [DEFINE HERE G00002,G00003
+G00002!][A!G00003!TERMIN]
+TERMIN
+
+
+\f;BUILD THE TYPE CODES AND ADD STUFF TO TYPVEC AND DEFINE $!TYPE)
+
+IFN MAIN,[RMT [SAVE==.
+       LOC TYPVLC
+       ]
+       ]
+
+TYPMAK S1WORD,[LOSE,FIX,FLOAT,[CHRS,CHARACTER],[ENTRY,IN],SUBR,FSUBR,UNBOUND,[BIND,IN],ILLEGAL]
+TYPMAK S1WORD,[TIME]
+TYPMAK S2WORD,[LIST,FORM,[SEG,SEGMENT],[EXPR,FUNCTION],[FUNARG,CLOSURE],LOCL,FALSE]
+TYPMAK S2DEFRD,[[DEFER,IN]]
+TYPMAK SNWORD,[[UVEC,UVECTOR],[OBLS,OBLIST]]
+TYPMAK S2NWORD,[[VEC,VECTOR],[CHAN,CHANNEL],LOCV,[TVP,IN],[BVL,IN],TAG]
+TYPMAK SPVP,[[PVP,IN]]
+TYPMAK STPSTK,[[LOCI,IN],[TP,IN],[SP,IN],[LOCS,IN],[PP,IN]]
+TYPMAK SPSTK,[[PDL,IN]]
+TYPMAK SARGS,[[ARGS,ARGUMENTS]]
+TYPMAK SABASE,[[AB,IN]]
+TYPMAK STBASE,[[TB,IN]]
+TYPMAK SFRAME,[FRAME]
+TYPMAK SCHSTR,[[CHSTR,STRING]]
+TYPMAK SATOM,[ATOM]
+TYPMAK SLOCID,[LOCD]
+TYPMAK SBYTE,[BYTE]
+TYPMAK SFRAME,[[ENV,ENVIRONMENT],[ACT,ACTIVATION]]
+TYPMAK S2WORD,[[PIC,PICTURE],[MOVTO,MOVE-TO],[MOVREL,MOVE-REL],[DRWTO,DRAW-TO],[DRWREL,DRAW-REL],TEXT]
+TYPMAK SASOC,[ASOC]
+TYPMAK SNWORD,[LOCU]
+TYPMAK SCHSTR,[LOCC]
+TYPMAK SARGS,[LOCA]
+TYPMAK S1WORD,[[ENTS,IN],[TBS,IN],[PDLS,IN],[PC,IN]]
+TYPMAK SINFO,[[INFO,IN]]
+TYPMAK SATOM,[[BNDS,IN]]
+TYPMAK S2NWORD,[[BVLS,IN]]
+
+IFN MAIN,[RMT [LOC SAVE
+       ]
+       ]
+EXPUNGE TYPMAK
+
+RMT [EQUALS XP EXPUNGE
+]
+
+DEFINE EXPUN LIST
+       IRP A,,[LIST]
+       IRP B,,[A]
+       EXPUNGE T!B
+       .ISTOP
+       TERMIN
+       TERMIN
+       TERMIN
+
+
+DEFINE GETYP AC,ADR
+       LDB AC,[221500,,ADR]
+       TERMIN
+
+DEFINE GETYPF AC,ADR
+       LDB AC,[003700,,ADR]
+       TERMIN
+\f
+
+;DEFINE ENTRIES IN PROCESS VECTOR AS BEING GLOBAL
+
+IRP A,,[0,A,B,C,D,E,PVP,TVP,TP,TB,AP,AB,P,PB,SP,PP]
+.GLOBAL A!STO
+TERMIN
+
+;MUDDLE WIDE GLOBALS
+
+
+.GLOBAL FOPEN,VECTOR,EVECTOR,CALER1,IVAL,SPECBIND,6TOCHS,CHMAK
+.GLOBAL ILOOKU
+
+
+.GLOBAL PROCID,LPROG,LERR,FINIS,PARTOP,VECTOP,TVLNTH,PVLNTH,SAT
+.GLOBAL CODTOP
+
+.GLOBAL SAVCAL,RESCAL,SAVCN,RESCN,LCKINT,SAVEUP,WNA,NOTATOM,INTFLG,TYPVEC
+
+;PRINTER GLOBALS NEEDED (WILL GO WHEN CHANNLES USED)
+
+.GLOBAL POSIT,CHRLIN
+
+;GLOBALS ASSOCIATED WITH CHANNELS (SEE 'FOPEN >' FOR DETAILS)
+
+.GLOBAL CHANNO,DIRECT,DEVICE,NAME1,NAME2,SNAME,RNAME1,RNAME2,STATUS,IOINS,LINLN
+.GLOBAL CHRPOS,PAGLN,LINPOS,UNAME,FDIR,CALER1,ROOT,TTICHN,TTOCHN
+
+
+;GLOBALS FOR MACROS IN VECTOR AND PAIR SPACE
+
+.GLOBAL VECLOC,PARLOC,TVBASE,TVLOC,PVLOC,PVBASE
+.GLOBAL PARTOP,VECTOP,TVLNTH,PVLNTH
+
+
+;STORAGE ALLOCATIN SPECIFICATION GLOBALS
+
+PROLOC=10      ;NUMBER OF INITIAL LOCALS PER PROCESS
+PPLNT==150.            ;PLANNER PDL LENGTH
+TPLNT"=1500.   ;TEMP PDL LENGTHH
+GSPLNT==2000   ;INITIAL GLOBAL SP
+SPLNT"=300.    ;SPECIAL LENGTH
+GCPLNT"=1000.  ;GARBAGE COLLECTOR'S PDL LENGTH
+PVLNT"=100     ;LENGTH OF INITIAL PROCESS VECTOR
+TVLNT"==2000   ;MAX TRANSFER VECTOR
+IAPLNT"=100    ;AP FOR GC
+ITPLNT"=100    ;TP FOR GC
+PLNT"=300.     ;PDL FOR USER PROCESS
+
+;LOCATIONS OF VARIOUS STORAGE AREAS
+
+
+
+PARBASE"=26000 ;START OF PAIR SPACE
+VECBASE"=40000 ;START OF VECTOR SPACE
+IFN MAIN,[PARLOC"=PARBASE
+VECLOC"=VECBASE
+]
+\f
+;INITIAL MACROS
+
+
+
+;STANDARD SUBROUTINE CALL TO F WITH N ARGUMENTS
+;VALUE COMES BACK IN B WITH TYPE IN A
+;IN ORDER TO BE ABLE TO BUM CALLS IN THE FUTURE, ALL CALLS SHOULD BE
+;COMMENTED AS TO WHICH STACK POINTERS THEY ASSUME ARE SAVED.
+
+;SYMBLOS ASSOCIATED WITH STACK FRAMES
+FRAMLN==10     ;LENGTH OF A FRAME
+FSAV==-8       ;POINT TO CALLED FUNCTION
+OTBSAV==-7     ;POINT TO PREVIOUS FRAME AND CONTAINS TIME
+ABSAV==-6      ;ARGUMENT POINTER
+SPSAV==-5      ;BINDING POINTER
+PSAV==-4       ;SAVED P-STACK
+TPSAV==-3      ;TOP OF STACK POINTER
+PPSAV==-2      ;SAVED PLANNER PDL
+PCSAV==-1      ;PCWORD
+
+RMT [EXPUNGE FRAMLN
+]
+IFE MAIN,[RMT [EXPUNGE PCSAV TPSAV SPSAV PSAV ABSAV FSAV TBSAV
+]
+]
+
+;STANDARD SUBROUTINE RETURN
+;      JRST FINIS"
+;CALL MACRO
+
+.GLOBAL .MCALL,.ACALL,FINIS,CONTIN
+
+DEFINE MCALL N,F
+       .GLOBAL F
+       IFGE <17-N>,.MCALL N,F
+       IFL <17-N>,[PRINTC /LOSSAGE AT MCALL - TOO MANY ARGS
+/
+       .MCALL F
+       ]
+       TERMIN
+
+DEFINE ACALL N,F
+       .GLOBAL F
+       .ACALL N,F
+       TERMIN
+
+.GLOBAL TBINIT
+
+
+
+
+
+
+;INTERRUPT IF THERE IS A WAITING INTERRUPT
+
+DEFINE INTGO
+       SKIPGE INTFLG
+       JSR LCKINT
+TERMIN
+
+
+;CHECK THAT THE ENTRY POINT WAS CALLED WITH N ARGUMENTS
+;AND SEE IF THERE ARE PENDING INTERRUPTS
+;THEN PROBABLY WANT TO SAVE TB WITH GENTEM (BELOW)
+
+DEFINE ENTRY N
+       IFSN N,,[
+               HLRZ A,AB
+               CAIE A,-2*N
+               JRST WNA]
+TERMIN
+
+
+;TO BECOME INTERRUPTABLE
+
+DEFINE ENABLE
+       AOSN INTFLG
+       JSR LCKINT
+TERMIN
+
+
+;TO BECOME UNITERRUPTABLE
+
+DEFINE DISABLE
+       SETZM INTFLG
+TERMIN
+\f;MACRO TO BUILD TYPE DISPATCH TABLES EASILY
+
+DEFINE TBLDIS NAME,DEFAULT,LIST,LNTH
+
+NAME:
+       REPEAT LNTH+1,DEFAULT
+       IRP A,,[LIST]
+               IRP TYPE,LOCN,[A]
+               LOC NAME+TYPE
+               LOCN
+               .ISTOP
+               TERMIN
+       TERMIN
+       LOC NAME+LNTH+1
+TERMIN
+
+; DISPATCH FOR NUMPRI GOODIES
+
+DEFINE DISTBL NAME,DEFAULT,LIST
+       TBLDIS NAME,DEFAULT,[LIST]NUMPRI
+       TERMIN
+
+DEFINE DISTBS NAME,DEFAULT,LIST
+       TBLDIS NAME,DEFAULT,[LIST]NUMSAT
+       TERMIN
+
+\f
+
+VECFLG==0
+PARFLG==0
+
+;MACROS FOR INITIIAL MUDDLE LIST STRUCTURE
+
+;CHAR STRING MAKER, RETURNS POINTER AND TYPE
+
+DEFINE MACHAR NAME,TYPE,VAL,\LNT,WHERE,LAST
+               TYPE==TCHSTR
+               VECTGO WHERE
+               ASCII \NAME!\
+               LAST==$."
+               TCHRS,,0
+               $."-WHERE+1,,0
+               VAL==-<LAST-WHERE>,,WHERE
+               VECRET
+
+TERMIN
+;MACRO TO DEFINE ATOMS
+
+DEFINE MAKAT NAME,TYAT,VALU,OBLIS,REFER,LOCN,\TVENT,FIRST
+       FIRST==.
+       TYAT,,OBLIS
+       VALU
+       ASCII \NAME!\
+       400000+SATOM,,0
+       .-FIRST+1,,0
+       TVENT==FIRST-.+2,,FIRST
+       IFSN [LOCN],LOCN==TVENT
+       ADDTV TATOM,TVENT,REFER
+       TERMIN
+
+
+
+\f;MACROS TO SWITCH BACK AND FORTH INTO AND OUT OF VECTOR AND PAIR SPACE
+;GENERAL SWITCHER
+
+DEFINE LOCSET LOCN,RETNAM,NEWLOC,OTHLOC,F1,F2,TOPWRD,\SAVE,SAVEF1,SAVEF2,NEW
+
+       IFE F1,[SAVE==.
+               LOC NEWLOC
+               SAVEF2==F2
+               IFN F2,OTHLOC==SAVE
+               F2==0
+               DEFINE RETNAM
+                       F1==F1-1
+                       IFE F1,[NEWLOC==.
+                       F2==SAVEF2
+                       LOC TOPWRD
+                       NEWLOC
+                       LOC SAVE
+                       ]
+                       TERMIN
+               ]
+
+       IFN F1,[F1==F1+1
+               ]
+
+       IFSN LOCN,,LOCN==.
+       IFE F1,F1==1
+
+TERMIN
+
+
+DEFINE VECTGO LOCN
+       LOCSET LOCN,VECRET,VECLOC,PARLOC,VECFLG,PARFLG,VECTOP
+       TERMIN
+
+DEFINE PARGO LOCN
+       LOCSET LOCN,PARRET,PARLOC,VECLOC,PARFLG,VECFLG,PARTOP
+       TERMIN
+
+DEFINE ADDTV TYPE,GOODIE,REFER,\SAVE
+       SAVE==.
+       LOC TVLOC
+       TVOFF==.-TVBASE+1
+       TYPE,,REFER
+       GOODIE
+       TVLOC==.
+       LOC SAVE
+       TERMIN
+
+;MACRO TO ADD TO PROCESS VECTOR
+
+DEFINE ADDPV TYPE,GOODIE,OFFS,\SAVE
+       SAVE==.
+       LOC PVLOC
+       PVOFF==.-PVBASE
+       IFSN OFFS,,OFFS==PVOFF
+       TYPE,,0
+       GOODIE
+       PVLOC==.
+       LOC SAVE
+       TERMIN
+
+
+
+
+\f;MACRO TO DEFINE A FUNCTION ATOM
+
+DEFINE MFUNCTION NAME,TYPE,PNAME
+       (TVP)
+NAME":
+       VECTGO DUMMY1
+       IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM,<NAME-1>
+       IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM,<NAME-1>
+       VECRET
+       TERMIN
+
+;MACRO TO DEFINE QUOTED GOODIE
+
+DEFINE MQUOTE ARG,PNAME,OBLIS,\LOCN
+       (TVP)
+
+       LOCN==.-1
+       VECTGO DUMMY1
+       IFSE [PNAME],MAKAT [ARG]TUNBOU,0,OBLIS,LOCN
+       IFSN [PNAME],MAKAT [PNAME]TUNBOU,0,OBLIS,LOCN
+       VECRET
+       TERMIN
+
+
+
+
+DEFINE CHQUOTE NAME,\LOCN,TYP,VAL
+       (TVP)
+       LOCN==.-1
+       MACHAR [NAME]TYP,VAL
+       ADDTV TYP,VAL,LOCN
+
+       TERMIN
+
+\f
+CHRWD==5
+
+IFN READER,[
+NCHARS==177
+;CHARACTER TABLE GENERATING MACROS
+
+DEFINE SETSYM WRDL,BYTL,COD
+       WRD!WRDL==<WRD!WRDL>&<MSK!BYTL>
+       WRD!WRDL==<WRD!WRDL>\<<COD&177>_<<4-BYTL>*7+1>>
+       TERMIN
+
+DEFINE INIWRD N,INIT
+       WRD!N==INIT
+       TERMIN
+
+DEFINE OUTWRD N
+       WRD!N
+       TERMIN
+
+;MACRO TO KILL THESE SYMBOLS LATER
+
+DEFINE KILLWD N
+       EXPUNGE WRD!N
+       TERMIN
+DEFINE SETMSK N
+       MSK!N=<177_<<4-N>*7+1>>#<-1>
+       TERMIN
+
+;MACRO TO KILL MASKS LATER
+
+DEFINE KILMSK N
+       EXPUNGE MSK!N
+       TERMIN
+
+NWRDS==<NCHARS+CHRWD-1>/CHRWD
+
+REPEAT CHRWD,SETMSK \.RPCNT
+
+REPEAT NWRDS,INIWRD \.RPCNT,004020100402
+
+DEFINE OUTTBL
+       REPEAT NWRDS,OUTWRD \.RPCNT
+       TERMIN
+
+
+;MACRO TO GENERATE THE DUMMIES EASLILIER
+
+DEFINE INITCH \DUM1,DUM2,DUM3
+
+
+DEFINE SETCOD  COD,LIST
+       IRP CHAR,,[LIST]
+       DUM1==CHAR/5
+       DUM2==CHAR-DUM1*5
+       SETSYM \DUM1,\DUM2,COD
+       TERMIN
+       TERMIN
+
+DEFINE SETCHR COD,LIST
+       IRPC CHAR,,[LIST]
+       DUM3=="CHAR
+       DUM1==DUM3/5
+       DUM2==DUM3-DUM1*5
+       SETSYM \DUM1,\DUM2,COD
+       TERMIN
+       TERMIN
+
+DEFINE INCRCO OCOD,LIST
+       IRP CHAR,,[LIST]
+       DUM1==CHAR/5
+       DUM2==CHAR-DUM1*5
+       SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
+       TERMIN
+       TERMIN
+
+DEFINE INCRCH OCOD,LIST
+       IRPC CHAR,,[LIST]
+       DUM3=="CHAR
+       DUM1==DUM3/5
+       DUM2==DUM3-DUM1*5
+       SETSYM \DUM1,\DUM2,\<OCOD+.IRPCN>
+       TERMIN
+       TERMIN
+       RMT [EXPUNGE DUM1,DUM2,DUM3
+       REPEAT NWRDS,KILLWD \.RPCNT
+       REPEAT CHRWD,KILMSK \.RPCNT
+]
+
+TERMIN
+
+INITCH
+]
+\f
+;REDEFINE END DO ALL THE REMOTES (ON LAST PASS ONLY)
+
+EQUALS E.END END
+
+DEFINE END ARG
+       EQUALS END E.END
+       CONSTANTS
+       VARIABLES
+       HERE
+       .LNKOT
+       IFP GEXPUN
+       CONSTANTS
+       VARIABLES
+       CODEND==.
+       LOC CODTOP
+       CODEND
+       LOC CODEND
+       END ARG
+       TERMIN
+
+
+;MACROS TO PRINT VERSIONS OF PROGRAMS DURING ASSEMBLY
+
+DEFINE NUMGEN SYM,\REST,N
+       NN==NN-1
+       N==<SYM_-30.>&77
+       REST==<SYM_6>
+       IFN N,IFGE <31-N>,IFGE <N-20>,TOTAL==TOTAL*10.+<N-20>
+       IFN NN,NUMGEN REST
+       EXPUNGE N,REST
+       TERMIN
+
+DEFINE VERSIO N
+       PRINTC /VERSION = N
+/
+       TERMIN
+
+TOTAL==0
+NN==7
+
+NUMGEN .FNAM2
+
+IF1 [
+RADIX 10.
+
+VERSIO \TOTAL
+
+RADIX 8
+PROGVN==TOTAL
+
+
+]
+
+DEFINE VATOM SYM,\LOCN,TV,A,B
+       VECTGO
+       LOCN==.
+       TFIX,,ERRORS
+       PROGVN
+       A==<<<<SYM_-30.>&77>+40>_29.>
+       B==<<SYM_-24.>&77>
+       IFN B,A==A+<<B+40>_22.>
+       B==<<SYM_-18.>&77>
+       IFN B,A==A+<<B+40>_15.>
+       B==<<SYM_-12.>&77>
+       IFN B,A==A+<<B+40>_8.>
+       B==<<SYM_-6.>&77>
+       IFN B,A==A+<<B+40>_1.>
+       A
+       IFN <SYM&77>,<<SYM&77>+40>_29.
+       400000+SATOM,,
+       .-LOCN+1,,0
+       TV==LOCN-.+2,,LOCN
+       ADDTV TATOM,TV,0
+       VECRET
+       TERMIN
+
+VATOM .FNAM1
+
+
+;MACRO TO REMMVE SYMBOLS OF THE FORM "GXXXXX"
+
+DEFINE GEXPUN \SYM
+       NN==7
+       TOTAL==0
+       NUMGEN \<SIXBIT /SYM!/>
+       RADIX 10.
+       .GSSET 0
+       REPEAT TOTAL,XXP
+       RADIX 8
+TERMIN
+
+DEFINE XXP \A
+       EXPUNGE A
+       TERMIN
+\f\f\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/multi.test b/MUDDLE/multi.test
new file mode 100644 (file)
index 0000000..52f2b4a
--- /dev/null
@@ -0,0 +1,12 @@
+<SETG PROC2FUN <FUNCTION (A)<PRINT PROCESS2><PRINT .A>
+<RESUME <PROC1ID 'PROCESS2PASS> PROC2FUN>>>
+
+<SETG PROC2ID <CREATE ,PROC2FUN>>
+
+<SET P PROCESS1>
+
+<SETG PROC1FUN <FUNCTION (A)<PRINT PROC1FUN> <PRINT .A>>>
+
+
+<SETG PROC1ID .THIS-PROCESS>
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nactor.1 b/MUDDLE/nactor.1
new file mode 100644 (file)
index 0000000..12ee558
--- /dev/null
@@ -0,0 +1,524 @@
+<DEFINE ACTOR
+  <FUNCTION ("STACK" "ARGS" A) <CHTYPE .A ACTOR>  >>
+
+<DEFINE ACTOR-FUNCTION
+  <FUNCTION ("STACK" "ARGS" A) <CHTYPE .A ACTOR-FUNCTION>  >>
+
+<DEFINE ACTOR?
+  <FUNCTION ("STACK" EXP)
+   <AND <ATOM? .EXP> <SET EXP <AVAL .EXP>>>
+   <AND <MEMQ <TYPE .EXP> '(ACTOR ACTOR-FUNCTION)>
+        .EXP>  >>
+
+<DEFINE ACTORFORM?
+ <FUNCTION ("STACK" EXP)
+   <AND <MEMQ <TYPE .EXP> '(FORM SEGMENT)>
+        <NOT <EMPTY? .EXP>>
+        <ACTOR? <1 .EXP>>>  >>
+
+
+<DEFINE PRECEDENCE
+ <FUNCTION ("STACK" ATOM) <OR <GET .ATOM PRECEDENCE> 0>   >>
+
+
+<DEFINE INVOKE
+ <FUNCTION INVOKER ("STACK" F OBJECT "OPTIONAL" (BOUND <BOTTOM .OBJECT>)
+                      (OBL T) (ENV <>) (OBJENV <>) (PURE? T)
+                      (UV1 <UARGS .F .ENV>)
+                    "AUX" (UV2 ()))
+   <SET F <CHTYPE .F FORM>>
+   <COND (<OR <EMPTY? .UV1> <GET <1 .F> FACTOR>>
+          <.INVOKER <INVOKE1 .F .OBJECT .BOUND .OBL .PURE? .ENV .OBJENV>>)
+         (.PURE?
+          <COND (.OBL)
+                (T <SET BOUND <ANOTHER .OBJECT .BOUND>>)   >)
+         (.OBL
+          <COND (<==? <TYPE .OBJECT> FORM>
+                 <COND (<OR <EMPTY? <SET UV2 <UARGS .OBJECT .OBJENV>>>
+                            <GET <1 .F> FACTOR>>
+                        <.INVOKER <INVOKE1 .OBJECT .F '<> T <> .OBJENV .ENV .UV2>>)   >)
+                (T <SET UV2 <UVARS .OBJECT .BOUND .OBJENV>>)   >)
+         (T <SET OBJECT <FRONT .OBJECT <> <LLOC BOUND> .OBJENV <LLOC UV2>>>)   >
+   <LINKVARS .UV1 .UV2 .F .OBJECT <OR .ENV .TOPMATCH> <OR .OBJENV .TOPMATCH>>
+   .BOUND   >>\f<DEFINE INVOKE1
+ <FUNCTION ("STACK" "BIND" CUR
+            F OBJECT BOUND OBL PURE? ENV OBJENV
+            "AUX" ACTR VAL)
+   <COND (<OR <EMPTY? .F> <NOT <SET ACTR <ACTOR? <1 .F>>>>>
+          <SET VAL <EVAL .F .ENV>>
+          <COND (.PURE?
+                 <COND (.OBL
+                        <OR <=UPTO? .VAL .OBJECT .BOUND> <FAIL>>
+                        .BOUND)
+                       (T <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUND>)   >)
+                (.OBL
+                 <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> .BOUND>)
+                (T <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>)   >)
+         (<==? <TYPE .ACTR> ACTOR-FUNCTION>
+          <FINSPLICE .CUR .ENV>
+          <EVAL <FORM <CHTYPE .ACTR FUNCTION>
+                      '.OBJECT '.BOUND '.OBL '.PURE? '<OR .ENV .TOPMATCH>
+                      '<OR .OBJENV .PURE? .TOPMATCH> !<REST .F>>>)
+         (<==? <TYPE .ACTR> ACTOR>
+          <FINSPLICE .CUR .ENV>
+          <BIND .ACTR <REST .F>
+                ((BODY <REST .ACTR <COND (<ATOM? <1 .ACTR>> 2) (1)   >>))
+             <APPLY <CHTYPE ,ET FUNCTION> 
+                    (.OBJECT .BOUND .OBL .PURE? <ENVIRON> .OBJENV !.BODY)>   >)
+         (T <ERROR NON-INVOKABLE-TYPE>)   >   >>\f<DEFINE GIVEN
+ <ACTOR-FUNCTION GA ("STACK" OBJECT BOUNDARY OBLIGATORY PURE? ENV OBJENV VAR
+                     "AUX" (VAL <RLVAL .VAR>) RS (VALRS ()) (UV ()) PURESOFAR NEWVAL
+                           NEWBOUND (VARLOC <LLOC .VAR>) VARFORM RS2)
+   <COND (<ASSIGNED? .VAR>
+          <COND (.OBLIGATORY
+                 <COND (.PURE?
+                        <OR <=UPTO? .VAL .OBJECT .BOUNDARY> <FAIL>>)
+                       (T <IS1 .OBJECT .VAL .OBJENV <BOTTOM .VAL> T .BOUNDARY>)   >
+                 <.GA .BOUNDARY>)
+                (.PURE?
+                 <.GA <PREFIX1 .VAL <BOTTOM .VAL> .OBJECT .BOUNDARY>>)
+                (T <.GA <MATCH1 .VAL .OBJECT .ENV .OBJENV <BOTTOM .VAL> .BOUND <>>>)   >)   >
+   <SET RS <CHTYPE <RLVAL VAL> LIST>>
+   <COND (<AND .PURE? .OBLIGATORY>
+          <THSET .VAR <UPTO .OBJECT .BOUNDARY>>
+          <CHECKRESTRICTS .RS () ..VAR>
+          <.GA .BOUNDARY>)   >
+   <COND (<AND <==? .OBJECT <SET VARFORM <FORM GIVEN .VAR>>>
+               <==? .VARLOC
+                    <EVAL <PUT '<LLOC VAR> 2 .VAR> .OBJENV>>>
+          <.GA .BOUNDARY>)
+         (<SET RS2 <MEMRES .OBJECT .BOUNDARY .OBJENV .RS>>
+          <THPUT .RS2 1 ()>)
+         (T
+          <THSET .VAR ?()>
+          <REPEAT CHECK ("STACK" RS1)
+             <AND <EMPTY? .RS> <.CHECK <>>>
+             <SET RS1 <1 .RS>>   <SET RS <REST .RS>>
+             <COND (<MONAD? .RS1>)
+                   (<==? <1 .RS1> PATTERN>
+                    <SET BOUNDARY
+                         <COND (.PURE?
+                                <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY .OBLIGATORY>)
+                               (T
+                                <MATCH1 <2 .RS1> .OBJECT <3 .RS1> .OBJENV
+                                        <BOTTOM <2 .RS1>> .BOUNDARY
+                                        .OBLIGATORY>)   >>
+                    <SET OBLIGATORY T>
+                    <COND (<ASSIGNED? .VAR>
+                            <CHECKRESTRICTS .RS .VALRS ..VAR>
+                            <.GA .BOUNDARY>)
+                          (<FULL? <RLVAL .VAR>>
+                            <THSET RS <NCONC <CHTYPE <RLVAL .VAR> LIST>
+                                            .RS>>
+                            <THSET .VAR ?()>)   >)
+                   (T <THSET VALRS (.RS1 !.VALRS)>)   >>)   >
+   <THTRYSET .VARLOC .VARFORM .OBJECT .BOUNDARY .OBLIGATORY .PURE?
+             .ENV .OBJENV .RS .VALRS>   >>
+
+<PUT GIVEN PRECEDENCE 3>\f<DEFINE ALTER
+ <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV VAR)
+   <THTRYSET <LLOC .VAR> <FORM GIVEN .VAR> .OBJECT .BOUND .OBL?
+             .PURE? .ENV .OBJENV>   >>
+
+<PUT ALTER PRECEDENCE 4>
+
+
+<DEFINE BE
+ <ACTOR ("STACK" PRED)
+   <DO <OR .PRED <FAIL>>>   >>
+
+<PUT BE PRECEDENCE 30>
+
+
+<DEFINE DO
+ <ACTOR ("STACK" ACTION)
+   <?>   >>
+
+<PUT DO PRECEDENCE 29>
+
+
+<DEFINE ?
+ <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL" (N <>)
+                  "AUX" UV)
+   <COND (.OBL?
+          <COND (.PURE?
+                 <OR <NOT .N>
+                     <==? .N <BLENGTH .OBJECT .BOUND>>
+                     <FAIL>>)
+                (<OR <PROG2 <SET OBJECT <INSTANTIATE .OBJECT UV .BOUND .OBJENV>>
+                            .UV>
+                     <NOT <UNCERTAINLENGTH .OBJECT>>>
+                 <OR <NOT .N> <==? .N <LENGTH .OBJECT>> <FAIL>>)
+                (<EMPTY? .UV> <FAIL>)
+                (T <LINKVARS () .UV <SET FORM1 <FORM ? .N>> .OBJECT
+                             <> .OBJENV .FORM1 .BOUND>)   >
+          .BOUND)
+         (.PURE?
+          <COND (.N
+                 <COND (<G? .N <BLENGTH .OBJECT .BOUND>> <FAIL>)
+                       (T <REST .OBJECT .BOUND>)   >)
+                (T <ANOTHER .OBJECT .BOUND>)   >)
+         (T 
+          <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV>>
+          <COND (.N
+                 <OR <==? .N <LENGTH .OBJECT>> <FAIL>>)   >
+          .BOUND)   >   >>
+
+<PUT ? PRECEDENCE 2>\f<DEFINE ET
+ <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS)
+   <REPEAT ACTITER ("STACK")
+                <COND (<EMPTY? .PATS>
+                       <.ACTITER <COND (.OBL? .BOUND)
+                                       (.PURE? <ANOTHER .OBJECT .BOUND>)
+                                       (T <REAR .OBJECT .OBJENV .BOUND>)   >>)   >
+                <SET BOUND
+                     <COND (.PURE?
+                            <IS1 <1 .PATS> .OBJECT .ENV .BOUND .OBL?>)
+                           (T <MATCH1 <1 .PATS>
+                                      .OBJECT
+                                      .ENV
+                                      .OBJENV
+                                      <BOTTOM <1 .PATS>>
+                                      .BOUND
+                                      .OBL?>)   >>
+                <SET OBL? T>
+                <THSET PATS <REST .PATS>>   >   >>
+
+<PUT ET PRECEDENCE 10>   <PUT ET FACTOR T>
+
+
+
+<DEFINE VEL
+ <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'PATS
+                  "AUX" (PAT1 <CLIP PATS>))
+   <COND (.PURE?
+          <IS1 .PAT1 .OBJECT <> .BOUND .OBL?>)
+         (T <MATCH1 .PAT1 .OBJECT <> .OBJENV <BOTTOM .PAT1> .BOUND .OBL?>)   >   >>
+
+
+<PUT VEL PRECEDENCE 20>   <PUT VEL FACTOR T>
+
+<DEFINE NON
+ <ACTOR-FUNCTION ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV 'PAT)
+   <OR .OBL?
+       <SET OBJECT
+            <COND (.PURE? <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>)
+                  (T <FRONT .OBJECT <> <LLOC BOUND> .OBJENV>)   >>   >
+   <FAILPOINT NAY-SAYER ("STACK")
+      <PROG2 <COND (.PURE? <IS1 .PAT .OBJECT>)
+                   (T <MATCH1 .PAT .OBJECT <> .OBJENV>)   >
+             <FAIL <> .NAY-SAYER>>
+      ("STACK")
+      <.NAY-SAYER .BOUND>   >>>
+
+<PUT NON PRECEDENCE 6>   <PUT NON FACTOR T>\f<DEFINE WHEN
+ <ACTOR-FUNCTION WA ("STACK" OBJECT BOUND OBL? PURE? ENV OBJENV "REST" 'CLAUSES
+                     "AUX" (CLAUSE <CLIP CLAUSES>) NEWBOUND)
+   <SET NEWBOUND
+        <COND (<EMPTY? .CLAUSE> <ERROR EMPTY-CLAUSE--WHEN>)
+              (.PURE? <IS1 <1 .CLAUSE> .OBJECT <> .BOUND .OBL?>)
+              (T <MATCH1 <1 .CLAUSE> .OBJECT <> .OBJENV
+                         <BOTTOM <1 .CLAUSE>> .BOUND .OBL?>)   >>
+   <FAILPOINT () <> ("STACK") <FAIL <> .WA>>
+   <APPLY <CHTYPE ,ET FUNCTION>
+          (.OBJECT .NEWBOUND T .PURE? .ENV .OBJENV !<REST .CLAUSE>)>
+   .NEWBOUND   >>
+
+<PUT WHEN PRECEDENCE 25>   <PUT WHEN FACTOR T>\f<DEFINE THTRYSET
+ <FUNCTION ("STACK" VARLOC VARFORM OBJECT BOUND OBL? PURE? ENV OBJENV "OPTIONAL"
+              (RS ()) (VALRS ()) 
+            "AUX" VAR2)
+   <COND (.OBL?
+          <COND (.PURE?
+                 <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC <UPTO .OBJECT .BOUND>>>)
+                (<PROG2
+                    <SET OBJECT <INSTANTIATE .OBJECT PURE? .BOUND .OBJENV>>
+                    .PURE?>
+                 <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
+
+                (<SET VAR2 <UVAR? .OBJECT>>
+                 <THPSEUDOSETLOC <LLOC .VAR2> .VARFORM .ENV>
+                 <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>)
+                (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>)   >)
+         (.PURE?
+          <THSETLOC .VARLOC <UPTO .OBJECT <SET BOUND <ANOTHER .OBJECT .BOUND>>>>)
+         (<PROG2
+             <SET OBJECT <FRONT .OBJECT T <LLOC BOUND> .OBJENV <LLOC PURE?>>>
+             .PURE?>
+          <CHECKRESTRICTS .RS .VALRS <THSETLOC .VARLOC .OBJECT>>)
+         (T <THIMPURESETLOC .VARLOC .PURE? .VARFORM .OBJECT .ENV .OBJENV>)   >
+   .BOUND   >>
+
+
+<DEFINE THIMPURESETLOC
+   <FUNCTION ("STACK" LOC UV VARFORM OBJECT ENV OBJENV)
+   <COND (<MEMQ .VARLOC <LINKVARS () .UV .VARFORM .OBJECT .ENV .OBJENV>>
+          <FAIL>)
+         (T <THPSEUDOSETLOC .VARLOC .OBJECT .OBJENV>)   >  >>
+
+
+<DEFINE THPSEUDOSETLOC
+ <FUNCTION ("STACK" LOC OBJ OBJENV)
+   <THSETLOC .LOC 
+             <CHTYPE ([PATTERN .OBJ .OBJENV] !<CHTYPE <IN .LOC> LIST>)
+                     UNASSIGNED>>   >>\f<DEFINE PREFIX1
+ <FUNCTION P ("STACK" L1 TERM1 L2 TERM2)
+   <COND (<OR <EMPTY? .L1> <==? .L1 .TERM1>>
+          <EXIT .P .L2>)
+         (<==? .L2 .TERM2> <FAIL>)>
+   <OR <=? <1 .L1> <1 .L2>> <FAIL>>
+   <SET L1 <REST .L1>>   <SET L2 <REST .L2>>
+   <AGAIN .P>  >>
+
+
+
+<DEFINE FRONT
+ <FUNCTION ("STACK" "BIND" CUR
+            OBJECT EV? BOUNDLOC "OPTIONAL" (ENV <>)
+               (PURELOC <>)
+            "AUX" V P (LP <LLOC P>) (CONSTRUCT <CONSTRUCTOR <TYPE .OBJECT>>)
+               (BOUND <IN .BOUNDLOC>))
+   <SETLOC .BOUNDLOC .OBJECT>
+   <AND .PURELOC <SETLOC .PURELOC ()>>
+   <FINSPLICE .CUR .ENV>
+   <SET RESULT
+      <FAILPOINT EXTENDER ("STACK")
+         <BOTTOM .OBJECT>
+         ("STACK")
+         <COND (<==? .OBJECT .BOUND> <FAIL>)
+               (<==? <TYPE <1 .OBJECT>> SEGMENT>
+                <SET V <FORMSUBST <1 .OBJECT> .LP>>
+                <COND (<EMPTY? .V>
+                       <SET OBJECT <REST .OBJECT>>
+                       <AGAIN .EXTENDER>)   >
+                <SET OBJECT <BACKTO .OBJECT <REST .V> .BOUNDLOC>>
+                <RESTORE .EXTENDER <.CONSTRUCT !.RESULT <1 .V>>>)
+               (.EV? <SET V <INSTANTIATE <1 .OBJECT> P>>
+                     <AND .PURELOC <NOT .P> <SETLOC .PURELOC <NCONC .P <IN .PURELOC>>>>
+                     <SETLOC .BOUNDLOC <SET OBJECT <REST .OBJECT>>>
+                     <RESTORE .EXTENDER <.CONSTRUCT !.RESULT .V>>)
+               (T <AND .PURELOC
+                       <FULL? <SET P <UVARS <1 .OBJECT>>>>
+                       <SETLOC .PURELOC <NCONC <CHTYPE .P FALSE> <IN .PURELOC>>>>
+                  <RESTORE .EXTENDER
+                           <PROG1 <.CONSTRUCT !.RESULT <1 .OBJECT>>
+                                  <SETLOC .BOUNDLOC  <SET OBJECT <REST .OBJECT>>>>>)   >>>  >>\f<DEFINE REAR
+ <FUNCTION ("STACK""BIND" CUR
+            OBJECT "OPTIONAL" (ENV <>) (BOUND <BOTTOM .OBJECT>)
+            "AUX" V P (LP <LLOC P>))
+   <FINSPLICE .CUR .ENV>
+   <FAILPOINT CHOPPER ("STACK")
+      .BOUND
+      ("STACK")
+      <COND (<==? .OBJECT .BOUND> <FAIL>)
+            (<==? <TYPE <1 .OBJECT>> SEGMENT>
+             <SET V <FORMSUBST <1 .OBJECT> .LP>>
+             <COND (<EMPTY? .V>
+                    <SET OBJECT <REST .OBJECT>>
+                    <AGAIN .CHOPPER>)   >
+             <RESTORE .CHOPPER <SET OBJECT <BACKTO .OBJECT <REST .V>>>>)
+            (T <RESTORE .CHOPPER <SET OBJECT <REST .OBJECT>>>)   >   >>>\f<DEFINE INSTANTIATE
+ <FUNCTION ("STACK" "BIND" CUR
+            EXP UVAR "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
+              (LUV <LLOC .UVAR>))
+   <FINSPLICE .CUR .ENV>
+   <COND (<==? <TYPE .EXP> FORM>
+          <FORMSUBST .EXP .LUV>)
+         (<MONAD? .EXP>
+          <SETLOC .LUV ()>
+          .EXP)
+         (T <INSTANTIATE1 .EXP .LUV .BOUND>)   >>>
+
+
+<DEFINE INSTANTIATE1
+ <FUNCTION INSTLP ("STACK" EXP LUV "OPTIONAL" (BOUND <BOTTOM .EXP>)
+                   "AUX" (RESULT ()) (P ()) P1 (LP1 <LLOC P1>) EXP1)
+   <COND (<==? .EXP .BOUND> <SETLOC .LUV .P>
+          <.INSTLP <REVERSE .RESULT <CONSTRUCTOR <TYPE .EXP>>>>)
+         (<==? <TYPE <SET EXP1 <1 .EXP>>> SEGMENT>
+          <SET RESULT (<REVERSE <FORMSUBST .EXP1 .LP1> ,CONSL>
+                       !.RESULT)>)
+         (T <SET RESULT (<INSTANTIATE .EXP1 P1> !.RESULT)>)   >
+   <OR .P1 <SET P <NCONC .P1 .P>>>
+   <SET EXP <REST .EXP>>
+   <AGAIN .INSTLP>   >>
+
+
+<DEFINE FORMSUBST
+ <FUNCTION ("STACK" F PURELOC "AUX" P A1 VAR)
+   <COND (<FULL? <SET P <UARGS .F>>>
+          <SETLOC .PURELOC <CHTYPE .P FALSE>>
+          .F)
+         (<OR <EMPTY? .F> <NOT <SET A1 <ACTOR? <1 .F>>>>>
+          <SETLOC .PURELOC ()>
+          <EVAL .F>)
+         (<EMPTY? <REST .F>>
+          <SETLOC .PURELOC <>>
+          .F)
+         (<==? .A1 ,ALTER>
+          <THSET <SET VAR <EVAL <2 .F>>> ?()>
+          <SETLOC .PURELOC <FALSE .VAR>>
+          <FORM GIVEN .VAR>)
+         (<==? .A1 ,GIVEN>
+          <COND (<ASSIGNED? <SET VAR <EVAL <2 .F>>>>
+                 <SETLOC .PURELOC ()>
+                 <LVAL .VAR>)
+                (T <SETLOC .PURELOC <FALSE .VAR>>
+                   .F)   >)
+         (T <SETLOC .PURELOC <>>
+            .F)   >>>\f<DEFINE UVARS
+ <FUNCTION ("STACK" "BIND" CUR
+            EXP "OPTIONAL" (BOUND <BOTTOM .EXP>) (ENV <>)
+            "AUX" UA ACTR VAR)
+   <FINSPLICE .CUR .ENV>
+   <COND (<==? <TYPE .EXP> FORM>
+          <COND (<FULL? <SET UA <UARGS .EXP>>> .UA)
+                (<AND <==? <LENGTH .EXP> 2>
+                      <SET ACTR <ACTOR? <1 .EXP>>>>
+                 <COND (<==? .ACTR ,GIVEN>
+                        <COND (<OR <NOT <BOUND? <SET VAR <EVAL <2 .EXP>>>>>
+                                   <UNASSIGNED? .VAR>>
+                               (.VAR))   >)
+                       (<==? .ACTR ,ALTER>
+                        <THSET <SET VAR <EVAL <2 .EXP>>> ?()>
+                        (.VAR))   >)   >)
+         (<==? .EXP .BOUND> ())
+         (T <NCONC <UVARS <1 .EXP>> <UVARS <REST .EXP> .BOUND>>)   >>>
+
+
+<DEFINE UARGS
+ <FUNCTION ("STACK" "BIND" C
+            F "OPTIONAL" (ENV <>)
+            "AUX" VAR)
+   <FINSPLICE .C .ENV>
+   <COND (<MULTILEVEL .F>
+          <COND (<AND <MEMQ <TYPE .F> '(FORM SEGMENT)>
+                      <==? <1 .F> LVAL>
+                      <ATOM? <SET VAR <2 .F>>>
+                      <OR <NOT <BOUND? .VAR>> <UNASSIGNED? .VAR>>>
+                 (.VAR))
+                (T <MAPCAN ,UARGS .F>)   >)   >   >>
+
+
+<DEFINE UVAR?
+ <FUNCTION ("STACK" OBJECT "AUX" RES)
+   <AND <==? <TYPE .OBJECT> FORM>
+        <==? <LENGTH .OBJECT> 2>
+        <==? <1 .OBJECT> GIVEN>
+        <ATOM? <SET RES <EVAL <2 .OBJECT>>>>
+        .RES>   >>
+
+
+<DEFINE UNCERTAINLENGTH
+ <FUNCTION ("STACK" OBJECT)
+   <OR <==? <TYPE .OBJECT> FORM>
+       <AND <MULTILEVEL .OBJECT>
+            <MAPC #FUNCTION (("STACK" EL) <AND <==? <TYPE .EL> SEGMENT> <.UNC T>>)
+                  .OBJECT>
+            <>>>   >>\f<DEFINE UPTO
+ <FUNCTION ("STACK" OBJECT BOUNDARY)
+   <COND (<MONAD? .OBJECT> .OBJECT)
+         (T <REVERSE <UPTO1 .OBJECT .BOUNDARY>
+                     <CONSTRUCTOR <TYPE .OBJECT>>>)   >   >>
+
+
+<DEFINE UPTO1
+ <FUNCTION LOOP ("STACK" OBJ BOU "AUX" (RES ()))
+   <COND (<==? .OBJ .BOU> .RES)
+         (T <SET RES (<1 .OBJ> !.RES)>
+            <SET OBJ <REST .OBJ>>
+            <AGAIN .LOOP>)   >>>
+
+
+<DEFINE BACKTO
+ <FUNCTION ("STACK" PAT BEG "OPTIONAL" (BOUNDLOC <>))
+   <COND (<EMPTY? .BEG> .PAT)
+         (<ISREST .PAT .BEG> .BEG)
+         (T <SET PAT <REVERSE (!<REVERSEUPTO .PAT <IN .BOUNDLOC>>
+                               !<REVERSE .BEG ,CONSL>)
+                              <CONSTRUCTOR <TYPE .PAT>>>>
+            <SETLOC .BOUNDLOC <BOTTOM .PAT>>
+             .PAT)   >>>
+
+
+<DEFINE REVERSEUPTO
+ <FUNCTION REV ("STACK" EXP1 EXP2 "AUX" (RESULT()))
+   <COND (<==? .EXP1 .EXP2> .RESULT)
+         (T <SET RESULT (<1 .EXP1> !.RESULT)>
+            <SET EXP1 <REST .EXP1>>
+            <AGAIN .REV>)   >>>
+
+
+<DEFINE ISREST
+ <FUNCTION CHECKER ("STACK" EXP1 EXP2)
+   <COND (<==? .EXP1 .EXP2> T)
+         (<EMPTY? .EXP2> <>)
+         (T <SET EXP2 <REST .EXP2>>
+            <AGAIN .CHECKER>)   >>>\f<DEFINE CHECKRESTRICTS
+ <FUNCTION CH ("STACK" RS VALRS OBJECT "OPTIONAL" (BOUNDARY <BOTTOM .OBJECT>))
+   <REPEAT CR ("STACK" RS1)
+      <AND <EMPTY? .RS> <EXIT .CR <>>>
+      <COND (<MONAD? <SET RS1 <1 .RS>>>)
+            (<==? <1 .RS1> PATTERN>
+             <IS1 <2 .RS1> .OBJECT <3 .RS1> .BOUNDARY>)
+            (<THSET VALRS (.RS1 !.VALRS)>)   >
+      <THSET RS <REST .RS>>   >
+   <REPEAT ("STACK" VALRS1)
+      <AND <EMPTY? .VALRS> <EXIT .CH <>>>
+      <SET VALRS1 <1 .VALRS>>
+      <OR <==? <1 .VALRS1> VALUE>
+          <ERROR MEANINGLESS-RESTRICTION--CHECKRESTRICTS>>
+      <REPEAT REMTAGS ("STACK" (LOCS <REST .VALRS1 7>))
+         <AND <EMPTY? .LOCS> <EXIT .REMTAGS<>>>
+         <COND (<==? <TYPE <IN <1 .LOCS>>> UNASSIGNED>
+                <THSETLOC <1 .LOCS> <THDELQ .VALRS1 <IN <1 .LOCS>>>>)   >
+         <SET LOCS <REST .LOCS>>   >
+      <MATCH1 <2 .VALRS1> <3 .VALRS1> <4 .VALRS1> <5 .VALRS1>
+              <6 .VALRS1> <7 .VALRS1>>
+      <THSET VALRS <REST .VALRS>>   >   >>
+
+
+<DEFINE MEMRES
+ <FUNCTION CHECK ("STACK" EXP BOUND ENV RESTRICTIONS "AUX" R1)
+   <REPEAT ("STACK")
+      <AND <EMPTY? .RESTRICTIONS> <EXIT .CHECK <>>>
+      <SET R1 <1 .RESTRICTIONS>>
+      <COND (<AND <NOT <MONAD? .R1>>
+                  <==? <1 .R1> PATTERN>
+                  <==? .ENV <3 .R1>>
+                  <=UPTO? <2 .R1> .EXP .BOUND>>
+             <.CHECK T>)   >
+      <SET RESTRICTIONS <REST .RESTRICTIONS>>   >   >>
+
+
+<DEFINE =UPTO?
+ <FUNCTION ("STACK" EXP1 EXP2 BOUND)
+   <COND (<AND <MONAD? .EXP1> <FULL? .EXP1>>
+          <=? .EXP1 .EXP2>)
+         (<AND <MONAD? .EXP2> <FULL? .EXP2>> <>)
+         (<PROG =CHECK ("STACK")
+             <COND (<EMPTY? .EXP1> <==? .EXP2 .BOUND>)
+                   (<==? .EXP2 .BOUND> <>)
+                   (<=? <1 .EXP1> <1 .EXP2>>
+                    <SET EXP1 <REST .EXP1>>   <SET EXP2 <REST .EXP2>>
+                    <AGAIN .=CHECK>)   >>)   >>>\f<DEFINE LINKVARS
+ <FUNCTION LINKER ("STACK" VARS1 VARS2 PAT1 PAT2 ENV1 ENV2 "OPTIONAL"
+                     (BOUND1 <BOTTOM .PAT1>) (BOUND2 <BOTTOM .PAT2>)
+                   "AUX" (LOCS <NCONC <GENLOCS .VARS1 .ENV1>
+                                      <GENLOCS .VARS2 .ENV2>>))
+  <REPEAT ("STACK" (LOCS1 .LOCS)
+           (R [VALUE .PAT1 .PAT2 .ENV1 .ENV2 .BOUND1 .BOUND2 !.LOCS]))
+      <AND <EMPTY? .LOCS1> <.LINKER .LOCS>>
+      <THSETLOC <1 .LOCS1>
+                <CHTYPE (.R !<CHTYPE <IN <1 .LOCS>> LIST>) UNASSIGNED>>
+      <SET LOCS1 <REST .LOCS1>>   >   >>
+
+
+<DEFINE GENLOCS
+ <FUNCTION ("STACK" "BIND" C VARS ENV)
+   <COND (<EMPTY? .VARS> ())
+         (T <SPLICE .C .ENV>
+            <REPEAT GEN ("STACK" (LOCS ()))
+               <SET LOCS (<LLOC <1 .VARS>> !.LOCS)>
+               <SET VARS <REST .VARS>>
+               <AND <EMPTY? .VARS> <.GEN .LOCS>>   >)   >>>\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nagc.17 b/MUDDLE/nagc.17
new file mode 100644 (file)
index 0000000..d310f8c
--- /dev/null
@@ -0,0 +1,1835 @@
+TITLE AGC MUDDLE GARBAGE COLLECTOR
+;SYSTEM WIDE DEFINITIONS GO HERE
+.GLOBAL PDLBUF,VECTOP,VECBOT,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,WRONGT
+.GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,TMA,TFA,PPGROW
+
+; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR
+
+.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS
+.GLOBAL CELL
+
+
+PDLBUF=100
+TPMAX==5000    ;PDLS LARGER THAN THIS WILL BE SHRUNK
+PMAX==1000     ;MAXIMUM PSTACK SIZE
+TPMIN==100     ;MINIMUM PDL SIZES
+PMIN==100
+TPGOOD==2000   ; A GOOD STACK SIZE
+PGOOD==1000
+
+RELOCATABLE
+.INSRT MUDDLE >
+
+TYPNT=AB       ;SPECIAL AC USAGE DURING GC
+F=TP                           ;ALSO SPECIAL DURING GC
+LPVP=SP                                ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN
+LINF=TB                                ;SPECIAL FOR GC, HOLDS POINTER TO INFO CELL CHAIN
+;FUNCTION TO CONSTRUCT A LIST
+MFUNCTION CONS,SUBR
+       ENTRY   2
+       HLRZ    A,2(AB)         ;GET TYPE OF 2ND ARG
+       CAIE    A,TLIST         ;LIST?
+       JRST    BADTYP          ;NO , COMPLAIN
+       HLRZ    A,(AB)          ;GET TYPE OF FIRST
+       PUSHJ   P,NWORDT        ;GET NO. OF WORDS NEEDED FOR DATUM
+       SOJN    A,CDEFER        ;GREATER THAN 1, MUST MAKE DEFERRED POINTER
+       MOVEI   A,2             ;SET UP CALL TO CELL
+       PUSHJ   P,CELL
+       HLLZ    A,(AB)          ;TYPE OF FIRST ARG
+       MOVE    C,1(AB)         ;GET DATUM
+CFINIS:        PUSHJ   P,CLOBIT        ;STORE
+       JRST    FINIS
+
+;HERE TO STORE IN PAIR
+
+CLOBIT:        HRR     A,3(AB)         ;GET CDR
+CLOBT1:        MOVEM   A,(B)           ;STORE FIRST
+       MOVEM   C,1(B)          ;AND SECOND
+       MOVSI   A,TLIST         ;GET FINAL TYPE
+       POPJ    P,
+
+;HERE FOR A DEFERRED CONS
+
+CDEFER:        MOVEI   A,4             ;NEED 4 CELLS
+       PUSHJ   P,CELL
+       MOVE    A,(AB)          ;GET COMPLETE 1ST WORD
+       MOVE    C,1(AB)         ;AND SECOND
+       PUSHJ   P,CLOBT1        ;STORE
+       MOVE    C,B             ;POINT TO DEFERRED PAIR WITH C
+       ADDI    B,2             ;POINT TO OTHER PAIR
+       MOVSI   A,TDEFER        ;GET TYPE
+       JRST    CFINIS
+
+\f
+;THIS ROUTINE ALLOCATES A CELL
+CELL:  MOVE    B,PARTOP        ;GET TOP OF PAIRS
+       ADD     B,A             ;FIND PROPOSED NEW TOP
+       CAMLE   B,VECBOT        ;CROSSING INTO VECTORS?
+       JRST    FULL            ;YES, GO COLLECT GARBAGE
+       EXCH    B,PARTOP        ;NO, SET NEW TOP AND RETURN POINTER
+       POPJ    P,
+
+FULL:  MOVEM   A,GETNUM        ;STORE WORDS NEEDED
+       SETZM   PARNEW          ;NO MOVEMENT NEEDED
+       PUSHJ   P,AGC           ;COLLECT GARBAGE
+       JRST    CELL            ;AND TRY AGAIN
+
+
+;SUBROUTINES TO RETURN WORDS NEEDED BASED ON TYPE OR SAT
+
+NWORDT:        PUSHJ   P,SAT           ;GET STORAGE ALLOC TYPE
+NWORDS:        SKIPL   MKTBS(A)        ;-ENTRY IN TABLE MEANS 2 NEEDED
+       SKIPA   A,[1]           ;NEED ONLY 1
+       MOVEI   A,2             ;NEED 2
+       POPJ    P,
+
+\f
+;FUNCTION TO BUILD A LIST OF MANY ELEMENTS
+
+MFUNCTION LIST,SUBR
+       ENTRY
+
+       HLRE    A,AB            ;GET -NUM OF ARGS
+       MOVNS   A               ;MAKE IT +
+       JUMPE   A,LISTN         ;JUMP IF 0
+       PUSHJ   P,CELL          ;GET NUMBER OF CELLS
+       PUSH    TP,$TLIST       ;SAVE IT
+       PUSH    TP,B
+       LSH     A,-1            ;NUMBER OF REAL LIST ELEMENTS
+
+CHAINL:        ADDI    B,2             ;LOOP TO CHAIN ELEMENTS
+       HRRZM   B,-2(B)         ;CHAIN LAST ONE TO NEXT ONE
+       SOJG    A,.-2           ;LOOP TIL ALL DONE
+       CLEARM  B,-2(B)         ;SET THE  LAST CDR TO NIL
+
+; NOW LOBEER THE DATA IN TO THE LIST
+
+       MOVE    B,(TP)          ;RESTORE LIS POINTER
+LISTLP:        HLRZ    A,(AB)          ;GET TYPE
+       PUSHJ   P,NWORDT        ;GET NUMBER OF WORDS
+       SOJN    A,LDEFER        ;NEED TO DEFER POINTER
+       HLLZ    A,(AB)          ;NOW CLOBBER ELEMENTS
+       HLLM    A,(B)
+       MOVE    A,1(AB)         ;AND VALUE..
+       MOVEM   A,1(B)
+LISTL2:        ADDI    B,2             ;STEP B
+       ADD     AB,[2,,2]       ;STEP ARGS
+       JUMPL   AB,LISTLP
+
+       POP     TP,B
+       POP     TP,A
+       JRST    FINIS
+
+; MAKE A DEFERRED POINTER
+
+LDEFER:        PUSH    TP,$TLIST       ;SAVE CURRENT POINTER
+       PUSH    TP,B
+       MOVEI   A,2             ; SET UP TO GET CELLS
+       PUSHJ   P,CELL
+       MOVE    A,(AB)          ;GET FULL DATA
+       MOVE    C,1(AB)
+       PUSHJ   P,CLOBT1
+       MOVE    C,(TP)          ;RESTORE LIST POINTER
+       MOVEM   B,1(C)          ;AND MAKE THIS BE THE VALUE
+       MOVSI   A,TDEFER
+       HLLM    A,(C)           ;AND STORE IT
+       MOVE    B,C
+       SUB     TP,[2,,2]
+       JRST    LISTL2
+
+LISTN: MOVEI   B,0
+       MOVSI   A,TLIST
+       JRST    FINIS
+\fBADTYP:       PUSH    TP,$TATOM       ;ARGUMENT OF TYPE ATOM
+       PUSH    TP,MQUOTE 2ND-ARGUMENT-NOT-A-LIST
+       JRST    CALER1          ;OFF TO ERROR HANDLER
+
+
+\f;FUNCTION WHICH CONSES ITS ARGUMENT WITH NIL
+MFUNCTION NCONS,SUBR
+       ENTRY   1
+       PUSH    TP,(AB)         ;SET UP CONS CALL
+       PUSH    TP,1(AB)
+       PUSH    TP,$TLIST
+       PUSH    TP,[0]
+       MCALL   2,CONS
+       JRST    FINIS
+
+\f;FUNCTION TO GENERATE A VECTOR IN VECTOR SPACE
+;CALLED WITH ONE FIXNUM ARGUMENT, WHICH IS THE NUMBER OF ELEMENTS DESIRED.
+
+MFUNCTION VECTOR,SUBR
+       ENTRY
+       MOVEI   C,1             ;THIS IS A GENERAL VECTOR
+VECTO3:        JUMPGE  AB,TFA          ;TOO FEW ARGS
+       CAMGE   AB,[-4,,0]      ;ASSURE NOT TOO MANY
+       JRST    TMA
+       HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
+       CAIE    A,TFIX          ;IS IT A FIXED NUMBER?
+       JRST    BDTYPV          ;NO,  GO COMPLAIN
+       SKIPGE  A,1(AB)         ;GET LENGTH
+       JRST    BADNUM          ;LOSING NUMBER
+       ASH     A,(C)           ;TIMES TWO FOR NUMBER OF WORDS IF GENERAL
+       ADDI    A,2             ;PLUS TWO FOR DOPEWDS
+VECTO2:        MOVE    B,VECBOT        ;GET CURRENT BOTTOM OF VECTORS
+       SUB     B,A             ;AND SUBTRACT THE WORDS IN THIS VECTOR
+       CAMGE   B,PARTOP        ;HAVE WE BUMPED INTO PAIR SPACE?
+       JRST    VECTO1          ;YES, GO GARBAGE COLLECT
+       EXCH    B,VECBOT        ;UPDATE VECBOT, GET OLD POINTER
+       HRLZM   A,-1(B)         ;PUT LENGTH IN DOPE WORD FIELD.
+       MOVSI   D,400000        ;PREPARE TO SET NONUNIFORM BIT
+       JUMPE   C,.+2           ;DONT SET IF UNIFORM
+       MOVEM   D,-2(B)         ;CLOBBER IT IN
+       HRRO    B,VECBOT        ;AND GET TOP OF VECTOR IN RH, -1 IN LH.
+       TLC     B,-3(A)         ;SET LH OF ANSWER TO NEGATIVE COUNT
+       MOVSI   A,TVEC          ;AND GET TYPE VECTOR TO MARK B AS AN AOBJN POINTER TO A VECTOR
+       CAML    AB,[-2,,0]      ;SKIP IF 2 ARGS SUPPLIED
+       JRST    VFINIS          ;ONLY ONE, LEAVE
+       JUMPE   C,UINIT         ;JUMP IF NOT GENERAL VECTOR
+
+       JUMPGE  B,FINIS         ;ZERO LENGTH, DONT INIT
+       PUSH    TP,A
+       PUSH    TP,B
+       PUSH    TP,A
+       PUSH    TP,B            ;SAVE THE VECTOR
+
+INLP:  PUSH    TP,2(AB)
+       PUSH    TP,3(AB)                ;PUSH FORM TO BE EVALLED
+       MCALL   1,EVAL
+       MOVE    C,(TP)          ;RESTORE VECTOR
+       MOVEM   A,(C)
+       MOVEM   B,1(C)          ;CLOBBER
+       ADD     C,[2,,2]
+       MOVEM   C,(TP)
+       JUMPL   C,INLP          ;JUMP TO DO NEXT
+
+GETVEC:        MOVE    A,-3(TP)
+       MOVE    B,-2(TP)
+       SUB     TP,[4,,4]       ;GC TP
+       JRST    FINIS
+
+UINIT: PUSH    TP,$TUVEC
+       PUSH    TP,B
+       PUSH    TP,$TUVEC
+       PUSH    TP,B
+       PUSH    P,[-1]          ;WILL HOLD TYPE
+
+UINLP: PUSH    TP,2(AB)
+       PUSH    TP,3(AB)
+       MCALL   1,EVAL
+       HLRZS   A               ;TYPE TO RH
+       SKIPGE  (P)             ;SKIP IF 1ST SEEN
+       JRST    SET1ST
+       CAME    A,(P)
+       JRST    WRNGUT
+UINLP1:        MOVE    C,(TP)
+       MOVEM   B,(C)
+       AOBJP   C,.+3
+       MOVEM   C,(TP)
+       JRST    UINLP           ;AND CONTINUE
+
+       POP     P,A             ;RESTORE TYPE
+       HRLZM   A,(C)           ;CLOBBER UNIFORM TYPE
+       JRST    GETVEC
+
+SET1ST:        MOVEM   A,(P)
+       PUSHJ   P,NWORDT
+       SOJN    A,CANTUN
+       JRST    UINLP1
+
+VFINIS:        JUMPN   C,FINIS
+       MOVSI   A,TUVEC
+       JRST    FINIS
+
+
+;FUNCTION TO GENERATE A UNIFOM VECTOR
+
+MFUNCTION UVECTOR,SUBR
+
+       MOVEI   C,0             ;SET FOR A UNIFORM HACK
+       JRST    VECTO3
+
+BADNUM:        PUSH    TP,$TATOM       ;COMPLAIN
+       PUSH    TP,MQUOTE NEGATIVE-ARGUMENT
+       JRST    CALER1
+\fBDTYPV:       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-INTEGER-ARGUMENT
+       JRST    CALER1
+
+VECTO1:        SETZM   PARNEW          ;CLEAR RELOCATION OF PAIR SPACE
+       MOVEM   A,GETNUM        ;SAVE NUMBER OF WORDS TO GET
+       PUSHJ   P,AGC           ;GARBAGE COLLECT
+       JRST    VECTO3          ;AND TRY AGAIN
+
+MFUNCTION EVECTOR,SUBR
+       ENTRY
+       HLRE    A,AB
+       MOVNS   A
+       PUSH    P,A             ;SAVE NUMBER OF WORDS
+       ASH     A,-1            ;FOR VECTOR TO WIN NEED NO. OF ELEMENTS
+       PUSH    TP,$TFIX
+       PUSH    TP,A
+       MCALL   1,VECTOR
+
+       POP     P,D             ;RESTORE NUMBER OF WORDS
+       HRLI    C,(AB)          ;START BUILDING BLT POINTER
+       HRRI    C,(B)           ;TO ADDRESS
+       ADDI    D,(B)-1         ;SET D TO FINAL ADDRESS
+       BLT     C,(D)
+       JRST    FINIS
+
+;EXPLICIT VECTORS FOR THE UNIFORM CSE
+
+MFUNCTION EUVECTOR,SUBR
+
+       ENTRY
+       HLRE    A,AB            ;-NUM OF ARGS
+       MOVNS   A
+       ASH     A,-1            ;NEED HALF AS MANY WORDS
+       PUSH    TP,$TFIX
+       PUSH    TP,A
+       GETYP   A,(AB)          ;GET FIRST ARG
+       PUSHJ   P,NWORDT                ;SEE IF NEEDS EXTRA WORDS
+       SOJN    A,CANTUN
+       MCALL   1,UVECTOR               ;GET THE VECTOR
+
+       GETYP   C,(AB)          ;GET THE FIRST TYPE
+       MOVE    D,AB            ;COPY THE ARG POINTER
+       MOVE    E,B             ;COPY OF RESULT
+
+EUVLP: GETYP   0,(D)           ;GET A TYPE
+       CAIE    0,(C)           ;SAME?
+       JRST    WRNGUT          ;NO , LOSE
+       MOVE    0,1(D)          ;GET GOODIE
+       MOVEM   0,(E)           ;CLOBBER
+       ADD     D,[2,,2]        ;BUMP ARGS POINTER
+       AOBJN   E,EUVLP
+
+       HRLM    C,(E)           ;CLOBBER UNIFORM TYPE IN
+       JRST    FINIS
+
+WRNGUT:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TYPES-DIFFER-IN-UNIFORM-VECTOR
+       JRST    CALER1
+
+CANTUN:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE DATA-CANT-GO-IN-UNIFORM-VECTOR
+       JRST    CALER1
+
+\f
+; FUNCTION TO GROW A VECTOR
+
+MFUNCTION GROW,SUBR
+
+       ENTRY   3
+
+       MOVEI   D,0             ;STACK HACKING FLAG
+       HLRZ    A,(AB)          ;FIRST TYPE
+       PUSHJ   P,SAT           ;GET STORAGE TYPE
+       HLRZ    B,2(AB)         ;2ND ARG
+       CAIE    A,STPSTK        ;IS IT ASTACK
+       CAIN    A,SPSTK
+       AOJA    D,GRSTCK        ;YES, WIN
+       CAIE    A,SNWORD        ;UNIFORM VECTOR
+       CAIN    A,S2NWORD       ;OR GENERAL
+GRSTCK:        CAIE    B,TFIX          ;IS 2ND FIXED
+       JRST    WRONGT          ;COMPLAIN
+       HLRZ    B,4(AB)
+       CAIE    B,TFIX          ;3RD ARG
+       JRST    WRONGT          ;LOSE
+
+       MOVEI   E,1             ;UNIFORM/GENERAL FLAG
+       CAIE    A,SNWORD        ;SKIP IF UNIFORM
+       CAIN    A,SPSTK         ;DONT SKIP IF UNIFORM PDL
+       MOVEI   E,0
+
+       HRRZ    B,1(AB)         ;POINT TO START
+       HLRE    A,1(AB)         ;GET -LENGTH
+       SUB     B,A             ;POINT TO DOPE WORD
+       SKIPE   D               ;SKIP IF NOT STACK
+       ADDI    B,PDLBUF        ;FUDGE FOR PDL
+       HLLZS   (B)             ;ZERO OUT GROWTH SPECS
+       SKIPN   A,3(AB)         ;ANY TOP GROWTH?
+       JRST    GROW1           ;NO, LOOK FOR BOTTOM GROWTH
+       ASH     A,(E)           ;MULT BY 2 IF GENERAL
+       ADDI    A,77            ;ROUND TO NEAREST BLOCK
+       ANDCMI  A,77            ;CLEAR LOW ORDER BITS
+       ASH     A,9-6           ;DIVIDE BY 100 AND SHIFT TO POSTION
+       TRZE    A,400000        ;CONVERT TO SIGN MAGNITUDE
+       MOVNS   A
+       TLNE    A,-1            ;SKIP IF NOT TOO BIG
+       JRST    GTOBIG          ;ERROR
+GROW1: SKIPN   C,5(AB)         ;CHECK LOW GROWTH
+       JRST    GROW4           ;NONE, SKIP
+       ASH     C,(E)           ;GENRAL FUDGE
+       ADDI    C,77            ;ROUND
+       ANDCMI  C,77            ;FUDGE FOR VALUE RETURN
+       PUSH    P,C             ;AND SAVE
+       ASH     C,-6            ;DIVIDE BY 100
+       TRZE    C,400           ;CONVERT TO SIGN MAGNITUDE
+       MOVNS   C
+       TDNE    C,[-1,,777000]  ;CHECK FOR OVERFLOW
+       JRST    GTOBIG
+GROW2: HLRZ    E,1(B)          ;GET TOTAL LENGTH OF VECTOR
+       SUBI    E,2             ;FUDGE FOR DOPE WORDS
+       MOVNS   E
+       HRLI    E,-1(E)         ;TO BOTH HALVES
+       ADDI    E,(B)           ;POINTS TO TOP
+       SKIPE   D               ;STACK?
+       ADD     E,[PDLBUF,,0]   ;YES, FUDGE LENGTH
+       SKIPL   D,(P)           ;SHRINKAGE?
+       JRST    GROW3           ;NO, CONTINUE
+       MOVNS   D               ;PLUSIFY
+       HRLI    D,(D)           ;TO BOTH HALVES
+       ADD     E,D             ;POINT TO NEW LOW ADDR
+GROW3: IORI    A,(C)           ;OR TOGETHER
+       HRRM    A,(B)           ;DEPOSIT INTO DOPEWORD
+       PUSH    TP,(AB)         ;PUSH TYPE
+       PUSH    TP,E            ;AND VALUE
+       SKIPE   A               ;DON'T GC FOR NOTHING
+       PUSHJ   P,AGC
+       POP     P,C             ;RESTORE GROWTH
+       HRLI    C,(C)
+       POP     TP,B            ;GET VECTOR POINTER
+       SUB     B,C             ;POINT TO NEW TOP
+       POP     TP,A
+       JRST    FINIS
+
+GTOBIG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ATTEMPT-TO-GROW-VECTOR-TOO-MUCH
+       JRST    CALER1
+GROW4: PUSH    P,[0]           ;0 BOTTOM GROWTH
+       JRST    GROW2
+\f
+; SUBROUTINE TO BUILD CHARACTER STRING GOODIES
+
+MFUNCTION STRING,SUBR
+
+       ENTRY
+
+       MOVE    B,AB            ;COPY ARG POINTER
+       MOVEI   C,0             ;INITIALIZE COUNTER
+       PUSH    TP,$TAB         ;SAVE A COPY
+       PUSH    TP,B
+       JUMPGE  B,MAKSTR                ;ZERO LENGTH
+
+STRIN2:        GETYP   D,(B)           ;GET TYPE CODE
+       CAIN    D,TCHRS         ;SINGLE CHARACTER?
+       AOJA    C,STRIN1
+       CAIE    D,TCHSTR        ;OR STRING
+       JRST    WRONGT          ;NEITHER
+
+       MOVEM   B,(TP)          ;SAVE CURRENT POINTER
+       PUSH    TP,(B)
+       PUSH    TP,1(B)
+       PUSH    P,C             ;SAVE CURRENT COUNT
+       MCALL   1,LENGTH                ;FIND THE LENGTH
+       POP     P,C
+       ADDI    C,(B)           ;BUMP COUNT
+       MOVE    B,(TP)          ;RESTORE
+
+STRIN1:        ADD     B,[2,,2]
+       JUMPL   B,STRIN2
+
+; NOW GET THE NECESSARY VECTOR
+
+MAKSTR:        PUSH    TP,$TFIX
+       ADDI    C,4             ;COMPUTE NEEDED WORDS
+       IDIVI   C,5
+       PUSH    TP,C
+       MCALL   1,UVECTOR               ;GET THE VECTOR
+
+       HRLI    B,440700                ;CONVERT B TO A BYTE POINTER
+       SKIPL   C,AB            ;ANY ARGS?
+       JRST    DONEC
+
+NXTRG1:        GETYP   D,(C)           ;GET AN ARG
+       CAIE    D,TCHRS
+       JRST    TRYSTR
+       LDB     D,[350700,,1(C)]        ;GET IT
+       IDPB    D,B             ;AND DEPOSIT IT
+       JRST    NXTARG
+
+TRYSTR:        MOVE    E,1(C)          ;GET BYTER
+       HRRZ    0,(C)           ;AND DOPE WORD POINTER
+       LDB     D,E             ;GET 1ST CHAR
+NXTCHR:        CAIG    0,1(E)          ;STILL WINNING?
+       JRST    NXTARG          ;NO, GET NEXT ARG
+       JUMPE   D,NXTARG        ;HIT 0, QUIT
+       IDPB    D,B             ;INSERT
+       ILDB    D,E             ;AND GET NEXT
+       JRST    NXTCHR
+
+NXTARG:        ADD     C,[2,,2]        ;BUMP ARG POINTER
+       JUMPL   C,NXTRG1
+       ADDI    B,1
+
+DONEC: MOVSI   C,TCHRS
+       HLLM    C,(B)           ;AND CLOBBER AWAY
+       HLRZ    C,1(B)          ;GET LENGTH BACK
+       MOVEI   A,1(B)          ;POINT TO DOPE WORD
+       HRLI    A,TCHSTR
+       SUBI    B,-2(C)
+       HRLI    B,350700                ;MAKE A BYTE POINTER
+       JRST    FINIS
+\f
+AGC":
+;SET FLAG FOR INTERRUPT HANDLER
+
+       SETOM   GCFLG
+
+;SAVE AC'S
+       IRP     AC,,[0,A,B,C,D,E,P,SP,TP,TB,AB,TVP,PP,PVP]
+       MOVEM   AC,AC!STO"+1(PVP)
+       TERMIN
+
+;SET UP E TO POINT TO TYPE VECTOR
+       HLRZ    E,TYPVEC(TVP)
+       CAIE    E,TVEC
+       JRST    AGCE1
+       HRRZ    TYPNT,TYPVEC+1(TVP)
+       HRLI    TYPNT,B
+
+;DECIDE WHETHER TO SWITCH TO GC PDL
+
+       MOVE    D,P             ;SAVE TRUE P FOR FRAME MUNGING
+       MOVEI   A,(P)           ;POINNT TO PDL
+       HRRZ    B,GCPDL         ;POINT TO BASE OF GC PDL
+       CAIG    A,(B)           ;SKIP IF MUST CHANGE
+       JRST    CHPDL
+       HLRE    C,GCPDL         ;-LENGTH OF GC'S PDL
+       SUB     B,C             ;POINT TO END OF GC'S PDL
+       CAILE   A,(B)           ;SKIP IF WITHIN GCPDL
+CHPDL: MOVE    P,GCPDL         ;GET GC'S PDL
+
+;FENCE POST PDLS AND CHECK IF ANY SHOULD BE SHRUNK
+
+       MOVE    A,TP            ;THEN TEMPORARY PDL
+       PUSHJ   P,PDLCHK
+       MOVE    A,PP            ;GET PLANNER PDL
+       PUSHJ   P,PDLCHK        ;AND CHECK IT FOR GROWTH
+       MOVE    A,PSTO+1(PVP)   ;AND UNMARKED P STACK
+       CAMN    P,GCPDL         ;DID PDLS CHANGE
+       PUSHJ   P,PDLCHP
+\f;MARK PHASE: MARK ALL LISTS AND VECTORS
+;POINTED TO WITH ONE BIT IN SIGN BIT
+;START AT TRANSFER VECTOR
+
+       SETZB   LPVP,VECNUM     ;CLEAR NUMBER OF VECTOR WORDS
+       SETZB   LINF,PARNUM     ;CLEAR NUMBER OF PAIRS
+       MOVSI   D,400000        ;SIGN BIT FOR MARKING
+       MOVE    A,ASOVEC+1(TVP) ;MARK ASSOC. VECTOR NOW
+       HLRE    B,A
+       SUBI    A,(B)           ;POINT TO DOPE WORD
+       IORM    D,1(A)          ;AND MARK
+       MOVE    A,PVP           ;START AT PROCESS VECTOR
+       MOVEI   B,TPVP          ;IT IS A PROCESS VECTOR
+       PUSHJ   P,MARK          ;AND MARK THIS VECTOR
+
+; ASSOCIATION FLUSHING PHASE
+
+       MOVE    A,ASOVEC+1(TVP) ;GET POINTER TO VECTOR
+       PUSHJ   P,ASOMRK        ;MARK AND FLUSH
+
+;OPTIONAL RETIMING PHASE
+;THIS HAS BEEN FLUSHED BECAUSE OF PLANNER
+       REPEAT 0,[
+       SKIPE   A,TIMOUT        ;ANY TIME OVERFLOWS
+       PUSHJ   P,RETIME        ;YES, RE-CALIBRATE THEM
+]
+;CORE ADJUSTMENT PHASE
+       SETZM   CORSET          ;CLEAR LATER CORE SETTING
+       PUSHJ   P,CORADJ        ;AND MAKE CORE ADJUSTMENTS
+
+;RELOCATION ESTABLISHMENT PHASE
+;1 -- IN PAIR SPACE, SWAP LOW GARBAGE WITH HIGHER NON GARBAGE
+       MOVE    A,PARBOT"       ;ONE POINTER TO BOTTOM OF PAIR SPACE
+       MOVE    B,PARTOP"       ;AND ANOTHER TO TOP.
+       PUSHJ   P,PARREL        ;AND ESTABLISH THE PAIR RELOCATION
+       MOVEM   B,PARTOP        ;ESTABLISH NEW TOP OF PAIRS HERE
+
+;2 -- IN VECTOR SPACE, ESTABLISH POINTERS TO TOP OF CORE
+       MOVE    A,VECTOP"       ;START AT TOP OF VECTOR SPACE
+       MOVE    B,VECNEW"       ;AND SET TO INITIAL OFFSET
+       SUBI    A,1             ;POINT TO DOPE WORDS
+       PUSHJ   P,VECREL        ;AND ESTABLISH RELOCATION FOR VECTORS
+       MOVEM   B,VECNEW        ;SAVE FINAL OFFSET
+
+\f;POINTER UPDATE PHASE
+;1 -- UPDATE ALL PAIR POINTERS
+       MOVE    A,PARBOT        ;START AT BOTTOM OF PAIR SPACE
+       PUSHJ   P,PARUPD        ;AND UPDATE ALL PAIR POINTERS
+
+;2 -- UPDATE ALL VECTORS
+       MOVE    A,VECTOP        ;START AT TOP OF VECTOR SPACE
+       PUSHJ   P,VECUPD        ;AND UPDATE THE POINTERS
+
+;3 -- UPDATE THE PVP AC
+       MOVEI   A,PVP-1         ;SET LOC TO POINT TO PVP
+       MOVE    C,PVP           ;GET THE DATUM
+       PUSHJ   P,NWRDUP        ;AND UPDATE THIS VALUE
+;4 -- UPDATE THE MAIN PROCESS POINTER
+       MOVEI   A,MAINPR-1      ;POINT TO MAIN PROCESS POINTER
+       MOVE    C,MAINPR        ;GET CONTENTS IN C
+       PUSHJ   P,NWRDUP        ;AND UPDATE IT
+;DATA MOVEMMENT ANDCLEANUP PHASE
+
+;1 -- ADJUST FOR SHRINKING VECTORS
+       MOVE    A,VECTOP        ;VECTOR SHRINKING PHASE
+       PUSHJ   P,VECSH         ;GO SHRINK ANY SHRINKERS
+
+;2 -- MOVE VECTORS (AND LIST ELEMENTS)
+       MOVE    A,VECTOP        ;START AT TOP OF VECTOR SPACE
+       PUSHJ   P,VECMOVE       ;AND MOVE THE VECTORS
+       MOVE    A,VECNEW        ;GET FINAL CHANGE TO VECBOT
+       ADDM    A,VECBOT        ;OFFSET VECBOT TO ITS NEW PLACE
+       MOVE    A,CORTOP        ;GET NEW VALUE FOR TOP OF VECTOR SPACE
+       MOVEM   A,VECTOP        ;AND UPDATE VECTOP
+
+;3 -- CLEANUP VECTORS (NOTE A CONTAINS NEW VECTOP)
+
+       PUSHJ   P,VECZER        ;
+
+;GARBAGE ZEROING PHASE
+GARZER:        MOVE    A,PARTOP        ;FIRST WORD OF GARBAGE IS AFTER PAIR SPACE
+       HRLS    A               ;GET FIRST ADDRESS IN LEFT HALF
+       MOVE    B,VECBOT        ;LAST ADDRESS OF GARBAGE + 1
+       CLEARM  (A)             ;ZERO   THE FIRST WORD
+       ADDI    A,1             ;MAKE A A BLT POINTER
+       BLT     A,-1(B)         ;AND COPY ZEROES INTO REST OF AREA
+
+;FINAL CORE ADJUSTMENT
+       SKIPE   A,CORSET        ;IFLESS CORE NEEDED
+       PUSHJ   P,CORADL        ;GIVE SOME AWAY.
+
+;NOW REHASH THE ASSOCIATIONS BASED ON NEW VALUES
+
+       PUSHJ   P,REHASH
+
+;RESTORE AC'S
+       IRP     AC,,[0,A,B,C,D,E,P,SP,TP,TB,AB,PP,PVP,TVP]
+       MOVE    AC,AC!STO+1(PVP)
+       TERMIN
+
+       SETZM   PARNEW          ;CLEAR FOR NEXT AGC CALL
+       SETZM   GETNUM          ;ALSO CLEAR THIS
+       SETZM   GCFLG
+
+
+CPOPJ: POPJ    P,
+
+
+AGCE1: MOVEI   B,[ASCIZ /TYPVEC IS NOT OF TYPE VECTOR
+/]
+TYPSTP:        PUSHJ   P,MSGTYP"       ;TYPE OUT A HOPELESSMESSAGE
+       .VALUE          ;AND GIVE UP
+
+
+\f
+; SUBROUTINE TO CHECK SIZE OF PDLS AND DO FENCEPOSTING
+
+PDLCHK:        JUMPGE  A,CPOPJ
+       HLRE    B,A             ;GET NEGATIVE COUNT
+       MOVE    C,A             ;SAVE A COPY OF PDL POINTER
+       SUBI    A,-1(B)         ;LOCATE DOPE WORD PAIR
+       HRRZS   A               ; ISOLATE POINTER
+       CAME    A,TPGROW        ;GROWING?
+       CAMN    A,PPGROW                ;OR PLANNER PDL
+       JRST    .+2
+       ADDI    A,PDLBUF        ;NO, POINT TO REAL DOPE WORD
+       HLRZ    D,(A)           ;GET COUNT FROM DOPE WORD
+       MOVNS   B               ;GET POSITIVE AMOUNT LEFT
+       SUBI    D,2(B)          ; PDL FULL?
+       JUMPE   D,NOFENC        ;YES NO FENCE POSTING
+       SETOM   1(C)            ;CLOBBER TOP WORD
+       SOJE    D,NOFENC        ;STILL MORE?
+       MOVSI   D,1(C)          ;YES, SET UP TO BLT FENCE POSTS
+       HRRI    D,2(C)
+       BLT     D,-2(A)         ;FENCE POST ALL EXCEPT DOPE WORDS
+
+
+NOFENC:        CAIG    B,TPMAX         ;NOW CHECK SIZE
+       CAIG    B,TPMIN
+       JRST    MUNGTP          ;TOO BIG OR TOO SMALL
+       POPJ    P,
+
+MUNGTP:        SUBI    B,TPGOOD        ;FIND DELTA TP
+MUNG3: MOVE    C,-1(A)         ;IS GROWTH ALREADY SPECIFIED
+       TRNE    C,777000        ;SKIP IF NOT
+       POPJ    P,              ;ASSUME GROWTH GIVEN WILL WIN
+
+       ASH     B,-6            ;CONVERT TO NUMBER OF BLOCKS
+       JUMPLE  B,MUNGT1
+       TRO     B,400           ;TURN ON SHRINK BIT
+       JRST    MUNGT2
+MUNGT1:        MOVMS   B
+       ANDI    B,377
+MUNGT2:        DPB     B,[111100,,-1(A)]       ;STORE IN DOPE WORD
+       POPJ    P,
+
+; CHECK UNMARKED STACK (NO NEED TO FENCE POST)
+
+PDLCHP:        HLRE    B,A             ;-LENGTH TO B
+       SUBI    A,-1(B)         ;POINT TO DOPE WORD
+       HRRZS   A               ;ISOLATE POINTER
+       CAME    A,PGROW         ;GROWING?
+       ADDI    A,PDLBUF        ;NO, POINT TO REAL DOPE WORD
+       MOVMS   B               ;PLUS LENGTH
+
+       CAIG    B,PMAX          ;TOO BIG?
+       CAIG    B,PMIN          ;OR TOO LITTLE
+       JRST    .+2             ;YES, MUNG IT
+       POPJ    P,
+       SUBI    B,PGOOD
+       JRST    MUNG3
+
+\f
+;GENERAL MARK SUBROUTINE.  CALLED TO MARK ALL THINGS
+; A/ GOODIE TO MARK FROM
+; B/ TYPE OF A (IN RH)
+; C/ TYPE,DATUM PAIR POINTER
+
+MARK2: HLRZ    B,(C)           ;GET TYPE
+MARK1: MOVE    A,1(C)          ;GET GOODIE
+MARK:  JUMPE   A,CPOPJ         ; NEVER MARK 0
+       PUSH    P,A             ;SAVE GOODIE
+       HRLM    C,-1(P)         ;AND POINTER TO IT
+       LSH     B,1             ;TIMES 2 TO GET SAT
+       HRRZ    B,@TYPNT        ;GET SAT
+       JRST    @MKTBS(B)       ;AND GO MARK
+
+; DISPATCH TABLE FOR MARK PHASE ("SETZ'D" ENTRIES MUST BE DEFERRED)
+
+DISTBS MKTBS,GCRET,[[S2WORD,PAIRMK],[S2DEFR,DEFMK],[SNWORD,VECTMK]
+[STPSTK,TPMK],[SARGS,<SETZ ARGMK>],[S2NWORD,VECTMK],[SPSTK,TPMK]
+[SFRAME,<SETZ FRMK>],[SBYTE,<SETZ BYTMK>],[SATOM,ATOMK],[SPVP,VECTMK]
+[SCHSTR,<SETZ BYTMK>],[SASOC,ASMRK],[SINFO,INFMK]]
+
+
+;HERE TO MARK THAT WHICH IS POINTED TO BY A DEFERRED POINTER
+
+DEFMK: TLOA    TYPNT,400000    ;USE SIGN BIT AS FLAG
+
+;HERE TO MARK LIST ELEMENTS
+
+PAIRMK:        TLZ     TYPNT,400000    ;TURN OF DEFER BIT
+       MOVEI   C,(A)           ;POINT TO LIST
+PAIRM1:        CAMGE   C,PARTOP        ;CHECK FOR BEING IN BOUNDS
+       CAMGE   C,PARBOT
+       JRST    BDPAIR          ;OUT OF BOUNDS,COMPLAIN
+       SKIPGE  B,(C)           ;SKIP IF NOT MARKED
+       JRST    GCRET           ;ALREADY MARKED, RETURN
+       IORM    D,(C)           ;MARK IT
+       AOS     PARNUM
+       HLRZS   B               ;TYPE TO RH OF B
+       MOVE    A,1(C)          ;DATUM TO A
+       JUMPL   TYPNT,DEFDO     ;GO HANDLE DEFERRED POINTER
+       PUSHJ   P,MARK          ;MARK THIS DATUM
+       HRRZ    C,(C)           ;GET CDR OF LIST
+       JUMPN   C,PAIRM1        ;IF NOT NIL, MARK IT
+
+GCRET: TLZ     TYPNT,400000    ;FOR PAIRMKS BENEFIT
+       HLRZ    C,-1(P)         ;RESTORE C
+       POP     P,A
+       POPJ    P,              ;AND RETURN TO CALLER
+
+;HERE TO SQUAWK WHEN A PAIR POINTER IS BAD
+
+BDPAIR:        MOVEI   B,[ASCIZ /AGC -- MARKED PAIR POINTS OUTSIDE PAIR SPACE
+/]
+
+       PUSHJ   P,MSGTYP
+       .VALUE  0
+
+;HERE TO MARK DEFERRED POINTER
+
+DEFDO: PUSHJ   P,MARK          ;MARK THE DATUM
+       JRST    GCRET           ;AND RETURN
+
+\f
+; VECTOR AND TP MARKER, SIGN OF TYPNT IS SET BASED ON WHICH ONE
+
+TPMK:  TLOA    TYPNT,400000    ;SET TP MARK FLAG
+VECTMK:        TLZ     TYPNT,400000
+       MOVEI   E,(A)           ;SAVE A POINTER TO THE VECTOR
+       HLRE    B,A             ;GET -LNTH
+       SUB     A,B             ;LOCATE DOPE WORD
+       MOVEI   A,1(A)          ;ZERO LH AND POINT TO 2ND DOPE WORD
+       CAMGE   A,VECTOP        ;CHECK BOUNDS
+       CAMGE   A,VECBOT
+       JRST    VECTB1          ;LOSE, COMPLAIN
+
+       JUMPGE  TYPNT,NOBUFR    ;IF A VECTOR, NO BUFFER CHECK
+       CAMN    A,PPGROW        ;CHECK PLANNER PDL
+       JRST    NOBUFR
+       CAME    A,PGROW         ;IS THIS THE BLOWN P
+       CAMN    A,TPGROW        ;IS THIS THE GROWING PDL
+       JRST    NOBUFR          ;YES, DONT ADD BUFFER
+       ADDI    A,PDLBUF        ;POINT TO REAL DOPE WORD
+       MOVSI   0,-PDLBUF       ;ALSO FIX UP POINTER
+       ADDM    0,1(C)
+
+NOBUFR:        HLRZ    B,(A)           ;GET LENGTH FROM DOPE WORD
+       ANDI    B,377777        ;CLOBBER POSSIBLE MARK BIT
+       MOVEI   F,(A)           ;SAVE A POINTER TO DOPE WORD
+       SUBI    F,1(B)          ;F POINTS TO START OF VECTOR
+       HRRZ    0,-1(A)         ;SEE IF GROWTH SPECIFIED
+       JUMPE   0,NOCHNG        ;NONE, JUST CHECK CURRENT SIZES
+
+       LDB     B,[001100,,0]   ;GET GROWTH FACTOR
+       TRZE    B,400           ;KILL SIGN BIT AND SKIP IF +
+       MOVNS   B               ;NEGATE
+       ASH     B,6             ;CONVERT TO NUMBER OF WORDS
+       SUB     F,B             ;BOTTOM IS LOWER IN CORE
+       LDB     0,[111100,,0]   ;GET TOP GROWTH
+       TRZE    0,400           ;HACK SIGN BIT
+       MOVNS   0
+       ASH     0,6             ;CONVERT TO WORDS
+       ADD     B,0             ;TOTAL GROWTH TO B
+NOCHNG:
+VECOK: HLRE    E,(A)           ;GET LENGTH AND MARKING
+       MOVEI   F,(E)           ;SAVE A COPY
+       ADD     F,B             ;ADD GROWTH
+       SUBI    E,2             ;- DOPE WORD LENGTH
+       IORM    D,(A)           ;MAKE SURE NOW MARKED
+       JUMPLE  E,GCRET         ;ALREADY MARKED OR ZERO LENGTH, LEAVE
+
+       SKIPGE  B,-1(A)         ;SKIP IF UNIFORM
+       TLNE    B,377777        ;SKIP IF NOT SPECIAL
+       JUMPGE  TYPNT,NOTGEN    ;JUMP IF NOT A GENERAL VECTOR
+
+GENRAL:        HLRZ    0,B             ;CHECK FOR PSTACK
+       JUMPE   0,NOTGEN        ;IT ISN'T GENERAL
+       SUBI    A,1(E)          ;POINT TO FIRST ELEMENT
+       ADDM    F,VECNUM        ;AND UPDATE VECNUM
+       MOVEI   C,(A)           ;POINT TO FIRST ELEMENT WITH C
+\f
+; LOOP TO MARK ELEMENTS IN A GENRAL VECTOR
+
+VECTM2:        HLRE    B,(C)           ;GET TYPE AND MARKING
+       JUMPL   B,GCRET         ;RETURN, (EITHER DOPE WORD OR FENCE POST)
+       MOVE    A,1(C)          ;DATUM TO A
+       CAIE    B,TENTS         ;IS THIS A SAVED FRAME?
+       CAIN    B,TENTRY        ;IS THIS A STACK FRAME
+       JRST    MFRAME          ;YES, MARK IT
+       CAIN    B,TPDLS         ;IGNORE SAVED PDL BLOCKS
+       JRST    IGBLK
+       CAIN    B,TBIND         ;OR A BINDING BLOCK
+       JRST    MBIND
+
+VECTM3:        PUSHJ   P,MARK          ;MARK DATUM
+       ADDI    C,2
+       JRST    VECTM2
+
+MFRAME:        HRROI   C,FRAMLN+SPSAV-1(C)     ;POINT TO SAVED SP
+       MOVEI   B,TSP
+       PUSHJ   P,MARK1         ;MARK THE GOODIE
+       HRROI   C,PSAV-SPSAV(C) ;POINT TO SAVED P
+       MOVEI   B,TPDL
+       PUSHJ   P,MARK1         ;AND MARK IT
+       HRROI   C,TPSAV-PSAV(C) ;POINT TO SAVED TP
+       MOVEI   B,TTP
+       PUSHJ   P,MARK1         ;MARK IT ALS
+       MOVEI   C,PPSAV-TPSAV(C)        ;POINT SAVED PP
+       MOVEI   B,TPP
+       PUSHJ   P,MARK1
+       MOVEI   C,-PPSAV+1(C)   ;POINT PAST THE FRAME
+       JRST    VECTM2          ;AND DO MORE MARKING
+
+
+MBIND: MOVEI   B,TATOM         ;FIRST MARK ATOM
+       JRST    VECTM3
+
+VECLOS:        JUMPL   C,CCRET         ;JUMP IF CAN'T MUNG TYPE
+       HLLZ    0,(C)           ;GET TYPE
+       MOVEI   B,TILLEG        ;GET ILLEGAL TYPE
+       HRLM    B,(C)
+       MOVEM   0,1(C)          ;AND STORE OLD TYPE AS VALUE
+       JRST    GCRET           ;RETURN WITHOUT MARKING VECTOR
+
+CCRET: CLEARM  1(C)            ;CLOBBER THE DATUM
+       JRST    GCRET
+
+
+IGBLK: HRRZ    B,(C)           ;SKIP TO END OF PP BLOCK
+       ADDI    C,3(B)
+       JRST    VECTM2\f;ARG POINTER-- MARK ITS INFO CELL AND STACK
+ARGMK: HRRZ    A,(C)           ;A POINTS TO INFO CELL
+       JRST    PAIRMK          ;MARK IT
+
+
+
+; MARK FRAME POINTERS
+
+FRMK:  SUBI    C,1             ;PREPARE TO MARK PROCESS VECTOR
+       HRRZ    A,1(C)          ;USE AS DATUM
+       SUBI    A,1             ;FUDGE FOR VECTMK
+       MOVEI   B,TPVP          ;IT IS A VECTRO
+       PUSHJ   P,MARK          ;MARK IT
+       JRST    GCRET
+
+; MARK BYTE POINTER
+
+BYTMK: HRRZ    A,(C)           ;POINT TO DOPE WD
+       SOJG    A,VECTMK        ;FUDGE DOPE WORD POINTER FOR VECTMK
+
+
+       MOVEI   B,[ASCIZ /AGC -- BYTE POINTER WITH ZERO DOPE WORD POINTER
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+
+\f
+; MARK ATOMS
+
+ATOMK: PUSHJ   P,GETLNT        ;GET LENGTH AND CHECK BOUNDS
+       MOVEI   C,(A)
+       HLRZ    B,(C)           ;GET TYPE
+       MOVE    A,1(C)          ;AND VALUE
+;******FUDGE UNTIL MIRE WINNAGE******
+
+       HRRZ    E,(C)           ;GOBBLE PROCESS ID
+       CAIN    B,TUNBOUND      ;IF NOT UNBOUND
+       JRST    GCRET           ;IS UNVOUND, IGNORE
+       SKIPN   E               ;SKIP IF NOT GLOBAL PROCESS
+       MOVEI   B,TVEC          ;IS GLOBAL, MARK AS A VECTOR
+       PUSHJ   P,MARK          ;AND MARK IT
+       JRST    GCRET           ;AND LEAVE
+
+GETLNT:        HLRE    B,A             ;GET -LNTH
+       SUB     A,B             ;POINT TO 1ST DOPE WORD
+       MOVEI   A,1(A)          ;POINT TO 2ND DOPE WORD
+       CAMGE   A,VECTOP        ;CHECK BOUNDS
+       CAMGE   A,VECBOT
+       JRST    VECTB1          ;BAD VECTOR, COMPLAIN
+
+       HLRE    B,(A)           ;GET LENGTH AND MARKING
+       IORM    D,(A)           ;MAKE SURE MARKED
+       JUMPL   B,GCRET1        ;MARKED ALREADY, QUIT
+       SUBI    A,-1(B)         ;POINT TO TOP OF ATOM
+       ADDM    B,VECNUM        ;UPDATE VECNUM
+       POPJ    P,              ;AND RETURN
+
+GCRET1:        SUB     P,[1,,1]        ;FLUSH RETURN ADDRESS
+       JRST    GCRET
+
+; MARK NON-GENERAL VECTORS
+
+NOTGEN:        CAMN    B,[GENERAL+<SPVP,,0>]   ;PROCESS VECTOR?
+       JRST    GENRAL          ;YES, MARK AS A VECTOR
+       JUMPL   B,SPECLS        ; COMPLAIN IF A SPECIAL HACK
+       SUBI    A,1(E)          ;POINT TO TOP OF A UNIFORM VECTOR
+       ADDM    F,VECNUM        ;INCREASE VECNUM
+       HLRZS   B               ;ISOLATE TYPE
+       MOVE    F,B             ; AND COPY IT
+       LSH     B,1             ;FIND OUT WHERE IT WILL GO
+       HRRZ    B,@TYPNT        ;GET SAT IN B
+       MOVEI   C,@MKTBS(B)     ;POINT TO MARK SR
+       CAIN    C,GCRET         ;IF NOT A MARKED FROM GOODIE, IGNORE
+       JRST    GCRET
+       MOVEI   C,-1(A)         ;POINT 1 PRIOR TO VECTOR START
+       PUSH    P,E             ;SAVE NUMBER OF ELEMENTS
+       PUSH    P,F             ;AND UNIFORM TYPE
+
+UNLOOP:        MOVE    B,(P)           ;GET TYPE
+       MOVE    A,1(C)          ;AND GOODIE
+       TLO     C,400000        ;CAN'T MUNG TYPE
+       PUSHJ   P,MARK          ;MARK THIS ONE
+       SOSE    -1(P)           ;COUNT
+       AOJA    C,UNLOOP        ;IF MORE, DO NEXT
+
+       SUB     P,[2,,2]        ;REMOVE STACK CRAP
+       JRST    GCRET
+
+
+SPECLS:        MOVEI   B,[ASCIZ /AGC -- UNRECOGNIZED SPECIAL VECTOR
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+\f; MARK ASSOCIATION BLOCKS
+
+ASMRK: HRLI    A,-ASOLNT       ;LOOK LIKE A VECTOR POINTER
+       PUSHJ   P,GETLNT        ;GET LENGTH AND CHECK BOUNDS
+       GETYP   B,(A)           ;CHECK TYPE OF FIRST
+       CAIN    B,TTP
+       JRST    GCRET           ;THIS IS THE DUMMY
+       MOVEI   C,(A)           ;COPY POINTER
+       PUSHJ   P,MARK2         ;MARK ITEM CELL
+       ADDI    C,INDIC-ITEM    ;POINT TO INDICATOR
+       PUSHJ   P,MARK2
+       ADDI    C,VAL-INDIC
+       PUSHJ   P,MARK2
+       ADDI    C,NODPNT-VAL-1  ;POINT TO NODE CHAIN
+       HRRZ    A,1(C)          ;DOES IT EXIST
+       JUMPE   A,GCRET
+       MOVEI   B,TASOC
+       PUSHJ   P,MARK          ;AND MARK IT
+       JRST    GCRET
+
+
+
+;MARK INFO CELL
+INFMK: HLRZS   A               ;GENERATE AOBJN POINTER TO END OF STACK
+       JRST    VECTMK          ;GO MARK IT\f;HERE WHEN A VECTOR POINTER IS BAD
+
+VECTB1:        MOVEI   B,[ASCIZ /AGC -- VECTOR POINTS OUTSIDE VECTOR SPACE
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE  0
+
+
+\f
+; THIS PHASE REMOVES ANY UNWANTED ASSOCIATIONS ALSO PRESERVES DATA POINTED TO ONLY BY ASSOCIATIONS
+; RECEIVES POINTER TO ASSOCIATION VECTOR IN A
+
+ASOMRK:        SKIPN   C,(A)           ;DOES BUCKET CONTAIN ANYTHING
+       JRST    ASOM3           ;NO, ;IGNORE
+
+ASOM2: HRRE    0,ASOLNT+1(C)   ;CHECK FOR CIRCULARITY
+       AOJE    0,ASOM6         ;ALREADY MARKED, LOSE
+       HLLOS   ASOLNT+1(C)
+
+       SKIPGE  ASOLNT+1(C)     ;IS THIS ONE POINTED AT?
+       JRST    ASOM4           ;YES, GOODIES ALREADY MARKED
+       PUSHJ   P,MARKQ         ;SEE IF ITS ITEM IS MARKED
+       JRST    ASOFLS          ;NO, FLUSH THIS ASSOCIATION
+       MOVEI   E,MARKQ         ;POINT TO QUESTIONER
+       SKIPE   NODPNT(C)       ;SKIP IF NOT ON A CHAIN
+       MOVEI   E,MARK23        ;ON CHAIN, MARK THE INDICATOR
+       MOVEI   C,INDIC(C)              ;POINT TO INDICATOR
+       PUSHJ   P,(E)
+       JRST    ASOFL7          ;INDICATOR NOT MARKED
+       MOVEI   C,-INDIC(C)             ;POINT BACK TO START
+
+ASOM1: PUSH    P,C             ;ITEM IS MARKED, MARK INDIC AND VAL AND ASSOC
+       PUSH    P,A
+       ADDI    C,VAL   ;POINT TO VAL
+       PUSHJ   P,MARK2
+       IORM    D,ASOLNT+1-VAL(C)       ;MARK THE ASSOCIATION BLOCK
+       POP     P,A
+       POP     P,C
+
+ASOM4: MOVEI   E,(C)           ;INCASE NEED TO FLUSH CIRCULARITY
+       HRRZ    C,ASOLNT-1(C)   ;POINT TO NEXT IN CHAIN
+       JUMPN   C,ASOM2         ;GO MARKK IT
+
+
+ASOM3: AOBJN   A,ASOMRK        ;GO ONTO NEXT BUCKET
+       POPJ    P,              ;ALL MARKED, QUIT
+
+;HERE TO FLUSH AN ASSOCIATION
+
+ASOFLS:        HRRZ    B,ASOLNT-1(C)   ;GET FORWARD AND BACKWARD POINTERS
+       HLRZ    E,ASOLNT-1(C)
+       JUMPN   E,ASOFL1        ;JUMP IF PREV EXISTS
+       HRRZM   B,(A)           ;CLOBBER VECTOR ENTRY
+       JRST    .+2
+
+ASOFL1:        HRRM    B,ASOLNT-1(E)   ;CLOBBER PREVIOUS BLOCKKS NEXT
+       JUMPE   B,ASOM4         ;IF NEXT IS 0, DONE
+       HRLM    E,ASOLNT-1(B)   ;ELSE CLOBBER NEXT'S PREVIOUS
+       JRST    ASOM4
+
+ASOM6: HLLZS   (E)             ;FORCE CIRCULARITY AWAY
+       HRRZS   (C)             ;AND THE OTHERS PREV
+       JRST    ASOM3           ;AND FINISH THIS BUCKET
+
+MARK23:        PUSH    P,A
+       PUSHJ   P,MARK2 ;MARK IT
+       POP     P,A             ;RESTORE A
+       JRST    MKD             ;MUST SKIP
+
+ASOFL7:        MOVEI   C,ITEM-INDIC(C) ;RESET C
+       JRST    ASOFLS          ;AND FLUSH
+\f
+;SUBROUTINE TO SEE IF A GOODIE IS MARKED
+;RECEIVES POINTER IN C
+;SKIPS IF MARKED NOT OTHERWISE
+
+MARKQ: MOVE    E,1(C)          ;DATUM TO C
+       HLRZ    B,(C)           ;TYPE TO B
+       LSH     B,1
+       HRRZ    B,@TYPNT        ;GOBBLE SAT
+       JRST    @MQTBS(B)       ;DISPATCH
+
+
+DISTBS MQTBS,MKD,[[S2WORD,PAIRMQ],[S2DEFR,PAIRMQ],[SNWORD,VECMQ],[S2NWORD,VECMQ]
+[STPSTK,VECMQ],[SARGS,ARGMQ],[SPSTK,VECMQ],[SFRAME,FRMQ],[SBYTE,BYTMK]
+[SATOM,VECMQ],[SPVP,VECMQ],[SCHSTR,BYTMQ]]
+
+PAIRMQ:        SKIPGE  (E)             ;SKIP IF NOT MARKED
+MKD:   AOS     (P)
+       POPJ    P,
+
+BYTMQ: HRRZ    E,(C)           ;GET DOPE WORD POINTER
+       SOJA    E,VECMQ1        ;TREAT LIKE VECTOR
+
+ARGMQ: HLRE    F,E             ;CHECK AM ARG POINTER
+       SUB     E,F             ;POINT TO END OF ARG BLOCK
+       HLRZ    B,(E)           ;GET TYPE
+       CAIN    B,TENTRY        ;IS IT AN ENTRY
+       MOVEI   E,FRAMLN+1(E)   ;MAKE INTO FRAME POINTER
+       CAIN    B,TTB           ;IS IT A FRAME POINTER
+       HRRZ    E,1(E)          ;PICK IT UP
+
+FRMQ:  MOVE    E,TPSAV(E)      ;PICK UP A STACK POINTER
+
+VECMQ: HLRE    F,E             ;GET LENGTH
+       SUB     E,F             ;POINT TO DOPE WORDS
+
+VECMQ1:        SKIPGE  1(E)            ;SKIP IF NOT MARKED
+       AOS     (P)             ;MARKED, CAUSE SKIP RETURN
+       POPJ    P,
+
+
+\f
+
+
+;RETIME PHASE -- CALLED IFF A FRAME TIME HAS OVERFLOWED
+;RECEIVES POINTER TO STACK TO BE RECALIBRATED IN A
+;LEAVES HIGHEST TIME IN TIMOUT
+
+RETIME:        HLRE    B,A             ;GET LENGTH IN B
+       SUB     A,B             ;COMPUTE DOPE WORD LOCATION
+       MOVEI   A,1(A)          ;POINT TO 2D DOPE WORD AND CLEAR LH
+       CAME    A,TPGROW        ;IS THIS ONE BLOWN?
+       ADDI    A,PDLBUF        ;NO, POINT TO DOPE WORD
+       LDB     B,[222100,,(A)] ;GET LENGTH FIELD (IGNOREING MARK BIT
+       SUBI    A,-1(B)         ;POINT TO PDLS BASE
+       MOVEI   C,1             ;INITIALIZE NEW TIMES
+
+RETIM1:        SKIPGE  B,(A)           ;IF <0, HIT DOPE WORD OR FENCE POST
+       JRST    RETIM3
+       HLRZS   B               ;ISOLATE TYPE
+       CAIE    B,TENTRY        ;FRAME START?
+       AOJA    A,RETIM2        ;NO, TRY BINDING
+       HRLM    C,FRAMLN+OTBSAV(A)      ;STORE NEW TIME
+       ADDI    A,FRAMLN        ;POINT TO NEXT ELEMENT
+       AOJA    C,RETIM1        ;BUMP TIME AND MOVE ON
+
+RETIM2:        CAIN    B,TBIND         ;BINDING?
+       HRRM    C,3(A)          ;YES, STORE CURRENT TIME
+       AOJA    A,RETIM1        ;AND GO ON
+
+RETIM3:        MOVEM   C,TIMOUT        ;SAVE TIME
+       POPJ    P,              ;RETURN
+
+\f;CORE ADJUSTMENT PHASE -- SETS TOP OF CORE
+;AND TOP OF VECTOR SPACE TO SIZE NEEDED FOR SUFFICIENT FREE SPACE TO BE ADDED TO
+;ALLOW FOR "EFFICIENT" PROCESSING
+
+CORADJ:        .SUSET  [.RMEMT,,CORTOP]        ;SET CORTOP FROM SYSTEM
+       MOVE    A,PARBOT        ;GET ADDRESS OF BOTTOM OF MOVABLE CORE
+       ADD     A,PARNEW        ;AND ADDJUST TO WHERE IT WILL BE
+       ADD     A,PARNUM        ;ADD NUMBER OF PAIRS
+       ADD     A,PARNUM        ;TWICE TO GET TOP OF PAIR SPACE.
+       ADD     A,VECNUM        ;ADD NUMBER OF VECTOR WORDS
+       ADD     A,GETNUM        ;AND NUMBER OF WORDS TO BE GOTTEN THIS TIME
+       ADD     A,FREMIN        ;AND NUMBER OF FREE WORDS MINIMUM
+       SUB     A,CORTOP        ;LESS CURRENT TOP OF CORE
+       JUMPG   A,CORAD2        ;IF GREATER THAN ZERO, MORE CORE NEEDED
+       ADD     A,FREDIF        ;ADD IN DIFFERENCE BETWEEEN FREE AND GOT
+       ADDI    A,1777          ;ROUND UP TO NEXT BLOCK
+       ANDCMI  A,1777          ;AND DOWN TO A BLOCK BOUNDARY
+       JUMPGE  A,CORAD1        ;IF POSITIVE, NO CORE ADJUSTMENT NEEDED
+       ADDB    A,CORTOP        ;CALCULATE NEG TOP OF CORE
+       ASH     A,-10.          ;CONVERT TO BLOCKS
+       MOVEM   A,CORSET        ;AND SET NUMBER OF BLOCKS
+CORAD1:        MOVE    A,CORTOP        ;CALCU;ATE NEW TOP OF CORE
+       SUB     A,VECTOP        ;FIND OFFSET FROM CURRENT VECTOR TOP
+       MOVEM   A,VECNEW        ;AND SAVE AS NEW HOME OF VECTORS
+       POPJ    P,
+
+\f;HERE IF MORE CORE NEEDED, NO OF WDS IN A
+
+CORAD2:        ADD     A,CORTOP        ;FIND TOP OF CORE
+       ADDI    A,1777          ;AND ROUND UPWARDS
+       ASH     A,-10.          ;AND CONVERT TO NUMBER OF BLOCKS
+       CAMLE   A,SYSMAX        ;COMPARE TO MAXIMUM ALLOWED
+       PUSHJ   P,CORAD3
+       .CORE   (A)             ;ASK OFR THE NEW SIZE
+       PUSHJ   P,CORAD4        ;FAILURE, GO COMPLAIN
+       JRST    CORADJ          ;OK TRY AGAIN
+
+
+CORAD3:        SKIPA   B,[[ASCIZ /ATTEMPT TO EXPAND PAST MUDDLE LIMIT/]]
+CORAD4:        MOVEI   B,[ASCIZ /NO CORE AVAILABLE/]
+       PUSH    P,A             ;SAVE AMOUNT ASKED FOR
+       PUSHJ   P,MSGTYP
+       MOVEI   B,[ASCIZ /PROCEED?/]
+       PUSHJ   P,MSGTYP
+       PUSHJ   P,TYI"
+       CAIN    A,"Y
+       JRST    .+2
+       .VALUE
+       POP     P,A             ;RESTORE AMOUNT
+       POPJ    P,              ;AND GO BACK
+
+
+CORADL:        .CORE   (A)             ;SET TO NEW CORE VALUE
+       .VALUE
+       POPJ    P,
+\f
+;PARREL -- PAIR RELOCATION ESTABLISMENT
+;ESTABLISH PAIR RELOCATION. CALLED WITH
+;BOTTOM IN AC A, AND TOP IN AC B.
+
+PARRE0:        SUBI    B,2             ;MOVE POINTER BACK
+       IORM    D,(B)           ;MARK THIS PAIR AS JUNK
+PARREL:        CAIG    B,(A)           ;HAVE THE POINTERS MET?
+       POPJ    P,              ;YES -- RETURN WITH NEW PARTOP IN B
+       SKIPL   C,-2(B)         ;MARKED PAIR ON BOTTOM?
+       JRST    PARRE0          ;NO -- MOVE TOWARD BOTTOM
+PARRE1:        SKIPGE  (A)             ;JUNK ON BOTTOM?
+       JRST    PARRE2          ;NO -- MOVE FORWARD
+       MOVEM   C,(A)           ;STORE PAIR IN NEW LOCATION
+       MOVE    C,-1(B)         ;GET DATUM
+       MOVEM   C,1(A)          ;AND STORE IN NEW HOME
+       HRROM   A,-2(B)         ;SET "BROKEN HEART" TO NEW HOME
+       JRST    PARRE0          ;AND CONTINUE
+PARRE2:        ANDCAM  D,(A)           ;UNMARK PAIR
+       ADDI    A,2             ;GO ON TO NEXT PAIR
+       CAIG    B,(A)           ;TEST TO SEE IF POINTERS MET
+       POPJ    P,              ;YES -- DONE
+       JRST    PARRE1          ;KEEP LOOKING FORWARD
+
+\f;VECTOR RELOCATE --GETS VECTOP IN A
+;AND VECNEW IN B
+;FILLS IN RELOCATION FIELDS OF MARKED VECTORS
+;AND REUTRNS FINAL VECNEW IN B
+
+VECREL:        CAMG    A,VECBOT        ;PROCESSED TO BOTTOM OF VECTOR SPACE?
+       POPJ    P,              ;YES, RETURN
+       HLRE    C,(A)           ;GET COUNT FROM DOPE WD, EXTEND MARK BIT
+       JUMPL   C,VECRE1        ;IF MARKED GO PROCESS
+       HLLZS   (A)             ;CLEAR RELOC FIELD
+       ADDI    B,(C)           ;INCREMENT OFFSET
+       SUBI    A,(C)           ;MOVE ON TO NEXT VECTOR
+       SOJG    C,VECREL        ;AND KEEP SCANNING
+       JSP     D,VCMLOS        ;LOSER, LEAVE TRACKS AS TO WHO LOST
+
+VECRE1:        HRRZ    E,-1(A)         ;GOBBLE THE GROWTH FILEDS
+       HRRM    B,(A)           ;STORE RELOCATION
+       JUMPE   E,VECRE2        ;NO GROWTH (OR SHRINKAGE), GO AWAY
+       LDB     F,[111100,,E]   ;GET TOP GROWTH IN F
+       TRZN    F,400           ;CHECK AND FLUSH SIGN
+       MOVNS   F               ;WAS ON, NEGATE
+       ASH     F,6             ;CONVERT TO WORDS
+       ADD     B,F             ;UPDATE RELOCATION
+       HRRM    B,(A)           ;AND STORE IT
+       ANDI    E,777           ;ISOLATE BOTTOM GROWTH
+       TRZN    E,400           ;CHECK AND CLEAR SIGN
+       MOVNS   E
+       ASH     E,6             ;CONVERT TO WORDS
+       ADD     B,E             ;UPDATE FUTURE RELOCATIONS
+VECRE2:        SUBI    A,400000(C)     ;AND MOVE ON TO NEXT VECTOR
+       ANDI    C,377777        ;KILL MARK
+       SOJG    C,VECREL        ;AND KEEP GOING
+       JSP     D,VCMLOS        ;LOSES, LEAVE TRACKS
+
+;PAIR SPACE UPDATE
+
+;GETS PARBOT IN AC A
+;UPDATES VALUES AND CDRS UP TO PARTOP
+
+PARUPD:        CAML    A,PARTOP        ;ARE THERE MORE PAIRS TO PROCESS
+       POPJ    P,              ;NO -- RETURN
+       HRRZ    C,(A)           ;GET CURRENT CDR
+       HLRZ    B,(A)           ;GET TYPE
+       LSH     B,1             ;TIMES 2
+       HRRZ    B,@TYPNT        ;NOW GET SAT
+       SKIPGE  MKTBS(B)        ;SKIP IF IT HAS A CDR
+       JRST    PARUP1          ;NO CDR, DON'T UPDATE IT
+       JUMPE   C,PARUP1        ;IF NIL, DON'T UPDATE
+       SKIPGE  B,(C)           ;GET POINTER UPDATE AND SKIP IF THIS IS NOT A BROKEN HEART
+       HRRM    B,(A)           ;IT WAS, STORE NEW POINTER
+       SKIPE   B,PARNEW        ;IF LIST SPACE IS MOVING,
+       ADDM    B,(A)           ;THEN ADD OFFSET TO CDR
+
+;UPDATE VALUE CELL
+PARUP1:        HLRZ    B,(A)           ;SET RH OF B TO TYPE
+       MOVE    C,1(A)          ;SET C TO VALUE
+       PUSHJ   P,VALUPD        ;UPDATE THIS VALUE
+       ADDI    A,2             ;MOVE ON TO NEXT PAIR
+       JRST    PARUPD          ;AND CONTINUE
+
+\f;VECTOR SPACE UPDATE
+;GETS VECTOP IN A
+;UPDATES ALL VALUE CELLS IN MARKED VECTORS
+;ESCAPES WHEN IT GETS TO VECBOT
+
+VECUPD:        SUBI    A,1             ;MAKE A POINT TO LAST DOPE WD
+VECUP1:        CAMG    A,VECBOT        ;ANY MORE VECTORS TO PROCESS?
+       JRST    ENHACK          ;PROCESS ALL ENTRY BLOCKS NOW
+       SKIPGE  B,(A)           ;IS DOPE WORD MARKED?
+       JRST    VECUP2          ;YES -- GO PROCESS VALUES IN THIS VECTOR
+       HLLZS   -1(A)           ;MAKE SURE NO GROWTH ATTEMPTS
+       HLRZS   B               ;NO -- SET RH OF B TO SIZE OF VECTOR
+VECUP5:        SUB     A,B             ;SET A TO POINT TO DOPE WD OF NEXT VECTOR
+       JRST    VECUP1          ;AND CONTINUE
+
+VECUP2:        PUSH    P,A             ;SAVE DOPE WORD POINTER
+       HLRZ    B,(A)           ;GET LENGTH OF THIS VECTOR
+VECU11:        ANDI    B,377777        ;TURN OFF MARK BIT
+       SKIPGE  E,-1(A)         ;CHECK FOR UNIFORM OR SPECIAL
+       TLNE    E,377777        ;SKIP IF GENERAL
+       JRST    VECUP6          ;UNIFORM OR SPECIAL, GO DO IT
+VECU10:        SUB     A,B             ;SET AC A TO NEXT DOPE WORD
+       ADDI    A,1             ;AND ADVANCE TO FIRST ELEMENT OF THIS VECTOR
+VECUP3:        HLRZ    B,(A)           ;GET TYPE
+       TRNE    B,400000        ;IF MARK BIT SET
+       JRST    VECUP4          ;DONE WITH THIS VECTOR
+       CAIN    B,TENTS         ;SAVED ENTRY BLOCK?
+       JRST    ENTSUP
+       CAIN    B,TPDLS         ;SAVED P BLOCK?
+       JRST    IGBLK2
+       CAIN    B,TENTRY        ;SPECIAL HACK FOR ENTRY
+       JRST    ENTRUP
+       CAIE    B,TBVL          ;VECTOR BINDING?
+       CAIN    B,TBIND         ;AND BINDING BLOCK
+       JRST    BINDUP
+VECU15:        MOVE    C,1(A)          ;GET VALUE
+       PUSHJ   P,VALUPD        ;UPDATE THIS VALUE
+VECU12:        ADDI    A,2             ;GO ON TO NEXT VECTOR
+       JRST    VECUP3          ;AND CONTINUE
+
+VECUP4:        POP     P,A             ;SET TO OLD DOPE WORD
+       ANDCAM  D,(A)           ;TURN OFF MARK BIT
+       HLRZ    B,(A)           ;GET LENGTH
+       JRST    VECUP5          ;GO ON TO NEXT VECTOR
+
+
+
+;UPDATE A SAVED SAVE BLOCK
+ENTSUP:        MOVEI   A,FRAMLN+SPSAV-1(A)     ;A POINTS BEFORE SAVED SP
+       MOVEI   B,TSP
+       PUSHJ   P,VALPD1                ;UPDATE SPSAV
+       MOVEI   A,PSAV-SPSAV(A)
+       MOVEI   B,TPDL
+       PUSHJ   P,VALPD1                ;UPDATE PSAV
+       MOVEI   A,TPSAV-PSAV(A)
+       MOVEI   B,TTP
+       PUSHJ   P,VALPD1                ;UPDATE TPSAV
+       MOVEI   A,PPSAV-TPSAV(A)
+       MOVEI   B,TPP
+       PUSHJ   P,VALPD1                ;UPDATE PPSAV
+;SKIP TO END OF BLOCK
+       SUBI    A,PPSAV-1
+       JRST    VECUP3
+
+;IGNORE A BLOCK
+IGBLK2:        HRRZ    B,(A)           ;GET DISPLACEMENT
+       ADDI    A,3(B)          ;USE IT
+       JRST    VECUP3          ;GO
+       \f
+; ENTRY PART OF THE STACK UPDATER
+
+ENTRUP:        ADDI    A,FRAMLN-2      ;POINT PAST FRAME
+       JRST    VECU12          ;NOW REJOIN VECTOR UPDATE
+
+; UPDATE A BINDING BLOCK
+
+BINDUP:        HRRZ    C,(A)           ;POINT TO CHAIN
+       JUMPE   C,NONEXT        ;JUMP IF NO NEXT BINDING IN CHAIN
+       ADD     C,@(P)          ;ADD RELOCATION OF SELF
+       HRRM    C,(A)           ;AND STORE IT BACK
+NONEXT:        CAIE    B,TBIND         ;SKIP IF VAR BINDING
+       JRST    VECU14          ;NO, MUST BE A VECTOR BIND
+       MOVEI   B,TATOM         ;UPDATE ATOM POINTER
+       PUSHJ   P,VALPD1
+       ADDI    A,2
+       HLRZ    B,(A)           ;TYPE OF VALUE
+       PUSHJ   P,VALPD1
+       ADDI    A,2             ;POINT TO LOCATIVE POINTER
+       HLRZ    B,(A)           ;GET TYPE
+       PUSHJ   P,VALPD1
+       JRST    VECU12
+
+VECU14:        MOVEI   B,TVEC          ;NOW TREAT LIKE A VECTOR
+       JRST    VECU15
+
+; NOW SAFE TO UPDATE ALL ENTRY BLOCKS
+
+ENHACK:        HRRZ    F,TBSTO(LPVP)   ;GET POINTER TO TOP FRAME
+       HLLZS   TBSTO(LPVP)     ;CLEAR FIELD
+       HLLZS   TPSTO(LPVP)
+       JUMPE   F,LSTFRM        ;FINISHED
+
+ENHCK1:        MOVEI   A,OTBSAV-1(F)   ;POINT PRIOR TO SAVED TB
+       HRRZ    F,1(A)          ;POINT TO PRIOR FRAME
+       MOVEI   B,TTB           ;MARK  SAVED TB
+       PUSHJ   P,VALPD1
+       MOVEI   B,TAB           ;MARK ARG POINTER
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TSP           ;SAVED SP
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TPDL          ;SAVED P STACK
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TTP           ;SAVED TP
+       PUSHJ   P,[AOJA A,VALPD1]
+       MOVEI   B,TPP
+       PUSHJ   P,[AOJA A,VALPD1]       ;MARK THE PP
+       JUMPN   F,ENHCK1        ;MARK NEXT ONE IF IT EXISTS
+
+LSTFRM:        HRRZ    A,PROCID(LPVP)  ;NEXT PROCESS
+       HLLZS   PROCID(LPVP)    ;CLOBBER
+       MOVEI   LPVP,(A)
+       JUMPN   LPVP,ENHACK     ;DO NEXT PROCESS
+;NOW UPDATE DOPE WORD POINTERS IN ALL INFO CELLS
+INFHCK:        JUMPE   LINF,CPOPJ              ;IF ANY
+       HLRZ    A,1(LINF)               ;GET DOPE WORD ADDRESS
+       HRRE    B,1(A)          ;GET RELOCATION
+       ADD     A,B
+       HRLM    A,1(LINF)               ;UPDATE DOPE WORD ADDRESS
+       HRRZ    A,(LINF)
+       HLLZS   (LINF)          ;GO ON TO NEXT INFO CELL
+       MOVEI   LINF,(A)
+       JRST    INFHCK\f
+; UPDATE ELEMENTS IN UNIFROM AND SPECIAL VECTORS
+
+VECUP6:        JUMPL   E,VECUP7        ;JUMP IF  SPECIAL
+       HLRZS   E               ;ISOLATE TYPE
+       EXCH    E,B             ;TYPE TO B AND LENGTH TO E
+       SUBI    A,(E)           ;POINT TO NEXT DOPE WORD
+       LSH     B,1             ;FIND SAT
+       HRRZ    B,@TYPNT
+       MOVE    B,UPDTBS(B)     ;FIND WHERE POINTS
+       CAIN    B,CPOPJ         ;UNMARKED?
+       JRST    VECUP4          ;YES, GO ON TO NEXT VECTOR
+       PUSH    P,B             ;SAVE SR POINTER
+       SUBI    E,2             ;DON'T COUNT DOPE WORDS
+
+VECUP8:        SKIPE   C,1(A)          ;GET GOODIE
+       PUSHJ   P,@(P)          ;CALL UPDATE ROUTINE
+       ADDI    A,1
+       SOJG    E,VECUP8        ;LOOP FOR ALL ELEMNTS
+
+       SUB     P,[1,,1]        ;REMOVE RANDOMNESS
+       JRST    VECUP4
+
+; SPECIAL VECTOR UPDATE
+
+VECUP7:        HLRZS   E               ;ISOLATE SPECIAL TYPE
+       CAIN    E,SATOM+400000  ;ATOM?
+       JRST    ATOMUP          ;YES, GO DO IT
+       CAIN    E,STPSTK+400000 ;STACK
+       JRST    VECU10          ;TREAT LIKE A VECTOR
+       CAIN    E,SPVP+400000   ;PROCESS VECTOR
+       JRST    PVPUP           ;DO SPECIAL STUFF
+       CAIN    E,SASOC+400000
+       JRST    ASOUP           ;UPDATE ASSOCIATION BLOCK
+
+       MOVEI   B,[ASCIZ /VECTOR UPDATE, ENCOUNTERED FUNNY SPECIAL VECTOR
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+
+; UPDATE ATOM VALUE CELLS
+
+ATOMUP:        SUBI    A,-1(B)         ; POINT TO VALUE CELL
+       HLRZ    B,(A)
+       HRRZ    0,(A)           ;GOBBLE PROCID
+       JUMPN   0,.+3           ;NOT GLOBAL
+       CAIN    B,TLOCI         ;IS IT A LOCATIVE?
+       MOVEI   B,TVEC          ;MARK AS A VECTOR
+       PUSHJ   P,VALPD1        ;UPDATE IT
+       JRST    VECUP4
+
+; UPDATE PROCESS VECTOR
+
+PVPUP: SUBI    A,-1(B)         ;POINT TO TOP
+       HRRM    LPVP,PROCID(A)  ;CHAIN ALL PROCESSES TOGETHER
+       MOVEI   LPVP,(A)
+       HRRZ    0,TBSTO+1(A)    ;POINT TO CURRENT FRAME
+       HRRM    0,TBSTO(A)      ;SAVE
+       HRRZ    0,TPSTO+1(A)    ;0_SAVED TP POINTER
+       HLRE    B,TPSTO+1(A)
+       SUBI    0,-1(B)         ;0 _ POINTER TO OLD DOPE WORD
+       HRRM    0,TPSTO(A)
+       JRST    VECUP3
+
+\f
+;THIS SUBROUTINE TAKES CARE OF UPDATING ASSOCIATION BLOCKS
+
+ASOUP: SUBI    A,-1(B)         ;POINT TO START OF BLOCK
+       HRRZ    B,ASOLNT-1(A)   ;POINT TO NEXT
+       JUMPE   B,ASOUP1
+       HRRE    C,ASOLNT+1(B)   ;AND GET ITS RELOC IN C
+       ADDM    C,ASOLNT-1(A)   ;C NOW HAS UPDATED PONTER
+ASOUP1:        HLRZ    B,ASOLNT-1(A)   ;GET PREV BLOCK POINTER
+       JUMPE   B,ASOUP2
+       HRLZ    F,ASOLNT+1(B)   ;AND ITS RELOCATION
+       ADDM    F,ASOLNT-1(A)   ;RELOCATE
+ASOUP2:        HRRZ    B,NODPNT(A)             ;UPDATE NODE CHAIN
+       JUMPE   B,ASOUP4
+       HRRE    C,ASOLNT+1(B)           ;GET RELOC
+       ADDM    C,NODPNT(A)     ;ANID UPDATE
+ASOUP4:        HLRZ    B,NODPNT(A)     ;GET PREV POINTER
+       JUMPE   B,ASOUP5
+       HRLZ    F,ASOLNT+1(B)   ;RELOC
+       ADDM    F,NODPNT(A)
+ASOUP5:        HRLI    A,-3            ;SET TO UPDATE OTHER CONTENTS
+
+ASOUP3:        HLRZ    B,(A)           ;GET TYPE
+       PUSHJ   P,VALPD1        ;UPDATE
+       ADD     A,[1,,2]        ;MOVE POINTER
+       JUMPL   A,ASOUP3
+       JRST    VECUP4          ;AND QUIT
+
+\f;VALUPD UPDATES A SINLE VALUE FROM EITHER PAIR SPACE OR VECTOR SPACE
+;GETS POINTER TO TYPE CELL IN RH OF A
+;TYPE IN RH OF B (LH MUST BE 0)
+;VALUE IN C
+
+VALPD1:        MOVE    C,1(A)          ;GET VALUE TO UPDATE
+VALUPD:        TRNN    C,-1            ;ANY POINTER PART?
+       JRST    CPOPJ           ;NO, LEAVE
+       LSH     B,1             ;SET TYPE TIMES 2
+       HRRZ    B,@TYPNT        ;GET STORAGE ALLOCATION TYPE
+       JRST    @UPDTBS(B)      ;AND DISPATCH THROUGH STORAGE ALLOCATION DISPATCH TABLE
+
+;SAT DISPATCH TABLE
+
+DISTBS UPDTBS,CPOPJ,[[S2WORD,2WDUP],[S2DEFR,2WDUP],[SNWORD,NWRDUP],[STPSTK,STCKUP]
+[SFRAME,FRAMUP],[STBASE,TBUP],[SARGS,ARGUP],[SBYTE,BYTUP],[SATOM,NWRDUP],[SPSTK,STCKUP]
+[SPVP,NWRDUP],[S2NWORD,NWRDUP],[SABASE,ABUP],[SCHSTR,BYTUP],[SASOC,ASUP],[SINFO,INFUP]]
+
+
+
+
+;PAIR POINTER UPDATE
+2WDUP: TRNN    C,-1            ;POINT TO NIL?
+       POPJ    P,              ;YES -- NO UPDATE NEEDED
+       SKIPGE  B,(C)           ;NO -- IS THIS A BROKEN HEART
+       HRRM    B,1(A)          ;YESS -- STORE NEW VALUE
+       SKIPE   B,PARNEW        ;IF LIST SPACE IS MOVING
+       ADDM    B,1(A)          ;THEN ADD OFFSET TO VALUE
+       POPJ    P,              ;FINISHED
+
+
+; HERE TO UPDATE ASSOCIATIONS
+
+ASUP:  HRLI    C,-ASOLNT       ;MAKE INTO VECTOR POINTER
+       JRST    NWRDUP
+\f;VECTOR, ATOM, STACK, AND BASE POINTER UPDATE
+
+LOCUP: HRRZ    B,(A)           ;CHECK IF IT IS TIMED
+       JUMPN   B,LOCUP1        ;JUMP IF TIMED, OTHERWISE TREAT LIKE VECTORE
+
+NWRDUP:        HLRE    B,C             ;EXTEND COUNT IN B
+       SUBI    C,-1(B)         ;SET C TO POINT TO DOPE WORD
+       HRRE    B,(C)           ;EXTEND RELOCATION IN B
+       ADDM    B,1(A)          ;AND ADD RELOCATION TO STORED DATUM
+       HRRZ    C,-1(C)         ;GET GROWTH SPECS
+       JUMPE   C,CPOPJ         ;NO GROWTH, LEAVE
+       LDB     C,[111100,,C]   ;GET UPWORD GROWTH
+       TRZN    C,400           ;FLUSH SIGN AN NEGATR DIRECTION
+       MOVNS   C
+       ASH     C,6+18.         ;TO LH AND TIMES 100(8)
+       ADDM    C,1(A)          ;UPDATE POINTER
+       POPJ    P,
+
+
+LOCUP1:
+STCKUP:        MOVSI   B,PDLBUF        ;GET OFFSET FOR PDLS
+       ADDM    B,1(A)          ;AND ADD TO COUNT
+       JRST    NWRDUP          ;NOW TREAT LIKE VECTOR
+
+BYTUP: HRRZ    C,(A)           ;SET C TO POINT TO DOPE WD
+       HRRE    B,(C)           ;SET B TO RELOCATION FOR THIS VEC
+       ADDM    B,(A)           ;UPDATE DOPE WD POINTER
+       ADDM    B,1(A)          ;AND UPDATE VALUE
+       POPJ    P,              ;DONE WITH UPDATE
+
+ARGUP: HRRZ    B,(A)           ;GET INFO CELL
+       SKIPGE  C,(B)           ;BROKEN HEART?
+       HRRM    C,(A)
+       SKIPE   C,PARNEW                ;LISTS MOVING?
+       ADDM    C,(A)
+       HRRZ    B,(A)
+       HLRZ    C,1(B)          ;GET DOPE WORD ADDRESS
+       JRST    ABUP1           ;UPDATE ARGS POINTER
+ABUP:  HLRE    B,C             ;GET LENGTH
+       SUB     C,B             ;POINT TO FRAME
+       HLRZ    B,(C)           ;GET TYPE OF NEXT GOODIE
+       CAIN    B,TENTRY        ;IS IT A FRAME?
+       JRST    ABUP2           ;YES, ADD FRAMLN
+       HRRZ    C,1(C)          ;NO-- GET TTB
+       JRST    TBUP
+ABUP2: ADDI    C,FRAMLN
+TBUP:  MOVE    C,TPSAV(C)      ;GET A ASTACK POINTER TO FIND DOPE WORD
+       HLRE    B,C             ;UPDATE BASED ON THIS POINTER
+       SUBI    C,(B)
+ABUP1: HRRE    B,1(C)          ;GET RELOCATION
+       ADDM    B,1(A)          ;AND MUNG POINTER
+       POPJ    P,
+
+FRAMUP:        HRRZ    B,(A)           ;UPDATE PVP
+       HRRE    C,(B)           ;IN CELL
+       ADDM    C,(A)
+       HLRZ    C,(B)
+       ANDI    C,377777
+       SUBI    B,-1(C)         ;ADDRESS OF PV
+       HRRZ    C,TPSTO(B)              ;IF TPSTO HAS OLD TP DOPE WORD,
+       SOJN    C,ABUP1         ;USE IT
+       HRRZ    C,TPSTO+1(B)            ;ELSE, GENERATE IT
+       HLRE    B,TPSTO+1(B)
+       SUBI    C,(B)
+       JRST    ABUP1
+;STRING INFO CELLS TOGETHER UNTIL THE END
+INFUP: HRRM    LINF,(A)
+       MOVEI   LINF,(A)
+       POPJ    P,\f
+;VECTOR SHRINKING PHASE
+
+VECSH: SUBI    A,1             ;POOINT TO 1ST DOPE WORD
+VECSH1:        CAMGE   A,VECBOT        ;FINISHED
+       POPJ    P,              ;YES, QUIT
+       HRRZ    B,-1(A)         ;GET A SPEC
+       JUMPE   B,NXTSHN        ;IGNORE IF NONE
+       PUSHJ   P,GETGRO        ;GET THE SPECS
+       JUMPGE  C,SHRNBT        ;SHRINKIGN AT BOTTOM
+       MOVEI   E,(A)           ;COPY POINTER
+       ADD     A,C             ;POINT TO NEW DOPE LOCATION WITH E
+       MOVE    F,-1(E)         ;GET OLD DOPE
+       ANDCMI  F,777000        ;KILL THIS SPEC
+       MOVEM   F,-1(A)         ;STORE
+       MOVE    F,(E)           ;OTHER DOPE WORD
+       HRLZI   C,(C)           ;TO LH
+       ADD     F,C             ;CHANGE LENGTH
+       MOVEM   F,(A)           ;AND STORE
+       MOVMS   C               ;PLUSIFY
+       HLLZM   C,(E)           ;AND STORE
+       SETZM   -1(E)
+SHRNBT:        JUMPGE  B,NXTSHN        ;GROWTH, IGNOORE
+       MOVM    E,B             ;GET A POSITIVE COPY
+       HRLZI   B,(B)           ;TO LH
+       ADDM    B,(A)           ;ADD INTO DOPE WORD
+       MOVEI   0,777           ;SET TO CLOBBER GROWTH
+       ANDCAM  0,-1(A)         ;CLOBBER
+       HLRZ    B,(A)           ;GET NEW LENGTH
+       SUBI    A,(B)           ;POINT TO LOW END
+       HRLZM   E,(A)           ;STORE
+       SETZM   -1(A)
+
+NXTSHN:        HLRZ    B,(A)           ;GET LENGTH
+       JUMPE   B,VCMLOS        ;LOOSE
+       SUBI    A,(B)           ;STEP
+       JRST    VECSH1
+
+GETGRO:        LDB     C,[111100,,B]   ;GET UPWARD GROWTH
+       TRZE    C,400           ;CHECK AND MUNG SIGN
+       MOVNS   C
+       ASH     C,6             ;?IMES 100
+       ANDI    B,777           ;AND GET DOWN GROWTH
+       TRZE    B,400           ;CHECK AND MUNG SIGN
+       MOVNS   B
+       ASH     B,6
+       POPJ    P,
+\f;VECMOV -- MOVES VECTOR DATA TO WHERE RELOC FIELDS OF
+;VECTORS INDICATE.  MOVES DOPEWDS UP FOR VECTORS GROWING AT
+;THE END.
+;CALLED WITH VECTOP IN A.  CALLS PARMOV TO MOVE PAIRS
+
+VECMOV:        SUBI    A,1             ;SET A TO ADDR OF TOP DOPE WD
+       MOVSI   D,400000        ;NEGATIVE D MARKS END OF BACK CHAIN
+       MOVEI   TYPNT,0         ;CLEAR ON GOING ADDRESS FOR FORWARD RESUME
+VECMO1:        CAMGE   A,VECBOT        ;GOT TO BOTTOM OF VECTORS
+       JRST    PARMOV          ;YES, MOVE LIST ELEMENTS AND RETURN
+       MOVEI   C,(A)           ;NO, COPY ADDR OF THIS DOPEWD
+       HRRE    B,(A)           ;GET RELOCATION OF THIS VECTOR
+       JUMPL   B,VECMO5        ;IF MOVING DOWNWARD, MAKE BACK CHAIN
+       JUMPE   B,VECMO4        ;IF NON MOVER, JUST ADJUST DOPW AND MOVE ON
+
+       ADDI    C,(B)           ;SET ADDR OF LAST DESTINATION WD
+       HRLI    B,A             ;MAKE B INDEX ON A
+       HLL     A,(A)           ;COUNT TO A LEFT HALF
+
+       POP     A,@B            ;MOVE A WORD
+       TLNE    A,-1            ;REACHED END OF MOVING
+       JRST    .-2             ;NO, REPEAT
+               ;YES, NOTE A HAS ADDR OF NEXT DOPEWD
+;HERE TO ADJUST LOCATION OF DOPEWDS FOR GROWTH (FORWARDLY)
+VECMO2:        LDB     B,[111000,,-1(C)]               ;GET HIGH GROWTH FIELD
+       JUMPE   B,VECMO3        ;IF NO GROWTH, DONT MOVE
+       ASH     B,6             ;EXPRESS GROWTH IN WORDS
+       HRLI    C,2             ;SET COUNT FOR POPPING 2 DOPEWDS
+       HRLI    B,C             ;MAKE B INDEX ON C
+       POP     C,@B            ;MOVE PRIME DOPEWD
+       POP     C,@B            ;MOVE AUX DOPEWD
+VECMO3:        JUMPL   D,VECMO1        ;IF NO BACK CHAIN THEN MOVE ON
+       JRST    VECMO6          ;YES, BACKCHAINING, CONTINUE SAME
+
+;HERE TO SKIP OVER STILL VECTORS (FORWARDLY)
+VECMO4:        HLRZ    B,(A)           ;GET SIZE OF UNMOVER
+       SUBI    A,(B)           ;UPDATE A TO NEXT VECTOR
+       JRST    VECMO2          ;AND GO CLEAN UP GROWTH
+\f;HERE TO ESTABLISH A BACKWARDS CHAIN
+VECMO5:        EXCH    D,(A)           ;CHAIN FORWARD
+       HLRZ    B,D             ;GET SIZE
+       SUBI    A,(B)           ;GO ON TO NEXT VECOTR
+       CAMGE   A,VECBOT        ;HAVE WE GOT TO END OF VECTORS?
+       JRST    VECMO7          ;YES, GO MOVE PAIRS AND UNCHAIN
+       HRRE    B,(A)           ;GET RELOCATION OF THIS VECTOR
+       JUMPLE  B,VECMO5        ;IF NOT POSITIVE, CONTINUE CHAINING
+       MOVEM   A,TYPNT         ;SAVE ADDR FOR FORWARD RESUME
+
+;HERE TO UNCHAIN A VECTOR, MOVE IT, AND ADJUST DOPEWDS
+VECMO6:        HLRZ    B,D             ;GET SIZE
+       MOVEI   F,1(A)          ;GET A COPY OF BEGINNING OF VECTOR
+       ADDI    A,(B)           ;SET TO POINT TO ADDR OF DOPEWD CURRENTLY IN D
+       EXCH    D,(A)           ;AND UNCHAIN
+       HRRE    B,(A)           ;GET RELOCATION FOR THIS VECTOR
+       MOVEI   C,(A)           ;COPY A POINTER TO DOPEW
+       SKIPGE  D               ;HAVE WE REACHED THE TOP OF THE CHAIN?
+       MOVE    A,TYPNT         ;YES,   RESTORE FORWARD MOVE RESUME ADDR
+       JUMPE   B,VECMO2        ;IF STILL VECTOR,GO ADJUST DOPEWDS
+       ADDI    C,(B)           ;MAKE C POINT TO NEW DOPEW ADDR
+       ADDI    B,(F)           ;B RH NEW 1ST WORD
+       HRLI    B,(F)           ;B LH OLD 1ST WD ADDR
+       BLT     B,(C)           ;COPY THE DATA
+       JRST    VECMO2          ;AND GO ADJUST DOPEWDS
+
+;HERE TO STOP CHAINING BECAUSE OF BOTTOM OF VECTOR SPACE
+VECMO7:        MOVEM   A,TYPNT
+       PUSH    P,D
+       PUSHJ   P,PARMOV
+       POP     P,D
+       MOVE    A,TYPNT
+       JRST    VECMO6
+\f;PAIR MOVEMENT PHASE -- USES PARNEW,PARBOT, AND PARTOP TO MOVE PAIRS
+;TO NEW HOMES
+
+PARMOV:        SKIPN   A,PARNEW        ;IS THERE ANY PAIR MOVEMENT?
+       POPJ    P,              ;NO, RETURN
+       JUMPL   A,PARMO2        ;YES -- IF MOVING DOWNWARDS, GO DO A BLT
+       HRLI    A,B             ;MOVING UPWARDS SETAC A TO INDEX OFF AC B
+       MOVE    B,PARTOP        ;GET HIGH PAIR ADDREESS
+       SUB     B,PARBOT        ;AND SUBTRACT BOTTOM TO GET NUMBER OF PAIRS
+       HRLZS   B               ;PUT COUNT IN LEFT HALF
+       HRR     B,PARTOP        ;GET HIGH ADDRESS PLUS ONE IN RH
+       SUBI    B,1             ;AND SUBTRACT ONE TO POINT TO LAST WORD TO BE MOVED
+
+PARMO1:        TLNN    B,-1            ;HAS COUNT REACHED ZERO?
+       JRST    PARMO3          ;YES -- FINISH UP
+       POP     B,@A            ;NO -- TRANSFER2Y\eU NEXT WORD
+       JRST    PARMO1          ;AND REPEAT
+
+PARMO2:        MOVE    B,PARBOT        ;GET ADDRESS OF FIRST SOURCE WD
+       HRLS    B               ;IN BOTH HALVES OF AC B
+       ADD     B,A             ;MAKE RH OF B POINT TO FIRST DESTINATION WORD
+       ADD     A,PARTOP        ;MAKE RH OF A POINT TO LAST DESTINATION WORD PLUS ONE
+       BLT     B,-1(A)         ;AND TRANSFER THE BLOCK OF PAIRS
+
+PARMO3:        MOVE    A,PARNEW        ;GET OFFSET FOR PAIR SPACE
+       ADDM    A,PARBOT        ;AND CORRECT BOTTOM
+       ADDM    A,PARTOP        ;AND CORRECT TOP.
+       SETZM   PARNEW          ;CLEAR SO IF CALLED TWICE, NO LOSSAGE
+       POPJ    P,
+\f;VECZER -- CLEARS DATA IN AREAS JUST GROWN
+;UPDATES SIZE OF VECTORS
+;CLEARS RELOCATION AND GROWTH FIELDS IN DOPEWDS
+;CALLED WITH NEW VECTOP IN A (VECBOT SHOULD BE NEW TOO)
+
+VECZER:        SUBI    A,1             ;MAKE A POINT TO HIGH VECTORS
+VECZE1:        CAMGE   A,VECBOT        ;REACHED BOTTOM OF VECTORS?
+       POPJ    P,              ;YES, RETURN
+       HLLZS   F,(A)           ;NO, CLEAR RELOCATION GET SIZE
+       HLRZS   F               ;AND PUT SIZE IN RH OF F
+       HRRZ    B,-1(A)         ;GET GROWTH INTO B
+       JUMPN   B,VECZE3        ;IF THERE IS SOME GROWTH, GO DO IT
+VECZE2:        SUBI    A,(F)           ;GROWTH DONE, MOVE ON TO NEXT VECTOR
+       JRST    VECZE1          ;AND REPEAT
+
+VECZE3:        HLLZS   -1(A)           ;CLEAR GROWTH IN THE VECTOR
+       LDB     C,[111000,,B]           ;GET HIGH ORDER GROWTH IN C
+       ANDI    B,377           ;AND LIMIT B TO LOW SIDE
+       ASHC    B,6             ;EXPRESS GROWTH IN WORDS
+       JUMPE   C,VECZE4        ;IF NO HIGH GROWTH SKIP TO LOW GROWTH
+       ADDI    F,(C)           ;ADD HIGH GROWTH TO SIZE
+       SUBM    A,C             ;GET ADDR OF 2ND WD TO BE ZEROED
+       SETZM   -1(C)           ;CLEAR 1ST WORD
+       HRLI    C,-1(C)         ;MAKE C A CLEARING BLT POINTER
+       BLT     C,-2(A)         ;AND CLEAR HIGH END DATA
+\rVECZE4:       JUMPE   B,VECZE5        ;IF NO LOW GROWTH SKIP TO SIZE UPDATE
+       MOVNI   C,(F)           ;GET NEGATIVE SIZE SO FAR
+       ADDI    C,(A)           ;AND MAKE C POINT TO LAST WORD OF STUFF TO BE CLEARED
+       ADDI    F,(B)           ;UPDATE SIZE
+       SUBM    C,B             ;MAKE B POINT TO LAST WD OF NEXT VECT
+       ADDI    B,2             ;AND NOW TO 2ND DATA WD TO BE CLEARED
+       SETZM   -1(B)           ;CLEAR 1ST DATA WD
+       HRLI    B,-1(B)         ;MAKE B A CLEARING BLT POINTER
+       BLT     B,(C)           ;AND CLEAR THE LOW DATA
+\rVECZE5:       HRLZM   F,(A)           ;STORE THE NEW SIZE IN DOPEWD
+       JRST    VECZE2
+\f
+;SUBROUTINE TO REBUILD THE NOW DEFUNCT HASH TABLE
+
+REHASH:        MOVE    TVP,TVPSTO+1(PVP)       ;RESTORE TV POINTER
+       MOVE    D,ASOVEC+1(TVP) ;GET POINTER TO VECTOR
+       MOVEI   E,(D)
+       PUSH    P,E             ;PUSH A POINTER
+       HLRE    A,D             ;GET -LENGTH
+       MOVMS   A               ;AND PLUSIFY
+       PUSH    P,A             ;PUSH IT ALSO
+
+REH3:  HRRZ    C,(D)           ;POINT TO FIRST BUCKKET
+       HLRZS   (D)             ;MAKE SURE NEW POINTER IS IN RH
+       JUMPE   C,REH1          ;B\0UCKET EMPTY, QUIT
+
+REH2:  MOVEI   E,(C)           ;MAKE A COPY OF THE POINTER
+       MOVE    A,ITEM(C)       ;START HASHING
+       XOR     A,ITEM+1(C)
+       XOR     A,INDIC(C)
+       XOR     A,INDIC+1(C)
+       MOVMS   A               ;MAKE SURE FINAL HASH IS +
+       IDIV    A,(P)           ;DIVIDE BY TOTAL LENGTH
+       ADD     B,-1(P)         ;POINT TO WINNING BUCKET
+
+       MOVE    C,[002200,,(B)] ;BYTE POINTER TO RH
+       CAILE   B,(D)           ;IF PAST CURRENT POINT
+       MOVE    C,[222200,,(B)] ;USE LH
+       LDB     A,C             ;GET OLD VALUE
+       DPB     E,C             ;STORE NEW VALUE
+       HRRZ    B,ASOLNT-1(E)   ;GET NEXT POINTER
+       HRRZM   A,ASOLNT-1(E)   ;AND CLOBBER IN NEW NEXT
+       SKIPE   A               ;SKKIP IF NOTHING PREVIOUSLY IN BUCKET
+       HRLM    E,ASOLNT-1(A)   ;OTHERWISE CLOBBER
+       SKIPE   C,B             ;SKIP IF END OF CHAIN
+       JRST    REH2
+REH1:  AOBJN   D,REH3
+
+       SUB     P,[2,,2]        ;FLUSH THE JUNK
+       POPJ    P,
+\fVCMLOS:       MOVEI   B,[ASCIZ /AGC -- VECTOR WITH ZERO IN DOPE WORD LENGTH
+/]
+       PUSHJ   P,MSGTYP
+       .VALUE
+;LOCAL VARIABLES
+
+GETNUM:        0                       ;NO OF WORDS TO GET
+PARNUM:        0                       ;NO OF PAIRS MARKED
+VECNUM:        0                       ;NO OF WORDS IN MARKED VECTORS
+CORSET:        0                       ;NO OF BLOCKS OF CORE, IF GIVING CORE AWAY
+CORTOP:        0                       ;CURRENT TOP OF CORE, EXCLUDING ANY TO BE GIVEN AWAY
+
+;VARIABLES WHICH DETERMIN WHEN MUDDLE WILL ASK FOR MORE CORE,
+;AND WHEN IT WILL GET UNHAPPY
+
+SYSMAX:        50.                     ;MAXIMUM SIZE OF MUDDLE
+FREMIN:        1000                    ;MINIMUM FREE WORDS
+FREDIF:        10000                   ;DIFFERENCE BETWEEN FREMIN AND MAXIMUM NUMBER OF FREE WORDS
+;POINTER TO GROWING PDL
+
+TPGROW:        0                       ;POINTS TO A BLOWN TP
+PPGROW:        0                       ;POINTS TO A BLOWN PP
+TIMOUT:        0                       ;POINTS TO TIMED OUT PDL
+PGROW: 0                       ;POINTS TO A BLOWN P
+
+;IN GC FLAG
+
+GCFLG: 0
+
+
+END
+\f\f\f\f\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/neval.222 b/MUDDLE/neval.222
new file mode 100644 (file)
index 0000000..b59a860
--- /dev/null
@@ -0,0 +1,2966 @@
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971
+; DREW MCDERMOTT, 1972
+
+.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM
+.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL
+.GLOBAL PDLBUF,MESS,FACTI,ITRUTH,FLFLG,PDLOSS,AGC
+.GLOBAL PGROW,TPGROW,PDLGRO,SPCSTE,CNTIN2
+
+.INSRT MUDDLE >
+
+       MFUNCTION       EVAL,SUBR
+       INTGO
+       HLRZ    A,AB            ;GET NUMBER OF ARGS
+       CAIE    A,-2            ;EXACTLY 1?
+       JRST    AEVAL           ;EVAL WITH AN ALIST
+NORMEV:        HLRZ    A,(AB)          ;GET TYPE OF ARG
+       CAILE   A,NUMPRI        ;PRIMITIVE?
+       JRST    NONEVT          ;NO
+       JRST    @EVTYPT(A)      ;YES-DISPATCH
+
+SELF:  MOVE    A,(AB)          ;TYPES WHICH EVALUATE 
+       MOVE    B,1(AB)
+       JRST    FINIS           ;TO SELF-EG NUMBERS
+
+;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
+
+MFUNCTION VALUE,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IDVAL
+       JRST    FINIS
+
+IDVAL: PUSH    TP,A
+       PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
+       PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER
+       CAMN    A,$TUNAS
+       JRST    UNAS
+       CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED
+       JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN
+       POP     TP,B            ;GET ARG BACK
+       POP     TP,A
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    UNBOU
+       POPJ    P,
+RIDVAL:        SUB     TP,[2,,2]
+       POPJ    P,
+
+;GETS THE LOCAL VALUE OF AN IDENTIFIER
+
+MFUNCTION LVAL,SUBR
+       JSP     E,CHKAT
+LVAL2: PUSHJ   P,ILVAL
+       CAMN    A,$TUNBO
+       JRST    UNBOU           ;UNBOUND
+       CAMN    A,$TUNAS
+       JRST    UNAS            ;UNASSIGNED
+       JRST    FINIS           ;OTHER
+
+
+MFUNCTION RLVAL,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAME    A,$TUNBO
+       JRST    FINIS
+       PUSH    TP,(AB)         ;IF UNBOUND,
+       PUSH    TP,1(AB)        ;BIND IT GLOBALLY TO ?()
+       PUSH    TP,$TUNAS
+       PUSH    TP,[0]
+       MCALL   2,SET
+       JRST    FINIS
+
+
+MFUNCTION UNASSP,SUBR,[UNASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAMN    A,$TUNBO
+       JRST    UNBOU
+       CAME    A,$TUNAS
+       JRST    IFALSE
+       JRST    FINIS
+\f
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
+
+MFUNCTION LLOC,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,ILOC
+       CAMN    A,$TUNBOUND
+       JRST    UNBOU
+       MOVSI   A,TLOCD
+       HRR     A,2(B)
+       JRST    FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
+
+MFUNCTION BOUND,SUBR,[BOUND?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAMN    A,$TUNBOUND
+       JUMPE   B,IFALSE
+       JRST    TRUTH
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
+
+MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAMN    A,$TUNBOU
+       JRST    UNBOU
+       CAMN    A,$TUNAS
+       JRST    IFALSE
+       JRST    TRUTH
+
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GVAL,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    UNAS
+       JRST    FINIS
+
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GLOC,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IGLOC
+       CAMN    A,$TUNBOUND
+       JRST    UNAS
+       MOVSI   A,TLOCD
+       JRST    FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
+
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    IFALSE
+       JRST    TRUTH
+
+\f
+
+CHKAT: ENTRY   1
+       HLLZ    A,(AB)
+       CAME    A,$TATOM
+       JRST    NONATM
+       MOVE    B,1(AB)
+       JRST    2,(E)
+
+;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
+
+EVFORM:        SKIPN   C,1(AB)         ;EMPTY?
+       JRST    IFALSE
+       HLLZ    A,(C)           ;GET CAR TYPE
+       CAME    A, $TATOM       ;ATOMIC?
+       JRST    EV0             ;NO -- CALCULATE IT
+       MOVE    B,1(C)          ;GET PTR TO ATOM
+       CAMN    B,MQUOTE LVAL
+       JRST    EVATOM          ;".X" EVALUATED QUICKLY
+EVFRM1:        PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    LFUN
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    IAPPLY          ;APPLY IT
+EV0:   PUSH    TP,A            ;SET UP CAR OF FORM AND
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;EVALUATE IT
+       PUSH    TP,A            ;APPLY THE RESULT
+       PUSH    TP,B            ;AS A FUNCTION
+       JRST    IAPPLY
+
+LFUN:  MOVE    B,1(AB)
+       PUSH    TP,$TATOM
+       PUSH    TP,1(B)
+       MCALL   1,VALUE
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    IAPPLY
+
+;HERE TO EVALUATE AN ATOM
+
+EVATOM:        HRRZ    D,(C)           ;D _ REST OF FORM
+       MOVE    A,(D)           ;A _ TYPE OF ARG
+       CAME    A,$TATOM
+       JRST    EVFRM1
+       MOVE    B,1(D)          ;B _ ATOM POINTER
+       JRST    LVAL2           ;SIMULATE .MCALL TO LVAL
+
+;DISPATCH TABLE FOR EVAL
+DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
+
+\f;AEVAL DOES RELATIVE EVALUATIONS WITH RESPECT TO
+;AN ENVIRONMENT OR FRAME.  A FALSE ENVIRONMENT IS EQUIVALENT TO THE
+;CURRENT ONE.
+
+AEVAL: CAIE    A,-4            ;EXACTLY 2 ARGS?
+       JRST    WNA             ;NO-ERROR
+       HLRZ    A,2(AB)         ;CHECK THAT WE HAVE AN ENV OR FRAME
+       CAIN    A,TENV
+       JRST    EWRTNV
+       CAIN    A,TFALSE
+       JRST    NORMEV          ;OR <>
+       CAIE    A,TFRAME
+       JRST    WTYP
+
+       MOVE    A,3(AB)         ;A _ FRAME POINTER
+       HRR     B,A
+       HLL     B,OTBSAV(A)     ;CHECK ITS TIME...
+       CAME    A,B
+       JRST    ILLFRA
+       GETYP   C,FSAV(A)
+       CAIE    C,TENTRY        ;...AND CONTENTS
+       JRST    ILLFRA
+
+EWRTFM:        MOVE    B,SPSAV(A)      ;NOW USE THE NITTY-GRITTY
+       CAMN    SP,B            ;NAMELY, THE FRAME'S ACCESS ENVIRONMENT
+       JRST    NORMEV          ;UNLESS IT ISN'T NEW
+       PUSH    TP,2(AB)        ;NOW SIMULATE AN EWRTNV ON A TENV
+       PUSH    TP,A
+       MOVSI   A,TENV
+       MOVEM   A,2(AB)
+       MOVEM   B,3(AB)
+       MOVEI   C,
+       PUSHJ   P,ISPLIC
+       POP     TP,3(AB)        ;RESTORE WITH FRAME
+       POP     TP,2(AB)
+       JRST    NORMEV\fMFUNCTION SPLICE,SUBR
+       ENTRY   2               ;<SPLICE CURRENT NEW>
+       GETYP   A,2(AB)
+       CAIN    A,TFALSE
+       JRST    ITRUTH          ;IF .NEW = <>, EASY;
+       CAIE    A,TENV
+       JRST    WTYP            ;OTHERWISE,
+       GETYP   A,(AB)          ;TWO ENVIRONMENTS NEEDED
+       CAIE    A,TENV
+       JRST    WTYP
+       MOVE    A,1(AB)         ;.CURRENT = .NEW?
+       CAMN    A,3(AB)
+       JRST    ITRUTH          ;HOPEFULLY
+       PUSH    TP,$TSP
+       PUSH    TP,SP           ;SAVE CURRENT SP
+       AOSN    E,PTIME
+       .VALUE  [ASCIZ /TIMEOUT/]
+       PUSHJ   P,FINDSP        ;SP _ A, AMONG OTHER THINGS
+       PUSHJ   P,ISPLIC        ;SPLICE IT
+       EXCH    SP,1(TB)        ;RESTORE SP,
+       SKIPN   C
+       MOVE    SP,1(TB)        ;UNLESS SPLICE DONE TO TOP OF SP
+       MOVEM   SP,SPSAV(TB)    ;SPSAV SLOT CLOBBERED BY FINDSP
+       PUSH    TP,$TFIX        ;SAVE OLD PROCID
+       PUSH    TP,E
+       FPOINT  UNSPLI,4        ;SET FAILPOINT
+       JRST    IFALSE
+
+;FAIL BACK TO HERE
+
+UNSPLI:        MOVE    A,1(TB)         ;A _ SPLICE VECTOR ADDRESS
+       MOVEM   SP,1(TB)        ;SAVE SP
+       MOVE    E,3(TB)         ;E _ OLD PROCID
+       PUSHJ   P,FINDSP        ;SP _ SPLICE VECTOR
+       MOVEM   E,PROCID+1(PVP) ;RESET OLD PROCID
+       MOVE    SP,3(SP)        ;SP _ REBIND ENVIRONMENT
+       JUMPE   C,IFAIL         ;IF C = 0, KEEP FAILING
+       MOVEM   SP,1(C)         ;RECLOBBER ACCESS TO REBIND
+       MOVE    SP,1(TB)        ;IF NOTHING LOWER, SP _ SAME AS BEFORE
+       JRST    IFAIL
+
+
+;SPECIAL CASE FOR EVAL WITH ENVIRONMENT
+
+EWRTNV:        CAMN    SP,3(AB)                ;ALREADY GOT?
+       JRST    NORMEV
+       AOSN    E,PTIME
+       .VALUE  [ASCIZ /TIMEOUT/]
+       MOVEI   C,
+       PUSHJ   P,ISPLICE
+       JRST    NORMEV
+
+;SEARCH FOR A THROUGH ENVIRONMENTS, SETTING SP AS YOU GO
+;CLOBBER ALL PROCID'S OF BOUND ATOMS TO E, AND CLOBBER 
+;LOCATIVES IN ALL BIND BLOCKS EXCEPT FOR LAST VECTOR
+
+FINDSP:        MOVEI   C,
+       SKIPA
+SPLOOP:        MOVE    SP,1(C)
+       CAMN    SP,A            ;DONE?
+       POPJ    P,
+       SKIPN   SP
+       .VALUE  [ASCIZ /SPOVERPOP/]
+       JUMPE   C,JBVEC2
+
+;CLOBBER ALL LOCATIVES IN LAST BIND VECTOR
+
+BLOOP3:        GETYP   C,(B)
+       CAIE    C,TBIND
+       JRST    JBVEC2
+       MOVEI   C,TFALSE        ;MAKE FALSE LOCATIVE
+       HRLM    C,4(B)
+       SETZM   5(B)
+       HRRZ    B,(B)
+       JRST    BLOOP3
+JBVEC2:        HRRZ    B,SP            ;B _ SP
+       MOVE    C,SP            ;C _ BIND BLOCK ADDRESS = SP
+BLOOP4:        GETYP   D,(C)           ;SEARCH THROUGH BLOCKS ON THIS VECTOR
+       CAIE    D,TBIND
+       JRST    SPLOOP          ;GOT TO END
+       MOVE    D,1(C)          ;ALTER PROCID OF BOUND ATOM
+       HRRM    E,(D)
+       HRRZ    C,(C)           ;NEXT BLOCK
+       JRST    BLOOP4
+
+;SPLICE 3(AB) INTO SP 
+
+ISPLIC:        PUSH    TP,$TVEC        ;SAVE C
+       PUSH    TP,C
+       PUSH    TP,$TFIX
+       PUSH    TP,E            ;AND E
+       PUSH    TP,$TFIX
+       PUSH    TP,[3]
+       MCALL   1,VECTOR        ;B _ <VECTOR 3>
+       MOVSI   D,TSP
+       MOVEM   D,(B)
+       MOVEM   D,2(B)
+       MOVE    D,3(AB)
+       MOVEM   D,1(B)          ;<PUT .B 1 <3 .AB>>
+       MOVEM   SP,3(B)         ;<PUT .B 2 .SP>
+       MOVE    SP,B            ;SP _ B
+       MOVSI   D,TFIX
+       MOVEM   D,4(SP)         ;GET SET TO STORE NEW PROCID
+       MOVE    E,(TP)          ;E _ NEW PROCID
+       EXCH    E,PROCID+1(PVP) ;E _ OLD PROCID
+       MOVEM   E,5(SP)         ;SAVE OLD PROCID IN BIND VECTOR
+       SUB     TP,[4,,4]
+       SKIPE   C,2(TP)         ;RECOVER C
+       MOVEM   SP,1(C)         ;COMPLETE SPLICE
+       POPJ    P,\fMFUNCTION APPLY,SUBR
+       ENTRY   2
+       MOVE    A,(AB)          ;SAVE FUNCTION
+       PUSH    TP,A
+       MOVE    B,1(AB)
+       PUSH    TP,B
+       GETYP   A,2(AB)         ;AND ARG LIST
+       CAIE    A,TLIST
+       JRST    WTYP            ;WHICH SHOULD BE LIST
+       PUSH    TP,$TLIST
+       MOVE    B,3(AB)
+       PUSH    TP,B
+       MOVEI   0,
+       MOVEI   B,ARGNEV        ;ARGS NOT EVALED
+       JRST    IAPPL1
+
+IAPPLY:        MOVSI   A,TLIST
+       PUSH    TP,A
+       HRRZ    B,@1(AB)
+       PUSH    TP,B
+       HRRZ    0,1(AB)         ;0 _ CALL
+       MOVEI   B,ARGEV         ;ARGS TO BE EVALED
+IAPPL1:        GETYP   A,(TB)
+       CAIN    A,TEXPR         ;EXPR?
+       JRST    APEXPR          ;YES
+       CAIN    A,TFSUBR        ;NO -- FSUBR?
+       JRST    APFSUBR         ;YES
+       CAIN    A,TFUNARG       ;NO -- FUNARG?
+       JRST    APFUNARG        ;YES
+       CAIN    A,TPVP          ;NO -- PROCESS TO BE RESUMED?
+       JRST    NOTIMP          ;YES
+       SUBI    B,ARGNEV        ;B _ 0 IFF NO EVALUATION
+       PUSH    P,B             ;PUSH SWITCH
+       CAIN    A,TSUBR         ;NO -- SUBR?
+       JRST    APSUBR          ;YES
+       CAIN    A,TFIX          ;NO -- CALL TO NTH?
+       JRST    APNUM           ;YES
+       CAIN    A,TACT          ;NO -- ACTIVATION?
+       JRST    APACT           ;YES
+       JRST    NAPT            ;NONE OF THE ABOVE
+
+
+;APFSUBR CALLS FSUBRS
+
+APFSUBR:
+       MCALL   1,@1(TB)
+       JRST    FINIS
+
+;APSUBR CALLS SUBRS
+
+APSUBR:        PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
+TUPLUP:
+       SKIPN   A,3(TB)         ;IS IT NIL?
+       JRST    MAKPTR          ;YES -- DONE
+       PUSH    TP,(A)          ;NO -- GET CAR OF THE
+       HLLZS   (TP)            ;ARGLIST
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+       SKIPN   -1(P)           ;EVAL?
+       JRST    BUMP            ;NO
+       MCALL   1,EVAL          ;AND EVAL IT.
+       PUSH    TP,A            ;SAVE THE RESULT IN
+       PUSH    TP,B            ;THE GROWING TUPLE
+BUMP:  AOS     (P)             ;BUMP THE ARGCNT
+       HRRZ    A,@3(TB)        ;SET THE ARGLIST TO 
+       MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
+       JRST    TUPLUP
+MAKPTR:
+       POP     P,A     
+       ACALL   A,@1(TB)
+       JRST    FINIS
+
+;APACT INTERPRETS ACTIVATIONS AS CALLS TO FUNCTION EXIT
+
+APACT: MOVE    A,(TP)          ;A _ ARGLIST
+       JUMPE   A,TFA
+       GETYP   B,(A)           ;SETUP SECOND ARGUMENT
+       HRLZM   B,-1(TP)
+       MOVE    B,1(A)
+       MOVEM   B,(TP)
+       HRRZ    A,(A)           ;MAKE SURE ONLY ONE
+       JUMPN   A,TMA
+       JSP     E,CHKARG
+       SKIPN   (P)             ;IF ARGUMENT AS YET UNEVALED,
+       MCALL   2,EXIT
+       MCALL   1,EVAL          ;EVAL IT
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,EXIT          ;AND EXIT GIVEN ACTIVATION\f
+
+;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+APNUM:
+       MOVE    A,(TP)          ;GET ARLIST
+       JUMPE   A,ERRTFA        ;NO ARGUMENT
+       PUSH    TP,(A)          ;GET CAR OF ARGL
+       HLLZS   (TP)    
+       PUSH    TP,1(A)
+       HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
+       JUMPN   A,ERRTMA
+       JSP     E,CHKARG        ;HACK DEFERRED
+       SKIPN   (P)             ;EVAL?
+       JRST    DONTH
+       MCALL   1,EVAL          ;YES
+       PUSH    TP,A
+       PUSH    TP,B
+DONTH: PUSH    TP,(TB)
+       PUSH    TP,1(TB)
+       MCALL   2,NTH
+       JRST    FINIS
+
+;APEXPR APPLIES EXPRS
+;EXPRESSION IS IN 0(AB),  FUNCTION IS IN 0(TB)
+
+APEXPR:
+
+       SKIPN   C,1(TB)         ;BODY?
+       JRST    NOBODY          ;NO, ERROR
+       MOVE    D,(TP)          ;D _ ARG LIST
+       SETZM   (TP)            ;ZERO (TP) FOR BODY
+       PUSH    P,[0]           ;SWITCHES OFF
+       PUSH    P,B             ;ARGS EVALER OR NON-EVALER
+       PUSHJ   P,BINDER        ;DO THE BINDINGS
+
+       HRRZ    C,1(TB)         ;GET BODY BACK
+       TRNE    A,H             ;SKIP IF NO HEWITT ATOM
+       HRRZ    C,(C)           ;ELSE CDR AGAIN
+       MOVEM   C,3(TB)
+       JRST    STPROG
+
+;MAKE SURE ARGUMENT PUSHED ON STACK IS NOT OF TYPE DEFER
+;(CLOBBERS A AND E)
+
+CHKARG:        GETYP   A,-1(TP)
+       CAIE    A,TDEFER
+       JRST    (E)
+       HRRZS   (TP)            ;MAKE SURE INDIRECT WINS
+       MOVE    A,@(TP)
+       MOVEM   A,-1(TP)                ;CLOBBER IN TYPE SLOT
+       MOVE    A,(TP)          ;NOW GET POINTER
+       MOVE    A,1(A)          ;GET VALUE
+       MOVEM   A,(TP)          ;CLOBBER IN
+       JRST    (E)
+\f;LIST EVALUATOR
+
+EVLIST:        PUSHJ   P,PSHRG1        ;EVALUATE EVERYTHING
+       PUSH    P,C             ;SAVE COUNTER
+EVLIS1:        JUMPE   C,EVLDON        ;IF C=0, DONE
+       PUSH    TP,A            ;ELSE, CONS
+       PUSH    TP,B
+       MCALL   2,CONS          ;(A,B) _ ((TP) !(A,B))
+       SOS     C,(P)           ;DECREMENT COUNTER
+       JRST    EVLIS1
+EVLDON:        SUB     P,[1,,1]
+       JRST    FINIS
+
+
+;VECTOR EVALUATOR
+
+EVECT: PUSH    P,[0]           ;COUNTER
+       GETYPF  A,(AB)          ;COPY INPUT VECTOR POINTER
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+
+EVCT2: INTGO
+       SKIPL   A,1(TB)         ;IF VECTOR EMPTY,
+       JRST    MAKVEC          ;GO MAKE ITS VALUE
+       GETYPF  C,(A)           ;C _ TYPE OF NEXT ELEMENT
+       PUSH    P,C
+       CAMN    C,$TSEG
+       MOVSI   C,TFORM         ;EVALUATE SEGMENTS LIKE FORMS
+       PUSH    TP,C
+       PUSH    TP,1(A)
+       ADD     A,[2,,2]        ;TO NEXT VALUE
+       MOVEM   A,1(TB)
+       MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
+       POP     P,C
+       CAME    C,$TSEG         ;IF SEGMENT,
+       JRST    EVCT1
+       PUSHJ   P,PSHSEG        ;PUSH ITS ELEMENTS
+       JRST    EVCT2
+EVCT1: PUSH    TP,A            ;ELSE PUSH IT
+       PUSH    TP,B
+       AOS     (P)             ;BUMP COUNTER
+       JRST    EVCT2
+
+MAKVEC:        POP     P,A             ;A _ COUNTER
+       .ACALL  A,EVECTOR       ;CALL VECTOR CONSTRUCTOR
+       JRST    FINIS           ;QUIT
+
+
+;UNIFORM VECTOR EVALUATOR
+
+EUVEC: GETYPF  A,(AB)          ;COPY INPUT VECTOR POINTER
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+       HLRE    C,1(TB)         ;C _ - NO. OF WORDS: TO DOPE WORD
+       HRRZ    A,1(TB)
+       SUBM    A,C             ;C _ ADDRESS OF DOPE WORD
+       GETYPF  A,(C)
+       PUSH    P,A             ;-1(P) _ TYPE OF UVECTOR
+       PUSH    P,[0]           ;0(P) _ COUNTER
+EUVCT2:        INTGO
+       SKIPL   A,1(TB)         ;IF VECTOR EMPTY,
+       JRST    MAKUVC          ;GO MAKE ITS VALUE
+       MOVE    C,-1(P)         ;C _ TYPE
+       CAMN    C,$TSEG
+       MOVSI   C,TFORM         ;EVALUATE SEGMENTS LIKE FORMS
+       PUSH    TP,C
+       PUSH    TP,(A)
+       ADD     A,[1,,1]        ;TO NEXT VALUE
+       MOVEM   A,1(TB)
+       MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
+       MOVE    C,-1(P)
+       CAME    C,$TSEG         ;IF SEGMENT,
+       JRST    EUVCT1
+       PUSHJ   P,PSHSEG        ;PUSH ITS ELEMENTS
+       JRST    EUVCT2
+EUVCT1:        PUSH    TP,A            ;ELSE PUSH IT
+       PUSH    TP,B
+       AOS     (P)             ;BUMP COUNTER
+       JRST    EUVCT2
+
+MAKUVC:        POP     P,A             ;A _ COUNTER
+       .ACALL  A,EUVECT        ;CALL VECTOR CONSTRUCTOR
+       SUB     P,[1,,1]        ;FLUSH TYPE
+       JRST    FINIS           ;QUIT
+\f;ENTRY POINT FOR PUSHING ALL BUT LAST SEGMENT, IF ANY,
+;WHICH IS IN (A,B) INSTEAD OF ON STACK.  IF NO LAST SEGMENT
+;(OR IT IS NOT A LIST), (A,B) = () INSTEAD.
+
+PSHSW=-1               ;SWITCH BENEATH COUNTER ON STACK
+CPYLST==1              ;SWITCH ON IFF LAST SEGMENT TO BE COPIED LIKE OTHERS
+
+PSHRG1:        PUSH    P,[0]           ;DON'T COPY LAST SEGMENT
+       JRST    PSHRG2
+
+;INTERNAL ARG LIST PUSHER-- ACCEPTS SEGMENTS, LEAVES COUNTER OF 
+;THINGS PUSHED IN C
+
+PSHRGL:        PUSH    P,[1]           ;COPY FINAL SEGMENT
+PSHRG2:        PUSH    P,[0]           ;(P) IS A COUNTER
+       GETYPF  A,(AB)          ;COPY ARGLIST POINTER
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+
+IEVL2: INTGO
+       SKIPN   A,1(TB)         ;A _ NEXT LIST CELL ADDRESS
+       JRST    ARGSDN          ;IF 0, DONE
+       HRRZ    B,(A)           ;CDR THE ARGS
+       MOVEM   B,1(TB)
+       GETYP   C,(A)           ;C _ TRUE TYPE OF CELL ELEMENT
+       MOVSI   C,(C)
+       CAME    C,$TDEFER       ;DON'T ACCEPT DEFERREDS
+       JRST    IEVL3
+       MOVE    A,1(A)
+       MOVE    C,(A)
+IEVL3: PUSH    P,C             ;SAVE TYPE
+       CAMN    C,$TSEG         ;IF SEGMENT
+       MOVSI   C,TFORM         ;EVALUATE IT LIKE A FORM
+       PUSH    TP,C
+       PUSH    TP,1(A)
+       MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
+       POP     P,C
+       CAME    C,$TSEG         ;IF SEGMENT,
+       JRST    IEVL4
+       CAMN    A,$TLIST        ;THAT TURNED OUT TO BE A LIST,
+       SKIPE   1(TB)           ;CHECK IF LAST
+       JRST    IEVL1           ;IF NOT, COPY IT
+       MOVE    0,PSHSW(P)      ;IF SO, AND "COPY LAST"
+       TRNN    0,CPYLST        ;   SWITCH IS OFF
+       JRST    IEVL5           ;DON'T COPY
+IEVL1: PUSHJ   P,PSHSEG        ;PUSH SEGMENT'S ELEMENTS
+       JRST    IEVL2
+IEVL4: PUSH    TP,A            ;ELSE PUSH IT
+       PUSH    TP,B
+       AOS     (P)             ;BUMP COUNTER
+       JRST    IEVL2
+
+ARGSDN:        MOVE    B,PSHSW(P)      ;B _ SWITCH WORD
+       TRNN    B,CPYLST        ;IF COPY LAST SWITCH OFF,
+       MOVSI   A,TLIST         ;    (A,B) _ ()
+IEVL5: POP     P,C             ;C _ FINAL COUNT
+       SUB     P,[1,,1]        ;PITCH SWITCH WORD
+       POPJ    P,\f;THIS FUNCTION PUSHES THE ELEMENTS OF THE STRUCTURE (A,B) ONTO
+;TP; (P) = RETURN ADDRESS; -1(P) = COUNTER (SET UP BY CALLER)
+
+PSHSEG:        MOVEM   A,BSTO(PVP)     ;TYPE FOR AGC
+       GETYP   A,A
+       PUSHJ   P,SAT           ;A _ PRIMITIVE TYPE OF (A,B)
+       CAIN    A,S2WORD        ;LIST?
+       JRST    PSHLST          ;YES-- DO IT!
+       HLRE    C,B             ;MUST BE SOME KIND OF VECTOR OR TUPLE
+       MOVNS   C               ;C _ NUMBER OF WORDS TO DOPE WORD
+       CAIN    A,SNWORD        ;UVECTOR?
+       JRST    PSHUVC          ;YES-- DO IT!!
+       ASH     C,-1            ;NO-- C _ C/2 = NUMBER OF ELEMENTS
+       ADDM    C,-1(P)         ;BUMP COUNTER
+       CAIN    A,S2NWORD       ;VECTOR?
+       JRST    PSHVEC          ;YES-- DO IT!!!
+       CAIE    A,SARGS         ;ARGS TUPLE?
+       JRST    ILLSEG          ;NO-- DO IT!!!!
+       PUSH    TP,BSTO(PVP)    ;YES-- CHECK FOR LEGALITY
+       PUSH    TP,B
+       SETZM   BSTO(PVP)
+       MOVEI   B,-1(TP)        ;B _ ARGS POINTER ADDRESS
+       PUSHJ   P,CHARGS        ;CHECK IT OUT
+       POP     TP,B            ;RESTORE WORLD
+       POP     TP,BSTO(PVP)
+
+PSHVEC:        INTGO
+       JUMPGE  B,SEGDON        ;IF B = [], QUIT
+       PUSH    TP,(B)          ;PUSH NEXT ELEMENT
+       PUSH    TP,1(B)
+       ADD     B,[2,,2]        ;B _ <REST .B>
+       JRST    PSHVEC
+
+PSHUVC:        ADDM    C,-1(P)         ;BUMP COUNTER
+       ADDM    B,C             ;C _ DOPE WORD ADDRESS
+       GETYP   A,(C)           ;A _ UVECTOR ELEMENTS TYPE
+       MOVSI   A,(A)
+PSHUV1:        INTGO
+       JUMPGE  B,SEGDON        ;IF B = ![], QUIT
+       PUSH    TP,A            ;PUSH NEXT ELEMENT WITH TYPE
+       PUSH    TP,(B)
+       ADD     B,[1,,1]        ;B _ <REST .B>
+       JRST    PSHUV1
+
+PSHLST:        INTGO
+       JUMPE   B,SEGDON        ;IF B = (), QUIT
+       GETYP   A,(B)
+       MOVSI   A,(A)           ;PUSH NEXT ELEMENT
+       PUSH    TP,A
+       PUSH    TP,1(B)
+       JSP     E,CHKARG        ;KILL TDEFERS
+       AOS     -1(P)           ;COUNT ELEMENT
+       HRRZ    B,(B)           ;CDR LIST
+       JRST    PSHLST
+
+SEGDON:        SETZM   BSTO(PVP)               ;FIX TYPE
+       POPJ    P,\f;THESE THREE CONSTRUCTOR FUNCTIONS ARE USED
+;TO SIMULATE "VARIABLE BRACKETS"; FOR EXAMPLE, <CONSV ...>
+;MEANS [...].
+
+;LIST CONSTRUCTOR
+
+MFUNCTION CONSL,FSUBR
+       JRST    EVLIST          ;DEGENERATE CASE
+
+;VECTOR CONSTRUCTOR
+
+MFUNCTION CONSV,FSUBR
+       PUSHJ   P,PSHRGL        ;EVALUATE ARGS
+       .ACALL  C,EVECTOR       ;AND CALL EVECTOR ON THEM
+       JRST    FINIS
+
+;UVECTOR CONSTRUCTOR
+
+MFUNCTION CONSU,FSUBR
+       PUSHJ   P,PSHRGL        ;VERY SIMILAR
+       .ACALL  C,EUVECT        ;BUT CALL EUVECT INSTEAD
+       JRST    FINIS\f
+
+;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
+
+APFUNARG:
+       HRRZ    A,@1(TB)        ;GET CDR OF FUNARG
+       JUMPE   A,FUNERR        ;NON -- NIL
+       HLRZ    B,(A)           ;GET TYPE OF CADR
+       CAIE    B,TLIST         ;BETTR BE LIST
+       JRST    FUNERR
+       PUSH    TP,$TLIST       ;SAVE IT UP
+       PUSH    TP,1(A)
+FUNLP:
+       INTGO
+       SKIPN   A,3(TB)         ;ANY MORE
+       JRST    DOF             ;NO -- APPLY IT
+       HRRZ    B,(A)
+       MOVEM   B,3(TB)
+       HLRZ    C,(A)
+       CAIE    C,TLIST
+       JRST    FUNERR
+       HRRZ    A,1(A)
+       HLRZ    C,(A)           ;GET FIRST VAR
+       CAIE    C,TATOM         ;MAKE SURE IT IS ATOMIC
+       JRST    FUNERR
+       PUSH    TP,BNDA         ;SET IT UP
+       PUSH    TP,1(A)
+       HRRZ    A,(A)
+       PUSH    TP,(A)          ;SET IT UP
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+\r      PUSH    TP,[0]
+       PUSH    TP,[0]
+       JRST    FUNLP
+DOF:
+       PUSHJ   P,SPECBIND      ;BIND THEM
+       MOVE    A,1(TB)         ;GET GOODIE
+       HLLZ    B,(A)
+       PUSH    TP,B
+       PUSH    TP,1(A)
+       HRRZ    A,3(TB)         ;A _ ARG LIST
+       PUSH    TP,$TLIST
+       PUSH    TP,A
+       MCALL   2,CONS
+       PUSH    TP,$TFORM
+       PUSH    TP,B
+       MCALL   1,EVAL
+       JRST    FINIS
+\f
+
+;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
+;IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
+; IT IS CALLED BY PUSHJ P,ILOC.  IT CLOBBERS A, B, C, & 0
+
+ILOC:  MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL
+       HRR     A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
+       CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?
+       JRST    SCHSP           ;NO -- SEARCH THE LOCAL BINDINGS
+       MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER
+       POPJ    P,              ;FROM THE VALUE CELL
+
+SCHSP: PUSH    P,0             ;SAVE 0
+       MOVE    C,SP            ;GET TOP OF BINDINGS
+SCHLP: JUMPE   C,NPOPJ         ;IF NO MORE, LOSE
+SCHLP1:        GETYP   0,(C)
+       CAIN    0,TSP           ;INDIRECT LINK TO NEXT BIND BLOCK?
+       JRST    NXVEC2
+       CAMN    B,1(C)          ;FOUND ATOM?
+       JRST    SCHFND
+       HRR     C,(C)           ;FOLLOW CHAIN
+       SUB     C,[6,,0]
+       JRST    SCHLP
+NXVEC2:        MOVE    C,1(C)          ;GET NEXT BLOCK
+       JRST    SCHLP
+
+SCHFND:        EXCH    B,C             ;SAVE THE ATOM PTR IN C
+       ADD     B,[2,,2]        ;MAKE UP THE LOCATIVE
+
+       MOVEM   A,(C)           ;CLOBBER IT AWAY INTO THE
+       MOVEM   B,1(C)          ;ATOM'S VALUE CELL
+SCHPOP:        POP     P,0             ;RESTORE 0
+       POPJ    P,
+
+NPOPJ: POP     P,0             ;RESTORE 0
+UNPOPJ:        MOVSI   A,TUNBOUND
+       MOVEI   B,0
+       POPJ    P,0
+
+;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE 
+;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY
+;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
+
+\rIGLOC:        MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO
+       CAME    A,(B)           ;A PROCESS #0 VALUE?
+       JRST    SCHGSP          ;NO -- SEARCH
+       MOVE    B,1(B)          ;YES -- GET VALUE CELL
+       POPJ    P,
+
+SCHGSP:        MOVE    D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
+
+SCHG1: JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE
+       CAMN    B,1(D)          ;ARE WE FOUND?
+       JRST    GLOCFOUND       ;YES
+       ADD     D,[4,,4]        ;NO -- TRY NEXT
+       JRST    SCHG1
+
+GLOCFOUND:     EXCH    B,D             ;SAVE ATOM PTR
+       ADD     B,[2,,2]        ;MAKE LOCATIVE
+       MOVEM   A,(D)           ;CLOBBER IT AWAY
+       MOVEM   B,1(D)
+       POPJ    P,
+
+
+\f
+
+;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
+;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
+;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL
+
+ILVAL:
+       PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
+CHVAL: CAMN    A,$TUNBOUND     ;BOUND
+       POPJ    P,              ;NO -- RETURN
+       MOVE    A,(B)           ;GET THE TYPE OF THE VALUE
+       MOVE    B,1(B)          ;GET DATUM
+       POPJ    P,
+
+;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
+
+IGVAL: PUSHJ   P,IGLOC
+       JRST    CHVAL
+
+
+\fMFUNCTION BIND,FSUBR
+       ENTRY   1
+       GETYP   A,(AB)
+       CAIE    A,TLIST         ;ARG MUST BE LIST
+       JRST    WTYP
+       SKIPN   C,1(AB)         ;C _ BODY
+       JRST    TFA             ;NON-EMPTY
+       PUSH    TP,$TLIST
+       PUSH    TP,C
+       PUSH    TP,(C)          ;EVAL FIRST ELEMENT
+       HLLZS   (TP)
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       PUSH    TP,A
+       PUSH    TP,B            ;SAVE VALUE
+       GETYP   A,A             ;WHICH MUST BE LIST
+       PUSHJ   P,SAT
+       CAIE    A,S2WORD
+       JRST    WTYP
+       HRRZ    C,-2(TP)        ;C _ <REST .C>
+       HRRZ    C,(C)
+       JUMPE   C,NOBODY        ;MUST NOT BE EMPTY
+       PUSH    TP,(C)          ;EVALUATE FIRST ELEMENT
+       HLLZS   (TP)
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       MOVEI   D,              ;ASSUME AUX
+       PUSH    P,[AUX]
+       GETYP   A,A
+       CAIN    A,TFALSE        ;CAN BE #FALSE OR LIST
+       JRST    DOBI            ;IF <>, AUXILIARY BINDINGS
+       PUSHJ   P,SAT           ;OTHERWISE, TAKE SECOND ARG AS ARGLIST
+       CAIE    A,S2WORD
+       JRST    WTYP
+       MOVEI   D,(B)           ;D _ DECLARATIONS
+       SETZM   (P)             ;CLEAR SWITCHES
+DOBI:  POP     TP,C            ;RESTORE C _ FIRST ARG
+       SUB     TP,[1,,1]
+       MOVEI   0,              ;NO CALL
+       PUSHJ   P,BINDEV
+       HRRZ    C,1(AB)
+       HRRZ    C,(C)
+       HRRZ    C,(C)           ;C _ <REST <REST .ARG>>
+       JRST    BIPROG          ;NOW EXECUTE BODY AS PROG\f;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
+;      ARGUMENTS       AND TEMPORARIES APPROPRIATELY.
+;      
+;      CALL:   PUSHJ   P,BINDER OR BINDRR
+;
+;      BINDER - TAKES SWITCHES AND EVALER AS ARGS ON P
+;
+;      BINDEV - ASSUMES ARGS ARE TO BE EVALED
+;
+;      BINDRR - RESUME HACK - ARGS ON A LIST TO BE 
+;              EVALED IN PARENT PROCESS
+;
+
+;      C/      POINTS TO FUNCTION BEING HACKED
+;      D/      POINTS TO ARG LIST
+;      0/      IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
+;
+;EVALER IS STORED ON THE STACK P AND USED TO EVALUATE ARGS WHEN NEEDED
+EVALER==-1
+
+;SWTCHS,STORED ON THE STACK, HOLDS MANY SWITCHES:
+SWTCHS==-2
+
+OPT==1         ;ON IFF ARGUMENTS MAY BE OMITTED
+QUO==2         ;ON IFF ARGUMENT IS TO BE QUOTED
+AUX==4         ;ON IFF BINDING "AUX" VARS
+H==10          ;ON IFF THERE EXISTS A HEWITT ATOM
+DEF==20                ;ON IFF DEFAULT VALUE OF AN ARG HAS BEEN TAKEN
+STC==40                ;ON IFF "STACK" APPEARS IN DECLARATIONS
+BINDEV:        POP     P,A             ;A _ RETURN ADDRESS
+       PUSH    P,[ARGEV]
+       JRST    BIND1
+BINDRR:        POP     P,A
+       PUSH    P,[NOTIMP]
+BIND1: PUSH    P,A             ;REPUSH ADDRESS
+BINDER:        PUSH    TP,$TLIST
+       PUSH    TP,0            ;SAVE CALL, IF ANY
+       PUSHJ   P,BNDVEC        ;E _ TOP OF BINDING STACK
+       GETYP   A,(C)
+       CAIE    A,TATOM         ;HEWITT ATOM?
+       JRST    BIND2
+       MOVSI   A,TBIND
+       MOVEM   A,-6(B)         ;BUILD BIND BLOCK FOR ATOM
+       MOVE    A,1(C)          ;A _ HEWITT ATOM
+       MOVEM   A,-5(B)
+       MOVE    A,TB
+       HLL     A,OTBSAV(TB)    ;A _ POINTER TO THIS ACTIVATION
+       MOVEM   A,-3(B)
+       MOVEI   0,(PVP)
+       HLRE    A,PVP
+       SUBI    0,-1(A)         ;0 _ PROCESS VEC DOPE WORD
+       HRLI    0,TACT          ;0 IS FIRST WORD OF ACT VALUE
+       MOVEM   0,-4(B)         ;STORED IN BIND BLOCK
+       HRRZ    C,(C)           ;CDR THE FUNCTION
+BIND2: POP     TP,0            ;0 _ CALLING EXPRESSION
+       SUB     TP,[1,,1]
+       PUSHJ   P,CARLST        ;C _ DECLS LIST
+       JRST    BINDC           ;IF (), QUIT
+       MOVE    B,SWTCHS(P)
+       TRNE    B,STC           ;CDR PAST "STACK" IF IT APPEARS
+       HRRZ    C,(C)
+       TRNE    B,AUX
+       JRST    AUXDO           ;IN CASE OF PROG, GO TO AUXDO
+       MOVEI   A,(C)
+       JUMPE   A,BINDC         ;IF NO DECLS, TRY QUITTING
+       PUSHJ   P,NXTDCL        ;B _ NEXT STRING
+       JRST    BINDRG          ;ATOM INSTEAD
+       HRRZ    C,(C)           ;CDR DECLS
+
+
+;CHECK FOR "BIND"
+
+       CAME    B,[ASCII /BIND/ ]
+       JRST    CHCALL
+       JUMPE   C,MPD           ;GOT "BIND", NOW...
+       PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK
+       HRLZI   A,TENV
+       MOVE    B,1(SP)         ;B _ ENV BEFORE BNDVEC
+       PUSHJ   P,PSHBND        ;FINISH BIND BLOCK
+       HRRZ    C,(C)
+       JUMPE   C,BINDC         ;MAY BE DONE
+       MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;NEXT ONE
+       JRST    BINDRG          ;ATOM INSTEAD
+       HRRZ    C,(C)           ;CDR DECLS
+
+;CHECK FOR "CALL"
+
+CHCALL:        CAME    B,[ASCII /CALL/ ]
+       JRST    CHOPTI          ;GO INTO MAIN BINDING LOOP
+       JUMPE   0,MPD           ;GOT "CALL", SO 0 MUST BE CALL
+       JUMPE   C,MPD
+       PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK\f   MOVE    B,0             ;B _ CALL
+       MOVSI   A,TLIST
+       PUSHJ   P,PSHBND        ;MAKE BIND BLOCK
+       HRRZ    C,(C)           ;CDR PAST "CALL" ATOM
+       JUMPE   C,BINDC         ;IF DONE, QUIT
+
+;DECLLP IS THE MAIN BINDING LOOP FOR HANDLING FUNCTIONAL ARGUMENTS AND
+;THE STRINGS SCATTERED THEREIN
+
+DECLLP:        MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;NEXT STRING...
+       JRST    BINDRG          ;...UNLESS SOMETHING ELSE
+       HRRZ    C,(C)           ;CDR DECLARATIONS
+CHOPTI:        TRZ     B,1             ;GOD KNOWS WHY TRZ B,1 (SOMETHING TO DO WITH OPTIO)
+
+;CHECK FOR "OPTIONAL"
+
+       CAME    B,[ASCII /OPTIO/]
+       JRST    CHREST
+       MOVE    0,SWTCHS(P)     ;OPT _ ON
+       TRO     0,OPT
+       MOVEM   0,SWTCHS(P)
+       JUMPE   C,BINDC
+       PUSHJ   P,EBINDS        ;BIND ALL PREVIOUS ARGUMENTS
+       JRST    DECLLP
+
+;CHECK FOR "REST"
+
+CHREST:        MOVE    0,SWTCHS(P)     ;0 _ SWITCHES
+       TRZ     0,OPT           ;OPT _ OFF
+       MOVEM   0,SWTCHS(P)
+       MOVEI   A,(C)
+       CAME    B,[ASCII /REST/]
+       JRST    CHTUPL
+       PUSHJ   P,NXTDCL        ;GOT "REST"-- LOOK AT NEXT THING
+       SKIPN   C
+       JRST    MPD             ;WHICH CAN'T BE STRING
+       PUSHJ   P,BINDB         ;GET NEXT ATOM
+       TRNE    0,QUO           ;QUOTED?
+       JRST    ARGSDO          ;YES-- JUST USE ARGS
+       JRST    TUPLDO
+
+;CHECK FOR "TUPLE"
+
+CHTUPL:        CAME    B,[ASCII /TUPLE/]
+       JRST    CHARG   
+       PUSHJ   P,NXTDCL        ;GOT "TUPLE"-- LOOK AT NEXT THING
+       SKIPN   C
+       JRST    MPD
+       PUSHJ   P,CARATE        ;WHICH BETTER BE ATOM
+
+TUPLDO:        PUSH    TP,$TLIST       ;SAVE STUFF
+       PUSH    TP,C
+       PUSH    TP,$TVEC
+       PUSH    TP,E
+       PUSH    P,[0]           ;ARG COUNTER\f;THIS LOOP BUILDS A TUPLE ON THE STACK, ON THE TOP OF THE ENTITIES
+;JUST SAVED-- DON'T WORRY; THEY'RE SAFE
+
+TUPLP: JUMPE   D,TUPDON        ;IF NO MORE ARGS, DONE
+       INTGO                   ;WATCH OUT FOR BIG TUPLES AND SMALL STACKS
+       PUSH    TP,$TLIST       ;SAVE D
+       PUSH    TP,D
+       GETYP   A,(D)           ;GET NEXT ARG
+       MOVSI   A,(A)
+       PUSH    TP,A            ;EVAL IT
+       PUSH    TP,1(D)
+       TRZ     0,DEF           ;OFF DEFAULT
+       PUSHJ   P,@EVALER-1(P)
+       POP     TP,D            ;RESTORE D
+       SUB     TP,[1,,1]
+       PUSH    TP,A            ;BUILD TUPLE
+       PUSH    TP,B
+       SOS     (P)             ;COUNT ELEMENTS
+       HRRZ    D,(D)           ;CDR THE ARGS
+       JRST    TUPLP
+TUPDON:        PUSHJ   P,MRKTUP        ;MAKE A TUPLE OF (P) ENTRIES
+       SUB     P,[1,,1]        ;FLUSH COUNTER
+       JRST    BNDRST\f;CHECK FOR "ARGS"
+
+CHARG: CAME    B,[ASCII /ARGS/]
+       JRST    CHAUX
+       PUSHJ   P,NXTDCL        ;GOT "ARGS"-- CHECK NEXT THING
+       SKIPN   C
+       JRST    MPD
+       PUSHJ   P,CARATE        ;WHICH MUST BE ATOM
+
+;HERE TO BIND AN ATOM TO THE REMAINING ARGS, UNEVALUATED
+
+ARGSDO:        MOVSI   A,TLIST         ;(A,B) _ CURRENT ARGS LEFT
+       MOVE    B,D
+       MOVEI   D,
+
+;BNDRST COMPLETES THE BIND BLOCK FOR BOTH TUPLES AND ARGS
+
+BNDRST:        PUSHJ   P,PSHBND
+       HRRZ    C,(C)           ;CDR THE DECLS
+       JUMPE   C,BINDC
+       MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;WHAT NEXT?
+       JRST    MPD             ;MUST BE A STRING OR ELSE
+       HRRZ    C,(C)           ;CDR DECLS
+
+;CHECK FOR "AUX"
+
+CHAUX: CAME    B,[ASCII /AUX/]
+       JRST    CHACT
+       JUMPG   D,TMA           ;ARGS MUST BE USED UP BY NOW
+       PUSH    P,C             ;SAVE C ON P (NO GC POSSIBLE)
+       PUSHJ   P,EBIND         ;BIND ALL ARG ATOMS
+       POP     P,C             ;RESTORE C
+
+;HERE FOR AUXIES OF "AUX" OR PROG VARIETY
+
+AUXDO: MOVE    0,SWTCHS(P)
+       TRO     0,AUX\OPT\DEF   ;OPTIONALS OBVIOUSLY ALLOWED
+       MOVEM   0,SWTCHS(P)
+AUXLP: JUMPE   C,BNDHAT        ;IF NO MORE, QUIT
+       MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;GET NEXT DECLARATION STRING
+       JRST    AUXIE           ;INSTEAD, ANOTHER AUXIE-- DO IT
+       HRRZ    C,(C)           ;CDR PAST STRING
+       JRST    CHACT1          ;...WHICH MUST BE "ACT"
+
+;NORMAL AUXILIARY DECLARATION HANDLER
+
+AUXIE: MOVE    0,SWTCHS(P)
+       PUSH    TP,$TLIST       ;SAVE C
+       PUSH    TP,C
+       PUSHJ   P,BINDB         ;PUSH NEXT ATOM ONTO E
+       MOVE    A,$TVEC         ;SAVE E UNDER DEFAULT VALUE
+       EXCH    A,-1(TP)
+       EXCH    E,(TP)
+       PUSH    TP,A            ;(DEFAULT VALUE MUST BE REPUSHED)
+       PUSH    TP,E
+       PUSHJ   P,@EVALER(P)    ;EVAL THE VALUE IT IS TO RECEIVE
+       POP     TP,E            ;RESTORE E
+       SUB     TP,[1,,1]
+       PUSHJ   P,PSHBND        ;COMPLETE BINDING BLOCK WITH VALUE
+       PUSHJ   P,EBIND         ;BIND THE ATOM
+       POP     TP,C            ;RESTORE C
+       SUB     TP,[1,,1]
+       HRRZ    C,(C)           ;CDR THE DECLARATIONS
+       JRST    AUXLP
+\f;"ACT" CAN OCCUR ONLY AT THE END, HEWITT ATOMS NOTWITHSTANDING
+
+CHACT1:        MOVEI   D,              ;MAKE IT CLEAR THAT THERE ARE NO ARGS
+CHACT: CAME    B,[ASCII /ACT/] ;ONLY THING POSSIBLE
+       JRST    MPD
+       JUMPE   C,MPD           ;BETTER HAVE AN ATOM TO BIND TO ACT
+       PUSHJ   P,CARATE        ;START BIND BLOCK WITH IT
+       MOVEI   A,(PVP)
+       HLRE    B,PVP
+       SUBI    A,-1(B)         ;A _ PROCESS VEC DOPE WORD
+       HRLI    A,TACT
+       MOVE    B,TB
+       HLL     B,OTBSAV(TB)    ;(A,B) _ ACTIVATION POINTER
+       PUSHJ   P,PSHBND
+       HRRZ    C,(C)           ;"ACT" MUST HAVE BEEN LAST
+       JUMPN   C,MPD
+
+;AT THIS POINT, ALL ENTRIES ARE FINAL AND ALL THINGS LOOSED
+;IN E SHALL BE BOUND IN E, EVENTUALLY
+
+BINDC: JUMPG   D,TMA           ;ARGS SHOULD BE USED UP BY NOW
+       PUSHJ   P,EBIND         ;BIND EVERYTHING NOT BOUND
+BNDHAT:        MOVE    0,SWTCHS(P)     ;EVEN THE HEWITT ATOM
+       TRNN    0,H             ;IF THERE IS ONE
+       JRST    BNDRET
+       ADD     E,[2,,2]        ;E _ POINTER TO SECOND WORD OF NEXT BLOCK
+       PUSHJ   P,COMBLK        ;CHAIN THIS BLOCK TO PREVIOUS THING IN VECTOR
+       ADD     E,[4,,4]        ;E _ LAST WORD OF BINDING VECTOR
+       PUSHJ   P,EBIND         ;BIND THE HEWITT ATOM
+
+;THIS IS THE WAY OUT OF THE BINDER
+
+BNDRET:        SUB     P,[2,,2]        ;FLUSH EVALER
+       POP     P,A             ;A _ SWITCHES
+       JRST    @3(P)           ;RETURN FROM BINDER\f;TO BIND A PERFECTLY ORDINARY ARGUMENT SPECIFICATION
+;FOUND IN A DECLS LIST, JUMP HERE
+
+BINDRG:        MOVE    0,SWTCHS(P)
+       PUSHJ   P,BINDB         ;GET ATOM IN THE NEXT DECL
+       JUMPE   D,CHOPT3        ;IF ARG EXISTS,
+       TRNE    0,OPT
+       SUB     TP,[2,,2]       ;PITCH ANY DEFAULT THAT MAY EXIST
+       GETYP   A,(D)           ;(A,B) _ NEXT ARG
+       MOVSI   A,(A)
+       MOVE    B,1(D)
+       HRRZ    D,(D)           ;CDR THE ARGS
+       TRZN    0,QUO           ;ARG QUOTED?
+       JRST    BNDRG1          ;NO-- GO EVAL
+CHDEFR:        MOVEM   0,SWTCHS(P)
+       CAME    A,$TDEFER       ;QUOTED-- PUNT ANY TDEFER'S YOU FIND
+       JRST    DCLCDR
+       GETYP   A,(B)           ;(A,B) _ REAL POINTER, NOT DEFERRED
+       MOVE    B,1(B)
+       JRST    DCLCDR          ;AND FINISH BIND BLOCK
+
+;OPTIONAL ARGUMENT?
+
+CHOPT3:        TRNN    0,OPT           ;IF NO ARG, BETTER BE OPTIONAL
+       JRST    TFA
+       POP     TP,B            ;(A,B) _ DEFAULT VALUE
+       POP     TP,A
+       TRZE    0,QUO           ;IF QUOTED,
+       JRST    CHDEFR          ;JUST PUSH
+       TRO     0,DEF           ;ON DEFAULT
+
+;EVALUATE WHATEVER YOU HAVE AT THIS POINT
+
+BNDRG1:        PUSH    TP,$TLIST       ;SAVE STUFF
+       PUSH    TP,D
+       PUSH    TP,$TLIST
+       PUSH    TP,C
+       PUSH    TP,$TVEC
+       PUSH    TP,E
+       PUSH    TP,A
+       PUSH    TP,B
+       PUSHJ   P,@EVALER(P)    ;(A,B) _ <EVAL (A,B)>
+       MOVE    E,(TP)          ;RESTORE C, D, & E
+       MOVE    C,-2(TP)
+       MOVE    D,-4(TP)
+       SUB     TP,[6,,6]
+       MOVE    0,SWTCHS(P)     ;RESTORE 0
+
+
+;FINISH THE BIND BLOCK WITH (A,B) AND GO ON
+
+DCLCDR:        PUSHJ   P,PSHBND
+       TRNE    0,OPT           ;IF OPTIONAL,
+       PUSHJ   P,EBINDS        ;BIND IT
+       HRRZ    C,(C)
+       JUMPE   C,BINDC         ;IF NO MORE DECLS, QUIT
+       JRST    DECLLP\f;THIS ROUTINE CREATES THE BIND BLOCK BINDER USES; IT ALLOCATES
+;THREE SLOTS PER NON-STRING DECLARATION (I.E., ATOM TO BE BOUND),
+;THREE FOR A HEWITT ATOM IF IT FINDS ONE, AND ONE FOR THE ACCESS
+;TYPE-TSP POINTER TO SP.
+
+;THE BLOCK IS ALLOCATED AS A TUPLE IF "STACK" APPEARS
+;FIRST IN THE DECLARATIONS, AS A VECTOR OTHERWISE
+
+
+;BNDVEC SETS E TO THE CURRENT TOP OF THE BLOCK; IT FILLS IN
+;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
+;THE START OF THIS BLOCK.  IT SETS B TO POINT TO THE DOPE CELL 
+;OF THE TUPLE OR VECTOR.  IT MAY SET SWITCHES H OR STC TO ON,
+;IFF IT FINDS A HEWITT ATOM OR A "STACK".  IT CLOBBERS A,
+;RESTORES C & D, AND LEAVES THE SWITCHES IN 0
+
+;IF BNDVEC FINDS NO DECLARATIONS, IT TAKES THE LIBERTY OF EXITING
+;FROM THE BINDER WITHOUT DISTURBING SP.  BNDVEC DOES SOME ERROR
+;CHECKING, BUT NOT ALL, AS IT DOES NOT LOOK AT THE ARGS IN D.
+;THIS EXPLAINS WHY BINDER OMITS SOME.
+
+BNDVEC:        PUSH    TP,$TLIST       ;SAVE C & D
+       PUSH    TP,C
+       PUSH    TP,$TLIST
+       PUSH    TP,D
+       JUMPE   C,NOBODY
+       MOVE    0,SWTCHS-1(P)   ;UNBURY THE SWITCHES
+       MOVEI   D,              ;D = COUNTER _ 0
+       GETYP   A,(C)           ;A _ FIRST THING
+       CAIE    A,TATOM         ;HEWITT ATOM?
+       JRST    NOHATM
+       TRO     0,H             ;TURN SWITCH H ON
+       ADDI    D,3             ;YES-- SAVE 3 SLOTS FOR IT
+       HRRZ    C,(C)           ;CDR THE FUNCTION
+       JUMPE   C,NOBODY
+NOHATM:        PUSHJ   P,CARLST        ;C _ <1 .C>
+       JRST    CNTRET          ;IF (), ALL COUNTED
+       MOVEI   A,(C)           ;A _ DECLS
+       PUSHJ   P,NXTDCL        ;LOOK FOR "STACK"
+       JRST    DINC            ;NO STRING
+       TRZ     B,1
+       CAMN    B,[ASCII /STACK/]
+       TRO     0,STC           ;TURN ON STACK SWITCH
+
+;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
+
+DCNTLP:        HRRZ    A,(A)           ;CDR DECLS
+       JUMPE   A,CNTRET        ;IF NO MORE, DONE
+       PUSHJ   P,NXTDCL        ;SKIP IF NEXT ONE IS A STRING
+DINC:  ADDI    D,3             ;3 SLOTS FOR AN ATOM
+       JRST    DCNTLP
+
+;IF ANYTHING WAS FOUND, INITIALIZE THE VECTOR
+
+CNTRET:        JUMPE   D,NODCLS        ;OTHERWISE, BIND NOTHING
+       AOJ     D,              ;DON'T FORGET ACCESS SLOT
+       MOVEM   0,SWTCHS-1(P)   ;SAVE SWITCHES
+       TRNE    0,STC           ;FOUND "STACK"?
+       JRST    TUPBND
+       PUSH    TP,$TFIX
+       PUSH    TP,D
+       MCALL   1,VECTOR        ;B _ <VECTOR .D>
+       MOVE    E,B             ;FROM NOW ON, E _ BIND VECTOR TOP
+       HLRE    C,B
+       SUB     B,C             ;B _ VECTOR DOPE CELL ADDRESS
+SETSP: MOVE    A,E
+       MOVSI   0,TSP
+       MOVEM   0,(E)           ;FILL ACCESS SLOT
+       PUSH    E,SP
+       MOVE    SP,A            ;SP NOW POINTS THROUGH THIS VECTOR
+       MOVE    D,(TP)          ;RESTORE C & D
+       MOVE    C,-2(TP)
+       SUB     TP,[4,,4]
+       POPJ    P,
+
+;IF THERE ARE NO DECLS (E.G. <FUNCTION ()...>), JUST QUIT
+
+NODCLS:        MOVE    D,(TP)          ;RESTORE C & D
+       MOVE    C,-2(TP)
+       SUB     TP,[6,,6]
+       SUB     P,[1,,1]        ;PITCH RETURN ADDRESS
+       JRST    BNDRET\f;HERE TO BIND BUGGERS ON STACK
+
+TUPBND:        LSH     D,1             ;D _ 2*NUMBER OF CELLS
+       MOVN    C,D             ;SAVE -D ON P
+       PUSH    P,C
+       ADDI    D,2             ;2 MORE FOR TTB MARKER
+       HRLI    D,(D)
+       MOVE    C,TP
+       ADD     TP,D            ;TP _ ADDRESS OF LAST TUPLE WORD
+       ADD     C,[1,,1]        ;C _ ADDRESS OF FIRST WORD OF TUPLE
+       MOVSI   0,TTP
+       MOVEM   0,CSTO(PVP)     ;IN CASE OF GC
+       SETZM   (C)             ;ZERO IT
+       MOVE    D,C
+       HRLI    D,(D)
+       ADDI    D,1             ;ZERO ENTIRE TUPLE SPACE
+       HRRZI   E,(TP)          ;BUT--
+       HLRE    B,TP            ;   IF TP BLOWN,
+       SKIPLE  B               ;    ZERO ONLY UP TO END OF PDL
+       SUBI    E,1(B)
+       BLT     D,(E)
+       SKIPL   TP              ;IF BLOWN,
+       PUSHJ   P,NBLOTP        ;NOW SAFE TO UNBLOW IT
+       SETZM   CSTO(PVP)
+       MOVEI   D,-5(TP)
+       HRLI    D,-6(C)
+       BLT     D,(TP)          ;MOVE SAVED 0, C & D TO TOP OF STACK
+       POP     P,D
+       HRLI    D,TTB           ;D _ [TTB,,-LENGTH]
+       MOVEI   B,-7(TP)        ;B _ POINTER TO TUPLE DOPE CELL
+       MOVEM   D,(B)
+       MOVEM   TB,1(B) ;FENCEPOST TUPLE
+       MOVE    E,C             ;E _ POINTER TO TUPLE START
+       SUB     E,[6,,6]        ;     ON TP STACK
+       HLRE    D,C
+       SUB     C,D             ;C = DOPE WORD POINTER?
+       CAME    C,TPGROW"
+       ADD     E,[-PDLBUF,,0]  ;MAKE E TRUE VECTOR POINTER
+       JRST    SETSP\f;THIS ROUTINE CREATES A POINTER TO THE TUPLE RESTING ON TOP OF
+;TP.  IT TAKES ITS NEGATIVE LENGTH (IN CELLS) IN (P).  IT ASSUMES
+;THERE ARE TWO TEMPORARY CELLS BENEATH IT, AND RESTORES
+;THEM INTO C AND E, MOVING THE TUPLE OVER THE TEMPORARY
+;SLOTS.  IT RETURNS A CORRECT TARGS POINTER TO THE TUPLE IN A AND B
+
+MRKTUP:        MOVSI   A,TTB           ;FENCE-POST TUPLE
+       PUSH    TP,A
+       PUSH    TP,TB
+       MOVEI   A,2             ;B_ADDRESS OF INFO CELL
+       PUSHJ   P,CELL"         ;MAY CALL AGC
+       MOVSI   A,TINFO
+       MOVEM   A,(B)
+       MOVEI   A,(TP)          ;GENERATE DOPE WORD POINTER
+       HLRE    C,TP
+       SUBI    A,-1(C)
+       CAME    A,TPGROW"       ;ALLOWING FOR BLOWN PDL
+       ADDI    A,PDLBUF
+       HRLZI   A,-1(A)         ;A HAS 1ST DW PTR IN LEFT HALF
+       HLR     A,OTBSAV(TB)    ;TIME TO RIGHT
+       MOVEM   A,1(B)          ;TO SECOND WORD OF CELL
+       EXCH    B,-1(P)         ;B _ - ARG COUNT
+       ASH     B,1             ;B _ 2*B
+       HRRM    B,-1(TP)        ;STORE IN TTB FENCEPOST
+       HRRZI   A,-5(TP)
+       ADD     A,B             ;A _ ADR OF TUPLE
+       HRLI    A,(B)           ;A _ TUPLE POINTER
+       MOVE    B,A             ;B, TOO
+       HRLI    A,4(A)          ;LH A _ CURRENT PLACE OF TUPLE
+       MOVE    C,1(A)          ;RESTORE C AND E
+       MOVE    E,3(A)
+       BLT     A,-4(TP)        ;MOVE TUPLE OVER OLD C, E COPIES
+       SUB     TP,[4,,4]
+       MOVE    A,-1(P)
+       HRLI    A,TARGS         ;A _ FIRST WORD OF ARGS TUPLE VALUE
+       POPJ    P,\f;THIS ROUTINE, GIVEN SWTCHS IN 0 AND DECLARATIONS LIST POINTER
+;IN C, PUSHES ATOM IN THE FIRST DECLARATION ONTO E.  IT MAY SET
+;SWITCHES OPT AND QUO, AND LEAVES SWITCHES IN 0.    IFF OPT = ON,
+;BINDB PUSHES A DEFAULT VALUE (EVEN IF ?()) ONTO TP.  A & B ARE
+;CLOBBERED.  C IS NOT ALTERED.
+
+BINDB: MOVE    A,C             ;A _ C
+       GETYP   B,(A)
+       CAIE    B,TLIST         ;A = ((...)...) ?
+       JRST    CHOPT1
+       TRNN    0,OPT           ;YES-- OPT MUST BE ON
+       JRST    MPD
+       MOVEM   0,SWTCHS-1(P)   ;SAVE SWITCHES
+       MOVE    A,1(A)          ;A _ <1 .A> = (...)
+       JUMPE   A,MPD           ;A = () NOT ALLOWED
+       HRRZ    B,(A)           ;B _ <REST .A>
+       JUMPE   B,MPD           ;B = () NOT ALLOWED
+       PUSH    TP,(B)          ;SAVE <1 .B> AS DEFAULT
+       PUSH    TP,1(B)         ;VALUE OF ATOM IN A
+       HRRZ    B,(B)
+       JUMPN   B,MPD           ;<REST .B> MUST = ()
+       GETYP   B,(A)
+       JRST    CHFORM          ;GO SEE WHAT <1 .A> IS
+
+CHOPT1:        TRNN    0,OPT           ;IF OPT = ON
+       JRST    CHFORM
+       PUSH    TP,$TUNAS       ;DEFAULT VALUE IS ?()
+       PUSH    TP,[0]
+
+;AT THIS POINT, <1 .A> MUST BE ATOM OR <QUOTE ATOM>
+
+CHFORM:        TRNE    0,AUX           ;NO QUOTES ALLOWED IN AUXIES
+       JRST    CHATOM
+       CAIE    B,TFORM
+       JRST    CHATOM
+       MOVE    A,1(A)          ;A _ <1 .A> = <...>
+       JUMPE   A,MPD           ;A = <> NOT ALLOWED
+       MOVE    B,1(A)          ;B _ <1 .A>
+       CAME    B,MQUOTE QUOTE
+       JRST    MPD             ;ONLY A = <QUOTE...> ALLOWED
+       TRO     0,QUO           ;QUO _ ON
+       MOVEM   0,SWTCHS-1(P)
+       HRRZ    A,(A)           ;A _ <REST .A>
+       JUMPE   A,MPD           ;<QUOTE> NOT ALLOWED
+       GETYP   B,(A)
+
+;AT THIS POINT WE HAVE THE ATOM OR AN ERROR
+
+CHATOM:        CAIE    B,TATOM         ;<1 .A> MUST BE ATOM
+       JRST    MPD
+       MOVE    A,1(A)          ;A _ THE ATOM!!!
+       JRST    PSHATM          ;WHICH MUST BE PUSHED ONTO E
+
+
+
+;THE FOLLOWING LITTLE ROUTINE ACCEPTS THE NEXT DECLARATION ONLY
+;IF IT IS ATOMIC, AND PUSHES IT ONTO E
+
+CARATE:        GETYP   A,(C)
+       CAIE    A,TATOM
+       JRST    MPD
+       MOVE    A,1(C)          ;A _ ATOM
+       MOVE    0,SWTCHS-1(P)
+PSHATM:        PUSH    E,$TBIND        ;FILL FIRST TWO SLOTS OF BIND BLOCK
+       PUSH    E,A
+
+;EACH BIND BLOCK MUST POINT TO THE PREVIOUS ONE OR TO AN ACCESS
+;POINTER TO ANOTHER VECTOR ALTOGETHER.  COMBLK MAKES SURE IT DOES.
+
+COMBLK:        GETYP   B,-7(E)         ;LOOK FOR PREVIOUS BIND
+       CAIE    B,TBIND         ;IF FOUND, MAKE NORMAL LINK
+       JRST    ABNORM          
+       MOVEI   B,-7(E)         ;IN MOST CASES, SEVEN
+MAKLNK:        HRRM    B,-1(E)         ;MAKE THE LINK
+       POPJ    P,
+ABNORM:        MOVEI   B,-3(E)
+       JRST    MAKLNK
+\f;THIS ROUTINE COMPLETES A BIND BLOCK BEGUN BY CARATE OR BINDB
+;WITH THE VALUE (A,B)
+
+PSHBND:        PUSH    E,A
+       PUSH    E,B
+       ADD     E,[2,,2]        ;ASSUME BIND VECTOR IS FULL OF 0'S
+       POPJ    P,
+
+;THIS ONE DOES AN EBIND, SAVING C & D:
+
+EBINDS:        PUSH    P,C             ;SAVE C & D (NO DANGER OF GC)
+       PUSH    P,D
+       PUSHJ   P,EBIND         ;BIND ALL NON-OPTIONAL ARGUMENTS
+       POP     P,D
+       POP     P,C             ;RESTORE C & D
+       POPJ    P,
+
+
+;THE FOLLOWING RETURNS THE CAR OF C IN C, SKIPPING IF 
+;<EMPTY? <1 .C>>, AND ERRING IF <NOT <==? <TYPE <1 .C>> LIST>>
+
+CARLST:        GETYP   A,(C)
+       CAIE    A,TLIST
+       JRST    MPD             ;NOT A LIST, FATAL
+       SKIPE   C,1(C)
+       AOS     (P)
+       POPJ    P,
+
+
+;...AND THERE ARE A FEW PEOPLE STILL CALLING THE FOLLOWING:
+
+MAKENV:        PUSH    P,C             ;SAVE AN AC
+       HLRE    C,PVP           ;GET -LNTH OF PROC VECTOR
+       MOVEI   A,(PVP)         ;COPY PVP
+       SUBI    A,-1(C)         ;POINT TO DOPWD WITH A
+       HRLI    A,TFRAME        ;MAKE INTO A FRAME
+       HLL     B,OTBSAV(B)     ;TIME TO B
+       POP     P,C
+       POPJ    P,
+
+
+
+\f;THESE ROUTINES ARE CALLED TO EVALUATE THE VALUE PUSHED
+;ON TP    ****THEY ARE ASSUMED TO CLOBBER EVERYTHING****
+
+ARGEV: JSP     E,CHKARG
+       MCALL   1,EVAL
+       POPJ    P,
+
+
+
+
+;WHEN APPLY-ING, ARGS ARE ALREADY EVALUATED
+
+ARGNEV:        JSP     E,CHKARG        ;PITCH ANY TDEFERS
+       TRNN    0,DEF           ;DEFAULT VALUES...
+       JRST    NOEV
+       MCALL   1,EVAL          ;...ARE ALWAYS EVALUATED
+       POPJ    P,
+NOEV:  POP     TP,B            ;OTHERWISE,
+       POP     TP,A            ;JUST RESTORE A&B
+       POPJ    P,\f;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
+;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.  
+;EACH TRIPLET IS AS FOLLOWS:
+;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
+;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
+;AND THE THIRD IS A PAIR OF ZEROES.
+;FOR ENTRY SPECB1, REGISTER 0 CONTAINS SWITCHES.  ONLY RELEVANT ONE
+;IS STC.
+
+
+BNDA:  TATOM,,-1
+
+SPECBIND:      MOVEI   0,              ;DEFAULT IS STC _ OFF
+SPECB1:        MOVE    E,TP            ;GET THE POINTER TO TOP
+       ADD     E,[1,,1]        ;BUMP POINTER ONCE
+       MOVEI   B,              ;ZERO COUNTER
+       MOVE    D,E
+SZLOOP:        MOVE    A,-6(D)         ;COUNT ATOM BLOCKS AS 3
+       CAME    A,BNDA
+       JRST    GETVEC
+       SUB     D,[6,,6]        ;D _ ADDRESS OF BOTTOM BLOCK
+       ADDI    B,3
+       JRST    SZLOOP
+GETVEC:        JUMPE   B,DEGEN
+       TRNE    0,STC           ;IF STC IS ON,
+       JRST    TPSPCB          ;    LEAVE BLOCKS ON TP
+       PUSH    P,B
+       AOJ     B,
+       PUSH    TP,$TTP
+       PUSH    TP,E
+       PUSH    TP,$TTP
+       PUSH    TP,D
+       PUSH    TP,$TFIX
+       PUSH    TP,B
+       MCALL   1,VECTOR        ;<VECTOR .B>
+       POP     TP,D            ;RESTORE D = POINTER TO BOTTOM TRIPLE
+       SUB     TP,[1,,1]
+       MOVE    A,$TSP          ;MAKE THIS BLOCK POINT TO PREVIOUS
+       MOVEM   A,(B)
+       MOVEM   SP,1(B)
+       ADDI    B,2
+
+;MOVE TRIPLES TO VECTOR
+
+       POP     P,E             ;E _ LENGTH  - 1
+       ASH     E,1             ;TIMES 2
+       ADDI    E,(B)           ;E _ POINTER TO VECTOR DOPE WORD
+       HRLI    A,(D)
+       HRRI    A,(B)
+       BLT     A,-1(E)         ;MOVE BIND TRIPLES TO VECTOR
+
+;CHANGE ALL [TATOM,,-1]'S TO [TBIND,,LINK TO PREVIOUS BLOCK]
+
+       HRRZI   B,(B)           ;ZERO LEFT HALF OF B
+       HRRI    C,-2(B)         ;C = LINK _ ADR OF FIRST OF VECTOR
+       PUSH    P,[POPOFF]
+LNKBLK:        HRLI    C,TBIND
+FIXLP: MOVEM   C,(B)           ;STORE LINK TO PREVIOUS BLOCK IN BLOCK B
+       HRRI    C,(B)           ;C _ LINK TO THIS BLOCK
+       ADDI    B,6
+       CAIE    B,(E)           ;GOT TO DOPE WORD?
+       JRST    FIXLP
+       POPJ    P,
+
+;CLEAN UP TP
+
+POPOFF:        POP     TP,C
+       SUB     TP,[1,,1]
+       CAMLE   C,TP            ;ANYTHING ABOVE TRIPLES?
+       JRST    NOBLT2
+       SUBI    TP,(C)          ;TP _ NUMBER THERE
+       HRLS    TP              ;IN BOTH HALVES
+       ADD     TP,D            ;NEW TP
+       HRLI    D,(C)
+       BLT     D,(TP)          ;BLLLLLLLLT!
+       JRST    SPCBE2
+DEGEN: SUB     TP,[2,,2]
+       POPJ,
+NOBLT2:        MOVE    TP,D            ;OR JUST RESTORE IT
+       SUB     TP,[1,,1]
+       JRST    SPCBE2
+
+;HERE TO JUST BIND THE LOSERS ON THIS STACK
+
+TPSPCB:        AOJ     B,
+       PUSH    TP,$TSP         ;PUSH ACCESS POINTER
+       MOVE    E,TP
+       PUSH    TP,SP
+       LSH     B,1
+       MOVN    B,B             ;B _ -2B
+       HRLI    B,TTB
+       PUSH    TP,B            ;FENCEPOST BIND TRIPLES AS TUPLE
+       PUSH    TP,TB
+       HRRZ    B,D
+       HRRI    C,-3(TP)
+       PUSHJ   P,LNKBLK        ;LINK BIND BLOCKS TOGETHER
+       HLRE    C,D             ;MAKE E A REAL VECTOR POINTER
+       SUB     D,C
+       CAME    C,TPGROW"       ;BY FINDING REAL DOPE WORD
+       ADD     E,[-PDLBUF,,0]
+
+\f;HERE TO BIND EVERYTHING IN BLOCK WITH DOPE WORD (E)
+
+SPCBE2:        SUB     E,[1,,1]        ;E _ LAST WORD OF LAST BLOCK
+
+;EBIND BINDS THE ATOMS SPECIFIED BY THE BLOCK WHOSE LAST WORD
+;E POINTS TO, THEN THE BLOCK LINKED TO IT, ETC., UNTIL
+;IT FINDS ONE ALREADY BOUND, WHEN IT RESTORES E AND EXITS.
+;IT RESETS SP TO POINT TO THE FIRST ONE BOUND.  IT CLOBBERS
+;ALL OTHER REGISTERS
+
+EBIND: HLRZ    A,-1(E)
+       SKIPE   A               ;ALREADY BOUND?
+       POPJ    P,              ;YES-- EBIND IS A NO-OP
+       MOVEI   D,              ;D WILL BE THE NEW SP
+       PUSH    P,E             ;SAVE E
+       JRST    DOBIND
+
+BINDLP:        HLRZ    A,-1(E)
+       SKIPE   A               ;HAS THIS BLOCK BEEN BOUND ALREADY?
+       JRST    SPECBD          ;YES, RESTORE AND QUIT
+DOBIND:        SUB     E,[6,,6]
+       SKIPN   D               ;HAS NEW SP ALREADY BEEN SET?
+       MOVE    D,E             ;NO, SET TO THIS BLOCK FOR NOW
+       MOVE    A,1(E)
+       MOVE    B,2(E)
+       PUSHJ   P,ILOC          ;(A,B) _ LOCATIVE OF (A,B)
+       HLR     A,OTBSAV(TB)
+       MOVEM   A,5(E)          ;CLOBBER IT AWAY
+       MOVEM   B,6(E)          ;IN RESTORE CELLS
+
+       HRRZ    A,PROCID+1(PVP) ;GET PROCESS NUMBER
+       HRLI    A,TLOCI         ;MAKE LOC PTR
+       MOVE    B,E             ;TO NEW VALUE
+       ADD     B,[3,,3]
+       MOVE    C,2(E)          ;GET ATOM PTR
+       MOVEM   A,(C)           ;CLOBBER ITS VALUE
+       MOVEM   B,1(C)          ;CELL
+       JRST    BINDLP
+
+SPECBD:        MOVE    SP,D            ;SP _ D
+       ADD     SP,[1,,1]       ;FIX SP
+       POP     P,E             ;RESTORE E TO TOP OF BIND VECTOR
+       POPJ    P,
+
+\f
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN 
+;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+       MOVE    E,SPSAV (TB)    ;GET TARGET POINTER
+SPCSTE:        HRRZ    SP,SP           ;CLEAR LEFT HALF OF SP
+STLOOP:
+       CAIN    SP,(E)          ;ARE WE DONE?
+       JRST    STPOPJ
+       HLRZ    C,(SP)          ;GET TYPE OF BIND
+       CAIE    C,TBIND         ;NORMAL IDENTIFIER?
+       JRST    JBVEC           ;NO-- FIND & FOLLOW REBIND POINTER
+
+
+       MOVE    C,1(SP)         ;GET TOP ATOM
+       MOVE    D,4(SP)         ;GET STORED LOCATIVE
+\r      HRR     D,PROCID+1(PVP) ;STORE SIGNATURE
+       MOVEM   D,(C)           ;CLOBBER INTO ATOM
+       MOVE    D,5(SP)
+       MOVEM   D,1(C)
+       HRRZS   4(SP)           ;NOW LOOKS LIKE A VIRGIN BLOCK
+       SETZM   5(SP)
+       HRRZ    SP,(SP)         ;GET NEXT BLOCK
+       JRST    STLOOP
+
+;IN JUMPING TO A NEW BIND VECTOR, FOLLOW
+;REBIND POINTER IF IT DIFFERS FROM ACCESS POINTER
+
+JBVEC: CAIE    C,TSP           ;THIS JUST BETTER BE TRUE, THAT'S ALL
+       .VALUE  [ASCIZ /BADSP/]
+       GETYP   D,2(SP)         ;REBIND POINTER?
+       CAIE    D,TSP
+       JRST    XCHVEC          ;NO-- USE ACCESS
+       MOVE    D,5(SP)         ;YES-- RESTORE PROCID
+       EXCH    D,PROCID+1(PVP)
+       MOVEM   D,5(SP)         ;SAVING CURRENT ONE FOR LATER FAILURES
+       ADD     SP,[2,,2]
+
+;IF WE JUST RAN OFF THE END OF THE ENVIRONMENT CHAIN, BARF
+
+XCHVEC:        HRRZ    SP,1(SP)
+       JUMPN   SP,STLOOP
+       JUMPE   E,STPOPJ        ;UNLESS THAT'S AS FAR AS WE WANTED TO GO
+       .VALUE  [ASCIZ /SPOVERPOP/]
+
+STPOPJ:
+       MOVE    SP,E
+       POPJ    P,
+
+
+\f
+
+MFUNCTION REP,FSUBR,[REPEAT]
+       JRST    PROG
+MFUNCTION PROG,FSUBR
+       ENTRY   1
+       GETYP   A,(AB)          ;GET ARG TYPE
+       CAIE    A,TLIST         ;IS IT A LIST?
+       JRST    WTYP            ;WRONG TYPE
+       SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT
+       JRST    ERRTFA          ;TOO FEW ARGS
+       PUSH    TP,$TLIST       ;PUSH GOODIE
+       PUSH    TP,C
+BIPROG:        PUSH    TP,$TLIST
+       PUSH    TP,C            ;SLOT FOR WHOLE BODY
+       MOVE    C,3(TB)         ;PROG BODY
+       MOVEI   D,
+       PUSH    P,[AUX]         ;TELL BINDER WE ARE APROG
+       PUSHJ   P,BINDEV
+       HRRZ    C,3(TB)         ;RESTORE PROG
+       TRNE    A,H             ;SKIP IF NO NAME ALA HEWITT
+       HRRZ    C,(C)
+       JUMPE   C,NOBODY
+       MOVEM   C,3(TB)         ;SAVE FOR AGAIN, ETC.
+       MOVE    0,A             ;SWITCHES TO 0
+BLPROG:        PUSHJ   P,PROGAT        ;BIND OBSCURE ATOM
+       MOVE    C,3(TB)
+STPROG:        HRRZ    C,(C)           ;SKIP DCLS
+       JUMPE   C,NOBODY
+
+; HERE TO RUN PROGS FUNCTIONS ETC.
+
+DOPROG:
+       HRRZM   C,1(TB)         ;CLOBBER AWAY BODY
+       PUSH    TP,(C)          ;EVALUATE THE
+       HLLZS   (TP)
+       PUSH    TP,1(C)         ;STATEMENT
+       JSP     E,CHKARG
+       MCALL   1,EVAL  
+       HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY
+       JUMPN   C,DOPROG        ;IF MORE -- DO IT
+ENDPROG:
+       HRRZ    C,FSAV(TB)
+       MOVE    C,@-1(C)
+       CAME    C,MQUOTE REP,REPEAT
+       JRST    FINIS
+       SKIPN   C,3(TB)         ;CHECK IT
+       JRST    FINIS
+       MOVEM   C,1(TB)
+       JRST    CNTIN2
+
+;HERE TO BIND PROG ATOM (AND ANYTHING ELSE ON STACK)
+
+PROGAT:        PUSH    TP,BNDA
+       PUSH    TP,MQUOTE [LPROG ],INTRUP
+       MOVE    B,TB
+       PUSHJ   P,MAKENV                ;B _ POINTER TO CURRENT FRAME
+       PUSH    TP,A
+       PUSH    TP,B
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       JRST    SPECB1\f
+
+MFUNCTION RETURN,SUBR
+       ENTRY   1
+       PUSHJ   P,PROGCH        ;CKECK IN A PROG
+       PUSHJ   P,SAVE          ;RESTORE PROG'S FRAME, BCKTRKING IF NECESSARY
+       MOVE    A,(AB)
+       MOVE    B,1(AB)
+       JRST    FINIS
+
+
+MFUNCTION AGAIN,SUBR
+       ENTRY   
+       HLRZ    A,AB            ;GET # OF ARGS
+       CAIN    A,-2            ;1 ARG?
+       JRST    NLCLA           ;YES
+       JUMPN   A,WNA           ;0 ARGS?
+       PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG
+       JRST    AGAD
+NLCLA: HLRZ    A,(AB)
+       CAIE    A,TACT
+       JRST    WTYP
+       MOVE    A,1(AB)
+       HRR     B,A
+       HLL     B,OTBSAV (B)
+       HRRZ    C,A
+       CAIG    C,1(TP)
+       CAME    A,B
+       JRST    ILLFRA
+       HLRZ    C,FSAV (C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+AGAD:  PUSHJ   P,SAVE          ;RESTORE FRAME TO REPEAT
+       MOVE    B,3(TB)
+       MOVEM   B,1(TB)
+       JRST    CNTIN2
+
+MFUNCTION GO,SUBR
+       ENTRY   1
+       PUSHJ   P,PROGCH        ;CHECK FOR A PROG
+       PUSH    TP,A            ;SAVE
+       PUSH    TP,B
+       MOVE    A,(AB)
+       CAME    A,$TATOM
+       JRST    NLCLGO
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+       PUSH    TP,2(B)
+       PUSH    TP,3(B)
+       MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?
+       JUMPE   B,NXTAG         ;NO -- ERROR
+FNDGO: EXCH    B,(TP)          ;SAVE PLACE TO GO
+       MOVSI   D,TLIST
+       MOVEM   D,-1(TP)
+       JRST    GODON
+
+NLCLGO:        CAME    A,$TTAG         ;CHECK TYPE
+       JRST    WTYP
+       MOVE    A,1(AB)         ;GET ARG
+       HRR     B,3(A)
+       HLL     B,OTBSAV(B)
+       HRRZ    C,B
+       CAIG    C,1(TP)
+       CAME    B,3(A)          ;CHECK TIME
+       JRST    ILLFRA
+       HLRZ    C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       PUSH    TP,(A)          ;SAVE BODY
+       PUSH    TP,1(A)
+GODON: PUSHJ   P,SAVE          ;GO BACK TO CORRECT FRAME
+       MOVE    B,(TP)          ;RESTORE ITERATION MARKER
+       MOVEM   B,1(TB)
+       MOVE    A,(AB)
+       MOVE    B,1(AB)
+       JRST    CNTIN2
+
+\f
+
+
+MFUNCTION TAG,SUBR
+       ENTRY   1
+       HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
+       CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM
+       JRST    WTYP
+       PUSHJ   P,PROGCH        ;CHECK PROG
+       PUSH    TP,A            ;SAVE VAL
+       PUSH    TP,B
+       PUSH    TP,0(AB)
+       PUSH    TP,1(AB)
+       PUSH    TP,2(B)
+       PUSH    TP,3(B)
+       MCALL   2,MEMQ
+       JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR
+       EXCH    A,-1(TP)        ;SAVE PLACE
+       EXCH    B,(TP)  
+       PUSH    TP,A            ;UNDER PROG FRAME
+       PUSH    TP,B
+       MCALL   2,EVECTOR
+       MOVSI   A,TTAG
+       JRST    FINIS
+
+PROGCH:        MOVE    B,MQUOTE [LPROG ],INTRUP
+       PUSHJ   P,ILVAL         ;GET VALUE
+       GETYP   C,A
+       CAIE    C,TFRAME
+       JRST    NXPRG
+       MOVE    C,B             ;CHECK TIME
+       HLL     C,OTBSAV(B)
+       CAME    C,B
+       JRST    ILLFRA
+       HRRZI   C,(B)           ;PLACE
+       CAILE   C,1(TP)
+       JRST    ILLFRA
+       GETYP   C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       POPJ    P,
+
+MFUNCTION EXIT,SUBR
+       ENTRY   2
+       PUSHJ   P,TILLFM        ;TEST FRAME
+       PUSHJ   P,SAVE          ;RESTORE FRAME
+       JRST    EXIT2
+
+;IF GIVEN, RETURN SECOND ARGUMENT
+
+RETRG2:        MOVE    A,2(AB)
+       MOVE    B,3(AB)
+       MOVE    AB,ABSAV(TB)    ;IN CASE OF GC
+       JRST    FINIS
+
+MFUNCTION COND,FSUBR
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP
+       PUSH    TP,(AB)
+       PUSH    TP,1(AB)                ;CREATE UNNAMED TEMP
+CLSLUP:        SKIPN   B,1(TB)         ;IS THE CLAUSELIST NIL?
+       JRST    IFALSE          ;YES -- RETURN NIL
+       HLRZ    A,(B)           ;NO -- GET TYPE OF CAR
+       CAIE    A,TLIST         ;IS IT A LIST?
+       JRST    BADCLS          ;
+       MOVE    A,1(B)          ;YES -- GET CLAUSE
+       JUMPE   A,BADCLS
+       PUSH    TP,(A)          ;EVALUATION OF
+       HLLZS   (TP)
+       PUSH    TP,1(A)         ;THE PREDICATE
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       CAMN    A,$TFALSE       ;IF THE RESULT IS
+       JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE
+       MOVE    C,1(TB)         ;IF NOT, DO FIRST CLAUSE
+       MOVE    C,1(C)
+       HRRZ    C,(C)
+       JUMPE   C,FINIS         ;(UNLESS DONE WITH IT)
+       JRST    DOPROG          ;AS THOUGH IT WERE A PROG
+NXTCLS:        HRRZ    A,@1(TB)        ;SET THE CLAUSLIST
+       HRRZM   A,1(TB)         ;TO CDR OF THE CLAUSLIST
+       JRST    CLSLUP
+       
+IFALSE:
+       MOVSI   A,TFALSE        ;RETURN FALSE
+       MOVEI   B,0
+       JRST    FINIS
+
+
+
+
+;RESTORE TB TO STACK FRAME POINTED TO BY B, SAVING INTERMEDIATE FRAMES ON THE PLANNER PDL 
+;IF NECESSARY;   CLOBBERS EVERYTHING BUT B
+SAVE:  MOVE    E,SPSAV(B)
+       PUSHJ   P,SPCSTE        ;RESTORE BINDINGS IF NECESSARY
+       SKIPN   C,OTBSAV(B)     ;PREVIOUS FRAME?
+       JRST    QWKRET
+       CAMN    PP,PPSAV(C)     ;ANYTHING HAPPEN TO PP BETWEEN B AND HERE?
+       JRST    QWKRET          ;NO-- JUST RETURN
+       PUSH    TP,$TTB
+       PUSH    TP,B
+SVLP:  HRRZ    B,(TP)
+       CAIN    B,(TB)          ;DONE?
+       JRST    SVRET
+       HRRZ    C,OTBSAV(TB)    ;ANYTHING TO SAVE YET?
+       CAME    PP,PPSAV(C)
+       PUSHJ   P,BCKTRK        ;DO IT
+       HRR     TB,OTBSAV(TB)   ;AND POP UP
+       JRST    SVLP
+QWKRET:        HRR     TB,B            ;SKIP OVER EVERYTHING
+       POPJ    P,
+SVRET: SUB     TP,[2,,2]       ;POP CRAP OFF TP
+       POPJ    P,\f
+
+;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
+;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS
+; ITS SECOND ARGUMENT.
+
+MFUNCTION SETG,SUBR
+       ENTRY   2
+       HLLZ    A,(AB)          ;GET TYPE OF FIRST ARGUMENT
+       CAME    A,$TATOM        ;CHECK THAT IT IS AN ATOM
+       JRST    NONATM          ;IF NOT -- ERROR
+       MOVE    B,1(AB)         ;GET POINTER TO ATOM
+       PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE
+       CAMN    A,$TUNBOUND     ;IF BOUND
+       PUSHJ   P,BSETG         ;IF NOT -- BIND IT
+       MOVE    C,B             ;SAVE PTR
+       MOVE    A,2(AB)         ;GET SECOND ARGUMENT
+       MOVE    B,3(AB)         ;INTO THE RETURN POSITION
+       MOVEM   A,(C)           ;DEPOSIT INTO THE 
+       MOVEM   B,1(C)          ;INDICATED VALUE CELL
+       JRST    FINIS
+
+BSETG: HRRZ    A,GLOBASE+1(TVP)
+       HRRZ    B,GLOBSP+1(TVP)
+       SUB     B,A
+       CAIL    B,6
+       JRST    SETGIT
+       PUSH    TP,GLOBASE(TVP)
+       PUSH    TP,GLOBASE+1 (TVP)
+       PUSH    TP,$TFIX
+       PUSH    TP,[0]
+       PUSH    TP,$TFIX
+       PUSH    TP,[100]
+       MCALL   3,GROW
+       MOVEM   A,GLOBASE(TVP)
+       MOVEM   B,GLOBASE+1(TVP)
+SETGIT:
+       MOVE    B,GLOBSP+1(TVP)
+       SUB     B,[4,,4]
+       MOVE    C,(AB)
+       MOVEM   C,(B)
+       MOVE    C,1(AB)
+       MOVEM   C,1(B)
+       MOVEM   B,GLOBSP+1(TVP)
+       ADD     B,[2,,2]
+       MOVSI   A,TLOCI
+       POPJ    P,
+
+\f
+
+
+;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
+;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.
+
+MFUNCTION SET,SUBR
+       ENTRY   2
+       HLLZ    A,(AB)          ;GET TYPE OF FIRST
+       CAME    A,$TATOM        ;ARGUMENT -- 
+       JRST    WTYP            ;BETTER BE AN ATOM
+       MOVE    B,1(AB)         ;GET PTR TO IT
+       PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
+       CAMN    A,$TUNBOUND     ;BOUND?
+       PUSHJ   P, BSET         ;BIND IT
+       MOVE    C,B             ;SAVE PTR
+       MOVE    A,2(AB)         ;GET SECOND ARG
+       MOVE    B,3(AB)         ;INTO RETURN VALUE
+       MOVEM   A,(C)           ;CLOBBER IDENTIFIER
+       MOVEM   B,1(C)
+       JRST    FINIS
+BSET:  PUSH    TP,$TFIX
+       PUSH    TP,[4]
+       MCALL   1,VECTOR        ;GET NEW BIND VECTOR
+       MOVE    A,$TSP
+       MOVEM   A,(B)           ;MARK IT
+       SETZM   A,1(B)
+       MOVSI   A,TBIND
+       HRRI    A,(B)
+       MOVEM   A,2(B)          ;CHAIN FIRST BLOCK
+       MOVE    A,1(AB)         ;A _ ATOM
+       MOVEM   A,3(B)
+       MOVE    C,SPBASE+1(PVP) ;CHAIN TO PREVIOUS BIND VECTOR
+       MOVEM   B,SPBASE+1(PVP) ;SET NEW TOP
+       ADD     B,[2,,2]
+       MOVEM   B,1(C)
+       ADD     B,[2,,2]        ;POINT TO LOCATIVE
+       MOVSI   A,TLOCI
+       HRR     A,PROCID+1(PVP) ;WHICH MAKE
+       MOVE    C,1(AB)         ;C _ ATOM _ VALUE CELL ADDRESS
+       MOVEM   A,(C)
+       MOVEM   B,1(C)          ;CLOBBER LOCATIVE SLOT
+       POPJ    P,
+\f
+
+MFUNCTION NOT,SUBR
+       ENTRY   1
+       HLRZ    A,(AB)          ; GET TYPE
+       CAIE    A,TFALSE        ;IS IT FALSE?
+       JRST    IFALSE          ;NO -- RETURN FALSE
+
+TRUTH:
+       MOVSI   A,TATOM         ;RETURN T (VERITAS) 
+       MOVE    B,MQUOTE T
+       JRST    FINIS
+
+MFUNCTION ANDA,FSUBR,AND
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP            ;IF ARG DOESN'T CHECK OUT
+       SKIPN   C,1(AB)         ;IF NIL
+       JRST    TRUTH           ;RETURN TRUTH
+       PUSH    TP,$TLIST               ;CREATE UNNAMED TEMP
+       PUSH    TP,C
+ANDLP:
+       JUMPE   C,FINIS         ;ANY MORE ARGS?
+       MOVEM   C,1(TB)         ;STORE CRUFT
+       PUSH    TP,(C)          ;EVALUATE THE
+       HLLZS   (TP)            ;FIRST REMAINING
+       PUSH    TP,1(C)         ;ARGUMENT
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       CAMN    A,$TFALSE       
+       JRST    FINIS           ;IF FALSE -- RETURN
+       HRRZ    C,@1(TB)        ;GET CDR OF ARGLIST
+       JRST    ANDLP
+
+MFUNCTION OR,FSUBR
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST         ;CHECK OUT ARGUMENT
+       JRST    WTYP
+       MOVE    C,1(AB)         ;PICK IT UP TO ENTER LOOP
+       PUSH    TP,$TLIST       ;CREATE UNNAMED TEMP
+       PUSH    TP,C
+ORLP:
+       JUMPE   C,IFALSE        ;IF NO MORE OPTIONS -- FALSE
+       MOVEM   C,1(TB)         ;CLOBBER IT AWAY
+       PUSH    TP,(C)  
+       HLLZS   (TP)
+       PUSH    TP,1(C)         ;EVALUATE THE FIRST REMAINING
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;ARGUMENT
+       CAME    A,$TFALSE       ;IF NON-FALSE RETURN
+       JRST    FINIS
+       HRRZ    C,@1(TB)        ;IF FALSE -- TRY AGAIN
+       JRST    ORLP
+
+MFUNCTION FUNCTION,FSUBR
+       PUSH    TP,(AB)
+       PUSH    TP,1(AB)
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FUNCTION
+       MCALL   2,CHTYPE
+       JRST    FINIS
+
+\f
+
+MFUNCTION CLOSURE,SUBR
+       ENTRY
+       SKIPL   A,AB            ;ANY ARGS
+       JRST    ERRTFA          ;NO -- LOSE
+       ADD     A,[2,,2]        ;POINT AT IDS
+       PUSH    TP,$TAB
+       PUSH    TP,A
+       PUSH    P,[0]           ;MAKE COUNTER
+
+CLOLP: SKIPL   A,1(TB)         ;ANY MORE IDS?
+       JRST    CLODON          ;NO -- LOSE
+       PUSH    TP,(A)          ;SAVE ID
+       PUSH    TP,1(A)
+       PUSH    TP,(A)          ;GET ITS VALUE
+       PUSH    TP,1(A)
+       ADD     A,[2,,2]        ;BUMP POINTER
+       MOVEM   A,1(TB)
+       AOS     (P)
+       MCALL   1,VALUE
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,LIST          ;MAKE PAIR
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    CLOLP
+
+CLODON:        POP     P,A
+       ACALL   A,LIST          ;MAKE UP LIST
+       PUSH    TP,(AB)         ;GET FUNCTION
+       PUSH    TP,1(AB)
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,LIST          ;MAKE LIST
+       MOVSI   A,TFUNARG
+       JRST    FINIS
+
+
+MFUNCTION FALSE,SUBR
+       ENTRY
+       JUMPGE  AB,IFALSE
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP
+       MOVSI   A,TFALSE
+       MOVE    B,1(AB)
+       JRST    FINIS
+\f;BCKTRK SAVES THINGS ON PP
+
+;IT AND ITS FRIENDS FLAG PP "FRAMES" WITH MARKERS OF FORM "TTP,,SWITCHES", WHERE SWITCHES INCLUDES
+
+COP==1         ;ON IFF CALL TO BCKTRK IS TO COPY FRAME (TB) AS WELL
+               ;AS OTBSAV(TB)
+SAV==2         ;ON IFF TUPLES OF (TB) ARE TO BE SAVED; COP IMPLIES
+               ;SAV
+TUP==4         ;ON IFF (TB) CONTAINS ANY TUPLES BESIDES ARGS
+ON==10         ;ON IFF THIS FRAME OR FAILPOINT "RESTS ON TOP OF"
+               ;FRAME DESIGNATED BY TTP POINTER, OR IS INTENDED TO
+               ;TAKE ITS PLACE
+
+;BELOW THE TTP POINTER IS ONE OR TWO BLOCKS FLAGGED BY A TFIX
+;VALUE.  IF ON=ON AND TUP=ON IN THE RIGHT HALF OF THE TFIX,
+;THE TFIX BEGINS A BLOCK OF TUPLE DEBRIS; OTHERWISE,
+;IT BEGINS A SAVED TP FRAME.
+
+
+BCKTRK:        HRRZ    A,-1(PP)        ;SLOT LEFT BY FAILPOINT?
+       TRNN    A,COP           ;(I.E., TO BE COPIED?)
+       JRST    NBCK
+       MOVE    E,TB            ;YES-- FIRST SAVE THIS FRAME
+       PUSHJ   P,BCKTRE
+       HRRZ    A,-1(PP)
+       JRST    NBCK1
+NBCK:  TRNN    A,SAV
+       JRST    RMARK
+
+;SAVE TUPLES OF FRAME ON TOP OF PP
+
+NBCK1: MOVSI   B,TTP           ;FAKE OUT GC
+       MOVEM   B,BSTO(PVP)
+       MOVSI   C,TPP
+       MOVEM   C,CSTO(PVP)
+       MOVEM   C,ESTO(PVP)
+       MOVE    B,(PP)          ;B _ TPIFIED TB POINTER
+       SUB     PP,[2,,2]       ;CLEAN OFF POINTER TO MAKE ROOM FOR ARGS
+       MOVE    E,PP
+       MOVE    C,PP            ;C _ E _ PP
+       SUB     C,(PP)          ;C _ ADDRESS OF SAVED OTB
+       HLRE    D,1(C)          ;D _ NO. OF ARGS
+       JUMPE   D,NOARGS
+       SUB     B,[FRAMLN,,FRAMLN]      ;B _ FIRST OF SAVE BLOCK
+       MOVNS   D
+       HRLS    D
+       SUB     B,D             ;B _ FIRST OF ARGS
+MVARGS:        INTGO
+       PUSH    PP,(B)          ;MOVE NEXT
+       PUSH    PP,1(B)
+       ADD     B,[2,,2]
+       SUB     D,[2,,2]
+       JUMPG   D,MVARGS
+       ADD     B,[FRAMLN,,FRAMLN]      ;B _ TB ADDRESS
+       JRST    MVTUPS
+NOARGS:        TRNN    A,TUP           ;ANY OTHER TUPLES?
+       JRST    RMARK
+MVTUPS:        ADD     C,[FRAMLN-1,,FRAMLN-1]  ;C _ PP TB SLOT
+       SUB     E,[1,,1]        ;E _ TFIX SLOT ADDRESS
+MTOLP: CAML    C,E             ;C REACHED E?
+       JRST    MTDON           ;YES-- ALL TUPLES FOUND
+       INTGO
+       GETYP   A,(C)           ;ELSE
+       CAIE    A,TTBS          ;LOOK FOR TUPLE
+       JRST    ARND22
+       HRRE    D,(C)           ;D _ NO. OF ELEMENTS
+MTILP: JUMPGE  D,ARND22
+       INTGO
+       PUSH    PP,(B)
+       PUSH    PP,1(B)
+       ADD     B,[2,,2]
+       ADDI    D,2
+       JRST    MTILP
+ARND22:        ADD     B,[2,,2]        ;ADVANCE IN STEP
+       ADD     C,[2,,2]
+       JRST    MTOLP
+;ALL TUPLES MOVED
+MTDON: HRRZ    C,PP
+       SUBI    C,1(E)          ;C _ NO. OF THINGS MOVED
+       HRLS    C
+       PUSH    PP,[TFIX,,TUP]  ;MARK AS TUPLE CRUFT
+       PUSH    PP,C
+;NEW TTP MARKER
+RMARK: MOVE    E,OTBSAV(TB)    ;SAVE PREVIOUS FRAME
+       HRRZ    D,E
+       HRLS    D
+       HLRE    C,B
+       SUBI    C,(B)
+       HRLZS   C
+       ADD     D,C
+       PUSH    PP,[TTP,,ON]
+       PUSH    PP,D
+       MOVSI   B,TFIX          ;RESTORE B TYPE
+       MOVEM   B,BSTO(PVP)
+
+;BCKTRE SAVE CONTENTS OF FRAME E OF TP ON PLANNER PDL
+
+BCKTRE:        MOVSI   A,TPDL          ;FOR AGC
+       MOVEM   A,ASTO(PVP)
+       MOVSI   C,TTP
+       MOVEM   C,CSTO(PVP)
+       MOVSI   A,TTB
+       MOVEM   A,ESTO(PVP)
+
+;MOVE P BLOCK OF PREVIOUS FRAME TO PP
+
+       MOVE    C,PSAV(E)       ;C _ LAST OF P "FRAME"
+       HRRZ    A,OTBSAV(E)     
+       MOVE    A,PSAV(A)       ;A _ LAST OF PREVIOUS P "FRAME"
+       ADD     A,[1,,1]
+MVPB:  CAMLE   A,C             ;IF BLOCK EMPTY,
+       JRST    MVTPB           ;DO NOTHING
+       HRRZ    D,C
+       SUBI    D,-1(A)         ;ELSE, SET COUNTER
+       PUSH    PP,$TPDLS       ;MARK BLOCK
+       HRRM    D,(PP)
+       HRLS    D
+       PUSH    P,D
+PSHLP1:        PUSH    PP,(A)
+       INTGO           ;MOVE BLOCK
+       ADD     A,[1,,1]
+       CAMG    A,C
+       JRST    PSHLP1
+       PUSH    PP,$TFIX
+       PUSH    PP,[0]          ;PUSH BLOCK COUNTER
+       POP     P,(PP)
+;NOW DO SIMILAR THING FOR TP
+MVTPB: MOVSI   A,TTP           ;FOR AGC
+       MOVEM   A,ASTO(PVP)
+       MOVE    C,TPSAV(E)      ;C POINT TO LAST OF BLOCK
+       PUSH    TP,$TPP         ;SAVE INITIAL PP
+       PUSH    TP,PP           ;FOR SUBTRACTION
+       HRRZ    A,E             ;A _ TPIFIED E
+       HLRE    B,C
+       SUBI    B,(C)
+       HRLZS   B
+       HRLS    A
+       ADD     A,B
+       GETYP   D,FSAV(A)
+       CAIE    D,TENTRY
+       .VALUE  [ASCIZ /TPFUCKED/]
+;MOVE THE SAVE BLOCK
+
+MSVBLK:        MOVSI   D,TENTS         ;MAKE TYPE TENTS
+       HRR     D,FSAV(A)
+       PUSH    PP,D
+       HLLZ    D,OTBSAV(E)     ;RELATIVIZE OTB AND AB POINTERS
+       PUSH    PP,D
+       HLLZ    D,ABSAV(E)
+       PUSH    PP,D
+       PUSH    PP,SPSAV(E)
+       PUSH    PP,PSAV(E)
+       PUSH    PP,TPSAV(E)
+       PUSH    PP,PPSAV(E)
+       PUSH    PP,PCSAV(E)
+       MOVEI   0,              ;0 _ 0 (NO TUPLES)
+PSHLP2:        INTGO
+       CAMLE   A,C             ;DONE?
+       JRST    MRKFIX
+       GETYP   D,(A)
+       CAIN    D,TTB           ;TUPLE?
+       JRST    MVTB
+       PUSH    PP,(A)          ;NO, JUST MOVE IT
+       PUSH    PP,1(A)
+ARND4: ADD     A,[2,,2]
+       JRST    PSHLP2
+MRKFIX:        HRRZ    C,(TP)          ;C _ PREVIOUS PP POINTER
+       SUB     TP,[2,,2]
+       HRRZ    D,PP            ;D _ CURRENT PP TOP
+       SUBI    D,(C)           ;D _ DIFFERENCE
+       HRLS    D
+       PUSH    PP,$TFIX        ;PUSH BLOCK COUNTER
+       PUSH    PP,D
+
+
+;NOW SAVE LOCATION OF THIS FRAME
+
+       HRLS    E
+       MOVE    C,TPSAV(E)
+       HLRE    B,C
+       SUBI    B,(C)
+       HRLZS   B
+       ADD     E,B             ;CONVERSION TO TTP
+       HRLI    0,TTP
+       TRO     0,SAV           ;PUSH A TTP MARKER WITH SAV & MAYBE TUP ON
+       PUSH    PP,0
+       PUSH    PP,E
+
+;RETURN
+
+       MOVSI   A,TFIX
+       MOVEM   A,ASTO(PVP)
+       MOVEM   A,CSTO(PVP)
+       MOVEM   A,ESTO(PVP)
+       POPJ    P,
+
+;RELATIVIZE A TB POINTER
+
+MVTB:  HRRE    D,(A)           ;D _ - LENGTH OF TUPLE
+       MOVNS   D
+       HRLS    D               ;D _ LENGTH,,LENGTH
+       SUB     PP,D            ;THROW TUPLE AWAY!!!
+       TRO     0,TUP
+       MOVNS   D
+       HRLI    D,TTBS
+       PUSH    PP,D
+       MOVE    D,1(A)
+       SUBI    D,(E)
+       PUSH    PP,D
+       JRST    ARND4
+\fMFUNCTION FAIL,SUBR
+
+;SINCE FAILURES ARE NOT INTERRUPTIBLE FOR ANYTHING BUT GARBAGE
+;COLLECTIONS, THE FOLLOWING MACRO REPLACES INTGO FOR STACK-BUILDING
+;LOOPS
+
+DEFINE UNBLOW STK
+       SKIPL   STK
+       PUSHJ   P,NBLO!STK
+TERMIN
+
+
+       ENTRY
+       HLRE    A,AB
+       MOVNS   A
+       CAILE   A,4             ;AT MOST 2 ARGS
+       JRST    WNA
+       CAIGE   A,2             ;IF FIRST ARG NOT GIVEN, 
+       JRST    MFALS           ;ASSUME <>
+       MOVE    B,(AB)          ;OTHERWISE, FIRST ARG IS MESSAGE
+       MOVEM   B,MESS(PVP)
+       MOVE    B,1(AB)
+       MOVEM   B,MESS+1(PVP)
+
+       CAIE    A,4             ;PLACE TO FAIL TO GIVEN?
+       JRST    AFALS1
+       HLRZ    A,2(AB)
+       CAIE    A,TACT          ;CAN ONLY FAIL TO AN ACTIVATION
+       JRST    TAFALS
+SAVACT:        MOVE    B,2(AB)         ;TRANSMIT ACTIVATION TO FAILPOINT
+       MOVEM   B,FACTI(PVP)    ;VIA PVP
+       MOVE    B,3(AB)
+       MOVEM   B,FACTI+1(PVP)
+;NOW REBUILD TP FROM PP
+IFAIL: SETOM   FLFLG           ;FLFLG _ ON
+       HRRZ    A,(PP)          ;GET FRAME TO NESTLE IN
+       JUMPE   A,BDFAIL
+       HRRZ    0,-1(PP)        ;0 _ SWITCHES FOR FRAME
+       CAIN    A,(TB)
+       JRST    RSTFRM
+       GETYP   B,FACTI(PVP)    ;IF FALSE ACTIVATION,
+       CAIN    B,TFALSE        ;JUST GO TO FRAME
+       JRST    POPFS
+       HRRZI   B,(TB)          ;OTHERWISE, CHECK TO SEE IF WE ARE LEAVING
+       HRRZ    D,FACTI+1(PVP)
+ALOOP: CAIN    B,(A)           ;     FRAME FACTI(PVP)
+       JRST    POPFS           ;NO-- IT'S ABOVE FAILPOINT (A)
+       CAIN    B,(D)           ;FOUND FACTI?
+       JRST    AFALS2          ;YES-- CLOBBER FACTI TO #FALSE()
+       HRRZ    B,OTBSAV(B)     ;NO-- KEEP LOOKING
+       JRST    ALOOP
+AFALS2:        MOVSI   B,TFALSE        ;SET IT TO FALSE FROM HERE ON
+       MOVEM   B,FACTI(PVP)
+       SETZB   D,FACTI+1(PVP)
+POPFS: HRR     TB,A            ;MAY TAKE MORE WORK
+RSTFRM:        MOVE    P,PSAV(TB)
+       MOVE    TP,TPSAV(TB)
+       SUB     PP,[2,,2]
+       GETYP   A,-1(PP)
+       CAIN    A,TPC
+       JRST    MHFRAM
+       CAIE    A,TFIX
+       JRST    BADPP
+       
+;MOVE A TP BLOCK FROM PP TO TP
+       MOVSI   A,TPP
+       MOVEM   A,ASTO(PVP)
+       MOVEM   A,CSTO(PVP)
+       MOVE    A,PP
+       SUB     A,(PP)          ;A POINTS TO BOTTOM OF BLOCK
+       TRNN    0,ON            ;"ON" BLOCK?
+       JRST    INBLK
+ONBLK: CAME    SP,SPSAV(TB)    ;YES-- FIX UP ENVIRONMENT
+       PUSHJ   P,SPECST
+       MOVE    C,A
+       HRRZ    0,-1(PP)        ;ANY TUPLES?
+       TRNN    0,TUP
+       JRST    USVBLK          ;NO-- GO MOVE SAVE BLOCK
+       SUB     A,[2,,2]        ;A _ BLOCK UNDER THIS ONE
+       SUB     A,(A)
+;FILL IN ARGS TUPLE
+       GETYP   B,-1(A)
+       CAIE    B,TENTS         ;LOOK IN SAVE BLOCK
+       JRST    BADPP
+       HLRE    D,FRAMLN+ABSAV-1(A)
+       PUSHJ   P,USVTUP
+
+;MOVE SAVE BLOCK BACK TO TP
+
+USVBLK:        ADD     A,[FRAMLN,,FRAMLN]
+       MOVSI   D,TENTRY
+       HRR     D,FSAV-1(A)
+       PUSH    TP,D
+       MOVEI   AB,(TP)         ;REGENERATE AB & OTBSAV
+       HLRE    D,ABSAV-1(A)
+       MOVNS   D
+       HRLS    D
+       SUB     AB,D
+       MOVEI   D,(TB)
+       HLL     D,OTBSAV-1(A)
+       PUSH    TP,D
+       PUSH    TP,AB
+       PUSH    TP,SPSAV-1(A)
+       PUSH    TP,PSAV-1(A)
+       PUSH    TP,TPSAV-1(A)
+       PUSH    TP,PPSAV-1(A)
+       PUSH    TP,PCSAV-1(A)
+       HRRI    TB,1(TP)
+       
+PSHLP4:        CAML    TP,TPSAV(TB)
+       JRST    USTPDN
+       UNBLOW  TP
+       GETYP   B,-1(A)
+       CAIN    B,TTBS          ;FOUND A TUPLE?
+       JRST    USVTB
+       PUSH    TP,-1(A)        ;NO-- JUST MOVE IT
+       PUSH    TP,(A)
+ARND12:        ADD     A,[2,,2]        ;BUMP POINTER
+       JRST    PSHLP4
+USVTB: HRRE    D,-1(A)
+       PUSHJ   P,USVTUP
+       MOVE    D,-1(A)         ;UNRELATIVIZE A TTB
+       HRLI    D,TTB
+       PUSH    TP,D
+       MOVE    D,(A)
+       ADDI    D,(TB)
+       PUSH    TP,D
+       JRST    ARND12
+USTPDN:        MOVE    0,-1(PP)        ;IF TUPLES,
+       TRNN    0,TUP
+       JRST    USTPD3
+       SUB     PP,(PP)         ;SKIP OVER TUPLE DEBRIS
+       SUB     PP,[2,,2]
+USTPD3:        CAME    TP,TPSAV(TB)    ;BETTER HAVE WORKED
+       JRST    BADPP
+       CAMN    SP,SPSAV(TB)    ;PLEASE GOD, NO MORE BINDINGS
+       JRST    USV2            ;PRAYER CAN MOVE MOUNTAINS
+       MOVEI   E,              ;E _ 0 = INITIAL LOWER BIND BLOCK
+       MOVE    C,SPSAV(TB)     ;C _ SPSAV = INITIAL UPPER BLOCK
+
+;REBIND EVERYTHING IN THIS FRAME-- FIRST, FIND THE TOPMOST BLOCK,
+;SINCE THEY MUST BE REBOUND IN THE ORDER BOUND
+
+BLOOP1:        GETYP   D,(C)
+       CAIE    D,TBIND         ;C POINTS TO BIND BLOCK?
+       JRST    SPLBLK
+       ADD     C,[5,,5]        ;YES-- C _ ADDRESS OF ITS LAST WORD
+       MOVEM   E,(C)           ;(C) _ E = LOWER BIND POINTER
+       MOVE    E,C             ;E _ C
+       SKIPA   D,-5(C)         ;FIND REBIND POINTER
+BLOOP5:        HRRZ    D,(D)           ;D _ NEXT BIND BLOCK
+       GETYP   0,(D)
+       CAIE    0,TSP           ;LOOK FOR REBINDER
+       JRST    BLOOP5
+       MOVE    C,1(D)          ;C _ REBIND BLOCK
+       JRST    JBVEC3
+SPLBLK:        GETYP   D,2(C)
+       CAIN    D,TSP
+       ADD     C,[2,,2]
+       ADD     C,[1,,1]        ;C _ REBIND POINTER ADDRESS
+       MOVE    D,(C)           ;D _ HIGHER BLOCK
+       MOVEM   E,(C)           ;(C) _ E
+       MOVE    E,C             ;E _ C
+       MOVE    C,D             ;C _ D = HIGHER BIND BLOCK
+JBVEC3:        CAME    SP,C            ;GOT TO SP YET?
+       JRST    BLOOP1
+
+
+;NOW REBIND EVERYTHING, RESET PROCID'S PROPERLY, ETC.;
+;THIS MUST BE DONE IN PROPER ORDER, FROM TOPMOST BLOCK DOWN
+
+BLOOP2:        HLRZ    D,-1(E)         ;WHAT DOES E POINT TO?
+       PUSH    P,(E)
+       JUMPN   D,TUGSP         ;IF NON-ZERO, MUST BE REBIND SLOT
+       PUSHJ   P,EBIND         ;OTHERWISE, BIND BLOCK TO BE REBOUND
+       JRST    DOWNBL
+TUGSP: MOVEM   SP,(E)          ;RECONNECT UPPER BLOCK
+       GETYP   0,1(E)
+       CAIE    0,TBIND
+       SUB     E,[2,,2]
+       MOVE    SP,E
+       SUB     SP,[1,,1]       ;TUG SP DOWN
+       CAIE    0,TSP           ;ID SWAP?
+       JRST    DOWNBL
+       MOVE    0,PROCID+1(PVP)
+       EXCH    0,5(SP)
+       MOVEM   0,PROCID+1(PVP)
+DOWNBL:        POP     P,E             ;E _ LOWER BLOCK
+       JUMPN   E,BLOOP2
+
+RBDON: CAME    SP,SPSAV(TB)    ;ALL THAT BETTER HAVE WORKED
+       JRST    BADPP
+       JRST    USV2
+
+;RESTORE A BLOCK "INTO" TB
+
+INBLK: ADD     A,[FRAMLN,,FRAMLN]
+       MOVSI   C,TTP
+       MOVEM   C,CSTO(PVP)
+       MOVSI   C,SPSAV-1(A)
+       HRRI    C,SPSAV(TB)
+       BLT     C,-1(TB)        ;RESTORE ALL OF SAVE BLOCK BUT FSAV,
+       MOVEI   C,-1(TB)        ;    OTBSAV, AND ABSAV
+       HRLS    C
+       MOVE    B,TPSAV(TB)
+       HLRE    D,B
+       SUBI    D,(B)
+       HRLZS   D
+       ADD     C,D             ;C _ "-1(TB)"TPIFIED
+PSHLP6:        CAML    A,PP
+       JRST    TPDON
+       GETYP   B,-1(A)         ;GOT TUPLE?
+       CAIN    B,TTBS
+       JRST    SKTUPL          ;YES-- SKIP IT
+       PUSH    C,-1(A)
+       PUSH    C,(A)
+ARND2: CAMLE   C,TP
+       MOVE    TP,C            ;PROTECT STACK FROM GARBAGE COLLECTION
+       UNBLOW  TP
+       ADD     A,[2,,2]
+       JRST    PSHLP6
+SKTUPL:        HRRE    D,-1(A)         ;D _ - LENGTH OF TUPLE
+       MOVNS   D
+       HRLS    D
+       ADD     C,D             ;SKIP!
+       ADD     C,[2,,2]        ;AND DON'T FORGET TTB
+       JRST    ARND2
+TPDON: MOVE    TP,C            ;IN CASE TP TOO BIG
+       CAME    TP,TPSAV(TB)    ;CHECK THAT INBLK WORKED
+       JRST    BADPP
+       MOVE    C,OTBSAV(TB)    ;RESTORE P STARTING FROM PREVIOUS
+       MOVE    P,PSAV(C)       ;FRAME
+
+;MOVE A P BLOCK BACK TO P
+
+USV2:  MOVSI   C,TFIX
+       MOVEM   C,CSTO(PVP)
+\r      SUB     PP,(PP)
+       SUB     PP,[2,,2]       ;NOW BACK BEYOND TP BLOCK
+       GETYP   A,-1(PP)
+       CAIE    A,TFIX          ;GET P BLOCK...
+       JRST    CHPC2           ;...IF ANY
+       MOVE    A,PP
+       SUB     A,(PP)          ;A POINTS TO FIRST
+PSHLP5:        PUSH    P,-1(A)         ;MOVE BLOCK
+       ADD     A,[1,,1]
+       UNBLOW  P
+       CAMGE   A,PP
+       JRST    PSHLP5
+       SUB     PP,(PP)
+       SUB     PP,[3,,3]               ;NOW AT NEXT PP "FRAME"
+       GETYP   A,-1(PP)
+CHPC2: CAME    P,PSAV(TB)      ;MAKE SURE P RESTORED OKAY
+       JRST    BADPP
+       CAIN    A,TTP
+       JRST    IFAIL
+       JRST    BADPP
+
+;FRAME IS ALREADY ON THE STACK--- BINDINGS ONLY HASSLE
+
+MHFRAM:        MOVE    AB,ABSAV(TB)    ;RESTORE ARGS POINTER
+       CAME    SP,SPSAV(TB)    ;AND ENVIRONMENT
+       PUSHJ   P,SPECSTO
+       MOVSI   A,TFIX
+       MOVEM   A,ASTO(PVP)
+       SETZM   FLFLG           ;FLFLG _ OFF
+       INTGO                   ;HANDLE POSTPONED INTERRUPTS
+       SUB     PP,[2,,2]
+       JRST    @2(PP)
+
+;HERE TO PUSH TUPLE STARTING AT (C), OF LENGTH -D
+
+USVTUP:        SKIPL   D
+       POPJ    P,
+       PUSH    TP,-1(C)
+       PUSH    TP,(C)
+       UNBLOW TP
+       ADD     C,[2,,2]
+       ADDI    D,2
+       JRST    USVTUP
+
+;DEFAULT MESSAGE IS <>
+
+MFALS: MOVSI   B,TFALSE        ;TYPE FALSE
+       MOVEM   B,MESS(PVP)
+       SETZM   MESS+1(PVP)
+
+
+;DEFAULT ACTIVATION IS <>, ALSO
+AFALS1:        MOVSI   B,TFALSE
+       MOVEM   B,FACTI(PVP)
+\r      SETZM   FACTI+1(PVP)
+       JRST    IFAIL
+
+;FALSE IS ALLOWED EXPLICITLY
+
+TAFALS:        CAIE    A,TFALSE
+       JRST    WTYP
+       JRST    SAVACT
+
+
+;FLAG FOR INTERRUPT SYSTEM
+
+FLFLG: 0
+
+;HERE TO UNBLOW P
+
+NBLOP: HRRZ    E,P
+       HLRE    B,P
+       SUBI    E,-PDLBUF-1(P)  ;E _ ADR OF REAL 2ND DOPE WORD
+       SKIPE   PGROW
+       JRST    PDLOSS          ;SORRY, ONLY ONE GROWTH PER FAMILY
+       HRRM    E,PGROW         ;SET PGROW
+       JRST    NBLO2
+
+;HERE TO UNBLOW TP
+
+NBLOTP:        HRRZ    E,TP            ;MORE OR LESS THE SAME
+       HLRE    B,TP
+       SUBI    E,-PDLBUF-1(TP)
+       SKIPE   TPGROW
+       JRST    PDLOSS
+       HRRM    E,TPGROW
+NBLO2: MOVEI   B,PDLGRO_-6
+       DPB     B,[111100,,-1(E)]
+       JRST    AGC
+\fMFUNCTION FINALIZE,SUBR,[FINALIZE]
+       ENTRY
+       SKIPL   AB              ;IF NOARGS;
+       JRST    GETTOP          ;FINALIZE ALL FAILPOINTS
+       HLRE    A,AB            ;AT MOST ONE ARG
+       CAME    A,[-2]
+       JRST    WNA
+       PUSHJ   P,TILLFM        ;MAKE SURE ARG IS LEGAL
+       HRR     B,OTBSAV(B)     ;B _ FRAME BEFORE ACTIVATION
+RESTPP:        MOVE    PP,PPSAV(B)     ;RESTORE PP
+       HRRZ    A,TB            ;IN EVERY FRAME
+FLOOP: CAIN    A,(B)           ;FOR EACH ONE,
+       JRST    FDONE
+       MOVEM   PP,PPSAV(A)
+       HRR     A,OTBSAV(A)
+       JRST    FLOOP
+FDONE: MOVE    A,$TFALSE
+       MOVEI   B,
+       JRST    FINIS   
+
+;TILLFM SETS B _ FIRST ARGUMENT IFF IT IS A LEGAL ACTIVATION
+
+TILLFM:        HLRZ    A,(AB)          ;FIRST ARG MUST BE ACTIVATION
+       CAIE    A,TACT
+       JRST    WTYP
+       MOVE    A,1(AB)         ;WITH RIGHT TIME
+       HRR     B,A
+       HLL     B,OTBSAV(B)
+       HRRZ    C,A             ;AND PLACE
+       CAIG    C,1(TP)
+       CAME    A,B
+       JRST    ILLFRA
+       GETYP   C,FSAV(C)       ;AND STRUCTURE
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       POPJ    P,
+
+
+;LET B BE TOP LEVEL FRAME
+
+GETTOP:        MOVE    B,TPBASE+1(PVP) ;B _ BOTTOM OF TP
+       MOVEI   B,FRAMLN+1(B)   ;B _ TOP LEVEL FRAME
+       JRST    RESTPP\fMFUNCTION FAILPOINT,FSUBR,[FAILPOINT]
+       ENTRY   1
+       GETYP   A,(AB)          ;ARGUMENT MUST BE LIST
+       CAIE    A,TLIST
+       JRST    WTYP
+       SKIPN   C,1(AB)         ;NON-NIL
+       JRST    ERRTFA
+       PUSH    TP,$TLIST       ;SLOT FOR BODY
+       PUSH    TP,[0]
+       PUSH    TP,$TLIST
+       PUSH    TP,[0]
+       PUSH    TP,$TSP
+       PUSH    TP,TP           ;SAVE SLOT FOR PRE-(MESS ACT) ENV
+       MOVE    C,1(AB)         ;GET SET TO CALL BINDER
+       MOVEI   D,0
+       PUSH    P,[AUX]         ;---AS A PROG
+       PUSHJ   P,BINDEV        ;AND GO
+       HRRZ    C,1(AB)         ;SKIP OVER THINGS BOUND
+       TRNE    A,H             ;INCLUDING HEWITT ATOM IF THERE
+       HRRZ    C,(C)
+       JUMPE   C,NOBODY
+       HRRZ    C,(C)           ;C _ (EXPR (MESS ACT) -FAIL-BODY-)
+       JUMPE   C,NOBODY
+       HRRZ    A,(C)           ;A _ ((MESS ACT) -FAIL-BODY-)
+       MOVEM   A,3(TB)
+       MOVE    A,5(TB)
+       SUB     A,[4,,4]
+       PUSH    PP,$TPC         ;ESTABLISH FAIL POINT
+       PUSH    PP,[FP]
+       PUSH    PP,[TTP,,COP\ON]
+       PUSH    PP,A            ;SAVE LOCATION OF THIS FRAME
+       PUSH    TP,(C)
+       HLLZS   (TP)
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;EVALUATE EXPR
+       JRST    FINIS           ;IF SUCCESSFUL, DO NORMAL FINIS
+
+;FAIL TO HERE--BIND MESSAGE AND ACTIVATION
+
+FP:    MOVEM   SP,5(TB)        ;SAVE SP BEFORE MESS AND ACT BOUND
+       HRRZ    A,3(TB)         ;A _ ((MESS ACT) -BODY-)
+       GETYP   C,(A)
+       CAIE    C,TLIST
+       JRST    MPD
+       MOVEI   0,
+       HRRZ    A,1(A)          ;C _ (MESS ACT)
+       JUMPE   A,TFMESS        ;IF (), THINGS MUST BE <>
+       PUSHJ   P,NXTDCL        ;CHECK FOR "STACK"
+       JRST    NOSTAC
+       TRZ     B,1
+       CAME    B,[ASCII /STACK/]
+       JRST    MPD
+       TRO     0,STC           ;FOUND,  TURN ON STC SWITCH
+       HRRZ    C,(A)
+       JUMPE   C,TFMESS        ;IF ONLY "STACK", MUST HAVE FALSE MESSAGE
+NOSTAC:        PUSHJ   P,CARATM        ;E _ MESS
+       JRST    MPD
+       PUSH    TP,BNDA         ;ELSE BIND IT
+       PUSH    TP,E
+       PUSH    TP,MESS(PVP)
+       PUSH    TP,MESS+1(PVP)
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       HRRZ    C,(C)           ;C _ (ACT)
+       JUMPE   C,TFACT         ;IF (), ACT MUST BE <>
+       PUSHJ   P,CARATM        ;E _ ACT
+       JRST    MPD
+       PUSH    TP,BNDA         ;BIND IT
+       PUSH    TP,E
+       PUSH    TP,FACTI(PVP)
+       PUSH    TP,FACTI+1(PVP)
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       JRST BLPROG
+TFMESS:        GETYP   A,MESS(PVP)
+       CAIE    A,TFALSE
+       JRST    IFAIL
+TFACT: GETYP   A,FACTI(PVP)
+       CAIE    A,TFALSE
+       JRST    IFAIL
+       JRST    BLPROG
+
+;THIS ROUTINE SETS E TO THE NEXT THING IN THE LIST C POINTS TO,
+;SKIPPING IFF IT IS AN ATOM
+
+CARATM:        GETYP   E,(C)
+       CAIE    E,TATOM
+       POPJ    P,
+       MOVE    E,1(C)
+       AOS     (P)
+       POPJ    P,
+
+
+MFUNCTION RESTORE,SUBR,[RESTORE]
+
+       ENTRY
+       HLRE    A,AB
+       MOVNS   A
+       CAIG    A,4             ;1 OR 2 ARGUMENTS
+       CAIGE   A,2
+       JRST    WNA
+       PUSHJ   P,TILLFM        ;B _ FRAME TO RESTORE (IF LEGAL)
+       HRRZ    C,FSAV(B)
+       CAIE    C,FAILPO        ;ONLY FAILPOINTS RESTORABLE
+       JRST    ILLFRA
+       PUSHJ   P,SAVE          ;RESTORE IT
+       SKIPN   D,5(TB)         ;ARE WE IN EXPR INSTEAD OF BODY?
+       JRST    EXIT2           ;YES-- EXIT
+       MOVEM   D,SPSAV(TB)
+       PUSHJ   P,SPECSTO       ;UNBIND MESS AND ACT
+       MOVE    TP,TPSAV(TB)
+       MOVE    P,PSAV(TB)
+       PUSH    PP,$TPC
+       PUSH    PP,[FP]
+       MOVE    E,TB
+       HRLS    E
+       MOVE    C,TPSAV(E)
+       HLRE    B,C
+       SUBI    B,(C)
+       HRLZS   B
+       ADD     E,B             ;CONVERSION TO TTP
+       PUSH    PP,[TTP,,COP\ON]        ;REESTABLISH FAILPOINT
+       PUSH    PP,E
+EXIT2: HLRE    C,AB
+       MOVNS   C
+       CAIN    C,4             ;VALUE GIVEN?
+       JRST    RETRG2          ;YES-- RETURN IT
+       MOVE    AB,ABSAV(TB)    ;IN CASE OF GARBAGE COLLECTION
+       JRST    IFALSE\f
+
+;ERROR COMMENTS FOR EVAL
+
+UNBOU: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE UNBOUND-VARIABLE
+       JRST    ER1ARG
+
+UNAS:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE UNASSIGNED-VARIABLE
+       JRST    ER1ARG
+
+TFA:
+ERRTFA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+       JRST    CALER1
+
+TMA:
+ERRTMA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+       JRST    CALER1
+
+BADENV:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-ENVIRONMENT
+       JRST    CALER1
+
+FUNERR:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-FUNARG
+       JRST    CALER1
+
+WRONGT:
+WTYP:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WRONG-TYPE
+       JRST    CALER1
+
+MPD:   PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
+       JRST    CALER1
+
+NOBODY:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE HAS-EMPTY-BODY
+       JRST    CALER1
+
+BADCLS:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-CLAUSE
+       JRST    CALER1
+
+NXTAG: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-EXISTENT-TAG
+       JRST    CALER1
+
+NXPRG: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NOT-IN-PROG
+       JRST    CALER1
+
+NAPT:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-APPLICABLE-TYPE
+       JRST    CALER1
+
+NONEVT:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-EVALUATEABLE-TYPE
+       JRST    CALER1
+
+
+NONATM:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
+       JRST    CALER1
+
+
+ILLFRA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
+       JRST    CALER1
+
+NOTIMP:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NOT-YET-IMPLEMENTED
+       JRST    CALER1
+
+ILLSEG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ILLEGAL-SEGMENT
+       JRST    CALER1
+
+BADPP: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE PP-IN-ILLEGAL-CONFIGURATION
+       JRST    CALER1
+
+
+BDFAIL:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE OVERPOP--FAIL
+       JRST    CALER1
+
+
+ER1ARG:        PUSH    TP,(AB)
+       PUSH    TP,1(AB)
+       MOVEI   A,2
+       JRST    CALER
+CALER1:        MOVEI   A,1
+CALER:
+       HRRZ    C,FSAV(TB)
+       PUSH    TP,$TATOM
+       PUSH    TP,@-1(C)
+       ADDI    A,1
+       ACALL   A,ERROR
+       JRST    FINIS
+  
+END
+***\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/neval.nostac b/MUDDLE/neval.nostac
new file mode 100644 (file)
index 0000000..2750d8c
--- /dev/null
@@ -0,0 +1,2875 @@
+TITLE EVAL -- MUDDLE EVALUATOR
+
+RELOCATABLE
+
+; GERALD JAY SUSSMAN, 1971
+; DREW MCDERMOTT, 1972
+
+.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP
+.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM
+.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA
+.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL
+.GLOBAL PDLBUF,MESS,FACTI,ITRUTH,FLFLG,PDLOSS,AGC
+.GLOBAL PGROW,TPGROW,PDLGRO
+
+.INSRT MUDDLE >
+
+       MFUNCTION       EVAL,SUBR
+       INTGO
+       HLRZ    A,AB            ;GET NUMBER OF ARGS
+       CAIE    A,-2            ;EXACTLY 1?
+       JRST    AEVAL           ;EVAL WITH AN ALIST
+NORMEV:        HLRZ    A,(AB)          ;GET TYPE OF ARG
+       CAILE   A,NUMPRI        ;PRIMITIVE?
+       JRST    NONEVT          ;NO
+       JRST    @EVTYPT(A)      ;YES-DISPATCH
+
+SELF:  MOVE    A,(AB)          ;TYPES WHICH EVALUATE 
+       MOVE    B,1(AB)
+       JRST    FINIS           ;TO SELF-EG NUMBERS
+
+;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL.
+
+MFUNCTION VALUE,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IDVAL
+       JRST    FINIS
+
+IDVAL: PUSH    TP,A
+       PUSH    TP,B            ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE
+       PUSHJ   P,ILVAL         ;LOCAL VALUE FINDER
+       CAMN    A,$TUNAS
+       JRST    UNAS
+       CAME    A,$TUNBOUND     ;IF NOT UNBOUND OR UNASSIGNED
+       JRST    RIDVAL          ;DONE - CLEAN UP AND RETURN
+       POP     TP,B            ;GET ARG BACK
+       POP     TP,A
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    UNBOU
+       POPJ    P,
+RIDVAL:        SUB     TP,[2,,2]
+       POPJ    P,
+
+;GETS THE LOCAL VALUE OF AN IDENTIFIER
+
+MFUNCTION LVAL,SUBR
+       JSP     E,CHKAT
+LVAL2: PUSHJ   P,ILVAL
+       CAMN    A,$TUNBO
+       JRST    UNBOU           ;UNBOUND
+       CAMN    A,$TUNAS
+       JRST    UNAS            ;UNASSIGNED
+       JRST    FINIS           ;OTHER
+
+
+MFUNCTION RLVAL,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAME    A,$TUNBO
+       JRST    FINIS
+       PUSH    TP,(AB)         ;IF UNBOUND,
+       PUSH    TP,1(AB)        ;BIND IT GLOBALLY TO ?()
+       PUSH    TP,$TUNAS
+       PUSH    TP,[0]
+       MCALL   2,SET
+       JRST    FINIS
+
+
+MFUNCTION UNASSP,SUBR,[UNASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAMN    A,$TUNBO
+       JRST    UNBOU
+       CAME    A,$TUNAS
+       JRST    IFALSE
+       JRST    FINIS
+\f
+; GETS A LOCATIVE TO THE LOCAL VALUE OF AN IDENTIFIER.
+
+MFUNCTION LLOC,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,ILOC
+       CAMN    A,$TUNBOUND
+       JRST    UNBOU
+       MOVSI   A,TLOCD
+       HRR     A,2(B)
+       JRST    FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY BOUND
+
+MFUNCTION BOUND,SUBR,[BOUND?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAMN    A,$TUNBOUND
+       JUMPE   B,IFALSE
+       JRST    TRUTH
+
+;TESTS TO SEE IF AN IDENTIFIER IS LOCALLY ASSIGNED
+
+MFUNCTION ASSIGP,SUBR,[ASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,ILVAL
+       CAMN    A,$TUNBOU
+       JRST    UNBOU
+       CAMN    A,$TUNAS
+       JRST    IFALSE
+       JRST    TRUTH
+
+;GETS THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GVAL,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    UNAS
+       JRST    FINIS
+
+;GETS A LOCATIVE TO THE GLOBAL VALUE OF AN IDENTIFIER
+
+MFUNCTION GLOC,SUBR
+       JSP     E,CHKAT
+       PUSHJ   P,IGLOC
+       CAMN    A,$TUNBOUND
+       JRST    UNAS
+       MOVSI   A,TLOCD
+       JRST    FINIS
+
+;TESTS TO SEE IF AN IDENTIFIER IS GLOBALLY ASSIGNED
+
+MFUNCTION GASSIG,SUBR,[GASSIGNED?]
+       JSP     E,CHKAT
+       PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    IFALSE
+       JRST    TRUTH
+
+\f
+
+CHKAT: ENTRY   1
+       HLLZ    A,(AB)
+       CAME    A,$TATOM
+       JRST    NONATM
+       MOVE    B,1(AB)
+       JRST    2,(E)
+
+;EVALUATE A FORM. IF CAR IS AN ATOM USE GLOBAL VALUE OVER LOCAL ONE.
+
+EVFORM:        SKIPN   C,1(AB)         ;EMPTY?
+       JRST    IFALSE
+       HLLZ    A,(C)           ;GET CAR TYPE
+       CAME    A, $TATOM       ;ATOMIC?
+       JRST    EV0             ;NO -- CALCULATE IT
+       MOVE    B,1(C)          ;GET PTR TO ATOM
+       CAMN    B,MQUOTE LVAL
+       JRST    EVATOM          ;".X" EVALUATED QUICKLY
+EVFRM1:        PUSHJ   P,IGVAL
+       CAMN    A,$TUNBOUND
+       JRST    LFUN
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    IAPPLY          ;APPLY IT
+EV0:   PUSH    TP,A            ;SET UP CAR OF FORM AND
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;EVALUATE IT
+       PUSH    TP,A            ;APPLY THE RESULT
+       PUSH    TP,B            ;AS A FUNCTION
+       JRST    IAPPLY
+
+LFUN:  MOVE    B,1(AB)
+       PUSH    TP,$TATOM
+       PUSH    TP,1(B)
+       MCALL   1,VALUE
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    IAPPLY
+
+;HERE TO EVALUATE AN ATOM
+
+EVATOM:        HRRZ    D,(C)           ;D _ REST OF FORM
+       MOVE    A,(D)           ;A _ TYPE OF ARG
+       CAME    A,$TATOM
+       JRST    EVFRM1
+       MOVE    B,1(D)          ;B _ ATOM POINTER
+       JRST    LVAL2           ;SIMULATE .MCALL TO LVAL
+
+;DISPATCH TABLE FOR EVAL
+DISTBL EVTYPT,SELF,[[TLIST,EVLIST],[TFORM,EVFORM],[TVEC,EVECT],[TSEG,ILLSEG],[TUVEC,EUVEC]]
+
+\f;AEVAL DOES RELATIVE EVALUATIONS WITH RESPECT TO
+;AN ENVIRONMENT OR FRAME.  A FALSE ENVIRONMENT IS EQUIVALENT TO THE
+;CURRENT ONE.
+
+AEVAL: CAIE    A,-4            ;EXACTLY 2 ARGS?
+       JRST    WNA             ;NO-ERROR
+       HLRZ    A,2(AB)         ;CHECK THAT WE HAVE AN ENV OR FRAME
+       CAIN    A,TENV
+       JRST    EWRTNV
+       CAIN    A,TFALSE
+       JRST    NORMEV          ;OR <>
+       CAIE    A,TFRAME
+       JRST    WTYP
+
+       MOVE    A,3(AB)         ;A _ FRAME POINTER
+       HRR     B,A
+       HLL     B,OTBSAV(A)     ;CHECK ITS TIME...
+       CAME    A,B
+       JRST    ILLFRA
+       GETYP   C,FSAV(A)
+       CAIE    C,TENTRY        ;...AND CONTENTS
+       JRST    ILLFRA
+
+EWRTFM:        MOVE    B,SPSAV(A)      ;NOW USE THE NITTY-GRITTY
+       CAMN    SP,B            ;NAMELY, THE FRAME'S ACCESS ENVIRONMENT
+       JRST    NORMEV          ;UNLESS IT ISN'T NEW
+       PUSH    TP,2(AB)        ;NOW SIMULATE AN EWRTNV ON A TENV
+       PUSH    TP,A
+       MOVSI   A,TENV
+       MOVEM   A,2(AB)
+       MOVEM   B,3(AB)
+       MOVEI   C,
+       PUSHJ   P,ISPLIC
+       POP     TP,3(AB)        ;RESTORE WITH FRAME
+       POP     TP,2(AB)
+       JRST    NORMEV\fMFUNCTION SPLICE,SUBR
+       ENTRY   2               ;<SPLICE CURRENT NEW>
+       GETYP   A,2(AB)
+       CAIN    A,TFALSE
+       JRST    ITRUTH          ;IF .NEW = <>, EASY;
+       CAIE    A,TENV
+       JRST    WTYP            ;OTHERWISE,
+       GETYP   A,(AB)          ;TWO ENVIRONMENTS NEEDED
+       CAIE    A,TENV
+       JRST    WTYP
+       MOVE    A,1(AB)         ;.CURRENT = .NEW?
+       CAMN    A,3(AB)
+       JRST    ITRUTH          ;HOPEFULLY
+       PUSH    TP,$TSP
+       PUSH    TP,SP           ;SAVE CURRENT SP
+       AOSN    E,PTIME
+       .VALUE  [ASCIZ /TIMEOUT/]
+       PUSHJ   P,FINDSP        ;SP _ A, AMONG OTHER THINGS
+       PUSHJ   P,ISPLIC        ;SPLICE IT
+       EXCH    SP,1(TB)        ;RESTORE SP,
+       SKIPN   C
+       MOVE    SP,1(TB)        ;UNLESS SPLICE DONE TO TOP OF SP
+       MOVEM   SP,SPSAV(TB)    ;SPSAV SLOT CLOBBERED BY FINDSP
+       PUSH    TP,$TFIX        ;SAVE OLD PROCID
+       PUSH    TP,E
+       FPOINT  UNSPLI,4        ;SET FAILPOINT
+       JRST    IFALSE
+
+;FAIL BACK TO HERE
+
+UNSPLI:        MOVE    A,1(TB)         ;A _ SPLICE VECTOR ADDRESS
+       MOVEM   SP,1(TB)        ;SAVE SP
+       MOVE    E,3(TB)         ;E _ OLD PROCID
+       PUSHJ   P,FINDSP        ;SP _ SPLICE VECTOR
+       MOVEM   E,PROCID+1(PVP) ;RESET OLD PROCID
+       MOVE    SP,3(SP)        ;SP _ REBIND ENVIRONMENT
+       JUMPE   C,IFAIL         ;IF C = 0, KEEP FAILING
+       MOVEM   SP,1(C)         ;RECLOBBER ACCESS TO REBIND
+       MOVE    SP,1(TB)        ;IF NOTHING LOWER, SP _ SAME AS BEFORE
+       JRST    IFAIL
+
+
+;SPECIAL CASE FOR EVAL WITH ENVIRONMENT
+
+EWRTNV:        CAMN    SP,3(AB)                ;ALREADY GOT?
+       JRST    NORMEV
+       AOSN    E,PTIME
+       .VALUE  [ASCIZ /TIMEOUT/]
+       MOVEI   C,
+       PUSHJ   P,ISPLICE
+       JRST    NORMEV
+
+;SEARCH FOR A THROUGH ENVIRONMENTS, SETTING SP AS YOU GO
+;CLOBBER ALL PROCID'S OF BOUND ATOMS TO E, AND CLOBBER 
+;LOCATIVES IN ALL BIND BLOCKS EXCEPT FOR LAST VECTOR
+
+FINDSP:        MOVEI   C,
+       SKIPA
+SPLOOP:        MOVE    SP,1(C)
+       CAMN    SP,A            ;DONE?
+       POPJ    P,
+       SKIPN   SP
+       .VALUE  [ASCIZ /SPOVERPOP/]
+       JUMPE   C,JBVEC2
+
+;CLOBBER ALL LOCATIVES IN LAST BIND VECTOR
+
+BLOOP3:        GETYP   C,(B)
+       CAIE    C,TBIND
+       JRST    JBVEC2
+       MOVEI   C,TFALSE        ;MAKE FALSE LOCATIVE
+       HRLM    C,4(B)
+       SETZM   5(B)
+       HRRZ    B,(B)
+       JRST    BLOOP3
+JBVEC2:        HRRZ    B,SP            ;B _ SP
+       MOVE    C,SP            ;C _ BIND BLOCK ADDRESS = SP
+BLOOP4:        GETYP   D,(C)           ;SEARCH THROUGH BLOCKS ON THIS VECTOR
+       CAIE    D,TBIND
+       JRST    SPLOOP          ;GOT TO END
+       MOVE    D,1(C)          ;ALTER PROCID OF BOUND ATOM
+       HRRM    E,(D)
+       HRRZ    C,(C)           ;NEXT BLOCK
+       JRST    BLOOP4
+
+;SPLICE 3(AB) INTO SP 
+
+ISPLIC:        PUSH    TP,$TVEC        ;SAVE C
+       PUSH    TP,C
+       PUSH    TP,$TFIX
+       PUSH    TP,E            ;AND E
+       PUSH    TP,$TFIX
+       PUSH    TP,[3]
+       MCALL   1,VECTOR        ;B _ <VECTOR 3>
+       MOVSI   D,TSP
+       MOVEM   D,(B)
+       MOVEM   D,2(B)
+       MOVE    D,3(AB)
+       MOVEM   D,1(B)          ;<PUT .B 1 <3 .AB>>
+       MOVEM   SP,3(B)         ;<PUT .B 2 .SP>
+       MOVE    SP,B            ;SP _ B
+       MOVSI   D,TFIX
+       MOVEM   D,4(SP)         ;GET SET TO STORE NEW PROCID
+       MOVE    E,(TP)          ;E _ NEW PROCID
+       EXCH    E,PROCID+1(PVP) ;E _ OLD PROCID
+       MOVEM   E,5(SP)         ;SAVE OLD PROCID IN BIND VECTOR
+       SUB     TP,[4,,4]
+       SKIPE   C,2(TP)         ;RECOVER C
+       MOVEM   SP,1(C)         ;COMPLETE SPLICE
+       POPJ    P,\fMFUNCTION APPLY,SUBR
+       ENTRY   2
+       MOVE    A,(AB)          ;SAVE FUNCTION
+       PUSH    TP,A
+       MOVE    B,1(AB)
+       PUSH    TP,B
+       GETYP   A,2(AB)         ;AND ARG LIST
+       CAIE    A,TLIST
+       JRST    WTYP            ;WHICH SHOULD BE LIST
+       PUSH    TP,$TLIST
+       MOVE    B,3(AB)
+       PUSH    TP,B
+       MOVEI   0,
+       PUSH    P,[0]           ;"UNEVAL" MARKER
+       JRST    IAPPL1
+
+IAPPLY:        MOVSI   A,TLIST
+       PUSH    TP,A
+       HRRZ    B,@1(AB)
+       PUSH    TP,B
+       HRRZ    0,1(AB)         ;0 _ CALL
+       PUSH    P,[-1]          ;"EVAL" MARKER
+IAPPL1:        GETYP   A,(TB)
+       CAIN    A,TEXPR         ;EXPR?
+       JRST    APEXPR          ;YES
+       CAIN    A,TSUBR         ;NO -- SUBR?
+       JRST    APSUBR          ;YES
+       CAIN    A,TFSUBR        ;NO -- FSUBR?
+       JRST    APFSUBR         ;YES
+       CAIN    A,TFIX          ;NO -- CALL TO NTH?
+       JRST    APNUM           ;YES
+       CAIN    A,TACT          ;NO -- ACTIVATION?
+       JRST    APACT           ;YES
+       CAIN    A,TFUNARG       ;NO -- FUNARG?
+       JRST    APFUNARG        ;YES
+       CAIN    A,TPVP          ;NO -- PROCESS TO BE RESUMED?
+       JRST    NOTIMP          ;YES
+       JRST    NAPT            ;NONE OF THE ABOVE
+
+
+;APFSUBR CALLS FSUBRS
+
+APFSUBR:
+       MCALL   1,@1(TB)
+       JRST    FINIS
+
+;APSUBR CALLS SUBRS
+
+APSUBR:
+       PUSH    P,[0]           ;MAKE SLOT FOR ARGCNT
+TUPLUP:
+       SKIPN   A,3(TB)         ;IS IT NIL?
+       JRST    MAKPTR          ;YES -- DONE
+       PUSH    TP,(A)          ;NO -- GET CAR OF THE
+       HLLZS   (TP)            ;ARGLIST
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+       SKIPN   -1(P)           ;EVAL?
+       JRST    BUMP            ;NO
+       MCALL   1,EVAL          ;AND EVAL IT.
+       PUSH    TP,A            ;SAVE THE RESULT IN
+       PUSH    TP,B            ;THE GROWING TUPLE
+BUMP:  AOS     (P)             ;BUMP THE ARGCNT
+       HRRZ    A,@3(TB)        ;SET THE ARGLIST TO 
+       MOVEM   A,3(TB)         ;CDR OF THE ARGLIST
+       JRST    TUPLUP
+MAKPTR:
+       POP     P,A     
+       ACALL   A,@1(TB)
+       JRST    FINIS
+
+;APACT INTERPRETS ACTIVATIONS AS CALLS TO FUNCTION EXIT
+
+APACT: MOVE    A,(TP)          ;A _ ARGLIST
+       JUMPE   A,TFA
+       GETYP   B,(A)           ;SETUP SECOND ARGUMENT
+       HRLZM   B,-1(TP)
+       MOVE    B,1(A)
+       MOVEM   B,(TP)
+       HRRZ    A,(A)           ;MAKE SURE ONLY ONE
+       JUMPN   A,TMA
+       JSP     E,CHKARG
+       SKIPN   (P)             ;IF ARGUMENT AS YET UNEVALED,
+       MCALL   2,EXIT
+       MCALL   1,EVAL          ;EVAL IT
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,EXIT          ;AND EXIT GIVEN ACTIVATION\f
+
+;APNUM INTERPRETS NUMBERS AS CALL TO FUNCTION GET
+
+APNUM:
+       MOVE    A,(TP)          ;GET ARLIST
+       JUMPE   A,ERRTFA        ;NO ARGUMENT
+       PUSH    TP,(A)          ;GET CAR OF ARGL
+       HLLZS   (TP)    
+       PUSH    TP,1(A)
+       HRRZ    A,(A)           ;MAKE SURE ONLY ONE ARG
+       JUMPN   A,ERRTMA
+       JSP     E,CHKARG        ;HACK DEFERRED
+       SKIPN   (P)             ;EVAL?
+       JRST    DONTH
+       MCALL   1,EVAL          ;YES
+       PUSH    TP,A
+       PUSH    TP,B
+DONTH: PUSH    TP,(TB)
+       PUSH    TP,1(TB)
+       MCALL   2,NTH
+       JRST    FINIS
+
+;APEXPR APPLIES EXPRS
+;EXPRESSION IS IN 0(AB),  FUNCTION IS IN 0(TB)
+
+APEXP2:        HRRZ    0,1(AB)
+       PUSH    P,[ARGEV]
+
+APEXPR:
+
+       SKIPN   C,1(TB)         ;BODY?
+       JRST    NOBODY          ;NO, ERROR
+       MOVE    D,(TP)          ;D _ ARG LIST
+       SETZM   (TP)            ;ZERO (TP) FOR BODY
+       PUSHJ   P,BINDAP        ;DO THE BINDINGS
+
+APEXP1:        HRRZ    C,1(TB)         ;GET BODY BACK
+       TRNE    A,H             ;SKIP IF NO HEWITT ATOM
+       HRRZ    C,(C)           ;ELSE CDR AGAIN
+       MOVEM   C,3(TB)
+       JRST    STPROG
+
+;MAKE SURE ARGUMENT PUSHED ON STACK IS NOT OF TYPE DEFER
+;(CLOBBERS A AND E)
+
+CHKARG:        GETYP   A,-1(TP)
+       CAIE    A,TDEFER
+       JRST    (E)
+       HRRZS   (TP)            ;MAKE SURE INDIRECT WINS
+       MOVE    A,@(TP)
+       MOVEM   A,-1(TP)                ;CLOBBER IN TYPE SLOT
+       MOVE    A,(TP)          ;NOW GET POINTER
+       MOVE    A,1(A)          ;GET VALUE
+       MOVEM   A,(TP)          ;CLOBBER IN
+       JRST    (E)
+\f;LIST EVALUATOR
+
+EVLIST:        PUSHJ   P,PSHRG1        ;EVALUATE EVERYTHING
+       PUSH    P,C             ;SAVE COUNTER
+EVLIS1:        JUMPE   C,EVLDON        ;IF C=0, DONE
+       PUSH    TP,A            ;ELSE, CONS
+       PUSH    TP,B
+       MCALL   2,CONS          ;(A,B) _ ((TP) !(A,B))
+       SOS     C,(P)           ;DECREMENT COUNTER
+       JRST    EVLIS1
+EVLDON:        SUB     P,[1,,1]
+       JRST    FINIS
+
+
+;VECTOR EVALUATOR
+
+EVECT: PUSH    P,[0]           ;COUNTER
+       GETYPF  A,(AB)          ;COPY INPUT VECTOR POINTER
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+
+EVCT2: INTGO
+       SKIPL   A,1(TB)         ;IF VECTOR EMPTY,
+       JRST    MAKVEC          ;GO MAKE ITS VALUE
+       GETYPF  C,(A)           ;C _ TYPE OF NEXT ELEMENT
+       PUSH    P,C
+       CAMN    C,$TSEG
+       MOVSI   C,TFORM         ;EVALUATE SEGMENTS LIKE FORMS
+       PUSH    TP,C
+       PUSH    TP,1(A)
+       ADD     A,[2,,2]        ;TO NEXT VALUE
+       MOVEM   A,1(TB)
+       MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
+       POP     P,C
+       CAME    C,$TSEG         ;IF SEGMENT,
+       JRST    EVCT1
+       PUSHJ   P,PSHSEG        ;PUSH ITS ELEMENTS
+       JRST    EVCT2
+EVCT1: PUSH    TP,A            ;ELSE PUSH IT
+       PUSH    TP,B
+       AOS     (P)             ;BUMP COUNTER
+       JRST    EVCT2
+
+MAKVEC:        POP     P,A             ;A _ COUNTER
+       .ACALL  A,EVECTOR       ;CALL VECTOR CONSTRUCTOR
+       JRST    FINIS           ;QUIT
+
+
+;UNIFORM VECTOR EVALUATOR
+
+EUVEC: GETYPF  A,(AB)          ;COPY INPUT VECTOR POINTER
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+       HLRE    C,1(TB)         ;C _ - NO. OF WORDS: TO DOPE WORD
+       HRRZ    A,1(TB)
+       SUBM    A,C             ;C _ ADDRESS OF DOPE WORD
+       GETYPF  A,(C)
+       PUSH    P,A             ;-1(P) _ TYPE OF UVECTOR
+       PUSH    P,[0]           ;0(P) _ COUNTER
+EUVCT2:        INTGO
+       SKIPL   A,1(TB)         ;IF VECTOR EMPTY,
+       JRST    MAKUVC          ;GO MAKE ITS VALUE
+       MOVE    C,-1(P)         ;C _ TYPE
+       CAMN    C,$TSEG
+       MOVSI   C,TFORM         ;EVALUATE SEGMENTS LIKE FORMS
+       PUSH    TP,C
+       PUSH    TP,(A)
+       ADD     A,[1,,1]        ;TO NEXT VALUE
+       MOVEM   A,1(TB)
+       MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
+       MOVE    C,-1(P)
+       CAME    C,$TSEG         ;IF SEGMENT,
+       JRST    EUVCT1
+       PUSHJ   P,PSHSEG        ;PUSH ITS ELEMENTS
+       JRST    EUVCT2
+EUVCT1:        PUSH    TP,A            ;ELSE PUSH IT
+       PUSH    TP,B
+       AOS     (P)             ;BUMP COUNTER
+       JRST    EUVCT2
+
+MAKUVC:        POP     P,A             ;A _ COUNTER
+       .ACALL  A,EUVECT        ;CALL VECTOR CONSTRUCTOR
+       SUB     P,[1,,1]        ;FLUSH TYPE
+       JRST    FINIS           ;QUIT
+\f;ENTRY POINT FOR PUSHING ALL BUT LAST SEGMENT, IF ANY,
+;WHICH IS IN (A,B) INSTEAD OF ON STACK.  IF NO LAST SEGMENT
+;(OR IT IS NOT A LIST), (A,B) = () INSTEAD.
+
+PSHSW=-1               ;SWITCH BENEATH COUNTER ON STACK
+CPYLST==1              ;SWITCH ON IFF LAST SEGMENT TO BE COPIED LIKE OTHERS
+
+PSHRG1:        PUSH    P,[0]           ;DON'T COPY LAST SEGMENT
+       JRST    PSHRG2
+
+;INTERNAL ARG LIST PUSHER-- ACCEPTS SEGMENTS, LEAVES COUNTER OF 
+;THINGS PUSHED IN C
+
+PSHRGL:        PUSH    P,[1]           ;COPY FINAL SEGMENT
+PSHRG2:        PUSH    P,[0]           ;(P) IS A COUNTER
+       GETYPF  A,(AB)          ;COPY ARGLIST POINTER
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+
+IEVL2: INTGO
+       SKIPN   A,1(TB)         ;A _ NEXT LIST CELL ADDRESS
+       JRST    ARGSDN          ;IF 0, DONE
+       HRRZ    B,(A)           ;CDR THE ARGS
+       MOVEM   B,1(TB)
+       GETYP   C,(A)           ;C _ TRUE TYPE OF CELL ELEMENT
+       MOVSI   C,(C)
+       CAME    C,$TDEFER       ;DON'T ACCEPT DEFERREDS
+       JRST    IEVL3
+       MOVE    A,1(A)
+       MOVE    C,(A)
+IEVL3: PUSH    P,C             ;SAVE TYPE
+       CAMN    C,$TSEG         ;IF SEGMENT
+       MOVSI   C,TFORM         ;EVALUATE IT LIKE A FORM
+       PUSH    TP,C
+       PUSH    TP,1(A)
+       MCALL   1,EVAL          ;(A,B) _ VALUE OF NEXT ELEMENT
+       POP     P,C
+       CAME    C,$TSEG         ;IF SEGMENT,
+       JRST    IEVL4
+       CAMN    A,$TLIST        ;THAT TURNED OUT TO BE A LIST,
+       SKIPE   1(TB)           ;CHECK IF LAST
+       JRST    IEVL1           ;IF NOT, COPY IT
+       MOVE    0,PSHSW(P)      ;IF SO, AND "COPY LAST"
+       TRNN    0,CPYLST        ;   SWITCH IS OFF
+       JRST    IEVL5           ;DON'T COPY
+IEVL1: PUSHJ   P,PSHSEG        ;PUSH SEGMENT'S ELEMENTS
+       JRST    IEVL2
+IEVL4: PUSH    TP,A            ;ELSE PUSH IT
+       PUSH    TP,B
+       AOS     (P)             ;BUMP COUNTER
+       JRST    IEVL2
+
+ARGSDN:        MOVE    B,PSHSW(P)      ;B _ SWITCH WORD
+       TRNN    B,CPYLST        ;IF COPY LAST SWITCH OFF,
+       MOVSI   A,TLIST         ;    (A,B) _ ()
+IEVL5: POP     P,C             ;C _ FINAL COUNT
+       SUB     P,[1,,1]        ;PITCH SWITCH WORD
+       POPJ    P,\f;THIS FUNCTION PUSHES THE ELEMENTS OF THE STRUCTURE (A,B) ONTO
+;TP; (P) = RETURN ADDRESS; -1(P) = COUNTER (SET UP BY CALLER)
+
+PSHSEG:        MOVEM   A,BSTO(PVP)     ;TYPE FOR AGC
+       GETYP   A,A
+       PUSHJ   P,SAT           ;A _ PRIMITIVE TYPE OF (A,B)
+       CAIN    A,S2WORD        ;LIST?
+       JRST    PSHLST          ;YES-- DO IT!
+       HLRE    C,B             ;MUST BE SOME KIND OF VECTOR OR TUPLE
+       MOVNS   C               ;C _ NUMBER OF WORDS TO DOPE WORD
+       CAIN    A,SNWORD        ;UVECTOR?
+       JRST    PSHUVC          ;YES-- DO IT!!
+       ASH     C,-1            ;NO-- C _ C/2 = NUMBER OF ELEMENTS
+       ADDM    C,-1(P)         ;BUMP COUNTER
+       CAIN    A,S2NWORD       ;VECTOR?
+       JRST    PSHVEC          ;YES-- DO IT!!!
+       CAIE    A,SARGS         ;ARGS TUPLE?
+       JRST    ILLSEG          ;NO-- DO IT!!!!
+       PUSH    TP,BSTO(PVP)    ;YES-- CHECK FOR LEGALITY
+       PUSH    TP,B
+       SETZM   BSTO(PVP)
+       MOVEI   B,-1(TP)        ;B _ ARGS POINTER ADDRESS
+       PUSHJ   P,CHARGS        ;CHECK IT OUT
+       POP     TP,B            ;RESTORE WORLD
+       POP     TP,BSTO(PVP)
+
+PSHVEC:        INTGO
+       JUMPGE  B,SEGDON        ;IF B = [], QUIT
+       PUSH    TP,(B)          ;PUSH NEXT ELEMENT
+       PUSH    TP,1(B)
+       ADD     B,[2,,2]        ;B _ <REST .B>
+       JRST    PSHVEC
+
+PSHUVC:        ADDM    C,-1(P)         ;BUMP COUNTER
+       ADDM    B,C             ;C _ DOPE WORD ADDRESS
+       GETYP   A,(C)           ;A _ UVECTOR ELEMENTS TYPE
+       MOVSI   A,(A)
+PSHUV1:        INTGO
+       JUMPGE  B,SEGDON        ;IF B = ![], QUIT
+       PUSH    TP,A            ;PUSH NEXT ELEMENT WITH TYPE
+       PUSH    TP,(B)
+       ADD     B,[1,,1]        ;B _ <REST .B>
+       JRST    PSHUV1
+
+PSHLST:        INTGO
+       JUMPE   B,SEGDON        ;IF B = (), QUIT
+       GETYP   A,(B)
+       MOVSI   A,(A)           ;PUSH NEXT ELEMENT
+       PUSH    TP,A
+       PUSH    TP,1(B)
+       JSP     E,CHKARG        ;KILL TDEFERS
+       AOS     -1(P)           ;COUNT ELEMENT
+       HRRZ    B,(B)           ;CDR LIST
+       JRST    PSHLST
+
+SEGDON:        SETZM   BSTO(PVP)               ;FIX TYPE
+       POPJ    P,\f;THESE THREE CONSTRUCTOR FUNCTIONS ARE USED
+;TO SIMULATE "VARIABLE BRACKETS"; FOR EXAMPLE, <CONSV ...>
+;MEANS [...].
+
+;LIST CONSTRUCTOR
+
+MFUNCTION CONSL,FSUBR
+       JRST    EVLIST          ;DEGENERATE CASE
+
+;VECTOR CONSTRUCTOR
+
+MFUNCTION CONSV,FSUBR
+       PUSHJ   P,PSHRGL        ;EVALUATE ARGS
+       .ACALL  C,EVECTOR       ;AND CALL EVECTOR ON THEM
+       JRST    FINIS
+
+;UVECTOR CONSTRUCTOR
+
+MFUNCTION CONSU,FSUBR
+       PUSHJ   P,PSHRGL        ;VERY SIMILAR
+       .ACALL  C,EUVECT        ;BUT CALL EUVECT INSTEAD
+       JRST    FINIS\f
+
+;APFUNARG APPLIES OBJECTS OF TYPE FUNARG
+
+APFUNARG:
+       HRRZ    A,@1(TB)        ;GET CDR OF FUNARG
+       JUMPE   A,FUNERR        ;NON -- NIL
+       HLRZ    B,(A)           ;GET TYPE OF CADR
+       CAIE    B,TLIST         ;BETTR BE LIST
+       JRST    FUNERR
+       PUSH    TP,$TLIST       ;SAVE IT UP
+       PUSH    TP,1(A)
+FUNLP:
+       INTGO
+       SKIPN   A,3(TB)         ;ANY MORE
+       JRST    DOF             ;NO -- APPLY IT
+       HRRZ    B,(A)
+       MOVEM   B,3(TB)
+       HLRZ    C,(A)
+       CAIE    C,TLIST
+       JRST    FUNERR
+       HRRZ    A,1(A)
+       HLRZ    C,(A)           ;GET FIRST VAR
+       CAIE    C,TATOM         ;MAKE SURE IT IS ATOMIC
+       JRST    FUNERR
+       PUSH    TP,BNDA         ;SET IT UP
+       PUSH    TP,1(A)
+       HRRZ    A,(A)
+       PUSH    TP,(A)          ;SET IT UP
+       PUSH    TP,1(A)
+       JSP     E,CHKARG
+\r      PUSH    TP,[0]
+       PUSH    TP,[0]
+       JRST    FUNLP
+DOF:
+       PUSHJ   P,SPECBIND      ;BIND THEM
+       MOVE    A,1(TB)         ;GET GOODIE
+       HLLZ    B,(A)
+       PUSH    TP,B
+       PUSH    TP,1(A)
+       HRRZ    A,3(TB)         ;A _ ARG LIST
+       PUSH    TP,$TLIST
+       PUSH    TP,A
+       MCALL   2,CONS
+       PUSH    TP,$TFORM
+       PUSH    TP,B
+       MCALL   1,EVAL
+       JRST    FINIS
+\f
+
+;ILOC RETURNS IN A AND B A LOCATIVE TO THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT
+;IN A AND B.  IF THE IDENTIFIER IS LOCALLY UNBOUND IT RETURNS $TUNBOUND IN A AND 0 IN B,
+; IT IS CALLED BY PUSHJ P,ILOC.  IT CLOBBERS A, B, C, & 0
+
+ILOC:  MOVSI   A,TLOCI         ;MAKE A LOCATIVE TYPE CELL
+       HRR     A,PROCID+1(PVP) ;FOR THE CURRENT PROCESS
+       CAME    A,(B)           ;IS THERE ONE IN THE VALUE CELL?
+       JRST    SCHSP           ;NO -- SEARCH THE LOCAL BINDINGS
+       MOVE    B,1(B)          ;YES -- GET LOCATIVE POINTER
+       POPJ    P,              ;FROM THE VALUE CELL
+
+SCHSP: PUSH    P,0             ;SAVE 0
+       MOVE    C,SP            ;GET TOP OF BINDINGS
+SCHLP: JUMPE   C,NPOPJ         ;IF NO MORE, LOSE
+SCHLP1:        GETYP   0,(C)
+       CAIN    0,TSP           ;INDIRECT LINK TO NEXT BIND BLOCK?
+       JRST    NXVEC2
+       CAMN    B,1(C)          ;FOUND ATOM?
+       JRST    SCHFND
+       HRR     C,(C)           ;FOLLOW CHAIN
+       SUB     C,[6,,0]
+       JRST    SCHLP
+NXVEC2:        MOVE    C,1(C)          ;GET NEXT BLOCK
+       JRST    SCHLP
+
+SCHFND:        EXCH    B,C             ;SAVE THE ATOM PTR IN C
+       ADD     B,[2,,2]        ;MAKE UP THE LOCATIVE
+
+       MOVEM   A,(C)           ;CLOBBER IT AWAY INTO THE
+       MOVEM   B,1(C)          ;ATOM'S VALUE CELL
+SCHPOP:        POP     P,0             ;RESTORE 0
+       POPJ    P,
+
+NPOPJ: POP     P,0             ;RESTORE 0
+UNPOPJ:        MOVSI   A,TUNBOUND
+       MOVEI   B,0
+       POPJ    P,0
+
+;IGLOC RETURNS IN A AND B A LOCATIVE TO THE GLOBAL VALUE OF THE 
+;IDENTIFIER PASSED TO IT IN A AND B.  IF THE IDENTIFIER IS GLOBALLY
+;UNBPOUND IT RETURNS $TUNBOUND IN A AND 0 IN B. IT IS CALLED BY PUSHJ P,IGLOC.
+
+\rIGLOC:        MOVSI   A,TLOCI         ;DO WE HAVE A LOCATIVE TO
+       CAME    A,(B)           ;A PROCESS #0 VALUE?
+       JRST    SCHGSP          ;NO -- SEARCH
+       MOVE    B,1(B)          ;YES -- GET VALUE CELL
+       POPJ    P,
+
+SCHGSP:        MOVE    D,GLOBSP+1(TVP) ;GET GLOBAL SP PTR
+
+SCHG1: JUMPGE  D,UNPOPJ        ;IF NO MORE, LEAVE
+       CAMN    B,1(D)          ;ARE WE FOUND?
+       JRST    GLOCFOUND       ;YES
+       ADD     D,[4,,4]        ;NO -- TRY NEXT
+       JRST    SCHG1
+
+GLOCFOUND:     EXCH    B,D             ;SAVE ATOM PTR
+       ADD     B,[2,,2]        ;MAKE LOCATIVE
+       MOVEM   A,(D)           ;CLOBBER IT AWAY
+       MOVEM   B,1(D)
+       POPJ    P,
+
+
+\f
+
+;ILVAL RETURNS IN A AND B THE LOCAL VALUE OF THE IDENTIFIER PASSED TO IT IN A AND B
+;IF THE IDENTIFIER IS UNBOUND ITS VALUE IS $TUNBOUND IN A AND 0 IN B. IF
+;IT IS UNASSIGNED ITS VALUE IS $TUNBOUND IN A AND -1 IN B.  CALL - PUSHJ P,IVAL
+
+ILVAL:
+       PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
+CHVAL: CAMN    A,$TUNBOUND     ;BOUND
+       POPJ    P,              ;NO -- RETURN
+       MOVE    A,(B)           ;GET THE TYPE OF THE VALUE
+       MOVE    B,1(B)          ;GET DATUM
+       POPJ    P,
+
+;IGVAL -- LIKE ILVAL EXCEPT FOR GLOBAL VALUES
+
+IGVAL: PUSHJ   P,IGLOC
+       JRST    CHVAL
+
+
+\fMFUNCTION BIND,FSUBR
+       ENTRY   1
+       GETYP   A,(AB)
+       CAIE    A,TLIST         ;ARG MUST BE LIST
+       JRST    WTYP
+       SKIPN   C,1(AB)         ;C _ BODY
+       JRST    TFA             ;NON-EMPTY
+       PUSH    TP,$TLIST
+       PUSH    TP,C
+       PUSH    TP,(C)          ;EVAL FIRST ELEMENT
+       HLLZS   (TP)
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       PUSH    TP,A
+       PUSH    TP,B            ;SAVE VALUE
+       GETYP   A,A             ;WHICH MUST BE LIST
+       PUSHJ   P,SAT
+       CAIE    A,S2WORD
+       JRST    WTYP
+       HRRZ    C,-2(TP)        ;C _ <REST .C>
+       HRRZ    C,(C)
+       JUMPE   C,NOBODY        ;MUST NOT BE EMPTY
+       PUSH    TP,(C)          ;EVALUATE FIRST ELEMENT
+       HLLZS   (TP)
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       SETO    D,
+       GETYP   A,A
+       CAIN    A,TFALSE        ;CAN BE #FALSE OR LIST
+       JRST    DOBI            ;IF <>, AUXILIARY BINDINGS
+       PUSHJ   P,SAT
+       CAIE    A,S2WORD
+       JRST    WTYP
+       MOVEI   D,(B)           ;D _ DECLARATIONS
+DOBI:  POP     TP,C            ;RESTORE C _ FIRST ARG
+       SUB     TP,[1,,1]
+       MOVEI   0,              ;NO CALL
+       PUSHJ   P,BINDER
+       HRRZ    C,1(AB)
+       HRRZ    C,(C)
+       HRRZ    C,(C)           ;C _ <REST <REST .ARG>>
+       JRST    BIPROG          ;NOW EXECUTE BODY AS PROG\f
+
+;BINDER - THIS SUBROUTINE PROCESSES FUNCTION DECLARATIONS AND BINDS
+;      ARGUMENTS       AND TEMPORARIES APPROPRIATELY.
+;      
+;      CALL:   PUSHJ   P,BINDER OR BINDRR
+;
+;      BINDAP - ARGS ARE ON A LIST, EVALED IFF (P) NOT = 0
+;
+;      BINDER - ASSUMES ARGS ARE TO BE EVALED
+;
+;      BINDRR - RESUME HACK - ARGS ON A LIST TO BE 
+;              EVALED IN PARENT PROCESS
+;
+
+;      C/      POINTS TO FUNCTION BEING HACKED
+;      D/      POINTS TO ARG LIST (IF <0, CALLED FROM A PROG)
+;      0/      IF NON-ZERO POINTS TO EXPRESSION GENREATING CALL
+;
+;EVALER IS STORED ON THE STACK P AND USED TO EVALUATE ARGS WHEN NEEDED
+EVALER==-1
+
+;SWTCHS,STORED ON THE STACK, HOLDS MANY SWITCHES:
+SWTCHS==0
+
+OPT==1         ;ON IFF ARGUMENTS MAY BE OMITTED
+QUO==2         ;ON IFF ARGUMENT IS TO BE QUOTED
+AUX==4         ;ON IFF BINDING "AUX" VARS
+H==10          ;ON IFF THERE EXISTS A HEWITT ATOM
+DEF==20                ;ON IFF DEFAULT VALUE OF AN ARG HAS BEEN TAKEN
+
+
+BINDAP:        MOVE    A,[ARGNEV]
+       SKIPE   -1(P)
+       MOVE    A,[ARGEV]
+       POP     P,-1(P)         ;FLUSH EVAL MARKER
+       PUSH    P,A
+       JRST    BIND1
+BINDER:        PUSH    P,[ARGEV]
+       JRST    BIND1
+BINDRR:        PUSH    P,[NOTIMP]
+BIND1: PUSH    P,[0]           ;OPT _ QUO _ AUX _ H _ OFF
+       PUSH    P,0             ;SAVE CALL, IF ANY
+       PUSHJ   P,BNDVEC        ;E _ TOP OF BINDING STACK
+       GETYP   A,(C)
+       CAIE    A,TATOM         ;HEWITT ATOM?
+       JRST    BIND2
+       HLRE    A,E
+       HRRZ    B,E
+       SUB     B,A             ;B _ FIRST DOPE WORD OF E
+       MOVSI   A,TBIND
+       MOVEM   A,-6(B)         ;BUILD BIND BLOCK FOR ATOM
+       MOVE    A,1(C)          ;A _ HEWITT ATOM
+       MOVEM   A,-5(B)
+       MOVE    A,TB
+       HLL     A,OTBSAV(TB)    ;A _ POINTER TO THIS ACTIVATION
+       MOVEM   A,-3(B)
+       MOVEI   0,(PVP)
+       HLRE    A,PVP
+       SUBI    0,-1(A)         ;0 _ PROCESS VEC DOPE WORD
+       HRLI    0,TACT          ;0 IS FIRST WORD OF ACT VALUE
+       MOVEM   0,-4(B)         ;STORED IN BIND BLOCK
+       HRRZ    C,(C)           ;CDR THE FUNCTION
+BIND2: POP     P,0             ;0 _ CALLING EXPRESSION
+       PUSHJ   P,CARLST        ;C _ DECLS LIST
+       JRST    BINDC           ;IF (), QUIT
+       JUMPL   D,AUXDO         ;IN CASE OF PROG
+       MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;B _ NEXT STRING
+       JRST    BINDRG          ;ATOM INSTEAD
+       HRRZ    C,(C)           ;CDR DECLS
+
+
+;CHECK FOR "BIND"
+
+       CAME    B,[ASCII /BIND/ ]
+       JRST    CHCALL
+       JUMPE   C,MPD           ;GOT "BIND", NOW...
+       PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK
+       HRLZI   A,TENV
+       MOVE    B,1(SP)         ;B _ ENV BEFORE BNDVEC
+       PUSHJ   P,PSHBND        ;FINISH BIND BLOCK
+       HRRZ    C,(C)
+       JUMPE   C,BINDC         ;MAY BE DONE
+       MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;NEXT ONE
+       JRST    BINDRG          ;ATOM INSTEAD
+       HRRZ    C,(C)           ;CDR DECLS
+
+;CHECK FOR "CALL"
+
+CHCALL:        CAME    B,[ASCII /CALL/ ]
+       JRST    CHOPTI          ;GO INTO MAIN BINDING LOOP
+       JUMPE   0,MPD           ;GOT "CALL", SO 0 MUST BE CALL
+       JUMPE   C,MPD
+       PUSHJ   P,CARATE        ;GET ATOM & START BIND BLOCK\f   MOVE    B,0             ;B _ CALL
+       MOVSI   A,TLIST
+       PUSHJ   P,PSHBND        ;MAKE BIND BLOCK
+       HRRZ    C,(C)           ;CDR PAST "CALL" ATOM
+       JUMPE   C,BINDC         ;IF DONE, QUIT
+
+;DECLLP IS THE MAIN BINDING LOOP FOR HANDLING FUNCTIONAL ARGUMENTS AND
+;THE STRINGS SCATTERED THEREIN
+
+DECLLP:        MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;NEXT STRING...
+       JRST    BINDRG          ;...UNLESS SOMETHING ELSE
+       HRRZ    C,(C)           ;CDR DECLARATIONS
+CHOPTI:        TRZ     B,1             ;GOD KNOWS WHY TRZ B,1 (SOMETHING TO DO WITH OPTIO)
+
+;CHECK FOR "OPTIONAL"
+
+       CAME    B,[ASCII /OPTIO/]
+       JRST    CHREST
+       MOVE    0,SWTCHS(P)     ;OPT _ ON
+       TRO     0,OPT
+       MOVEM   0,SWTCHS(P)
+       JUMPE   C,BINDC
+       PUSHJ   P,EBINDS        ;BIND ALL PREVIOUS ARGUMENTS
+       JRST    DECLLP
+
+;CHECK FOR "REST"
+
+CHREST:        MOVE    0,SWTCHS(P)     ;0 _ SWITCHES
+       TRZ     0,OPT           ;OPT _ OFF
+       MOVEM   0,SWTCHS(P)
+       MOVEI   A,(C)
+       CAME    B,[ASCII /REST/]
+       JRST    CHTUPL
+       PUSHJ   P,NXTDCL        ;GOT "REST"-- LOOK AT NEXT THING
+       SKIPN   C
+       JRST    MPD             ;WHICH CAN'T BE STRING
+       PUSHJ   P,BINDB         ;GET NEXT ATOM
+       TRNE    0,QUO           ;QUOTED?
+       JRST    ARGSDO          ;YES-- JUST USE ARGS
+       JRST    TUPLDO
+
+;CHECK FOR "TUPLE"
+
+CHTUPL:        CAME    B,[ASCII /TUPLE/]
+       JRST    CHARG   
+       PUSHJ   P,NXTDCL        ;GOT "TUPLE"-- LOOK AT NEXT THING
+       SKIPN   C
+       JRST    MPD
+       PUSHJ   P,CARATE        ;WHICH BETTER BE ATOM
+
+TUPLDO:        PUSH    TP,$TLIST       ;SAVE STUFF
+       PUSH    TP,C
+       PUSH    TP,$TVEC
+       PUSH    TP,E
+       PUSH    P,[0]           ;ARG COUNTER\f;THIS LOOP BUILDS A TUPLE ON THE STACK, ON THE TOP OF THE ENTITIES
+;JUST SAVED-- DON'T WORRY; THEY'RE SAFE
+
+TUPLP: JUMPE   D,TUPDON        ;IF NO MORE ARGS, DONE
+       INTGO                   ;WATCH OUT FOR BIG TUPLES AND SMALL STACKS
+       PUSH    TP,$TLIST       ;SAVE D
+       PUSH    TP,D
+       GETYP   A,(D)           ;GET NEXT ARG
+       MOVSI   A,(A)
+       PUSH    TP,A            ;EVAL IT
+       PUSH    TP,1(D)
+       TRZ     0,DEF           ;OFF DEFAULT
+       PUSHJ   P,@EVALER-1(P)
+       POP     TP,D            ;RESTORE D
+       SUB     TP,[1,,1]
+       PUSH    TP,A            ;BUILD TUPLE
+       PUSH    TP,B
+       SOS     (P)             ;COUNT ELEMENTS
+       HRRZ    D,(D)           ;CDR THE ARGS
+       JRST    TUPLP
+TUPDON:        PUSHJ   P,MRKTUP        ;MAKE A TUPLE OF (P) ENTRIES
+       SUB     P,[1,,1]        ;FLUSH COUNTER
+       JRST    BNDRST\f;CHECK FOR "ARGS"
+
+CHARG: CAME    B,[ASCII /ARGS/]
+       JRST    CHAUX
+       PUSHJ   P,NXTDCL        ;GOT "ARGS"-- CHECK NEXT THING
+       SKIPN   C
+       JRST    MPD
+       PUSHJ   P,CARATE        ;WHICH MUST BE ATOM
+
+;HERE TO BIND AN ATOM TO THE REMAINING ARGS, UNEVALUATED
+
+ARGSDO:        MOVSI   A,TLIST         ;(A,B) _ CURRENT ARGS LEFT
+       MOVE    B,D
+       MOVEI   D,
+
+;BNDRST COMPLETES THE BIND BLOCK FOR BOTH TUPLES AND ARGS
+
+BNDRST:        PUSHJ   P,PSHBND
+       HRRZ    C,(C)           ;CDR THE DECLS
+       JUMPE   C,BINDC
+       MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;WHAT NEXT?
+       JRST    MPD             ;MUST BE A STRING OR ELSE
+       HRRZ    C,(C)           ;CDR DECLS
+
+;CHECK FOR "AUX"
+
+CHAUX: CAME    B,[ASCII /AUX/]
+       JRST    CHACT
+       JUMPG   D,TMA           ;ARGS MUST BE USED UP BY NOW
+       PUSH    P,C             ;SAVE C ON P (NO GC POSSIBLE)
+       PUSHJ   P,EBIND         ;BIND ALL ARG ATOMS
+       POP     P,C             ;RESTORE C
+
+;HERE FOR AUXIES OF "AUX" OR PROG VARIETY
+
+AUXDO: MOVE    0,SWTCHS(P)
+       TRO     0,AUX\OPT\DEF   ;OPTIONALS OBVIOUSLY ALLOWED
+       MOVEM   0,SWTCHS(P)
+AUXLP: JUMPE   C,BNDHAT        ;IF NO MORE, QUIT
+       MOVEI   A,(C)
+       PUSHJ   P,NXTDCL        ;GET NEXT DECLARATION STRING
+       JRST    AUXIE           ;INSTEAD, ANOTHER AUXIE-- DO IT
+       HRRZ    C,(C)           ;CDR PAST STRING
+       JRST    CHACT1          ;...WHICH MUST BE "ACT"
+
+;NORMAL AUXILIARY DECLARATION HANDLER
+
+AUXIE: MOVE    0,SWTCHS(P)
+       PUSH    TP,$TLIST       ;SAVE C
+       PUSH    TP,C
+       PUSHJ   P,BINDB         ;PUSH NEXT ATOM ONTO E
+       MOVE    A,$TVEC         ;SAVE E UNDER DEFAULT VALUE
+       EXCH    A,-1(TP)
+       EXCH    E,(TP)
+       PUSH    TP,A            ;(DEFAULT VALUE MUST BE REPUSHED)
+       PUSH    TP,E
+       PUSHJ   P,@EVALER(P)    ;EVAL THE VALUE IT IS TO RECEIVE
+       POP     TP,E            ;RESTORE E
+       SUB     TP,[1,,1]
+       PUSHJ   P,PSHBND        ;COMPLETE BINDING BLOCK WITH VALUE
+       PUSHJ   P,EBIND         ;BIND THE ATOM
+       POP     TP,C            ;RESTORE C
+       SUB     TP,[1,,1]
+       HRRZ    C,(C)           ;CDR THE DECLARATIONS
+       JRST    AUXLP
+\f;"ACT" CAN OCCUR ONLY AT THE END, HEWITT ATOMS NOTWITHSTANDING
+
+CHACT1:        MOVEI   D,              ;MAKE IT CLEAR THAT THERE ARE NO ARGS
+CHACT: CAME    B,[ASCII /ACT/] ;ONLY THING POSSIBLE
+       JRST    MPD
+       JUMPE   C,MPD           ;BETTER HAVE AN ATOM TO BIND TO ACT
+       PUSHJ   P,CARATE        ;START BIND BLOCK WITH IT
+       MOVEI   A,(PVP)
+       HLRE    B,PVP
+       SUBI    A,-1(B)         ;A _ PROCESS VEC DOPE WORD
+       HRLI    A,TACT
+       MOVE    B,TB
+       HLL     B,OTBSAV(TB)    ;(A,B) _ ACTIVATION POINTER
+       PUSHJ   P,PSHBND
+       HRRZ    C,(C)           ;"ACT" MUST HAVE BEEN LAST
+       JUMPN   C,MPD
+
+;AT THIS POINT, ALL ENTRIES ARE FINAL AND ALL THINGS LOOSED
+;IN E SHALL BE BOUND IN E, EVENTUALLY
+
+BINDC: JUMPG   D,TMA           ;ARGS SHOULD BE USED UP BY NOW
+       PUSHJ   P,EBIND         ;BIND EVERYTHING NOT BOUND
+BNDHAT:        MOVE    0,SWTCHS(P)     ;EVEN THE HEWITT ATOM
+       TRNN    0,H             ;IF THERE IS ONE
+       JRST    BNDRET
+       HLRE    B,E
+       HRRZI   E,(E)
+       SUB     E,B             ;E _ DOPE WORD OF BINDING VECTOR
+       SUB     E,[5,,5]        ;E _ POINTER TO HEWITT ATOM SLOT
+       PUSHJ   P,COMBLK        ;CHAIN THIS BLOCK TO PREVIOUS THING IN VECTOR
+       ADD     E,[4,,4]        ;E _ LAST WORD OF BINDING VECTOR
+       PUSHJ   P,EBIND         ;BIND THE HEWITT ATOM
+
+;THIS IS THE WAY OUT OF THE BINDER
+
+BNDRET:        POP     P,A             ;A _ SWITCHES
+       SUB     P,[1,,1]        ;FLUSH EVALER
+       POPJ    P,              ;RETURN FROM BINDER\f;TO BIND A PERFECTLY ORDINARY ARGUMENT SPECIFICATION
+;FOUND IN A DECLS LIST, JUMP HERE
+
+BINDRG:        MOVE    0,SWTCHS(P)
+       PUSHJ   P,BINDB         ;GET ATOM IN THE NEXT DECL
+       JUMPE   D,CHOPT3        ;IF ARG EXISTS,
+       TRNE    0,OPT
+       SUB     TP,[2,,2]       ;PITCH ANY DEFAULT THAT MAY EXIST
+       GETYP   A,(D)           ;(A,B) _ NEXT ARG
+       MOVSI   A,(A)
+       MOVE    B,1(D)
+       HRRZ    D,(D)           ;CDR THE ARGS
+       TRZN    0,QUO           ;ARG QUOTED?
+       JRST    BNDRG1          ;NO-- GO EVAL
+CHDEFR:        MOVEM   0,SWTCHS(P)
+       CAME    A,$TDEFER       ;QUOTED-- PUNT ANY TDEFER'S YOU FIND
+       JRST    DCLCDR
+       GETYP   A,(B)           ;(A,B) _ REAL POINTER, NOT DEFERRED
+       MOVE    B,1(B)
+       JRST    DCLCDR          ;AND FINISH BIND BLOCK
+
+;OPTIONAL ARGUMENT?
+
+CHOPT3:        TRNN    0,OPT           ;IF NO ARG, BETTER BE OPTIONAL
+       JRST    TFA
+       POP     TP,B            ;(A,B) _ DEFAULT VALUE
+       POP     TP,A
+       TRZE    0,QUO           ;IF QUOTED,
+       JRST    CHDEFR          ;JUST PUSH
+       TRO     0,DEF           ;ON DEFAULT
+
+;EVALUATE WHATEVER YOU HAVE AT THIS POINT
+
+BNDRG1:        PUSH    TP,$TLIST       ;SAVE STUFF
+       PUSH    TP,D
+       PUSH    TP,$TLIST
+       PUSH    TP,C
+       PUSH    TP,$TVEC
+       PUSH    TP,E
+       PUSH    TP,A
+       PUSH    TP,B
+       PUSHJ   P,@EVALER(P)    ;(A,B) _ <EVAL (A,B)>
+       MOVE    E,(TP)          ;RESTORE C, D, & E
+       MOVE    C,-2(TP)
+       MOVE    D,-4(TP)
+       SUB     TP,[6,,6]
+       MOVE    0,SWTCHS(P)     ;RESTORE 0
+
+
+;FINISH THE BIND BLOCK WITH (A,B) AND GO ON
+
+DCLCDR:        PUSHJ   P,PSHBND
+       TRNE    0,OPT           ;IF OPTIONAL,
+       PUSHJ   P,EBINDS        ;BIND IT
+       HRRZ    C,(C)
+       JUMPE   C,BINDC         ;IF NO MORE DECLS, QUIT
+       JRST    DECLLP\f;THIS ROUTINE CREATES THE BIND VECTOR BINDER USES; IT ALLOCATES
+;THREE SLOTS PER NON-STRING DECLARATION (I.E., ATOM TO BE BOUND),
+;THREE FOR A HEWITT ATOM IF IT FINDS ONE, AND ONE FOR THE ACCESS
+;TYPE-TSP POINTER TO SP.
+
+;IT SETS E TO THE CURRENT TOP OF THE VECTOR; IT FILLS IN
+;ACCESS SLOT WITH SP, AND SETS SP TO POINT TO
+;THE START OF THIS VECTOR.  IT MAY SET SWITCH H TO ON, IFF IT FINDS
+;A HEWITT ATOM.  IT CLOBBERS A & B, RESTORES C & D, AND LEAVES THE
+;SWITCHES IN 0
+
+;IF BNDVEC FINDS NO DECLARATIONS, IT TAKES THE LIBERTY OF EXITING
+;FROM THE BINDER WITHOUT DISTURBING SP.  BNDVEC DOES SOME ERROR
+;CHECKING, BUT NOT ALL, AS IT DOES NOT LOOK AT THE ARGS IN D.
+;THIS EXPLAINS WHY BINDER OMITS SOME.
+
+BNDVEC:        PUSH    TP,$TLIST       ;SAVE C & D
+       PUSH    TP,C
+       PUSH    TP,$TLIST
+       PUSH    TP,D
+       JUMPE   C,NOBODY
+       MOVE    0,SWTCHS-2(P)   ;UNBURY THE SWITCHES
+       MOVEI   D,              ;D = COUNTER _ 0
+       GETYP   A,(C)           ;A _ FIRST THING
+       CAIE    A,TATOM         ;HEWITT ATOM?
+       JRST    NOHATM
+       TRO     0,H             ;TURN SWITCH H ON
+       ADDI    D,3             ;YES-- SAVE 3 SLOTS FOR IT
+       HRRZ    C,(C)           ;CDR THE FUNCTION
+       JUMPE   C,NOBODY
+NOHATM:        PUSHJ   P,CARLST        ;C _ <1 .C>
+       JRST    CNTRET          ;IF (), ALL COUNTED
+       MOVEI   A,(C)           ;A _ DECLS
+
+;HERE IS THE QUICK LOOP THROUGH THE DECLARATIONS
+
+DCNTLP:        PUSHJ   P,NXTDCL        ;SKIP IF NEXT ONE IS A STRING
+DINC:  ADDI    D,3             ;3 SLOTS FOR AN ATOM
+       HRRZ    A,(A)           ;GO AROUND AGAIN
+       JUMPN   A,DCNTLP
+
+;IF ANYTHING WAS FOUND, INITIALIZE THE VECTOR
+
+CNTRET:        JUMPE   D,NODCLS        ;OTHERWISE, BIND NOTHING
+       AOJ     D,              ;DON'T FORGET ACCESS SLOT
+       MOVEM   0,SWTCHS-2(P)   ;SAVE SWITCHES
+       PUSH    TP,$TFIX
+       PUSH    TP,D
+       MCALL   1,VECTOR        ;B _ <VECTOR .D>
+       MOVE    D,(TP)          ;RESTORE C & D
+       MOVE    C,-2(TP)
+       SUB     TP,[4,,4]
+       MOVE    E,B             ;FROM NOW ON, E _ BIND VECTOR TOP
+       MOVE    A,B
+       MOVSI   B,TSP
+       MOVEM   B,(E)           ;FILL ACCESS SLOT
+       PUSH    E,SP
+       MOVE    SP,A            ;SP NOW POINTS THROUGH THIS VECTOR
+       POPJ    P,
+
+;IF THERE ARE NO DECLS (E.G. <FUNCTION ()...>), JUST QUIT
+
+NODCLS:        MOVE    D,(TP)          ;RESTORE C & D
+       MOVE    C,-2(TP)
+       SUB     TP,[4,,4]
+       SUB     P,[2,,2]        ;PITCH RETURN ADDRESS AND CALL
+       JRST    BNDRET\f;THIS ROUTINE CREATES A POINTER TO THE TUPLE RESTING ON TOP OF
+;TP.  IT TAKES ITS NEGATIVE LENGTH (IN CELLS) IN (P).  IT ASSUMES
+;THERE ARE TWO TEMPORARY CELLS BENEATH IT, AND RESTORES
+;THEM INTO C AND E, MOVING THE TUPLE OVER THE TEMPORARY
+;SLOTS.  IT RETURNS A CORRECT TARGS POINTER TO THE TUPLE IN A AND B
+
+MRKTUP:        MOVSI   A,TTB           ;FENCE-POST TUPLE
+       PUSH    TP,A
+       PUSH    TP,TB
+       MOVEI   A,2             ;B_ADDRESS OF INFO CELL
+       PUSHJ   P,CELL"         ;MAY CALL AGC
+       MOVSI   A,TINFO
+       MOVEM   A,(B)
+       MOVEI   A,(TP)          ;GENERATE DOPE WORD POINTER
+       HLRE    C,TP
+       SUBI    A,-1(C)
+       CAME    A,TPGROW"       ;ALLOWING FOR BLOWN PDL
+       ADDI    A,PDLBUF
+       HRLZI   A,-1(A)         ;A HAS 1ST DW PTR IN LEFT HALF
+       HLR     A,OTBSAV(TB)    ;TIME TO RIGHT
+       MOVEM   A,1(B)          ;TO SECOND WORD OF CELL
+       EXCH    B,-1(P)         ;B _ - ARG COUNT
+       ASH     B,1             ;B _ 2*B
+       HRRM    B,-1(TP)        ;STORE IN TTB FENCEPOST
+       HRRZI   A,-5(TP)
+       ADD     A,B             ;A _ ADR OF TUPLE
+       HRLI    A,(B)           ;A _ TUPLE POINTER
+       MOVE    B,A             ;B, TOO
+       HRLI    A,4(A)          ;LH A _ CURRENT PLACE OF TUPLE
+       MOVE    C,1(A)          ;RESTORE C AND E
+       MOVE    E,3(A)
+       BLT     A,-4(TP)        ;MOVE TUPLE OVER OLD C, E COPIES
+       SUB     TP,[4,,4]
+       MOVE    A,-1(P)
+       HRLI    A,TARGS         ;A _ FIRST WORD OF ARGS TUPLE VALUE
+       POPJ    P,\f;THIS ROUTINE, GIVEN SWTCHS IN 0 AND DECLARATIONS LIST POINTER
+;IN C, PUSHES ATOM IN THE FIRST DECLARATION ONTO E.  IT MAY SET
+;SWITCHES OPT AND QUO, AND LEAVES SWITCHES IN 0.    IFF OPT = ON,
+;BINDB PUSHES A DEFAULT VALUE (EVEN IF ?()) ONTO TP.  A & B ARE
+;CLOBBERED.  C IS NOT ALTERED.
+
+BINDB: MOVE    A,C             ;A _ C
+       GETYP   B,(A)
+       CAIE    B,TLIST         ;A = ((...)...) ?
+       JRST    CHOPT1
+       TRNN    0,OPT           ;YES-- OPT MUST BE ON
+       JRST    MPD
+       MOVEM   0,SWTCHS-1(P)   ;SAVE SWITCHES
+       MOVE    A,1(A)          ;A _ <1 .A> = (...)
+       JUMPE   A,MPD           ;A = () NOT ALLOWED
+       HRRZ    B,(A)           ;B _ <REST .A>
+       JUMPE   B,MPD           ;B = () NOT ALLOWED
+       PUSH    TP,(B)          ;SAVE <1 .B> AS DEFAULT
+       PUSH    TP,1(B)         ;VALUE OF ATOM IN A
+       HRRZ    B,(B)
+       JUMPN   B,MPD           ;<REST .B> MUST = ()
+       GETYP   B,(A)
+       JRST    CHFORM          ;GO SEE WHAT <1 .A> IS
+
+CHOPT1:        TRNN    0,OPT           ;IF OPT = ON
+       JRST    CHFORM
+       PUSH    TP,$TUNAS       ;DEFAULT VALUE IS ?()
+       PUSH    TP,[0]
+
+;AT THIS POINT, <1 .A> MUST BE ATOM OR <QUOTE ATOM>
+
+CHFORM:        TRNE    0,AUX           ;NO QUOTES ALLOWED IN AUXIES
+       JRST    CHATOM
+       CAIE    B,TFORM
+       JRST    CHATOM
+       MOVE    A,1(A)          ;A _ <1 .A> = <...>
+       JUMPE   A,MPD           ;A = <> NOT ALLOWED
+       MOVE    B,1(A)          ;B _ <1 .A>
+       CAME    B,MQUOTE QUOTE
+       JRST    MPD             ;ONLY A = <QUOTE...> ALLOWED
+       TRO     0,QUO           ;QUO _ ON
+       MOVEM   0,SWTCHS-1(P)
+       HRRZ    A,(A)           ;A _ <REST .A>
+       JUMPE   A,MPD           ;<QUOTE> NOT ALLOWED
+       GETYP   B,(A)
+
+;AT THIS POINT WE HAVE THE ATOM OR AN ERROR
+
+CHATOM:        CAIE    B,TATOM         ;<1 .A> MUST BE ATOM
+       JRST    MPD
+       MOVE    A,1(A)          ;A _ THE ATOM!!!
+       JRST    PSHATM          ;WHICH MUST BE PUSHED ONTO E
+
+
+
+;THE FOLLOWING LITTLE ROUTINE ACCEPTS THE NEXT DECLARATION ONLY
+;IF IT IS ATOMIC, AND PUSHES IT ONTO E
+
+CARATE:        GETYP   A,(C)
+       CAIE    A,TATOM
+       JRST    MPD
+       MOVE    A,1(C)          ;A _ ATOM
+       MOVE    0,SWTCHS-1(P)
+PSHATM:        PUSH    E,$TBIND        ;FILL FIRST TWO SLOTS OF BIND BLOCK
+       PUSH    E,A
+
+;EACH BIND BLOCK MUST POINT TO THE PREVIOUS ONE OR TO AN ACCESS
+;POINTER TO ANOTHER VECTOR ALTOGETHER.  COMBLK MAKES SURE IT DOES.
+
+COMBLK:        GETYP   B,-7(E)         ;LOOK FOR PREVIOUS BIND
+       CAIE    B,TBIND         ;IF FOUND, MAKE NORMAL LINK
+       JRST    ABNORM          
+       MOVEI   B,-7(E)         ;IN MOST CASES, SEVEN
+MAKLNK:        HRRM    B,-1(E)         ;MAKE THE LINK
+       POPJ    P,
+ABNORM:        MOVEI   B,-3(E)
+       JRST    MAKLNK
+\f;THIS ROUTINE COMPLETES A BIND BLOCK BEGUN BY CARATE OR BINDB
+;WITH THE VALUE (A,B)
+
+PSHBND:        PUSH    E,A
+       PUSH    E,B
+       ADD     E,[2,,2]        ;ASSUME BIND VECTOR IS FULL OF 0'S
+       POPJ    P,
+
+;THIS ONE DOES AN EBIND, SAVING C & D:
+
+EBINDS:        PUSH    P,C             ;SAVE C & D (NO DANGER OF GC)
+       PUSH    P,D
+       PUSHJ   P,EBIND         ;BIND ALL NON-OPTIONAL ARGUMENTS
+       POP     P,D
+       POP     P,C             ;RESTORE C & D
+       POPJ    P,
+
+
+;THE FOLLOWING RETURNS THE CAR OF C IN C, SKIPPING IF 
+;<EMPTY? <1 .C>>, AND ERRING IF <NOT <==? <TYPE <1 .C>> LIST>>
+
+CARLST:        GETYP   A,(C)
+       CAIE    A,TLIST
+       JRST    MPD             ;NOT A LIST, FATAL
+       SKIPE   C,1(C)
+       AOS     (P)
+       POPJ    P,
+
+
+;...AND THERE ARE A FEW PEOPLE STILL CALLING THE FOLLOWING:
+
+MAKENV:        PUSH    P,C             ;SAVE AN AC
+       HLRE    C,PVP           ;GET -LNTH OF PROC VECTOR
+       MOVEI   A,(PVP)         ;COPY PVP
+       SUBI    A,-1(C)         ;POINT TO DOPWD WITH A
+       HRLI    A,TFRAME        ;MAKE INTO A FRAME
+       HLL     B,OTBSAV(B)     ;TIME TO B
+       POP     P,C
+       POPJ    P,
+
+
+
+\f;THESE ROUTINES ARE CALLED TO EVALUATE THE VALUE PUSHED
+;ON TP    ****THEY ARE ASSUMED TO CLOBBER EVERYTHING****
+
+ARGEV: JSP     E,CHKARG
+       MCALL   1,EVAL
+       POPJ    P,
+
+
+
+
+;WHEN APPLY-ING, ARGS ARE ALREADY EVALUATED
+
+ARGNEV:        JSP     E,CHKARG        ;PITCH ANY TDEFERS
+       TRNN    0,DEF           ;DEFAULT VALUES...
+       JRST    NOEV
+       MCALL   1,EVAL          ;...ARE ALWAYS EVALUATED
+       POPJ    P,
+NOEV:  POP     TP,B            ;OTHERWISE,
+       POP     TP,A            ;JUST RESTORE A&B
+       POPJ    P,\f
+
+;SPECBIND BINDS IDENTIFIERS. IT IS CALLED BY PUSHJ P,SPECBIND.
+;SPECBIND IS PROVIDED WITH A CONTIGUOUS SET OF TRIPLETS ON TP.  
+;EACH TRIPLET IS AS FOLLOWS:
+;THE FIRST ELEMENT IS THE IDENTIFIER TO BE BOUND, ITS TYPE WORD IS [TATOM,,-1],
+;THE SECOND IS THE VALUE TO WHICH IT IS TO BE ASSIGNED,
+;AND THE THIRD IS A PAIR OF ZEROES.
+
+BNDA:  TATOM,,-1
+
+SPECBIND:      MOVE    E,TP            ;GET THE POINTER TO TOP
+       ADD     E,[1,,1]        ;BUMP POINTER ONCE
+       PUSH    TP,$TTP
+       PUSH    TP,E
+       MOVEI   B,              ;ZERO COUNTER
+       MOVE    D,E
+SZLOOP:        MOVE    A,-6(D)         ;COUNT ATOM BLOCKS AS 3
+       CAME    A,BNDA
+       JRST    GETVEC
+       SUB     D,[6,,6]
+       ADDI    B,3
+       JRST    SZLOOP
+GETVEC:        JUMPE   B,DEGEN
+       PUSH    P,B
+       AOJ     B,
+       PUSH    TP,$TTP
+       PUSH    TP,D
+       PUSH    TP,$TFIX
+       PUSH    TP,B
+       MCALL   1,VECTOR        ;<VECTOR .B>
+       POP     TP,D            ;RESTORE D = POINTER TO BOTTOM TRIPLE
+       SUB     TP,[1,,1]
+       MOVE    A,$TSP          ;MAKE THIS BLOCK POINT TO PREVIOUS
+       MOVEM   A,(B)
+       MOVEM   SP,1(B)
+       ADDI    B,2
+
+;MOVE TRIPLES TO VECTOR
+
+       POP     P,E             ;E _ LENGTH  - 1
+       ASH     E,1             ;TIMES 2
+       ADDI    E,(B)           ;E _ POINTER TO VECTOR DOPE WORD
+       HRLI    A,(D)
+       HRRI    A,(B)
+       BLT     A,-1(E)         ;MOVE BIND TRIPLES TO VECTOR
+
+;CHANGE ALL [TATOM,,-1]'S TO [TBIND,,LINK TO PREVIOUS BLOCK]
+
+       HRRZI   B,(B)           ;ZERO LEFT HALF OF B
+       MOVSI   C,TBIND
+       HRRI    C,-2(B)         ;C = LINK _ ADR OF FIRST OF VECTOR
+FIXLP: MOVEM   C,(B)           ;STORE LINK TO PREVIOUS BLOCK IN BLOCK B
+       HRRI    C,(B)           ;C _ LINK TO THIS BLOCK
+       ADDI    B,6
+       CAIE    B,(E)           ;GOT TO DOPE WORD?
+       JRST    FIXLP
+
+;CLEAN UP TP
+
+       POP     TP,C
+       SUB     TP,[1,,1]
+       CAMLE   C,TP            ;ANYTHING ABOVE TRIPLES?
+       JRST    NOBLT2
+       SUBI    TP,(C)          ;TP _ NUMBER THERE
+       HRLS    TP              ;IN BOTH HALVES
+       ADD     TP,D            ;NEW TP
+       HRLI    D,(C)
+       BLT     D,(TP)          ;BLLLLLLLLT!
+       JRST    SPCBE2
+DEGEN: SUB     TP,[2,,2]
+       POPJ,
+NOBLT2:        MOVE    TP,D            ;OR JUST RESTORE IT
+       SUB     TP,[1,,1]
+
+;HERE TO BIND EVERYTHING IN VECTOR WITH DOPE WORD (E)
+
+SPCBE2:        SUB     E,[1,,1]        ;E _ LAST WORD OF LAST BLOCK
+
+;EBIND BINDS THE ATOMS SPECIFIED BY THE BLOCK WHOSE LAST WORD
+;E POINTS TO, THEN THE BLOCK LINKED TO IT, ETC., UNTIL
+;IT FINDS ONE ALREADY BOUND, WHEN IT RESTORES E AND EXITS.
+;IT RESETS SP TO POINT TO THE FIRST ONE BOUND.  IT CLOBBERS
+;ALL OTHER REGISTERS
+
+EBIND: HLRZ    A,-1(E)
+       SKIPE   A               ;ALREADY BOUND?
+       POPJ    P,              ;YES-- EBIND IS A NO-OP
+       MOVEI   D,              ;D WILL BE THE NEW SP
+       PUSH    P,E             ;SAVE E
+       JRST    DOBIND
+
+BINDLP:        HLRZ    A,-1(E)
+       SKIPE   A               ;HAS THIS BLOCK BEEN BOUND ALREADY?
+       JRST    SPECBD          ;YES, RESTORE AND QUIT
+DOBIND:        SUB     E,[6,,6]
+       SKIPN   D               ;HAS NEW SP ALREADY BEEN SET?
+       MOVE    D,E             ;NO, SET TO THIS BLOCK FOR NOW
+       MOVE    A,1(E)
+       MOVE    B,2(E)
+       PUSHJ   P,ILOC          ;(A,B) _ LOCATIVE OF (A,B)
+       HLR     A,OTBSAV(TB)
+       MOVEM   A,5(E)          ;CLOBBER IT AWAY
+       MOVEM   B,6(E)          ;IN RESTORE CELLS
+
+       HRRZ    A,PROCID+1(PVP) ;GET PROCESS NUMBER
+       HRLI    A,TLOCI         ;MAKE LOC PTR
+       MOVE    B,E             ;TO NEW VALUE
+       ADD     B,[3,,3]
+       MOVE    C,2(E)          ;GET ATOM PTR
+       MOVEM   A,(C)           ;CLOBBER ITS VALUE
+       MOVEM   B,1(C)          ;CELL
+       JRST    BINDLP
+
+SPECBD:        MOVE    SP,D            ;SP _ D
+       ADD     SP,[1,,1]       ;FIX SP
+       POP     P,E             ;RESTORE E TO TOP OF BIND VECTOR
+       POPJ    P,
+
+\f
+
+;SPECSTORE RESTORES THE BINDINGS SP TO THE ENVIRONMENT POINTER IN 
+;SPSAV (TB).  IT IS CALLED BY PUSHJ P,SPECSTORE.
+
+SPECSTORE:
+       HRRZ    E,SPSAV (TB)    ;GET TARGET POINTER
+
+STLOOP:
+       CAIN    E,(SP)          ;ARE WE DONE?
+       JRST    STPOPJ
+       HLRZ    C,(SP)          ;GET TYPE OF BIND
+       CAIE    C,TBIND         ;NORMAL IDENTIFIER?
+       JRST    JBVEC           ;NO-- FIND & FOLLOW REBIND POINTER
+
+
+       MOVE    C,1(SP)         ;GET TOP ATOM
+       MOVE    D,4(SP)         ;GET STORED LOCATIVE
+\r      HRR     D,PROCID+1(PVP) ;STORE SIGNATURE
+       MOVEM   D,(C)           ;CLOBBER INTO ATOM
+       MOVE    D,5(SP)
+       MOVEM   D,1(C)
+       HRRZS   4(SP)           ;NOW LOOKS LIKE A VIRGIN BLOCK
+       SETZM   5(SP)
+       HRRZ    SP,(SP)         ;GET NEXT BLOCK
+       JRST    STLOOP
+
+;IN JUMPING TO A NEW BIND VECTOR, FOLLOW
+;REBIND POINTER IF IT DIFFERS FROM ACCESS POINTER
+
+JBVEC: CAIE    C,TSP           ;THIS JUST BETTER BE TRUE, THAT'S ALL
+       .VALUE  [ASCIZ /BADSP/]
+       GETYP   D,2(SP)         ;REBIND POINTER?
+       CAIE    D,TSP
+       JRST    XCHVEC          ;NO-- USE ACCESS
+       MOVE    D,5(SP)         ;YES-- RESTORE PROCID
+       EXCH    D,PROCID+1(PVP)
+       MOVEM   D,5(SP)         ;SAVING CURRENT ONE FOR LATER FAILURES
+       ADD     SP,[2,,2]
+
+;IF WE JUST RAN OFF THE END OF THE ENVIRONMENT CHAIN, BARF
+
+XCHVEC:        SKIPE   SP,1(SP)
+       JRST    STLOOP
+       JUMPE   E,STPOPJ        ;UNLESS THAT'S AS FAR AS WE WANTED TO GO
+       .VALUE  [ASCIZ /SPOVERPOP/]
+
+STPOPJ:
+       MOVE    SP,SPSAV(TB)
+       POPJ    P,
+
+
+\f
+
+MFUNCTION REP,FSUBR,[REPEAT]
+       JRST    PROG
+MFUNCTION PROG,FSUBR
+       ENTRY   1
+       GETYP   A,(AB)          ;GET ARG TYPE
+       CAIE    A,TLIST         ;IS IT A LIST?
+       JRST    WTYP            ;WRONG TYPE
+       SKIPN   C,1(AB)         ;GET AND CHECK ARGUMENT
+       JRST    ERRTFA          ;TOO FEW ARGS
+       PUSH    TP,$TLIST       ;PUSH GOODIE
+       PUSH    TP,C
+BIPROG:        PUSH    TP,$TLIST
+       PUSH    TP,C            ;SLOT FOR WHOLE BODY
+       PUSHJ   P,PROGAT        ;BIND FUNNY PROG MARKER
+       MOVE    C,3(TB)         ;PROG BODY
+       MOVNI   D,1             ;TELL BINDER WE ARE APROG
+       PUSHJ   P,BINDER
+       HRRZ    C,3(TB)         ;RESTORE PROG
+       TRNE    A,H             ;SKIP IF NO NAME ALA HEWITT
+       HRRZ    C,(C)
+       JUMPE   C,NOBODY
+       MOVEM   C,3(TB)         ;SAVE FOR AGAIN, ETC.
+STPROG:        HRRZ    C,(C)           ;SKIP DCLS
+       JUMPE   C,NOBODY
+
+; HERE TO RUN PROGS FUNCTIONS ETC.
+
+DOPROG:
+       HRRZM   C,1(TB)         ;CLOBBER AWAY BODY
+       PUSH    TP,(C)          ;EVALUATE THE
+       HLLZS   (TP)
+       PUSH    TP,1(C)         ;STATEMENT
+       JSP     E,CHKARG
+       MCALL   1,EVAL  
+       HRRZ    C,@1(TB)        ;GET THE REST OF THE BODY
+       JUMPN   C,DOPROG        ;IF MORE -- DO IT
+ENDPROG:
+       HRRZ    C,FSAV(TB)
+       MOVE    C,@-1(C)
+       CAME    C,MQUOTE REP,REPEAT
+       JRST    FINIS
+       SKIPN   C,3(TB)         ;CHECK IT
+       JRST    FINIS
+       MOVEM   C,1(TB)
+       JRST    CONTINUE
+
+;HERE TO BIND PROG ATOM (AND ANYTHING ELSE ON STACK)
+
+PROGAT:        PUSH    TP,BNDA
+       PUSH    TP,MQUOTE [LPROG ],INTRUP
+       MOVE    B,TB
+       PUSHJ   P,MAKENV                ;B _ POINTER TO CURRENT FRAME
+       PUSH    TP,A
+       PUSH    TP,B
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       JRST    SPECBI\f
+
+MFUNCTION RETURN,SUBR
+       ENTRY   1
+       PUSHJ   P,PROGCH        ;CKECK IN A PROG
+       PUSHJ   P,SAVE          ;RESTORE PROG'S FRAME, BCKTRKING IF NECESSARY
+       MOVE    A,(AB)
+       MOVE    B,1(AB)
+       JRST    FINIS
+
+
+MFUNCTION AGAIN,SUBR
+       ENTRY   
+       HLRZ    A,AB            ;GET # OF ARGS
+       CAIN    A,-2            ;1 ARG?
+       JRST    NLCLA           ;YES
+       JUMPN   A,WNA           ;0 ARGS?
+       PUSHJ   P,PROGCH        ;CHECK FOR IN A PROG
+       JRST    AGAD
+NLCLA: HLRZ    A,(AB)
+       CAIE    A,TACT
+       JRST    WTYP
+       MOVE    A,1(AB)
+       HRR     B,A
+       HLL     B,OTBSAV (B)
+       HRRZ    C,A
+       CAIG    C,1(TP)
+       CAME    A,B
+       JRST    ILLFRA
+       HLRZ    C,FSAV (C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+AGAD:  PUSHJ   P,SAVE          ;RESTORE FRAME TO REPEAT
+       MOVE    B,3(TB)
+       MOVEM   B,1(TB)
+       JRST    CONTIN
+
+MFUNCTION GO,SUBR
+       ENTRY   1
+       PUSHJ   P,PROGCH        ;CHECK FOR A PROG
+       PUSH    TP,A            ;SAVE
+       PUSH    TP,B
+       MOVE    A,(AB)
+       CAME    A,$TATOM
+       JRST    NLCLGO
+       PUSH    TP,A
+       PUSH    TP,1(AB)
+       PUSH    TP,2(B)
+       PUSH    TP,3(B)
+       MCALL   2,MEMQ          ;DOES IT HAVE THIS TAG?
+       JUMPE   B,NXTAG         ;NO -- ERROR
+FNDGO: EXCH    B,(TP)          ;SAVE PLACE TO GO
+       MOVSI   D,TLIST
+       MOVEM   D,-1(TP)
+       JRST    GODON
+
+NLCLGO:        CAME    A,$TTAG         ;CHECK TYPE
+       JRST    WTYP
+       MOVE    A,1(AB)         ;GET ARG
+       HRR     B,3(A)
+       HLL     B,OTBSAV(B)
+       HRRZ    C,B
+       CAIG    C,1(TP)
+       CAME    B,3(A)          ;CHECK TIME
+       JRST    ILLFRA
+       HLRZ    C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       PUSH    TP,(A)          ;SAVE BODY
+       PUSH    TP,1(A)
+GODON: PUSHJ   P,SAVE          ;GO BACK TO CORRECT FRAME
+       MOVE    B,(TP)          ;RESTORE ITERATION MARKER
+       MOVEM   B,1(TB)
+       MOVE    A,(AB)
+       MOVE    B,1(AB)
+       JRST    CONTIN
+
+\f
+
+
+MFUNCTION TAG,SUBR
+       ENTRY   1
+       HLRZ    A,(AB)          ;GET TYPE OF ARGUMENT
+       CAIE    A,TATOM         ;CHECK THAT IT IS AN ATOM
+       JRST    WTYP
+       PUSHJ   P,PROGCH        ;CHECK PROG
+       PUSH    TP,A            ;SAVE VAL
+       PUSH    TP,B
+       PUSH    TP,0(AB)
+       PUSH    TP,1(AB)
+       PUSH    TP,2(B)
+       PUSH    TP,3(B)
+       MCALL   2,MEMQ
+       JUMPE   B,NXTAG         ;IF NOT FOUND -- ERROR
+       EXCH    A,-1(TP)        ;SAVE PLACE
+       EXCH    B,(TP)  
+       PUSH    TP,A            ;UNDER PROG FRAME
+       PUSH    TP,B
+       MCALL   2,EVECTOR
+       MOVSI   A,TTAG
+       JRST    FINIS
+
+PROGCH:        MOVE    B,MQUOTE [LPROG ],INTRUP
+       PUSHJ   P,ILVAL         ;GET VALUE
+       GETYP   C,A
+       CAIE    C,TFRAME
+       JRST    NXPRG
+       MOVE    C,B             ;CHECK TIME
+       HLL     C,OTBSAV(B)
+       CAME    C,B
+       JRST    ILLFRA
+       HRRZI   C,(B)           ;PLACE
+       CAILE   C,1(TP)
+       JRST    ILLFRA
+       GETYP   C,FSAV(C)
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       POPJ    P,
+
+MFUNCTION EXIT,SUBR
+       ENTRY   2
+       PUSHJ   P,TILLFM        ;TEST FRAME
+       PUSHJ   P,SAVE          ;RESTORE FRAME
+       JRST    EXIT2
+
+;IF GIVEN, RETURN SECOND ARGUMENT
+
+RETRG2:        MOVE    A,2(AB)
+       MOVE    B,3(AB)
+       MOVE    AB,ABSAV(TB)    ;IN CASE OF GC
+       JRST    FINIS
+
+MFUNCTION COND,FSUBR
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP
+       PUSH    TP,(AB)
+       PUSH    TP,1(AB)                ;CREATE UNNAMED TEMP
+CLSLUP:        SKIPN   B,1(TB)         ;IS THE CLAUSELIST NIL?
+       JRST    IFALSE          ;YES -- RETURN NIL
+       HLRZ    A,(B)           ;NO -- GET TYPE OF CAR
+       CAIE    A,TLIST         ;IS IT A LIST?
+       JRST    BADCLS          ;
+       MOVE    A,1(B)          ;YES -- GET CLAUSE
+       JUMPE   A,BADCLS
+       PUSH    TP,(A)          ;EVALUATION OF
+       HLLZS   (TP)
+       PUSH    TP,1(A)         ;THE PREDICATE
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       CAMN    A,$TFALSE       ;IF THE RESULT IS
+       JRST    NXTCLS          ;FALSE TRY NEXT CLAUSE
+       MOVE    C,1(TB)         ;IF NOT, DO FIRST CLAUSE
+       MOVE    C,1(C)
+       HRRZ    C,(C)
+       JUMPE   C,FINIS         ;(UNLESS DONE WITH IT)
+       JRST    DOPROG          ;AS THOUGH IT WERE A PROG
+NXTCLS:        HRRZ    A,@1(TB)        ;SET THE CLAUSLIST
+       HRRZM   A,1(TB)         ;TO CDR OF THE CLAUSLIST
+       JRST    CLSLUP
+       
+IFALSE:
+       MOVSI   A,TFALSE        ;RETURN FALSE
+       MOVEI   B,0
+       JRST    FINIS
+
+
+
+
+;RESTORE TB TO STACK FRAME POINTED TO BY B, SAVING INTERMEDIATE FRAMES ON THE PLANNER PDL 
+;IF NECESSARY;   CLOBBERS EVERYTHING BUT B
+SAVE:  SKIPN   C,OTBSAV(B)     ;PREVIOUS FRAME?
+       JRST    QWKRET
+       CAMN    PP,PPSAV(C)     ;ANYTHING HAPPEN TO PP BETWEEN B AND HERE?
+       JRST    QWKRET          ;NO-- JUST RETURN
+       PUSH    TP,$TTB
+       PUSH    TP,B
+SVLP:  HRRZ    B,(TP)
+       CAIN    B,(TB)          ;DONE?
+       JRST    SVRET
+       HRRZ    C,OTBSAV(TB)    ;ANYTHING TO SAVE YET?
+       CAME    PP,PPSAV(C)
+       PUSHJ   P,BCKTRK        ;DO IT
+       HRR     TB,OTBSAV(TB)   ;AND POP UP
+       JRST    SVLP
+QWKRET:        HRR     TB,B            ;SKIP OVER EVERYTHING
+       POPJ    P,
+SVRET: SUB     TP,[2,,2]       ;POP CRAP OFF TP
+       POPJ    P,\f
+
+;SETG IS USED TO SET THE GLOBAL VALUE OF ITS FIRST ARGUMENT,
+;AN IDENTIFIER, TO THE VALUE OF ITS SECOND ARGUMENT.  ITS VALUE IS
+; ITS SECOND ARGUMENT.
+
+MFUNCTION SETG,SUBR
+       ENTRY   2
+       HLLZ    A,(AB)          ;GET TYPE OF FIRST ARGUMENT
+       CAME    A,$TATOM        ;CHECK THAT IT IS AN ATOM
+       JRST    NONATM          ;IF NOT -- ERROR
+       MOVE    B,1(AB)         ;GET POINTER TO ATOM
+       PUSHJ   P,IGLOC         ;GET LOCATIVE TO VALUE
+       CAMN    A,$TUNBOUND     ;IF BOUND
+       PUSHJ   P,BSETG         ;IF NOT -- BIND IT
+       MOVE    C,B             ;SAVE PTR
+       MOVE    A,2(AB)         ;GET SECOND ARGUMENT
+       MOVE    B,3(AB)         ;INTO THE RETURN POSITION
+       MOVEM   A,(C)           ;DEPOSIT INTO THE 
+       MOVEM   B,1(C)          ;INDICATED VALUE CELL
+       JRST    FINIS
+
+BSETG: HRRZ    A,GLOBASE+1(TVP)
+       HRRZ    B,GLOBSP+1(TVP)
+       SUB     B,A
+       CAIL    B,6
+       JRST    SETGIT
+       PUSH    TP,GLOBASE(TVP)
+       PUSH    TP,GLOBASE+1 (TVP)
+       PUSH    TP,$TFIX
+       PUSH    TP,[0]
+       PUSH    TP,$TFIX
+       PUSH    TP,[100]
+       MCALL   3,GROW
+       MOVEM   A,GLOBASE(TVP)
+       MOVEM   B,GLOBASE+1(TVP)
+SETGIT:
+       MOVE    B,GLOBSP+1(TVP)
+       SUB     B,[4,,4]
+       MOVE    C,(AB)
+       MOVEM   C,(B)
+       MOVE    C,1(AB)
+       MOVEM   C,1(B)
+       MOVEM   B,GLOBSP+1(TVP)
+       ADD     B,[2,,2]
+       MOVSI   A,TLOCI
+       POPJ    P,
+
+\f
+
+
+;SET CLOBBERS THE LOCAL VALUE OF THE IDENTIFIER GIVEN BY ITS
+;FIRST ARGUMENT TO THE SECOND ARG.  ITS VALUE IS ITS SECOND ARGUMENT.
+
+MFUNCTION SET,SUBR
+       ENTRY   2
+       HLLZ    A,(AB)          ;GET TYPE OF FIRST
+       CAME    A,$TATOM        ;ARGUMENT -- 
+       JRST    WTYP            ;BETTER BE AN ATOM
+       MOVE    B,1(AB)         ;GET PTR TO IT
+       PUSHJ   P,ILOC          ;GET LOCATIVE TO VALUE
+       CAMN    A,$TUNBOUND     ;BOUND?
+       PUSHJ   P, BSET         ;BIND IT
+       MOVE    C,B             ;SAVE PTR
+       MOVE    A,2(AB)         ;GET SECOND ARG
+       MOVE    B,3(AB)         ;INTO RETURN VALUE
+       MOVEM   A,(C)           ;CLOBBER IDENTIFIER
+       MOVEM   B,1(C)
+       JRST    FINIS
+BSET:  PUSH    TP,$TFIX
+       PUSH    TP,[4]
+       MCALL   1,VECTOR        ;GET NEW BIND VECTOR
+       MOVE    A,$TSP
+       MOVEM   A,(B)           ;MARK IT
+       SETZM   A,1(B)
+       MOVSI   A,TBIND
+       HRRI    A,(B)
+       MOVEM   A,2(B)          ;CHAIN FIRST BLOCK
+       MOVE    A,1(AB)         ;A _ ATOM
+       MOVEM   A,3(B)
+       MOVE    C,SPBASE+1(PVP) ;CHAIN TO PREVIOUS BIND VECTOR
+       MOVEM   B,SPBASE+1(PVP) ;SET NEW TOP
+       ADD     B,[2,,2]
+       MOVEM   B,1(C)
+       ADD     B,[2,,2]        ;POINT TO LOCATIVE
+       MOVSI   A,TLOCI
+       HRR     A,PROCID+1(PVP) ;WHICH MAKE
+       MOVE    C,1(AB)         ;C _ ATOM _ VALUE CELL ADDRESS
+       MOVEM   A,(C)
+       MOVEM   B,1(C)          ;CLOBBER LOCATIVE SLOT
+       POPJ    P,
+\f
+
+MFUNCTION NOT,SUBR
+       ENTRY   1
+       HLRZ    A,(AB)          ; GET TYPE
+       CAIE    A,TFALSE        ;IS IT FALSE?
+       JRST    IFALSE          ;NO -- RETURN FALSE
+
+TRUTH:
+       MOVSI   A,TATOM         ;RETURN T (VERITAS) 
+       MOVE    B,MQUOTE T
+       JRST    FINIS
+
+MFUNCTION ANDA,FSUBR,AND
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP            ;IF ARG DOESN'T CHECK OUT
+       SKIPN   C,1(AB)         ;IF NIL
+       JRST    TRUTH           ;RETURN TRUTH
+       PUSH    TP,$TLIST               ;CREATE UNNAMED TEMP
+       PUSH    TP,C
+ANDLP:
+       JUMPE   C,FINIS         ;ANY MORE ARGS?
+       MOVEM   C,1(TB)         ;STORE CRUFT
+       PUSH    TP,(C)          ;EVALUATE THE
+       HLLZS   (TP)            ;FIRST REMAINING
+       PUSH    TP,1(C)         ;ARGUMENT
+       JSP     E,CHKARG
+       MCALL   1,EVAL
+       CAMN    A,$TFALSE       
+       JRST    FINIS           ;IF FALSE -- RETURN
+       HRRZ    C,@1(TB)        ;GET CDR OF ARGLIST
+       JRST    ANDLP
+
+MFUNCTION OR,FSUBR
+       ENTRY   1
+       HLRZ    A,(AB)
+       CAIE    A,TLIST         ;CHECK OUT ARGUMENT
+       JRST    WTYP
+       MOVE    C,1(AB)         ;PICK IT UP TO ENTER LOOP
+       PUSH    TP,$TLIST       ;CREATE UNNAMED TEMP
+       PUSH    TP,C
+ORLP:
+       JUMPE   C,IFALSE        ;IF NO MORE OPTIONS -- FALSE
+       MOVEM   C,1(TB)         ;CLOBBER IT AWAY
+       PUSH    TP,(C)  
+       HLLZS   (TP)
+       PUSH    TP,1(C)         ;EVALUATE THE FIRST REMAINING
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;ARGUMENT
+       CAME    A,$TFALSE       ;IF NON-FALSE RETURN
+       JRST    FINIS
+       HRRZ    C,@1(TB)        ;IF FALSE -- TRY AGAIN
+       JRST    ORLP
+
+MFUNCTION FUNCTION,FSUBR
+       PUSH    TP,(AB)
+       PUSH    TP,1(AB)
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FUNCTION
+       MCALL   2,CHTYPE
+       JRST    FINIS
+
+\f
+
+MFUNCTION CLOSURE,SUBR
+       ENTRY
+       SKIPL   A,AB            ;ANY ARGS
+       JRST    ERRTFA          ;NO -- LOSE
+       ADD     A,[2,,2]        ;POINT AT IDS
+       PUSH    TP,$TAB
+       PUSH    TP,A
+       PUSH    P,[0]           ;MAKE COUNTER
+
+CLOLP: SKIPL   A,1(TB)         ;ANY MORE IDS?
+       JRST    CLODON          ;NO -- LOSE
+       PUSH    TP,(A)          ;SAVE ID
+       PUSH    TP,1(A)
+       PUSH    TP,(A)          ;GET ITS VALUE
+       PUSH    TP,1(A)
+       ADD     A,[2,,2]        ;BUMP POINTER
+       MOVEM   A,1(TB)
+       AOS     (P)
+       MCALL   1,VALUE
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,LIST          ;MAKE PAIR
+       PUSH    TP,A
+       PUSH    TP,B
+       JRST    CLOLP
+
+CLODON:        POP     P,A
+       ACALL   A,LIST          ;MAKE UP LIST
+       PUSH    TP,(AB)         ;GET FUNCTION
+       PUSH    TP,1(AB)
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   2,LIST          ;MAKE LIST
+       MOVSI   A,TFUNARG
+       JRST    FINIS
+
+
+MFUNCTION FALSE,SUBR
+       ENTRY
+       JUMPGE  AB,IFALSE
+       HLRZ    A,(AB)
+       CAIE    A,TLIST
+       JRST    WTYP
+       MOVSI   A,TFALSE
+       MOVE    B,1(AB)
+       JRST    FINIS
+\f;BCKTRK SAVES THINGS ON PP
+
+;IT AND ITS FRIENDS FLAG PP "FRAMES" WITH MARKERS OF FORM "TTP,,SWITCHES", WHERE SWITCHES INCLUDES
+
+COP==1         ;ON IFF CALL TO BCKTRK IS TO COPY FRAME (TB) AS WELL
+               ;AS OTBSAV(TB)
+SAV==2         ;ON IFF TUPLES OF (TB) ARE TO BE SAVED; COP IMPLIES
+               ;SAV
+TUP==4         ;ON IFF (TB) CONTAINS ANY TUPLES BESIDES ARGS
+ON==10         ;ON IFF THIS FRAME OR FAILPOINT "RESTS ON TOP OF"
+               ;FRAME DESIGNATED BY TTP POINTER, OR IS INTENDED TO
+               ;TAKE ITS PLACE
+
+;BELOW THE TTP POINTER IS ONE OR TWO BLOCKS FLAGGED BY A TFIX
+;VALUE.  IF ON=ON AND TUP=ON IN THE RIGHT HALF OF THE TFIX,
+;THE TFIX BEGINS A BLOCK OF TUPLE DEBRIS; OTHERWISE,
+;IT BEGINS A SAVED TP FRAME.
+
+
+BCKTRK:        HRRZ    A,-1(PP)        ;SLOT LEFT BY FAILPOINT?
+       TRNN    A,COP           ;(I.E., TO BE COPIED?)
+       JRST    NBCK
+       MOVE    E,TB            ;YES-- FIRST SAVE THIS FRAME
+       PUSHJ   P,BCKTRE
+       HRRZ    A,-1(PP)
+       JRST    NBCK1
+NBCK:  TRNN    A,SAV
+       JRST    RMARK
+
+;SAVE TUPLES OF FRAME ON TOP OF PP
+
+NBCK1: MOVSI   B,TTP           ;FAKE OUT GC
+       MOVEM   B,BSTO(PVP)
+       MOVSI   C,TPP
+       MOVEM   C,CSTO(PVP)
+       MOVEM   C,ESTO(PVP)
+       MOVE    B,(PP)          ;B _ TPIFIED TB POINTER
+       SUB     PP,[2,,2]       ;CLEAN OFF POINTER TO MAKE ROOM FOR ARGS
+       MOVE    E,PP
+       MOVE    C,PP            ;C _ E _ PP
+       SUB     C,(PP)          ;C _ ADDRESS OF SAVED OTB
+       HLRE    D,1(C)          ;D _ NO. OF ARGS
+       JUMPE   D,NOARGS
+       SUB     B,[FRAMLN,,FRAMLN]      ;B _ FIRST OF SAVE BLOCK
+       MOVNS   D
+       HRLS    D
+       SUB     B,D             ;B _ FIRST OF ARGS
+MVARGS:        INTGO
+       PUSH    PP,(B)          ;MOVE NEXT
+       PUSH    PP,1(B)
+       ADD     B,[2,,2]
+       SUB     D,[2,,2]
+       JUMPG   D,MVARGS
+       ADD     B,[FRAMLN,,FRAMLN]      ;B _ TB ADDRESS
+       JRST    MVTUPS
+NOARGS:        TRNN    A,TUP           ;ANY OTHER TUPLES?
+       JRST    RMARK
+MVTUPS:        ADD     C,[FRAMLN-1,,FRAMLN-1]  ;C _ PP TB SLOT
+       SUB     E,[1,,1]        ;E _ TFIX SLOT ADDRESS
+MTOLP: CAML    C,E             ;C REACHED E?
+       JRST    MTDON           ;YES-- ALL TUPLES FOUND
+       INTGO
+       GETYP   A,(C)           ;ELSE
+       CAIE    A,TTBS          ;LOOK FOR TUPLE
+       JRST    ARND22
+       HRRE    D,(C)           ;D _ NO. OF ELEMENTS
+MTILP: JUMPGE  D,ARND22
+       INTGO
+       PUSH    PP,(B)
+       PUSH    PP,1(B)
+       ADD     B,[2,,2]
+       ADDI    D,2
+       JRST    MTILP
+ARND22:        ADD     B,[2,,2]        ;ADVANCE IN STEP
+       ADD     C,[2,,2]
+       JRST    MTOLP
+;ALL TUPLES MOVED
+MTDON: HRRZ    C,PP
+       SUBI    C,1(E)          ;C _ NO. OF THINGS MOVED
+       HRLS    C
+       PUSH    PP,[TFIX,,TUP]  ;MARK AS TUPLE CRUFT
+       PUSH    PP,C
+;NEW TTP MARKER
+RMARK: MOVE    E,OTBSAV(TB)    ;SAVE PREVIOUS FRAME
+       HRRZ    D,E
+       HRLS    D
+       HLRE    C,B
+       SUBI    C,(B)
+       HRLZS   C
+       ADD     D,C
+       PUSH    PP,[TTP,,ON]
+       PUSH    PP,D
+       MOVSI   B,TFIX          ;RESTORE B TYPE
+       MOVEM   B,BSTO(PVP)
+
+;BCKTRE SAVE CONTENTS OF FRAME E OF TP ON PLANNER PDL
+
+BCKTRE:        MOVSI   A,TPDL          ;FOR AGC
+       MOVEM   A,ASTO(PVP)
+       MOVSI   C,TTP
+       MOVEM   C,CSTO(PVP)
+       MOVSI   A,TTB
+       MOVEM   A,ESTO(PVP)
+
+;MOVE P BLOCK OF PREVIOUS FRAME TO PP
+
+       MOVE    C,PSAV(E)       ;C _ LAST OF P "FRAME"
+       HRRZ    A,OTBSAV(E)     
+       MOVE    A,PSAV(A)       ;A _ LAST OF PREVIOUS P "FRAME"
+       ADD     A,[1,,1]
+MVPB:  CAMLE   A,C             ;IF BLOCK EMPTY,
+       JRST    MVTPB           ;DO NOTHING
+       HRRZ    D,C
+       SUBI    D,-1(A)         ;ELSE, SET COUNTER
+       PUSH    PP,$TPDLS       ;MARK BLOCK
+       HRRM    D,(PP)
+       HRLS    D
+       PUSH    P,D
+PSHLP1:        PUSH    PP,(A)
+       INTGO           ;MOVE BLOCK
+       ADD     A,[1,,1]
+       CAMG    A,C
+       JRST    PSHLP1
+       PUSH    PP,$TFIX
+       PUSH    PP,[0]          ;PUSH BLOCK COUNTER
+       POP     P,(PP)
+;NOW DO SIMILAR THING FOR TP
+MVTPB: MOVSI   A,TTP           ;FOR AGC
+       MOVEM   A,ASTO(PVP)
+       MOVE    C,TPSAV(E)      ;C POINT TO LAST OF BLOCK
+       PUSH    TP,$TPP         ;SAVE INITIAL PP
+       PUSH    TP,PP           ;FOR SUBTRACTION
+       HRRZ    A,E             ;A _ TPIFIED E
+       HLRE    B,C
+       SUBI    B,(C)
+       HRLZS   B
+       HRLS    A
+       ADD     A,B
+       GETYP   D,FSAV(A)
+       CAIE    D,TENTRY
+       .VALUE  [ASCIZ /TPFUCKED/]
+;MOVE THE SAVE BLOCK
+
+MSVBLK:        MOVSI   D,TENTS         ;MAKE TYPE TENTS
+       HRR     D,FSAV(A)
+       PUSH    PP,D
+       HLLZ    D,OTBSAV(E)     ;RELATIVIZE OTB AND AB POINTERS
+       PUSH    PP,D
+       HLLZ    D,ABSAV(E)
+       PUSH    PP,D
+       PUSH    PP,SPSAV(E)
+       PUSH    PP,PSAV(E)
+       PUSH    PP,TPSAV(E)
+       PUSH    PP,PPSAV(E)
+       PUSH    PP,PCSAV(E)
+       MOVEI   0,              ;0 _ 0 (NO TUPLES)
+PSHLP2:        INTGO
+       CAMLE   A,C             ;DONE?
+       JRST    MRKFIX
+       GETYP   D,(A)
+       CAIN    D,TTB           ;TUPLE?
+       JRST    MVTB
+       PUSH    PP,(A)          ;NO, JUST MOVE IT
+       PUSH    PP,1(A)
+ARND4: ADD     A,[2,,2]
+       JRST    PSHLP2
+MRKFIX:        HRRZ    C,(TP)          ;C _ PREVIOUS PP POINTER
+       SUB     TP,[2,,2]
+       HRRZ    D,PP            ;D _ CURRENT PP TOP
+       SUBI    D,(C)           ;D _ DIFFERENCE
+       HRLS    D
+       PUSH    PP,$TFIX        ;PUSH BLOCK COUNTER
+       PUSH    PP,D
+
+
+;NOW SAVE LOCATION OF THIS FRAME
+
+       HRLS    E
+       MOVE    C,TPSAV(E)
+       HLRE    B,C
+       SUBI    B,(C)
+       HRLZS   B
+       ADD     E,B             ;CONVERSION TO TTP
+       HRLI    0,TTP
+       TRO     0,SAV           ;PUSH A TTP MARKER WITH SAV & MAYBE TUP ON
+       PUSH    PP,0
+       PUSH    PP,E
+
+;RETURN
+
+       MOVSI   A,TFIX
+       MOVEM   A,ASTO(PVP)
+       MOVEM   A,CSTO(PVP)
+       MOVEM   A,ESTO(PVP)
+       POPJ    P,
+
+;RELATIVIZE A TB POINTER
+
+MVTB:  HRRE    D,(A)           ;D _ - LENGTH OF TUPLE
+       MOVNS   D
+       HRLS    D               ;D _ LENGTH,,LENGTH
+       SUB     PP,D            ;THROW TUPLE AWAY!!!
+       TRO     0,TUP
+       MOVNS   D
+       HRLI    D,TTBS
+       PUSH    PP,D
+       MOVE    D,1(A)
+       SUBI    D,(E)
+       PUSH    PP,D
+       JRST    ARND4
+\fMFUNCTION FAIL,SUBR
+
+;SINCE FAILURES ARE NOT INTERRUPTIBLE FOR ANYTHING BUT GARBAGE
+;COLLECTIONS, THE FOLLOWING MACRO REPLACES INTGO FOR STACK-BUILDING
+;LOOPS
+
+DEFINE UNBLOW STK
+       SKIPL   STK
+       PUSHJ   P,NBLO!STK
+TERMIN
+
+
+       ENTRY
+       HLRE    A,AB
+       MOVNS   A
+       CAILE   A,4             ;AT MOST 2 ARGS
+       JRST    WNA
+       CAIGE   A,2             ;IF FIRST ARG NOT GIVEN, 
+       JRST    MFALS           ;ASSUME <>
+       MOVE    B,(AB)          ;OTHERWISE, FIRST ARG IS MESSAGE
+       MOVEM   B,MESS(PVP)
+       MOVE    B,1(AB)
+       MOVEM   B,MESS+1(PVP)
+
+       CAIE    A,4             ;PLACE TO FAIL TO GIVEN?
+       JRST    AFALS1
+       HLRZ    A,2(AB)
+       CAIE    A,TACT          ;CAN ONLY FAIL TO AN ACTIVATION
+       JRST    TAFALS
+SAVACT:        MOVE    B,2(AB)         ;TRANSMIT ACTIVATION TO FAILPOINT
+       MOVEM   B,FACTI(PVP)    ;VIA PVP
+       MOVE    B,3(AB)
+       MOVEM   B,FACTI+1(PVP)
+;NOW REBUILD TP FROM PP
+IFAIL: SETOM   FLFLG           ;FLFLG _ ON
+       HRRZ    A,(PP)          ;GET FRAME TO NESTLE IN
+       JUMPE   A,BDFAIL
+       HRRZ    0,-1(PP)        ;0 _ SWITCHES FOR FRAME
+       CAIN    A,(TB)
+       JRST    RSTFRM
+       GETYP   B,FACTI(PVP)    ;IF FALSE ACTIVATION,
+       CAIN    B,TFALSE        ;JUST GO TO FRAME
+       JRST    POPFS
+       HRRZI   B,(TB)          ;OTHERWISE, CHECK TO SEE IF WE ARE LEAVING
+       HRRZ    D,FACTI+1(PVP)
+ALOOP: CAIN    B,(A)           ;     FRAME FACTI(PVP)
+       JRST    POPFS           ;NO-- IT'S ABOVE FAILPOINT (A)
+       CAIN    B,(D)           ;FOUND FACTI?
+       JRST    AFALS2          ;YES-- CLOBBER FACTI TO #FALSE()
+       HRRZ    B,OTBSAV(B)     ;NO-- KEEP LOOKING
+       JRST    ALOOP
+AFALS2:        MOVSI   B,TFALSE        ;SET IT TO FALSE FROM HERE ON
+       MOVEM   B,FACTI(PVP)
+       SETZB   D,FACTI+1(PVP)
+POPFS: HRR     TB,A            ;MAY TAKE MORE WORK
+RSTFRM:        MOVE    P,PSAV(TB)
+       MOVE    TP,TPSAV(TB)
+       SUB     PP,[2,,2]
+       GETYP   A,-1(PP)
+       CAIN    A,TPC
+       JRST    MHFRAM
+       CAIE    A,TFIX
+       JRST    BADPP
+       
+;MOVE A TP BLOCK FROM PP TO TP
+       MOVSI   A,TPP
+       MOVEM   A,ASTO(PVP)
+       MOVEM   A,CSTO(PVP)
+       MOVE    A,PP
+       SUB     A,(PP)          ;A POINTS TO BOTTOM OF BLOCK
+       TRNN    0,ON            ;"ON" BLOCK?
+       JRST    INBLK
+ONBLK: CAME    SP,SPSAV(TB)    ;YES-- FIX UP ENVIRONMENT
+       PUSHJ   P,SPECST
+       MOVE    C,A
+       HRRZ    0,-1(PP)        ;ANY TUPLES?
+       TRNN    0,TUP
+       JRST    USVBLK          ;NO-- GO MOVE SAVE BLOCK
+       SUB     A,[2,,2]        ;A _ BLOCK UNDER THIS ONE
+       SUB     A,(A)
+;FILL IN ARGS TUPLE
+       GETYP   B,-1(A)
+       CAIE    B,TENTS         ;LOOK IN SAVE BLOCK
+       JRST    BADPP
+       HLRE    D,FRAMLN+ABSAV-1(A)
+       PUSHJ   P,USVTUP
+
+;MOVE SAVE BLOCK BACK TO TP
+
+USVBLK:        ADD     A,[FRAMLN,,FRAMLN]
+       MOVSI   D,TENTRY
+       HRR     D,FSAV-1(A)
+       PUSH    TP,D
+       MOVEI   AB,(TP)         ;REGENERATE AB & OTBSAV
+       HLRE    D,ABSAV-1(A)
+       MOVNS   D
+       HRLS    D
+       SUB     AB,D
+       MOVEI   D,(TB)
+       HLL     D,OTBSAV-1(A)
+       PUSH    TP,D
+       PUSH    TP,AB
+       PUSH    TP,SPSAV-1(A)
+       PUSH    TP,PSAV-1(A)
+       PUSH    TP,TPSAV-1(A)
+       PUSH    TP,PPSAV-1(A)
+       PUSH    TP,PCSAV-1(A)
+       HRRI    TB,1(TP)
+       
+PSHLP4:        CAML    TP,TPSAV(TB)
+       JRST    USTPDN
+       UNBLOW  TP
+       GETYP   B,-1(A)
+       CAIN    B,TTBS          ;FOUND A TUPLE?
+       JRST    USVTB
+       PUSH    TP,-1(A)        ;NO-- JUST MOVE IT
+       PUSH    TP,(A)
+ARND12:        ADD     A,[2,,2]        ;BUMP POINTER
+       JRST    PSHLP4
+USVTB: HRRE    D,-1(A)
+       PUSHJ   P,USVTUP
+       MOVE    D,-1(A)         ;UNRELATIVIZE A TTB
+       HRLI    D,TTB
+       PUSH    TP,D
+       MOVE    D,(A)
+       ADDI    D,(TB)
+       PUSH    TP,D
+       JRST    ARND12
+USTPDN:        MOVE    0,-1(PP)        ;IF TUPLES,
+       TRNN    0,TUP
+       JRST    USTPD3
+       SUB     PP,(PP)         ;SKIP OVER TUPLE DEBRIS
+       SUB     PP,[2,,2]
+USTPD3:        CAME    TP,TPSAV(TB)    ;BETTER HAVE WORKED
+       JRST    BADPP
+       CAMN    SP,SPSAV(TB)    ;PLEASE GOD, NO MORE BINDINGS
+       JRST    USV2            ;PRAYER CAN MOVE MOUNTAINS
+       MOVEI   E,              ;E _ 0 = INITIAL LOWER BIND BLOCK
+       MOVE    C,SPSAV(TB)     ;C _ SPSAV = INITIAL UPPER BLOCK
+
+;REBIND EVERYTHING IN THIS FRAME-- FIRST, FIND THE TOPMOST BLOCK,
+;SINCE THEY MUST BE REBOUND IN THE ORDER BOUND
+
+BLOOP1:        GETYP   D,(C)
+       CAIE    D,TBIND         ;C POINTS TO BIND BLOCK?
+       JRST    SPLBLK
+       ADD     C,[5,,5]        ;YES-- C _ ADDRESS OF ITS LAST WORD
+       MOVEM   E,(C)           ;(C) _ E = LOWER BIND POINTER
+       MOVE    E,C             ;E _ C
+       HLRE    D,C
+       SUB     C,D             ;C _ ADDRESS OF DOPE WORD
+       HLRZ    D,1(C)
+       SUB     D,[2,,2]
+       SUBM    C,D             ;D _ FIRST WORD ADDRESS
+       MOVE    C,1(D)          ;C _ REBIND BLOCK
+       JRST    JBVEC3
+SPLBLK:        GETYP   D,2(C)
+       CAIN    D,TSP
+       ADD     C,[2,,2]
+       ADD     C,[1,,1]        ;C _ REBIND POINTER ADDRESS
+       MOVE    D,(C)           ;D _ HIGHER BLOCK
+       MOVEM   E,(C)           ;(C) _ E
+       MOVE    E,C             ;E _ C
+       MOVE    C,D             ;C _ D = HIGHER BIND BLOCK
+JBVEC3:        CAME    SP,C            ;GOT TO SP YET?
+       JRST    BLOOP1
+
+
+;NOW REBIND EVERYTHING, RESET PROCID'S PROPERLY, ETC.;
+;THIS MUST BE DONE IN PROPER ORDER, FROM TOPMOST BLOCK DOWN
+
+BLOOP2:        HLRZ    D,-1(E)         ;WHAT DOES E POINT TO?
+       PUSH    P,(E)
+       JUMPN   D,TUGSP         ;IF NON-ZERO, MUST BE REBIND SLOT
+       PUSHJ   P,EBIND         ;OTHERWISE, BIND BLOCK TO BE REBOUND
+       JRST    DOWNBL
+TUGSP: MOVEM   SP,(E)          ;RECONNECT UPPER BLOCK
+       GETYP   0,1(E)
+       CAIE    0,TBIND
+       SUB     E,[2,,2]
+       MOVE    SP,E
+       SUB     SP,[1,,1]       ;TUG SP DOWN
+       CAIE    0,TSP           ;ID SWAP?
+       JRST    DOWNBL
+       MOVE    0,PROCID+1(PVP)
+       EXCH    0,5(SP)
+       MOVEM   0,PROCID+1(PVP)
+DOWNBL:        POP     P,E             ;E _ LOWER BLOCK
+       JUMPN   E,BLOOP2
+
+RBDON: CAME    SP,SPSAV(TB)    ;ALL THAT BETTER HAVE WORKED
+       JRST    BADPP
+       JRST    USV2
+
+;RESTORE A BLOCK "INTO" TB
+
+INBLK: ADD     A,[FRAMLN,,FRAMLN]
+       MOVSI   C,TTP
+       MOVEM   C,CSTO(PVP)
+       MOVSI   C,SPSAV-1(A)
+       HRRI    C,SPSAV(TB)
+       BLT     C,-1(TB)        ;RESTORE ALL OF SAVE BLOCK BUT FSAV,
+       MOVEI   C,-1(TB)        ;    OTBSAV, AND ABSAV
+       HRLS    C
+       MOVE    B,TPSAV(TB)
+       HLRE    D,B
+       SUBI    D,(B)
+       HRLZS   D
+       ADD     C,D             ;C _ "-1(TB)"TPIFIED
+PSHLP6:        CAML    A,PP
+       JRST    TPDON
+       GETYP   B,-1(A)         ;GOT TUPLE?
+       CAIN    B,TTBS
+       JRST    SKTUPL          ;YES-- SKIP IT
+       PUSH    C,-1(A)
+       PUSH    C,(A)
+ARND2: CAMLE   C,TP
+       MOVE    TP,C            ;PROTECT STACK FROM GARBAGE COLLECTION
+       UNBLOW  TP
+       ADD     A,[2,,2]
+       JRST    PSHLP6
+SKTUPL:        HRRE    D,-1(A)         ;D _ - LENGTH OF TUPLE
+       MOVNS   D
+       HRLS    D
+       ADD     C,D             ;SKIP!
+       ADD     C,[2,,2]        ;AND DON'T FORGET TTB
+       JRST    ARND2
+TPDON: MOVE    TP,C            ;IN CASE TP TOO BIG
+       CAME    TP,TPSAV(TB)    ;CHECK THAT INBLK WORKED
+       JRST    BADPP
+       MOVE    C,OTBSAV(TB)    ;RESTORE P STARTING FROM PREVIOUS
+       MOVE    P,PSAV(C)       ;FRAME
+
+;MOVE A P BLOCK BACK TO P
+
+USV2:  MOVSI   C,TFIX
+       MOVEM   C,CSTO(PVP)
+\r      SUB     PP,(PP)
+       SUB     PP,[2,,2]       ;NOW BACK BEYOND TP BLOCK
+       GETYP   A,-1(PP)
+       CAIE    A,TFIX          ;GET P BLOCK...
+       JRST    CHPC2           ;...IF ANY
+       MOVE    A,PP
+       SUB     A,(PP)          ;A POINTS TO FIRST
+PSHLP5:        PUSH    P,-1(A)         ;MOVE BLOCK
+       ADD     A,[1,,1]
+       UNBLOW  P
+       CAMGE   A,PP
+       JRST    PSHLP5
+       SUB     PP,(PP)
+       SUB     PP,[3,,3]               ;NOW AT NEXT PP "FRAME"
+       GETYP   A,-1(PP)
+CHPC2: CAME    P,PSAV(TB)      ;MAKE SURE P RESTORED OKAY
+       JRST    BADPP
+       CAIN    A,TTP
+       JRST    IFAIL
+       JRST    BADPP
+
+;FRAME IS ALREADY ON THE STACK--- BINDINGS ONLY HASSLE
+
+MHFRAM:        MOVE    AB,ABSAV(TB)    ;RESTORE ARGS POINTER
+       CAME    SP,SPSAV(TB)    ;AND ENVIRONMENT
+       PUSHJ   P,SPECSTO
+       MOVSI   A,TFIX
+       MOVEM   A,ASTO(PVP)
+       SETZM   FLFLG           ;FLFLG _ OFF
+       INTGO                   ;HANDLE POSTPONED INTERRUPTS
+       SUB     PP,[2,,2]
+       JRST    @2(PP)
+
+;HERE TO PUSH TUPLE STARTING AT (C), OF LENGTH -D
+
+USVTUP:        SKIPL   D
+       POPJ    P,
+       INTGO
+       PUSH    TP,-1(C)
+       PUSH    TP,(C)
+       UNBLOW TP
+       ADD     C,[2,,2]
+       ADDI    D,2
+       JRST    USVTUP
+
+;DEFAULT MESSAGE IS <>
+
+MFALS: MOVSI   B,TFALSE        ;TYPE FALSE
+       MOVEM   B,MESS(PVP)
+       SETZM   MESS+1(PVP)
+
+
+;DEFAULT ACTIVATION IS <>, ALSO
+AFALS1:        MOVSI   B,TFALSE
+       MOVEM   B,FACTI(PVP)
+\r      SETZM   FACTI+1(PVP)
+       JRST    IFAIL
+
+;FALSE IS ALLOWED EXPLICITLY
+
+TAFALS:        CAIE    A,TFALSE
+       JRST    WTYP
+       JRST    SAVACT
+
+
+;FLAG FOR INTERRUPT SYSTEM
+
+FLFLG: 0
+
+;HERE TO UNBLOW P
+
+NBLOP: HRRZ    E,P
+       HLRE    B,P
+       SUBI    E,-PDLBUF-1(P)  ;E _ ADR OF REAL 2ND DOPE WORD
+       SKIPE   PGROW
+       JRST    PDLOSS          ;SORRY, ONLY ONE GROWTH PER FAMILY
+       HRRM    E,PGROW         ;SET PGROW
+       JRST    NBLO2
+
+;HERE TO UNBLOW TP
+
+NBLOTP:        HRRZ    E,TP            ;MORE OR LESS THE SAME
+       HLRE    B,TP
+       SUBI    E,-PDLBUF-1(TP)
+       SKIPE   TPGROW
+       JRST    PDLOSS
+       HRRM    E,TPGROW
+NBLO2: MOVEI   B,PDLGRO_-6
+       DPB     B,[111100,,-1(E)]
+       JRST    AGC
+\fMFUNCTION FINALIZE,SUBR,[FINALIZE]
+       ENTRY
+       SKIPL   AB              ;IF NOARGS;
+       JRST    GETTOP          ;FINALIZE ALL FAILPOINTS
+       HLRE    A,AB            ;AT MOST ONE ARG
+       CAME    A,[-2]
+       JRST    WNA
+       PUSHJ   P,TILLFM        ;MAKE SURE ARG IS LEGAL
+       HRR     B,OTBSAV(B)     ;B _ FRAME BEFORE ACTIVATION
+RESTPP:        MOVE    PP,PPSAV(B)     ;RESTORE PP
+       HRRZ    A,TB            ;IN EVERY FRAME
+FLOOP: CAIN    A,(B)           ;FOR EACH ONE,
+       JRST    FDONE
+       MOVEM   PP,PPSAV(A)
+       HRR     A,OTBSAV(A)
+       JRST    FLOOP
+FDONE: MOVE    A,$TFALSE
+       MOVEI   B,
+       JRST    FINIS   
+
+;TILLFM SETS B _ FIRST ARGUMENT IFF IT IS A LEGAL ACTIVATION
+
+TILLFM:        HLRZ    A,(AB)          ;FIRST ARG MUST BE ACTIVATION
+       CAIE    A,TACT
+       JRST    WTYP
+       MOVE    A,1(AB)         ;WITH RIGHT TIME
+       HRR     B,A
+       HLL     B,OTBSAV(B)
+       HRRZ    C,A             ;AND PLACE
+       CAIG    C,1(TP)
+       CAME    A,B
+       JRST    ILLFRA
+       GETYP   C,FSAV(C)       ;AND STRUCTURE
+       CAIE    C,TENTRY
+       JRST    ILLFRA
+       POPJ    P,
+
+
+;LET B BE TOP LEVEL FRAME
+
+GETTOP:        MOVE    B,TPBASE+1(PVP) ;B _ BOTTOM OF TP
+       MOVEI   B,FRAMLN+1(B)   ;B _ TOP LEVEL FRAME
+       JRST    RESTPP\fMFUNCTION FAILPOINT,FSUBR,[FAILPOINT]
+       ENTRY   1
+       GETYP   A,(AB)          ;ARGUMENT MUST BE LIST
+       CAIE    A,TLIST
+       JRST    WTYP
+       SKIPN   C,1(AB)         ;NON-NIL
+       JRST    ERRTFA
+       PUSH    TP,$TLIST       ;SLOT FOR BODY
+       PUSH    TP,[0]
+       PUSH    TP,$TLIST
+       PUSH    TP,[0]
+       PUSH    TP,$TSP
+       PUSH    TP,[0]          ;SAVE SLOT FOR PRE-(MESS ACT) ENV
+       MOVE    C,1(AB)         ;GET SET TO CALL BINDER
+       MOVNI   D,1             ;---AS A PROG
+       PUSHJ   P,BINDER        ;AND GO
+       HRRZ    C,1(AB)         ;SKIP OVER THINGS BOUND
+       TRNE    A,H             ;INCLUDING HEWITT ATOM IF THERE
+       HRRZ    C,(C)
+       JUMPE   C,NOBODY
+       HRRZ    C,(C)           ;C _ (EXPR (MESS ACT) -FAIL-BODY-)
+       JUMPE   C,NOBODY
+       HRRZ    A,(C)           ;A _ ((MESS ACT) -FAIL-BODY-)
+       MOVEM   A,1(AB)         ;SAVE FOR FAILURE
+       MOVEM   A,3(TB)
+       MOVE    A,TP
+       SUB     A,[5,,5]
+       PUSH    PP,$TPC         ;ESTABLISH FAIL POINT
+       PUSH    PP,[FP]
+       PUSH    PP,[TTP,,COP\ON]
+       PUSH    PP,A            ;SAVE LOCATION OF THIS FRAME
+       PUSH    TP,(C)
+       HLLZS   (TP)
+       PUSH    TP,1(C)
+       JSP     E,CHKARG
+       MCALL   1,EVAL          ;EVALUATE EXPR
+       JRST    FINIS           ;IF SUCCESSFUL, DO NORMAL FINIS
+
+;FAIL TO HERE--BIND MESSAGE AND ACTIVATION
+
+FP:    MOVEM   SP,5(TB)        ;SAVE SP BEFORE MESS AND ACT BOUND
+       HRRZ    A,1(AB)         ;A _ ((MESS ACT) -BODY-)
+       GETYP   C,(A)
+       CAIE    C,TLIST
+       JRST    MPD
+       HRRZ    C,1(A)          ;C _ (MESS ACT)
+       JUMPE   C,TFMESS        ;IF (), THINGS MUST BE <>
+       PUSHJ   P,CARATM        ;E _ MESS
+       JRST    MPD
+       PUSH    TP,BNDA         ;ELSE BIND IT
+       PUSH    TP,E
+       PUSH    TP,MESS(PVP)
+       PUSH    TP,MESS+1(PVP)
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       HRRZ    C,(C)           ;C _ (ACT)
+       JUMPE   C,TFACT         ;IF (), ACT MUST BE <>
+       PUSHJ   P,CARATM        ;E _ ACT
+       JRST    MPD
+       PUSH    TP,BNDA         ;BIND IT
+       PUSH    TP,E
+       PUSH    TP,FACTI(PVP)
+       PUSH    TP,FACTI+1(PVP)
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+BLPROG:        PUSHJ   P,PROGAT
+       HRRZ    C,1(AB)
+       JRST    STPROG
+TFMESS:        GETYP   A,MESS(PVP)
+       CAIE    A,TFALSE
+       JRST    IFAIL
+TFACT: GETYP   A,FACTI(PVP)
+       CAIE    A,TFALSE
+       JRST    IFAIL
+       JRST    BLPROG
+
+;THIS ROUTINE SETS E TO THE NEXT THING IN THE LIST C POINTS TO,
+;SKIPPING IFF IT IS AN ATOM
+
+CARATM:        GETYP   E,(C)
+       CAIE    E,TATOM
+       POPJ    P,
+       MOVE    E,1(C)
+       AOS     (P)
+       POPJ    P,
+
+
+MFUNCTION RESTORE,SUBR,[RESTORE]
+
+       ENTRY
+       HLRE    A,AB
+       MOVNS   A
+       CAIG    A,4             ;1 OR 2 ARGUMENTS
+       CAIGE   A,2
+       JRST    WNA
+       PUSHJ   P,TILLFM        ;B _ FRAME TO RESTORE (IF LEGAL)
+       HRRZ    C,FSAV(B)
+       CAIE    C,FAILPO        ;ONLY FAILPOINTS RESTORABLE
+       JRST    ILLFRA
+       PUSHJ   P,SAVE          ;RESTORE IT
+       SKIPN   D,5(TB)         ;ARE WE IN EXPR INSTEAD OF BODY?
+       JRST    EXIT2           ;YES-- EXIT
+       MOVEM   D,SPSAV(TB)
+       PUSHJ   P,SPECSTO       ;UNBIND MESS AND ACT
+       MOVE    TP,TPSAV(TB)
+       MOVE    P,PSAV(TB)
+       PUSH    PP,$TPC
+       PUSH    PP,[FP]
+       MOVE    E,TP
+       SUB     E,[5,,5]
+       PUSH    PP,[TTP,,COP\ON]        ;REESTABLISH FAILPOINT
+       PUSH    PP,E
+EXIT2: HLRE    C,AB
+       MOVNS   C
+       CAIN    C,4             ;VALUE GIVEN?
+       JRST    RETRG2          ;YES-- RETURN IT
+       MOVE    AB,ABSAV(TB)    ;IN CASE OF GARBAGE COLLECTION
+       JRST    IFALSE\f
+
+;ERROR COMMENTS FOR EVAL
+
+UNBOU: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE UNBOUND-VARIABLE
+       JRST    ER1ARG
+
+UNAS:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE UNASSIGNED-VARIABLE
+       JRST    ER1ARG
+
+TFA:
+ERRTFA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TOO-FEW-ARGUMENTS-SUPPLIED
+       JRST    CALER1
+
+TMA:
+ERRTMA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TOO-MANY-ARGUMENTS-SUPPLIED
+       JRST    CALER1
+
+BADENV:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-ENVIRONMENT
+       JRST    CALER1
+
+FUNERR:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-FUNARG
+       JRST    CALER1
+
+WRONGT:
+WTYP:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WRONG-TYPE
+       JRST    CALER1
+
+MPD:   PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE MEANINGLESS-PARAMETER-DECLARATION
+       JRST    CALER1
+
+NOBODY:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE HAS-EMPTY-BODY
+       JRST    CALER1
+
+BADCLS:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-CLAUSE
+       JRST    CALER1
+
+NXTAG: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-EXISTENT-TAG
+       JRST    CALER1
+
+NXPRG: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NOT-IN-PROG
+       JRST    CALER1
+
+NAPT:  PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-APPLICABLE-TYPE
+       JRST    CALER1
+
+NONEVT:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-EVALUATEABLE-TYPE
+       JRST    CALER1
+
+
+NONATM:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
+       JRST    CALER1
+
+
+ILLFRA:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
+       JRST    CALER1
+
+NOTIMP:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NOT-YET-IMPLEMENTED
+       JRST    CALER1
+
+ILLSEG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ILLEGAL-SEGMENT
+       JRST    CALER1
+
+BADPP: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE PP-IN-ILLEGAL-CONFIGURATION
+       JRST    CALER1
+
+
+BDFAIL:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE OVERPOP--FAIL
+       JRST    CALER1
+
+
+ER1ARG:        PUSH    TP,(AB)
+       PUSH    TP,1(AB)
+       MOVEI   A,2
+       JRST    CALER
+CALER1:        MOVEI   A,1
+CALER:
+       HRRZ    C,FSAV(TB)
+       PUSH    TP,$TATOM
+       PUSH    TP,@-1(C)
+       ADDI    A,1
+       ACALL   A,ERROR
+       JRST    FINIS
+  
+END
+***\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/ninter.4 b/MUDDLE/ninter.4
new file mode 100644 (file)
index 0000000..27debb8
--- /dev/null
@@ -0,0 +1,668 @@
+
+TITLE INTERRUPT HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+;C. REEVE  APRIL 1971
+
+.INSRT MUDDLE >
+
+PDLGRO==10000  ;AMOUNT TO GROW A PDL THAT LOSES
+NINT==72.      ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE
+
+;SET UP LOCATION 42 TO POINT TO TSINT
+
+ZZZ==. ;SAVE CURRENT LOCATION
+
+LOC 42
+î      JSR     TSINT           ;GO TO HANDLER
+
+LOC ZZZ
+
+; GLOBALS NEEDED BY INTERRUPT HANDLER
+
+.GLOBA GCFLG   ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING
+.GLOBA GCINT   ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT
+.GLOBAL INTNUM,INTVEC  ;TV ENTRIES CONCERNING INTERRUPTS
+.GLOBAL AGC    ;CALL THE GARBAGE COLLECTOR
+.GLOBAL VECNEW,PARNEW,GETNUM   ;GC PSEUDO ARGS
+.GLOBAL GCPDL  ;GARBAGE COLLECTORS PDL
+.GLOBAL VECTOP,VECBOT  ;DELIMIT VECTOR SPACE
+.GLOBAL PDLBUF ;AMOUNT OF  PDL GROWTH
+.GLOBAL PGROW  ;POINTS TO DOPE WORD OF NEXT PDL TO GROW
+.GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW
+.GLOBAL PPGROW ;BLOWN PLANNER PDL
+.GLOBAL PLDGRO ;SEE ABOVE
+.GLOBAL CALER1,TMA,TFA
+.GLOBAL BUFRIN,CHANL0,SYSCHR   ;CHANNEL GLOBALS
+.GLOBAL IFALSE,TPOVFL,PDLOSS
+.GLOBAL FLFLG  ;-1  IFF INTERRUPT IN FAIL
+
+
+.GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS
+
+.GLOBAL MSGTYP,TYI,IFLUSH,OCLOS,ERRET  ;SUBROUTINES USED
+;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE)
+
+TSINT: 0                       ;INTERRUPT BITS GET STORED HERE
+TSINTR:        0                       ;INTERRUPT PC WORD STORED HERE
+       JRST    TSINTP          ;GO TO PURE CODE
+
+; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE
+
+LCKINT:        0
+       JRST    DOINT
+
+;THE REST OF THIS CODE IS PURE
+
+TSINTP:        SOSGE   INTFLG          ; SKIP IF ENABLED
+       SETOM   INTFLG          ;DONT GET LESS THAN -1
+
+       MOVEM   A,TSAVA         ;SAVE TWO ACS
+       MOVEM   B,TSAVB
+       MOVE    A,TSINT         ;PICK UP INT BIT PATTERN
+       JUMPL   A,2NDWORD       ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON
+
+       TRZE    A,200000        ;IS THIS A PDL OVERFLOW?
+       JRST    IPDLOV          ;YES, GO HANDLE IT FIRST
+
+IMPCH: TRZE    A,20000         ;IS IT A MEMORY PROTECTION VIOLATION?
+       JRST    IMPV            ;YES, GO HANDLE IT
+
+       TRZE    A,40            ;ILLEGAL OP CODE?
+       JRST    ILOPR           ;YES, GO HANDLE
+
+;DECODE THE REST OF THE INTERRUPTS USING A TABLE
+
+2NDWORD:
+       JUMPL   A,GC2           ;2ND WORD?
+       IORM    A,PIRQ          ;NO, INTO WORD 1
+       JRST    GCQUIT          ;AND DISMISS INT
+
+GC2:   TLZ     A,400000        ;TURN OFF SIGN BIT
+       IORM    A,PIRQ2
+       TRNE    A,177777        ;CHECK FOR CHANNELS
+       JRST    CHNACT          ;GO IF CHANNEL ACTIVITY
+
+GCQUIT:        SKIPGE  INTFLG          ;SKIP IF INTERRUPTS ENABLED
+       JRST    INTDON          ;NO, DEFER REAL HANDLING UNTIL LATER
+
+       MOVE    A,TSINTR        ;PICKUP RETURN WORD
+       MOVEM   A,LCKINT        ;STORE ELSEWHERE
+       MOVEI   A,DOINTE        ;CAUSE DISMISS TO HANDLER
+       HRRM    A,TSINTR        ;STORE IN INT RETURN
+       PUSH    P,INTFLG        ;SAVE INT FLAG
+       SETOM   INTFLG          ;AND DISABLE
+
+
+INTDON:        MOVE    A,TSAVA         ;RESTORE ACS
+       MOVE    B,TSAVB
+       .DISMISS        TSINTR          ;AND DISMISS THE INTERRUPT
+
+; HERE IF INTERRUPTED IN OTHER THAN GC
+
+DOINT: PUSH    P,INTFLG
+DOINTE:        PUSH    P,LCKINT        ;SAVE RETURN
+       SETZM   INTFLG          ;DISABLE
+       AOS     -1(P)           ;INCR SAVED FLAG
+
+;NOW SAVE WORKING ACS
+
+IRP A,,[0,A,B,C,D,E]
+       PUSH    TP,A!STO(PVP)
+       SETZM   A!STO(PVP)      ;NOW ZERO TYPE
+       PUSH    TP,A
+       TERMIN
+       PUSH    P,INTNUM+1(TVP) ;PUSH CURRENT VALUE
+
+DIRQ:  MOVE    A,PIRQ          ;NOW SATRT PROCESSING
+       JFFO    A,FIRQ          ;COUNT BITS AND GO
+       MOVE    A,PIRQ2         ;1ST DONE, LOOK AT 2ND
+       JFFO    A,FIRQ2
+
+INTDN1:
+       POP     P,INTNUM+1(TVP) ;RESTORE CURRENT
+IRP A,,[E,D,C,B,A,0]
+       POP     TP,A
+       POP     TP,A!STO(PVP)
+       TERMIN
+
+       POP     P,LCKINT
+       POP     P,INTFLG
+       JRST    @LCKINT         ;AND RETURN
+
+FIRQ:  PUSHJ   P,GETBIT        ;SET UP THE BIT TO CLOBBER IN PIRQ
+       ANDCAM  A,PIRQ          ;CLOBBER IT
+       ADDI    B,36.           ;OFSET INTO TABLE
+       JRST    XIRQ            ;GO EXECUTE
+
+FIRQ2: PUSHJ   P,GETBIT        ;PREPARE TO CLOBBER BIT
+       ANDCAM  A,PIRQ2         ;CLOBBER IT
+       ADDI    B,71.           ;AGAIN OFFSET INTO TABLE
+XIRQ:
+       CAIN    B,21            ;PDL OVERFLOW?
+       JRST    PDL2            ;YES, HACK APPROPRIATELY
+       MOVEM   B,INTNUM+1(TVP) ;AND SAVE
+       LSH     B,1             ;TIMES 2
+       ADD     B,INTVEC+1(TVP) ;POINT TO LIST OF TASKS
+       SKIPN   A,(B)           ;ANY TASKS?
+       JRST    DIRQ            ;NO, PUNT
+
+       PUSH    TP,$TLIST       ;SAVE LIST
+       PUSH    TP,A
+DOINTS:        HLRZ    C,(A)           ;GET TYPE
+       CAIE    C,TLIST         ;LIST?
+       JRST    IWTYP
+       HRRZ    A,1(A)
+       JUMPE   A,IWTYP         ;LIST IS NIL, LOSE
+       HLRZ    C,(A)           ;CHECK FOR A PROCESS
+       CAIE    C,TPVP
+       JRST    IWTYP
+       HRRZ    D,(A)           ;POINT TO 2D PART OF PAIR
+       PUSH    TP,(D)          ;SETUP CALL TO EVAL
+       PUSH    TP,1(D)
+       MOVE    D,TB            ;GET CURRENT FRAME POINTER
+       MOVE    C,1(A)          ;GET PROCESS WHO WANTS THIS INTERRUPT
+       CAME    C,PVP           ;SKIP IF CURRENT PROCESS
+       MOVE    D,TBSTO+1(C)    ;GET SAVED FRAME
+       HLRE    A,C             ;COMPUTE DOPE WORD POINTER
+       SUBI    C,-1(A)         ;HAVE POINTER
+       HRLI    C,TFRAME        ;BUILD A FRAME HACK
+       HLL     D,OTBSAV(D)     ;GET A WINNING TIME
+       PUSH    TP,C            ;AND PUSH IT
+       PUSH    TP,D
+       MCALL   2,EVAL
+INTCDR:        HRRZ    A,@(TP)         ;CDR THE LIST OF TASKS
+       JUMPE   A,TPPOP
+       MOVEM   A,(TP)          ;SAVE THE CDR'D LIST
+       JRST    DOINTS
+
+TPPOP: SUB     TP,[2,,2]       ;REMOVE LIST
+       JRST    DIRQ
+
+IWTYP: PUSH    TP,(A)          ;SAVE TASK
+       PUSH    TP,1(A)
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-INTERRUPT-HANDLER-TASK-IGNORED
+       MCALL   1,PRINT
+       MCALL   1,PRINT
+       JRST    INTCDR
+
+PDL2:  MOVEI   B,PDLGRO_-6     ;GET GROWTH SPEC
+       SKIPE   A,PGROW         ;SKIP IF A P IS NOT GROWING
+       DPB     B,[111100,,-1(A)]       ;STORE GROWTH SPEC
+TRYTPG:        SKIPE   A,TPGROW        ;IS TP BLOWN
+       DPB     B,[111100,,-1(A)]       ;YES, SET GROWTH SPEC
+       SKIPE   A,PPGROW                ;POINT TO BLOWN PP
+       DPB     B,[111100,,-1(A)]
+       PUSHJ   P,AGC           ;COLLECT GARBAGE
+       SETZM   PPGROW
+       SETZM   PGROW
+       SETZM   TPGROW
+       JRST    INTDN1
+
+
+
+;SUBROUTINE TO SET AN INTERRUPT HANDLER
+
+MFUNCTION SETINT,SUBR
+       ENTRY   2
+
+       HLRZ    A,(AB)          ;FIRST IS FIXED
+       CAIE    A,TFIX
+       JRST    WTYP1
+       HLRZ    A,2(AB)
+       CAIE    A,TLIST
+       JRST    WTYP2
+       SKIPGE  B,1(AB)         ;GET NUMBER
+       JRST    NEGINT          ;INTERRUPT NEGATIVE
+       HRRZ    C,3(AB)         ;PICKUP LIST
+ISENT1:        PUSH    P,CFINIS                ;FALL INTO INTERNAL SET TO POP TO FINIS
+
+ISETNT:        MOVEI   D,(B)           ;COPY
+       LSH     B,1
+       HRLI    B,(B)           ;TO 2 HALVES
+       ADD     B,INTVEC+1(TVP) ;POINT TO HANDLER
+       JUMPGE  B,INTOBG        ;OUT OF RANGE
+       HRRZ    E,(B)           ;AND OLD POINTER
+       HRRM    E,(C)           ;SPLICE
+       HRRM    C,(B)
+       CAILE   D,35.           ;WHICH MASK?
+       JRST    SETW2
+
+       SUBI    D,36.           ;FIND BIT POSITION
+       MOVSI   A,400000
+       LSH     A,(D)           ;POSTITION
+       IORM    A,MASK1
+       .SUSET  [.SMASK,,MASK1]
+SETIN1:        MOVE    A,(AB)
+       MOVE    B,1(AB)
+CFINIS:        POPJ    P,FINIS ;USED BY SETINT TO SETUP RETURN
+
+SETW2: SUBI    D,71.
+       MOVSI   A,400000
+       LSH     A,(D)
+       IORM    A,MASK2
+       .SUSET  [.SMSK2,,MASK2]
+       JRST    SETIN1
+WTYP1: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FIRST-ARG-WRONG-TYPE
+       JRST    CALER1
+
+
+WTYP2: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE SECOND-ARG-WRONG-TYPE
+       JRST    CALER1
+
+NEGINT:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NEGATIVE-INTERRUPT-NUMBER
+       JRST    CALER1
+INTOBG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE INT-NUMBER-TOO-LARGE
+       JRST    CALER1
+
+BADCHN:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE CHANNEL-NOT-PHYSICAL
+       JRST    CALER1
+
+LWTYP: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE LAST-ARG-WRONG-TYPE
+       JRST    CALER1
+
+; SET A CHANNEL INTERRUPT
+
+MFUNCTION ONCHAR,SUBR
+
+       ENTRY
+
+       SKIPL   B,AB            ;COPY ARG POINTER
+       JRST    TFA
+       ADD     B,[2,,2]        ;POINT TO EXPRESSION ARG
+       PUSHJ   P,CHKRGS        ;CHECK OUT THE ARGS AND MAKE THE LIST
+       GETYP   A,(AB)  ;CHECK FOR A CHANNEL
+       CAIE    A,TCHAN
+       JRST    WTYP1
+       MOVE    C,1(AB)         ;GET CHANNEL
+       SKIPN   C,CHANNO(C)     ;GET CHANNEL
+       JRST    BADCHN
+       ADDI    C,36.           ;POINT INTO INT VECTOR
+       EXCH    B,C
+       PUSHJ   P,ISETNT        ;SET THE INTERRUPT
+       MOVE    A,2(AB)         ;RETURN ARG
+       MOVE    B,3(AB)
+       JRST    FINIS
+
+; SET A CLOCK INTERRUPT
+
+MFUNCTION ONCLOCK,SUBR
+
+       ENTRY
+
+       MOVE    B,AB
+       PUSHJ   P,CHKRGS                ;CHECK ARGS AND MAKE LIST
+       MOVE    C,B     ;COPY LIST POINTER
+       MOVEI   B,13.           ;CLOCK INT NUMBER
+       JRST    ISENT1          ;SET UP THE INT
+
+CHKRGS:        JUMPGE  B,TFA
+       MOVE    C,PVP           ;GET CURRENT PROCESS
+       CAML    B,[-2,,0]       ;CHECK FOR PROCESS ARG
+       JRST    GOTPVP
+       CAMGE   B,[-4,,0]       ;SKIP IF RIGHT NO. OF ARGS
+       JRST    TMA             ;TOO MANY
+       GETYP   A,2(B)          ;CHECK TYPE
+       CAIE    A,TPVP
+       JRST    LWTYP           ;WRONG TYPE
+       MOVE    C,3(B)          ;GET PROCESS
+GOTPVP:        PUSH    TP,$TPVP
+       PUSH    TP,C
+       PUSH    TP,(B)          ;PUSH EXPRESSION
+       PUSH    TP,1(B)
+       MCALL   2,LIST  ;MAKE THE LIST
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   1,LIST          ;MAKE A LIST OF A LIST
+       POPJ    P,
+
+
+;ROUTINE TO GET CURRENT INT NUMBER
+
+MFUNCTION GETINT,SUBR
+
+       ENTRY   0
+       MOVSI   A,TFIX
+       MOVE    B,INTNUM+1(TVP)
+       JRST    FINIS
+
+MFUNCTION INTCHAR,SUBR
+
+       ENTRY
+       PUSH    P,CFINIS        ;CAUSE RETURN TO FINIS
+INTCH1:        MOVE    B,INTNUM+1(TVP)
+       JUMPGE  AB,GOTNUM
+       HLRZ    A,(AB)
+       CAIE    A,TFIX
+       JRST    WTYP1
+       MOVE    B,1(AB)
+
+GOTNUM:        SUBI    B,36.           ;CONVERT TO CHANNEL
+       MOVEI   C,(B)           ;SAVE A COPY OF CHANNEL
+       .ITYIC  B,
+       JRST    NOCHRS
+
+       LSH     B,29.
+       MOVSI   A,TCHRS
+       MOVEI   D,(C)   ;COPY CHANNEL AGAIN
+       LSH     D,1             ;TIMES 2
+       ADDI    D,CHANL0+1(TVP) ;POINT TO INFO
+       HRRZ    E,(D)   ;POINT TO CHANNEL
+       HRRZ    E,BUFRIN(E)     ;POINT TO ADDL INFO
+       AOS     SYSCHR(E)
+
+REINT: MOVEI   E,1     ;PREPARE TO RENABLE
+       LSH     E,(C)
+       IORM    E,MASK2
+       .SUSET  [.SMSK2,,MASK2]
+       POPJ    P,
+
+
+NOCHRS:        MOVEI   B,0
+       MOVSI   A,TFALSE
+       JRST    REINT
+
+MFUNCTION QUITTER,SUBR
+
+       ENTRY   0
+
+REQT:  PUSHJ   P,INTCH1        ;CHECK FOR A CHAR
+       CAMN    A,$TFALSE       ;ANY LEFT?
+       JRST    FINIS   ;NO
+       CAME    B,[7_29.]       ;CNTL G?
+       JRST    REQT
+       PUSH    TP,$TCHAN               ;QUIT HERE
+       PUSH    TP,(D)          ;PUSH CHANNEL
+       MCALL   1,RRRES
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE CONTROL-G
+       MCALL   1,ERROR
+       JRST    FINIS
+
+MFUNCTION INTRCH,SUBR,INTCHAN
+
+       ENTRY   0
+
+       MOVE    B,INTNUM+1(TVP) ;GET INT NUMBER
+       SUBI    B,36.
+       JUMPL   B,IFALSE        ;NOT A CHANNEL
+       CAILE   B,17
+       JRST    IFALSE          ;NOT A CHANNEL
+       LSH     B,1             ;TIMES 2
+       ADDI    B,CHANL0(TVP)   ;GET POINTER TO CHANNEL
+       MOVE    A,(B)
+       MOVE    B,1(B)
+       JRST    FINIS
+
+MFUNCTION GASCII,SUBR,ASCII
+       ENTRY   1
+
+       HLRZ    A,(AB)
+       CAIE    A,TCHRS
+       JRST    TRYNUM
+
+       MOVE    B,1(AB)
+       TDNN    B,[3777,,-1]
+       LSH     B,-29.
+       MOVSI   A,TFIX
+       JRST    FINIS
+
+TRYNUM:        CAIE    A,TFIX
+       JRST    WTYP1
+       SKIPGE  B,1(AB)         ;GET NUMBER
+       JRST    TOOBIG
+       CAILE   B,177           ;CHECK RANGE
+       JRST    TOOBIG
+       LSH     B,29.
+       MOVSI   A,TCHRS
+       JRST    FINIS
+
+TOOBIG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE OUT-OF-RANGE
+       JRST    CALER1
+
+;SUBROUTINE TO GET BIT FOR CLOBBERAGE
+
+GETBIT:        MOVNS   B               ;NEGATE
+       MOVSI   A,400000        ;GET THE BIT
+       LSH     A,(B)           ;SHIFT TO POSITION
+       POPJ    P,              ;AND RETURN
+
+;HERE TO HANDLE PDL OVERFLOW.  ASK FOR A GC
+
+IPDLOV:        SKIPE   FLFLG           ;DURING FAILURE,
+       JRST    IMPCH           ;LET FAIL HANDLE BLOWN PDLS
+       MOVEM   A,TSINT         ;SAVE INT WORD
+       MOVEI   A,200000        ;GET BIT TO CLOBBER
+       IORM    A,PIRQ          ;LEAVE A MESSAGE FOR HIGHER LEVEL
+
+       SKIPE   GCFLG           ;IS GC RUNNING?
+       JRST    GCPLOV          ;YES, COMPLAIN GROSSLY
+
+       EXCH    P,GCPDL         ;GET A WINNING PDL
+       HRRZ    B,TSINTR        ;GET POINTER TO LOSING INSTRUCTION
+       LDB     B,[270400,,-1(B)]       ;GET AC FIELD
+       MOVEI   A,(B)           ;COPY IT
+       LSH     A,1             ;TIMES 2
+       ADDI    A,0STO(PVP)     ;POINT TO THIS ACS CURRENT TYPE
+       HLRZ    A,(A)           ;GET THAT TYPE INTO A
+       CAIN    B,P             ;IS IT P
+       MOVEI   B,GCPDL         ;POINT TO SAVED P
+
+       CAIN    B,B             ;OR IS IT B ITSELF
+       MOVEI   B,TSAVB
+       CAIN    B,A             ;OR A
+       MOVEI   B,TSAVA
+
+       CAIN    B,C             ;OR C
+       MOVEI   B,1(P)          ;C WILL BE ON THE STACK
+
+       PUSH    P,C
+       PUSH    P,A
+
+       MOVE    A,(B)           ;GET THE LOSING POINTER
+       MOVEI   C,(A)           ;AND ISOLATE RH
+
+       CAMG    C,VECTOP        ;CHECK IF IN GC SPACE
+       CAMG    C,VECBOT
+       JRST    NOGROW          ;NO, COMPLAIN
+
+       HLRZ    C,A             ;GET -LENGTH
+       SUBI    A,-1(C)         ;POINT TO A DOPE WORD
+       POP     P,C             ;RESTORE TYPE INTO C
+       CAIE    C,TPDL          ;IS IT A P STACK?
+       JRST    TRYTP           ;NO
+       SKIPE   PGROW           ;YES, ALREADY GROWN?
+       JRST    PDLOSS          ;YES, LOSE
+       ADDI    A,PDLBUF        ;POINT TO REAL DOPE WORD
+       HRRM    A,PGROW         ;STORE
+       JRST    PNTRHK          ;FIX UP THE PDL POINTER
+
+TRYTP: CAIE    C,TTP           ;TP STACK
+       JRST    TRYPP
+       SKIPE   TPGROW          ;ALREADY GROWN?
+       JRST    PDLOSS
+       ADDI    A,PDLBUF        ;POINT TO REAL DOPE WORD
+       HRRM    A,TPGROW
+       JRST    PNTRHK          ;GO MUNG POINTER
+
+TRYPP: CAIE    C,TPP           ;PLANNER PDL?
+       JRST    BADPDL
+       SKIPE   PPGROW
+       JRST    PDLOSS          ;LOSER
+       ADDI    A,PDLBUF
+       HRRM    A,PPGROW
+
+
+PNTRHK:        MOVE    C,(B)           ;RESTORE PDL POINTER
+       SUB     C,[PDLBUF,,0]   ;FUDGE THE POINTER
+       MOVEM   C,(B)           ;AND STORE IT
+
+       POP     P,C             ;RESTORE THE WORLD
+       MOVE    A,TSINT         ;RESTORE INT WORD
+
+       EXCH    P,GCPDL         ;GET BACK ORIG PDL
+       JRST    IMPCH           ;LOOK FOR MORE INTERRUPTS
+
+TPOVFL:        SETOM   INTFLG          ;SIMULATE PDL OVFL
+       PUSH    P,A
+       MOVEI   A,200000        ;TURN ON THE BIT
+       IORM    A,PIRQ
+       SUB     TP,[PDLBUF,,0]  ;HACK STACK POINTER
+       HLRE    A,TP            ;FIND DOPEW
+       SUBM    TP,A            ;POINT TO DOPE WORD
+       ADDI    A,1
+       HRRZM   A,TPGROW
+       POP     P,A
+       POPJ    P,
+
+
+;HERE TO HANDLE LOW-LEVEL CHANNELS
+
+
+CHNACT:        SKIPN   GCFLG           ;GET A WINNING PDL
+       EXCH    P,GCPDL
+       ANDI    A,177777        ;ISOLATE CHANNEL BITS
+       PUSH    P,0             ;SAVE
+
+CHNA1: MOVEI   B,0             ;BIT COUNTER
+       JFFO    A,.+2           ;COUNT
+       JRST    CHNA2
+       SUBI    B,35.           ;NOW HAVE CHANNEL
+       MOVMS   B               ;PLUS IT
+       MOVEI   0,1
+       LSH     0,(B)           ;SET TO CLOBBER BIT
+       ANDCM   A,0
+       LSH     B,23.           ;POSITION FOR A .STATUS
+       IOR     B,[.STATUS B]
+       XCT     B               ;DO IT
+       ANDI    B,77            ;ISOLATE DEVICE
+       CAILE   B,2
+       JRST    CHNA1
+       ANDCAM  0,MASK2         ;TURN OFF BIT
+       .SUSET  [.SMSK2,,MASK2]
+       JRST    CHNA1
+
+CHNA2: POP     P,0
+       SKIPN   GCFLG
+       EXCH    P,GCPDL
+       JRST    GCQUIT
+
+;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION
+
+BADPDL:        SKIPA   B,[[ASCIZ /NON-PDL OVERFLOW
+/]]
+GCPLOV:        MOVEI   B,[ASCIZ /PDL OVERFLOW DURING GARBAGE COLLECTION
+/]
+GFATER:        MOVE    P,GCPDL         ;GET ORIGINAL PDL FOR TYPE OUT
+       JRST    FATERR          ;GO TO FATAL ERROR ROUTINE
+
+NOGROW:        MOVEI   B,[ASCIZ /PDL OVERFLOW ON NON-EXPANDABLE PDL
+/]
+       JRST    GFATER
+
+PDLOSS:        MOVEI   B,[ASCIZ /PDL OVERFLOW BUFFER EXHAUSTED
+/]
+       JRST    GFATER
+
+FATERR:        PUSHJ   P,MSGTYP        ;TYPE THE MESSAGE
+       MOVEI   B,[ASCIZ /FATAL ERROR, PLEASE DUMP SO THAT MUDDLE SYSTEM PROGRAMMERS
+MAY DEBUG./]
+       PUSHJ   P,MSGTYP        ;TYPE THE LOSER MESSAGE
+       PUSHJ   P,OCLOS         ;CLOSE THE TTY
+       .VALUE
+       JRST    .-1
+
+
+;MEMORY PROTECTION INTERRUPT
+
+IMPV:  MOVEI   B,[ASCIZ /MPV -- /]
+
+IMPV1: PUSHJ   P,MSGTYP        ;TYPE
+       SKIPE   GCFLG           ;THESE ERRORS FATAL IN GARBAGE COLLECTOR
+       JRST    GCERR
+
+       MOVE    P,GCPDL         ;MAKE SURE OF A WINNING PDL
+ERLP:  MOVEI   B,[ASCIZ /TYPE "S" TO GO TO SUPERIOR, "R" TO RESTART PROCESS./]
+       PUSHJ   P,IFLUSH        ;FLUSH AWAITING INPUT
+       PUSHJ   P,MSGTYP
+
+       PUSHJ   P,TYI           ;READ THE CHARACTER
+
+       PUSHJ   P,UPLO          ;CONVERT TO UPPER CASE
+       CAIN    A,"S
+       .VALUE
+
+       CAIE    A,"R            ;DOES HE WANT TO RESTART
+       JRST    ERLP            ;NO, TELL HIM AGAIN
+
+       MCALL   0,INTABR        ;ABORT THE PROCESS
+
+INTABR:        MOVEI   A,ERRET         ;REAALY GO TO ERRET
+       HRRM    A,TSINTR
+       .DISMISS        TSINTR
+
+
+GCERR: MOVEI   B,[ASCIZ /IN GARBAGE COLLECTOR
+/]
+       JRST    FATERR
+
+ILOPR: MOVEI   B,[ASCIZ /ILLEGAL OPERATION -- /]
+       JRST    IMPV1
+
+; SUBROUTINE TO CONVERT LOWER CASE LETTERS TO UPPER
+
+UPLO:  CAIG    A,172           ;GEATER THAN Z?
+       CAIG    A,140           ;NO, LESS THAN A
+       POPJ    P,              ;YES, LOSE
+       SUBI    A,40            ;MAKE UPPER CASE
+       POPJ    P,
+
+;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO FUDGE INT PC
+
+INTINT:        PUSHJ   P,PCHACK        ;FUDGE PC LOSSAGE
+       MOVE    A,MASK1 ;SET MASKS
+       MOVE    B,MASK2
+       .SETM2  A,              ;SET BOTH MASKS
+       POPJ    P,
+
+PCHACK:        .SUSET  [.SMASK,,[200000]]      ;SET FOR ONLY PDL OVERFLOW
+       MOVE    D,TSINT+2       ;SAVE CONTENTS OF ITERRUPT HANDLER
+       MOVEI   A,FUNINT        ;POINT TO DUMMY THEREOF
+       HRRM    A,TSINT+2       ;AND STORE IT
+       HRROI   A,0             ;MAKE A VERY SHORT PDL
+CHPUSH:        PUSH    A,0             ;PUSH SOMETHING AND OVERFLOW
+       .VALUE  [ASCIZ /?/]     ;SHOULD NEVER GET HERE
+
+FUNINT:        HRRM    D,TSINT+2       ;RESTORE STANDARD HANDLER
+       HRRZ    D,TSINTR        ;GET THE LOCATION STORED
+       SUBI    D,CHPUSH        ;FIND THE DIFFERENCE
+       MOVEM   D,PCOFF         ;AND SAVE
+       POP     P,TSINTR        ; POP INTO DISMISS WORD
+       .DISMISS        TSINTR          ;AND DISMISS
+
+
+
+INTLOS:        .VALUE  [ASCIZ /INT/]
+CHARCH:        .VALUE  [ASCIZ /CHAR?/]
+;RANDOM IMPURE CRUFT NEEDED
+
+TSAVA: 0
+TSAVB: 0
+PIRQ:  0                       ;HOLDS REQUEST BITS FOR 1ST WORD
+PIRQ2: 0                       ;SAME FOR WORD 2
+PCOFF: 0
+MASK1: 220040                  ;FIRST MASK
+MASK2: 0                       ;SECOND THEREOF
+
+
+END
+\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nmain.14 b/MUDDLE/nmain.14
new file mode 100644 (file)
index 0000000..4da7b6c
--- /dev/null
@@ -0,0 +1,791 @@
+TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES
+RELOCA
+MAIN==1        ;THIS INCLUDES ONCE ONLY CODE
+
+NINT==72.      ;NUMBER OF POSSIBLE ITS INTERRUPTS
+NASOCS==159.   ;LENGTH OF ASSOCIATION VECTOR
+
+
+.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2
+.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS
+.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES
+.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI
+
+.INSRT MUDDLE >
+
+VECTGO
+TVBASE":       BLOCK   TVLNT
+       GENERAL
+       TVLNT+2,,0
+TVLOC=TVBASE
+
+
+
+;INITIAL TYPE TABLE
+
+TYPVLC":       BLOCK   2*NUMPRI+2
+       GENERAL
+       2*NUMPRI+2+2,,0
+
+TYPTP==.-2                     ; POINT TO TOP OF TYPES
+
+INTVCL:        BLOCK   2*NINT
+       TLIST,,0
+       2*NINT+2,,0
+
+NODLST:        TTP,,0
+       0
+       TASOC,,0
+       BLOCK   ASOLNT-3
+       GENERAL+<SASOC,,0>
+       ASOLNT+2,,0
+
+
+ASOVCL:        BLOCK   NASOCS
+       TASOC,,0
+       NASOCS+2,,0
+
+
+
+;THESE ENTRIES MUST NOT MOVE DURING INITILAIZATION
+
+ADDTV TVEC,[-2*NUMPRI-2,,TYPVLC]
+TYPVEC==TVOFF-1
+
+ADDTV TVEC,TYPTP
+TYPTOP==TVOFF-1                        ; POINT TO CURRENT TOP OF TYPE VECTORS
+
+;ENTRY FOR ROOT,TTICHN,TTOCHN
+
+ADDTV TCHAN,0
+TTICHN==TVOFF-1
+
+ADDTV TCHAN,0
+TTOCHN==TVOFF-1
+
+ADDTV TOBLS,0
+ROOT==TVOFF-1
+ADDTV TOBLS,0
+INTOBL==TVOFF-1
+ADDTV TOBLS,0
+ERROBL==TVOFF-1
+ADDTV TVEC,0
+GRAPHS==TVOFF-1
+ADDTV TFIX,0
+INTNUM==TVOFF-1
+ADDTV TVEC,[-2*NINT,,INTVCL]
+INTVEC==TVOFF-1
+ADDTV TUVEC,[-NASOCS,,ASOVCL]
+ASOVEC==TVOFF-1
+
+DEFINE ADDCHN N
+       ADDTV TCHAN,0
+       CHANL!N==TVOFF-1
+       .GLOBAL CHANL!N
+       TERMIN
+
+REPEAT 16.,ADDCHN \.RPCNT
+
+ADDTV TASOC,[-ASOLNT,,NODLST]
+NODES==TVOFF-1
+
+
+;GLOBAL SPECIAL PDL
+
+GSP:   BLOCK   GSPLNT
+       GENERAL
+       GSPLNT+2,,0
+
+ADDTV TVEC,[-GSPLNT,,GSP]
+GLOBASE==TVOFF-1
+GLOB==.-2
+ADDTV TVEC,GLOB
+GLOBSP==TVOFF-1        ;ENTRY FOR CURRENT POINTER TO GLOBAL SP
+
+;PROCESS VECTOR FOR GARBAGE COLLECTOR PROCESS
+
+GCPVP: BLOCK   PVLNT*2
+       GENERAL
+       PVLNT*2+2,,0
+
+
+VECRET
+
+;INITIAL PROCESS VECTOR
+
+PVBASE":       BLOCK   PVLNT*2
+       GENERAL
+       PVLNT*2+2,,0
+PVLOC==PVBASE
+
+
+;ENTRY FOR PROCESS I.D.
+
+       ADDPV   TFIX,1,PROCID
+;THE FOLLOWING IRP MAKES SPACE FO9 SAVED ACS
+
+ZZZ==.
+
+IRP A,,[0,A,B,C,D,E,PVP,TVP,PP,AB,TB,TP,SP,P]B,,[0
+0,0,0,0,0,TPVP,TTVP,TPP,TAB,TTB,TTP,TSP,TPDL]
+
+LOC PVLOC+2*A
+A!STO=.-PVBASE
+B,,0
+0
+TERMIN
+
+PVLOC==PVLOC+16.*2
+LOC ZZZ
+
+;ADD LAST ERROR AND PROG GOODIE
+
+ADDPV TTB,0,LERR
+
+ADDPV TTB,0,LPROG
+
+
+
+ADDPV TTB,0,TBINIT
+ADDPV TTP,0,TPBASE
+ADDPV TSP,0,SPBASE
+ADDPV TPDL,0,PBASE
+ADDPV 0,0,RESFUN
+ADDPV TLIST,0,.BLOCK
+ADDPV TLIST,0,MESS
+ADDPV TACT,0,FACTI
+
+
+
+;MAIN LOOP AND STARTUP
+
+;SECONDARY STARTUP
+
+START:
+       MOVE    PVP,MAINPR              ;MAKE SURE WE START IN THE MAIN PROCESS
+       PUSHJ   P,INTINT        ;INITIALIZE INTERRUPT HANDLER
+       PUSHJ   P,TTYOPEN               ;OPEN THE TTY
+MIO:   MOVEI   B,[ASCIZ /MUDDLE IN OPERATION./]
+       PUSHJ   P,MSGTYP        ;TYPE OUT TO USER
+
+       XCT     MESSAG          ;MAYBE PRINT A MESSAGE
+
+RESTART:                               ;RESTART A PROCESS
+STP:
+       HRR     TB,TBINIT+1(PVP)        ;POINT INTO STACK AT START
+       MOVE    PP,PPSAV(TB)    ;FLUSH FAILPOINTS
+       JRST    CONTIN
+
+       MQUOTE  TOPLEVEL
+TOPLEVEL:
+       MCALL   0,LISTEN
+       JRST    TOPLEVEL
+
+MFUNCTION LISTEN,SUBR
+
+       ENTRY
+
+       PUSH    P,[0]   ;FLAG: DON'T PRINT ERROR MSG
+       JRST    ER1
+
+MFUNCTION ERROR,SUBR
+
+       ENTRY
+       PUSH    P,[-1]          ;PRINT ERROR FLAG
+
+ER1:   PUSH    TP,$TMATOM      ;BIND CHANNELS,OBLIST AND EOF
+       PUSH    TP,MQUOTE INCHAN
+       PUSH    TP,TTICHN(TVP)  ;TYPE OF TTY CHAN
+       PUSH    TP,TTICHN+1(TVP)        ;AND ITS VALUE
+       PUSH    TP,[0]  ;DUMMY FOR SPECBIND
+       PUSH    TP,[0]
+
+       PUSH    TP,$TMATOM
+       PUSH    TP,MQUOTE OUTCHAN
+       PUSH    TP,TTOCHN(TVP)  ;TYPE OF OUT CHNA
+       PUSH    TP,TTOCHN+1(TVP)        ;AND IT S VAL
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+
+       PUSH    TP,$TMATOM
+       PUSH    TP,MQUOTE OBLIST
+       PUSH    TP,ROOT(TVP)    ;DEFAULT OBLIST TYPE
+       PUSH    TP,ROOT+1(TVP)  ;AND VALUE
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+
+       PUSH    TP,$TMATOM
+       PUSH    TP,MQUOTE EOF
+       PUSH    TP,$TLIST       ;DEFAULT EOF- NIL
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+
+       MOVE    B,MQUOTE LER,[LERR ]INTRUP
+       PUSHJ   P,ILVAL         ;GET VALUE OF LAST ERR
+       PUSH    TP,[TATOM,,-1]          ;FOR BINDING
+       PUSH    TP,MQUOTE LER,[LERR ]INTRUP
+       PUSH    TP,$TTB
+       ADD     B,[1,,0]                ;INCREASE LEVEL
+       HRR     B,TB
+       HLRZ    A,B             ;AND SAVE NEW LEVEL
+       PUSH    P,A
+       PUSH    TP,B
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+
+       PUSHJ   P,SPECBIND      ;BIND THE CRETANS
+       MOVE    A,-1(P)         ;RESTORE SWITHC
+       JUMPE   A,NOERR         ;IF 0, DONT PRINT ERROR MESS
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE *ERROR*
+       MCALL   1,PRINT         ;PRINT THE MESSAGE
+NOERR: MOVE    C,AB            ;GET A COPY OF AB
+
+ERRLP: JUMPGE  C,LEVPRT        ;IF NONE, RE-ENTER READ-EVAL-PRINT LOOP
+       PUSH    TP,$TAB
+       PUSH    TP,C
+       PUSH    TP,(C)          ;GET AN ARGS TYPE
+       PUSH    TP,1(C)         ;AND VALUE
+       MCALL   1,PRINT
+       POP     TP,C
+       SUB     TP,[1,,1]
+       ADD     C,[2,,2]        ;BUMP SAVED AB
+       JRST    ERRLP           ;AND CONTINUE
+
+LEVPRT:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE LISTENING-AT-LEVEL
+       MCALL   1,PRINT         ;PRINT LEVEL
+       PUSH    TP,$TFIX        ;READY TO PRINT LEVEL
+       MOVE    A,(P)           ;GET LEVEL
+       SUB     P,[2,,2]        ;AND POP STACK
+       PUSH    TP,A
+       MCALL   1,PRIN1         ;PRINT WITHOUT SPACES ETC.
+       PUSH    TP,$TATOM       ;NOW PROCESS
+       PUSH    TP,MQUOTE [ PROCESS ]
+       MCALL   1,PRINC         ;DONT SLASHIFY SPACES
+       PUSH    TP,PROCID(PVP)  ;NOW ID
+       PUSH    TP,PROCID+1(PVP)
+       MCALL   1,PRIN1
+       
+MAINLP:        PUSHJ   P,CRLF          ;TYPE OUT A CARRIAGE RETURN, LINEFEED
+       MCALL   0,READ
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   1,EVAL
+       PUSH    TP,A
+       PUSH    TP,B
+       MCALL   1,PRINT
+       JRST    MAINLP
+
+
+
+;FUNCTION TO DO ERROR RETURN
+
+MFUNCTION ERRET,SUBR
+
+       ENTRY
+       CAML    AB,[-1,,0]      ;CHECK FOR AN ARG
+       JRST    STP             ;NO ARGS, RESTART PROCESS
+       CAML    AB,[-3,,0]      ;FRAME SUPPLIED
+       JRST    ERRET1          ;NO
+       ADD     AB,[2,,2]       ;POINT AB AT FRAME ARG
+       PUSHJ   P,FRCHECK       ;CHECK IT OUT   
+       SUB     AB,[2,,2]       ;POINT IT BACK
+
+
+ERRET1:        MOVE    B,MQUOTE LER,[LERR ]INTRUP
+       PUSHJ   P,ILVAL         ;GET VALUE
+       HRR     TB,B            ;AND CLOBBER
+       CAMGE   AB,[-3,,0]      ;FRAME SUPPLIED?
+       HRR     TB,3(AB)        ;YES, RESTORE TB FROM FRAME
+RTA:   MOVE    A,(AB)
+       MOVE    B,1(AB)         ;AND GET RETURNED VALUE
+       JRST    FINIS
+
+
+MFUNCTION      FRAME,SUBR
+       ENTRY
+       MOVE    B,MQUOTE LER,[LERR ]INTRUP
+       PUSHJ   P,ILVAL
+       JUMPGE  AB,FRM1         ;FRAME ARGUMENT SUPPLIED?
+       PUSHJ   P,FRCHECK       ;YES, CHECK IT
+       MOVE    B,OTBSAV(C)     ;GET PREVIOUS FRAME
+
+FRM1:  HLL     B,OTBSAV(B)     ;TIME
+       MOVEI   A,1(PVP)        ;PVP END
+       HLRE    D,PVP   ;PVP LENGTH
+       SUB     A,D     ;ARRIVE AT PVP DOPE WORD
+       HRLI    A,TFRAME
+       JRST    FINIS
+
+MFUNCTION      ARGS,SUBR
+       ENTRY   1       ;
+       PUSHJ   P,FRCHECK
+       MOVEI   A,2
+       PUSHJ   P,CELL"         ;B_ADDRESS OF INFO CELL
+       MOVSI   A,TINFO
+       MOVEM   A,(B)
+       MOVEI   A,(TP)          ;GENERATE DOPE WORD POINTER
+       HLRE    E,TP
+       SUBI    A,-1(E)
+       CAME    A,TPGROW"       ;ALLOWING FOR BLOWN PDL
+       ADDI    A,PDLBUF"
+       HRLZS   A               ;POINTER TO LEFT HALF...
+       HLR     A,OTBSAV(C)     ;TIME TO RIGHT
+       MOVEM   A,1(B)          ;TO SECOND WORD OF CELL
+       HRRI    A,(B)           ;INFO CELL IN CDR OF ARGS VALUE CELL
+       HRLI    A,TARGS
+       MOVE    B,ABSAV(C)
+       JRST    FINIS
+
+MFUNCTION      FUNCT,SUBR      ;RETURNS FUNCTION NAME OF
+       ENTRY   1       ; FRAME ARGUMENT
+       PUSHJ   P,FRCHECK       ;CHECK ARG; LEAVE TB IN C
+       HRRZ    A,FSAV(C)       ;FUNCTION POINTER
+       MOVE    B,@-1(A)        ;GET FUNCTION NAME POINTER
+       MOVSI   A,TATOM
+       JRST    FINIS
+
+FRCHECK:
+       HLRZ    A,(AB)  ;CHECK TYPE OF ARG
+       CAIE    A,TFRAME        ;FRAME?
+       JRST    WRTYFR
+       HRRZ    C,1(AB) ;GET TB OF FRAME
+       CAILE   C,1(TP) ;DOES FRAME POINT BEYOND END OF STACK?
+       JRST    BADFRAME
+       HLRZ    A,FSAV(C)       ;GET TYPE OF  POINTED AT BY FRAME
+       CAIE    A,TENTRY        ;ENTRY?
+       JRST    BADFRAME        ;NO
+       HLRZ    D,1(AB) ;TIME IN FRAME
+       HLRZ    E,OTBSAV(C)     ;TIME IN .FRAME
+       CAME    D,E     ;THE SAME?
+       JRST    BADFRAME        ;NO, PDL UP-DOWN LOSSAGE
+       HRRZ    D,OTBSAV(C)     ;AT TOPLEVEL?
+       JUMPE D,TOPLOSE ;YES
+       POPJ    P,
+
+
+
+WRTYFR:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WRONG-TYPE-FRAME
+       JRST    CALER1
+
+
+BADFRAME:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE FRAME-NO-LONGER-EXISTS
+       JRST    CALER1
+
+
+TOPLOSE:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE TOP-LEVEL-FRAME
+       JRST    CALER1
+
+
+
+
+
+
+;THIS SUBROUTINE ALLOCATES A NEW PROCESS TAKES NO ARGS AND
+;IS CALLED BY PUSHJ P,. RETURNS IN A AND B A NEW PROCESS.
+
+ICR:   MOVEI   A,PVLNT         ;SETUP CALL TO VECTOR FOR PVP
+       PUSHJ   P,IVECT         ;GOBBLE A VECTOR
+       HRLI    C,PVBASE        ;SETUP A BLT POINTER
+       HRRI    C,(B)           ;GET INTO ADDRESS
+       BLT     C,PVLNT*2-1(B)  ;COPY A PROTOTYPE INTO NEW PVP
+       MOVSI   C,400000+SPVP   ;SET SPECIAL TYPE
+       MOVEM   C,PVLNT*2(B)    ;CLOBBER IT IN
+       PUSH    TP,A            ;SAVE THE RESULTS OF VECTOR
+       PUSH    TP,B
+
+       PUSH    TP,$TFIX        ;GET A UNIFORM VECTOR
+       PUSH    TP,[PLNT]
+       MCALL   1,UVECTOR
+       ADD     B,[PDLBUF-2,,-1]        ;FUDGE WITH BUFFER
+       MOVE    C,(TP)          ;REGOBBLE PROCESS POINTER
+       MOVEM   B,PSTO+1(C)     ;STORE IN ALL HOMES
+       MOVEM   B,PBASE+1(C)
+
+       MOVEI   A,PPLNT         ;GET LENGTH OF PP
+       PUSHJ   P,IVECT
+       ADD     B,[PDLBUF-2,,-1]
+       MOVE    C,(TP)          ;GET PROCESS POINTER BACK
+       MOVEM   B,PPSTO+1(C)
+
+       MOVEI   A,TPLNT         ;PREPARE TO CREATE A TEMPORARY PDL
+       PUSHJ   P,IVECT         ;GET THE TEMP PDL
+       ADD     B,[PDLBUF,,0]   ;PDL GROWTH HACK
+       MOVE    C,(TP)          ;RE-GOBBLE NEW PVP
+       SUB     B,[1,,1]        ;FIX FOR STACK
+       MOVEM   B,TPBASE+1(C)
+       MOVEM   B,TPSTO+1(C)    ;MAKE THIS THE CURRENT STACK POINTER
+       MOVEM   C,PVPSTO+1(C)   ;SAVE THE NEW PVP ITSELF
+       MOVEM   TVP,TVPSTO+1(C) ;AND THE GOOD OLD TRANSFER VECTOR
+       AOS     A,PTIME         ;GOBBLE A UNIQUE PROCESS I.D.
+       MOVEM   A,PROCID+1(C)   ;SAVE THAT ALSO
+
+;SETUP INITIAL BINDINGS
+
+       PUSH    TP,$TPVP                ;SAVE PVP
+       PUSH    TP,C
+       MOVEI   A,4
+       PUSHJ   P,IVECT         ;B _ NEW BIND VECTOR
+       POP     TP,C
+       SUB     TP,[1,,1]
+       MOVEM   B,SPBASE+1(C)   ;NEW SPBASE
+       MOVE    A,$TSP
+       MOVEM   A,(B)
+       SETZM   1(B)
+       MOVE    A,$TBIND
+       HRR     A,B
+       ADD     B,[1,,1]
+       PUSH    B,A
+       MOVEM   B,SPSTO+1(C)    ;SAVE AS INITIAL SP
+       PUSH    B,MQUOTE THIS-PROCESS
+       PUSH    B,$TPVP
+       PUSH    B,C
+       PUSH    B,[0]
+       PUSH    B,[0]
+       AOBJP   B,ICRQ
+       .VALUE  [ASCIZ /SP DISASTER/]
+ICRQ:  MOVSI   A,TPVP
+       MOVE    B,C
+       POPJ    P,      
+
+;MINI ROUTINE TO CALL VECTOR WITH COUNT IN A
+
+IVECT: PUSH    TP,$TFIX
+       PUSH    TP,A
+       MCALL   1,VECTOR        ;GOBBLE THE VECTOR
+       POPJ    P,
+
+
+;SUBROUTINE TO SWAP A PROCESS IN
+;CALLED WITH JSP A,SWAP AND NEW PVP IN B
+
+SWAP:                          ;FIRST STORE ALL THE ACS
+
+       IRP     A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
+       MOVEM   A,A!STO+1(PVP)
+       TERMIN
+
+       MOVE    E,PVP   ;RETURN OLD PROCESS IN E
+       MOVE    PVP,D   ;AND MAKE NEW ONE BE D
+
+       ;NOW RESTORE NEW PROCESSES AC'S
+
+       IRP     A,,[PVP,TVP,PP,AB,TB,TP,SP,P,PP]
+       MOVE    A,A!STO+1(PVP)
+       TERMIN
+
+       JRST    (C)             ;AND RETURN
+
+
+;INTERNAL FUNCTION TO GET STRAGE ALLOCATION TYPE
+;GETS THE TYPE CODE IN A AND RETURNS SAT IN A.
+
+SAT:   LSH     A,1             ;TIMES 2 TO REF VECTOR
+       HRLS    A               ;TO BOTH HALVES TO HACK AOBJN POINTER
+       ADD     A,TYPVEC+1(TVP) ;ACCESS THE VECTOR
+       HRR     A,(A)           ;GET PROBABLE SAT
+       JUMPL   A,.+2           ;DID WE REALLY HAVE A VALID TYPE
+       MOVEI   A,0             ;NO RETURN 0
+       MOVEI   A,(A)           ;CLOBBER LEFT HALF
+       POPJ    P,              ;AND RETURN
+
+;TYPE (ITYPE) ARE FUNCTIONS TO RETURN THE ATOMIC NAME OF THE
+;TYPE OF A GOODIE.  TYPE TAKES ITS ARGS ON AP AND RETURNS IN A AND B.
+;ITYPE TAKES ITS ARGS IN A AND B AND RETURNS IN SAME (B=0) FOR INVALID
+;TYPECODE.
+MFUNCTION TYPE,SUBR
+
+       ENTRY   1
+       HLLZ    A,(AB)          ;TYPE INTO A
+TYPE1: PUSHJ   P,ITYPE         ;GO TO INTERNAL
+       JUMPN   B,FINIS         ;GOOD RETURN
+TYPERR:        PUSH    TP,$TATOM       ;SETUP ERROR CALL
+       PUSH    TP,MQUOTE TYPE-UNDEFINED
+       JRST    CALER1"         ;STANDARD ERROR HACKER
+
+ITYPE: LSH     A,1             ;TIMES 2
+       HLRS    A               ;TO BOTH SIDES
+       ADD     A,TYPVEC+1(TVP) ;GET ACTUAL LOCATION
+       JUMPGE  A,TYPLOS        ;LOST, TYPE OUT OF BOUNDS
+       MOVE    B,1(A)          ;PICKUP TYPE
+       HLLZ    A,(A)
+       POPJ    P,
+
+TYPLOS:        MOVSI   A,TLIST
+       MOVEI   B,NIL
+       POPJ    P,
+
+;PRIMTTYPE  RETURNS THE TYPE ATOM OF A PRIMITIVE TYPE IN A CLASS
+
+STBL:  REPEAT NUMSAT,MQUOTE INTERNAL-TYPE
+
+LOC STBL
+
+IRP A,,[[1WORD,FIX],[2WORD,LIST],[NWORD,UVECTOR],[2NWORD,VECTOR]
+[ARGS,ARGUMENTS],[FRAME,FRAME],[ATOM,ATOM],[CHSTR,STRING]]
+
+IRP B,C,[A]
+LOC STBL+S!B
+MQUOTE C
+
+.ISTOP
+
+TERMIN
+TERMIN
+
+LOC STBL+NUMSAT+1
+
+
+MFUNCTION PRIMTYPE,SUBR
+
+       ENTRY   1
+
+       GETYP   A,(AB)          ;GET TYPE
+       PUSHJ   P,SAT           ;GET SAT
+       JUMPE   A,TYPERR
+       MOVE    B,@STBL(A)
+       MOVSI   A,TATOM
+       JRST    FINIS
+
+;CHTYPE TAKES TWO ARGUMENTS.  ANY GOODIE AND A AN ATOMIC TYPE NAME
+;IT CHECKS THE STORAGE ALLOCATION TYPES OF THE TWO ARE THE SAME AND
+;IF THEY ARE CHANGES THE TYPE OF THE FIRST TO THAT NAME D IN THE SECOND
+
+MFUNCTION CHTYPE,SUBR
+
+       ENTRY   2
+       HLRZ    A,2(AB)         ;FIRST CHECK THAT ARG 2 IS AN ATOM
+       CAIE    A,TATOM 
+       JRST    NOTATOM
+       MOVE    B,3(AB)         ;AND TYPE NAME
+       PUSHJ   P,TYPLOO                ;GO LOOKUP TYPE
+TFOUND:        HRRZ    B,(A)           ;GOBBLE THE SAT
+       HLRZ    A,(AB)          ;NOW GET TYPE TO HACK
+       PUSHJ   P,SAT           ;FIND OUT ITS SAT
+       JUMPE   A,TYPERR        ;COMPLAIN
+       CAIE    A,(B)           ;DO THEY AGREE?
+       JRST    TYPDIF          ;NO, COMPLAIN
+       MOVSI   A,(D)           ;GET NEW TYPE
+       MOVE    B,1(AB)         ;AND VALUE
+       JRST    FINIS
+
+TYPLOO:        MOVE    A,TYPVEC+1(TVP) ;GOBBLE DOWN TYPE VECTOR
+       MOVEI   D,0             ;INITIALIZE TYPE COUNTER
+TLOOK: CAMN    B,1(A)          ;CHECK THIS ONE
+       POPJ    P,              ;WIN, RETURN
+       ADDI    D,1             ;BUMP COUNTER
+       AOBJP   A,.+2           ;COUTN DOWN ON VECTOR
+       AOBJN   A,TLOOK
+
+       PUSH    TP,$TATOM       ;LOST, GENERATE ERROR
+       PUSH    TP,MQUOTE BAD-TYPE-NAME
+       JRST    CALER1
+
+TYPDIF:        PUSH    TP,$TATOM       ;MAKE ERROR MESSAGE
+       PUSH    TP,MQUOTE STORAGE-TYPES-DIFFER
+       JRST    CALER1
+
+; FUNCTION TO ADD A NEW TYPE TO THE WORLD WITH GIVEN PRIMITIVE TYPE
+
+MFUNCTION NEWTYPE,SUBR
+
+       ENTRY   2
+
+       GETYP   A,(AB)          ; GET 1ST ARGS TYPE (SHOULD BE ATOM)
+       GETYP   C,2(AB)         ; SAME WITH SECOND
+       CAIN    A,TATOM         ; CHECK
+       CAIE    C,TATOM
+       JRST    NOTATOM
+
+       SKIPGE  C,TYPTOP+1(TVP) ; SKIP IF VECTOR FULL
+       JRST    ADDIT           ; NO, GO ADD
+       PUSH    TP,$TVEC                ; CALL GROW
+       PUSH    TP,TYPVEC+1(TVP)
+       PUSH    TP,$TFIX
+       PUSH    TP,[100]
+       PUSH    TP,$TFIX
+       PUSH    TP,[0]
+       MCALL   3,GROW          ; GROW THE POOR VECTOR
+       MOVE    C,TYPTOP+1(TVP) ; GET NEW TOP
+
+ADDIT: MOVE    B,3(AB) ; GET PRIM TYPE NAME
+       PUSHJ   P,TYPLOO                ; LOOK IT UP
+       HRRZ    A,(B)           ; GOBBLE SAT
+       HRLI    A,TATOM ; MAKE NEW TYPE
+       MOVEM   A,(C)           ; CLOBBER IT IN
+       MOVE    B,1(AB)         ; GET NEW TYPE NAME
+       MOVEM   B,1(C)
+       ADD     C,[2,,2]        ; BUMP POINTER
+       MOVEM   C,TYPTOP+1(TVP)
+       MOVE    A,(AB)
+       MOVE    B,1(AB)         ; RETURN NAME
+       JRST    FINIS
+
+MFUNCTION ALLTYPES,SUBR
+
+       ENTRY   0
+
+       MOVE    A,TYPVEC(TVP)
+       MOVE    B,TYPVEC+1(TVP)
+       JRST    FINIS
+
+MFUNCTION UTYPE,SUBR
+
+       ENTRY   1
+
+       GETYP   A,(AB)          ;GET U VECTOR
+       CAIE    A,TUVEC
+       JRST    WTYP1
+       HLRE    A,1(AB)         ;GET -LENGTH
+       HRRZ    B,1(AB)
+       SUB     B,A             ;POINT TO TYPE WORD
+       HLLZ    A,(B)
+       JRST    TYPE1           ;NOW, USE TYPE CODE
+MFUNCTION CHUTYPE,SUBR
+
+       ENTRY   2
+
+       GETYP   A,2(AB)         ;GET 2D TYPE
+       CAIE    A,TATOM
+       JRST    NOTATO
+       MOVE    A,3(AB)         ;GET ATOM
+       PUSHJ   P,TYPLOO        ;LOOK IT UP
+       HRRZ    B,(A)           ;GET SAT
+       GETYP   A,(AB)          ;CHECK FOR UVECTOR
+       CAIE    A,TUVEC
+       JRST    WTYP1
+       HLRE    C,1(AB)         ;-LENGTH
+       HRRZ    E,1(AB)
+       SUB     E,C             ;POINT TO TYPE
+       HLRZ    A,(E)           ;GET TYPE
+       JUMPE   A,WIN0          ;ALLOW TYPE "LOSE" TO CHANGE TO ANYTHING
+       PUSHJ   P,SAT           ;GET SAT
+       JUMPE   A,TYPERR
+       CAIE    A,(B)           ;COMPARE
+       JRST    TYPDIF
+WIN0:  HRLM    D,(E)           ;CLOBBER NEW ONE
+       GETYPF  A,(AB)          ;RETURN ARG
+       MOVE    B,1(AB)
+       JRST    FINIS
+
+WNA:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
+       MOVEI   A,1
+       JRST    CALER"
+
+NOTATOM:
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NON-ATOMIC-ARGUMENT
+       PUSH    TP,(AB)
+       PUSH    TP,1(AB)
+       MOVEI   A,2
+       JRST    CALER
+
+
+CRLF:  MOVEI   A,15
+       JRST    TYO"
+MSGTYP":       HRLI    B,440700        ;MAKE BYTE POINTER
+MSGTY1:        ILDB    A,B             ;GET NEXT CHARACTER
+       JUMPE   A,CPOPJ         ;NULL ENDS STRING
+       PUSHJ   P,TYO"
+       JRST    MSGTY1          ;AND GET NEXT CHARACTER
+CPOPJ: POPJ    P,
+
+; HACK TO PRINT MESSAGE OF INTEREST TO USER
+
+MESOUT:        MOVSI   A,(JFCL)
+       MOVEM   A,MESSAG                ;DO ONLY ONCE
+       .SUSET  [.RSNAM,,A]     ;READ SNAME AND SAVE
+       PUSH    P,A             ;AND SAVE
+       .SUSET  [.SSNAM,,[SIXBIT /MUDDLE/]
+       MOVEI   A,[SIXBIT /   DSKMUDDLEMESSAG/]
+       PUSHJ   P,OPEN          ;TRY TO OPEN
+       JRST    RESNM
+MESSI: PUSHJ   P,IOT           ;READ A CHAR
+       JUMPL   B,MESCLS        ;DONE, QUIT
+       EXCH    A,B             ;CHAR TO A SAVE CHAN
+       CAIE    A,14            ;DONT TYPE FF
+       PUSHJ   P,TYO           ;AND TYPE IT OUT
+       MOVE    A,B             ;CHANNEL BACK TO A
+       JRST    MESSI           ;UNTIL DONE
+
+MESCLS:        PUSHJ   P,CLOSE ;AND CLOSE
+
+RESNM: POP     P,A             ;RESTORE SNAME
+       .SUSET  [.SSNAM,,A]
+       POPJ    P,
+
+MESSAG:        PUSHJ   P,MESOUT                ;MESSAGE SWITCH
+
+
+CRADIX":       10.
+PTIME: 0                       ;UNIQUE NUMBER FOR PROCID AND ENVIRONMENTS
+OBLNT":        151.                    ;LENGTH OF INITIAL OBLISTS
+VECTOP:        VECLOC
+VECBOT":       VECBASE
+CODBOT:        0                       ;ABSOLUTE BOTTOM OF CODE
+CODTOP":       PARBASE
+PARTOP:        PARLOC
+PARBOT":       PARBASE
+PVLNTH:        0
+TVLNTH:        0
+TVBOT: TVBASE
+VECNEW":       0                       ;LOCATION FOR OFFSET BETWWEN OLD VECTOP AND NEW VECTOP
+PARNEW":       0                       ;LOCATION FOR OFFSET BETTWEEN OLD PARBOT AND NEW PARBOT
+INTFLG:        0                       ;INTERRUPT PENDING FLAG
+MAINPR:        0               ;HOLDS POINTER TO THE MAIN PROCESS
+
+PATCH:
+PAT:   BLOCK   100
+PATEND:        0
+
+;GARBAGE COLLECTORS PDLS
+
+
+GCPDL: -GCPLNT,,GCPDL
+
+       BLOCK   GCPLNT
+
+
+;PROCESS PDL
+
+
+;MARKED PDLS FOR GC PROCESS
+
+VECTGO
+; DUMMY FRAME FOR INITIALIZER CALLS
+
+       TENTRY,,LISTEN
+       0
+       .-3
+       0
+       0
+       -ITPLNT,,TPBAS-1
+       0
+
+TPBAS: BLOCK   ITPLNT+PDLBUF
+       GENERAL
+       ITPLNT+2+PDLBUF+7,,0
+
+APBAS: BLOCK   IAPLNT
+       IAPLNT+1,,0
+
+VECRET
+
+
+
+
+$TMATO:        TATOM,,-1
+
+
+END 
+\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nmatch.1 b/MUDDLE/nmatch.1
new file mode 100644 (file)
index 0000000..3661531
--- /dev/null
@@ -0,0 +1,216 @@
+<DEFINE IS
+ <FUNCTION ("STACK" "BIND" TOPMATCH
+            'PAT EXP)
+   <IS1 .PAT .EXP>
+   T   >>
+
+
+<DEFINE IS?
+ <FUNCTION ("STACK" "BIND" TOPMATCH
+            'PAT EXP)
+   <FAILPOINT ()
+      <PROG2 <IS1 .PAT .EXP> T>
+      ("STACK")
+      <>   >>>
+
+
+<DEFINE MATCH
+ <FUNCTION ("STACK" "BIND" TOPMATCH
+            'PAT1 'PAT2)
+   <MATCH1 .PAT1 .PAT2>
+   T   >>
+
+
+<DEFINE MATCH?
+ <FUNCTION ("STACK" "BIND" TOPMATCH
+            'PAT1 'PAT2)
+   <FAILPOINT ()
+      <PROG2 <MATCH1 .PAT1 .PAT2> T>
+      ("STACK")
+      <>   >>>
+
+
+<DEFINE ASSIGN
+ <FUNCTION ("STACK" "BIND" TOPMATCH
+            'PAT EXP)
+  <FAILPOINT ()
+      <PROG2 <IS1 .PAT .EXP> .EXP>
+      ("STACK")
+      <ERROR IMPOSSIBLE-ASSIGNMENT>   >>>\f<DEFINE IS1
+ <FUNCTION S ("STACK" "BIND" C
+              PAT EXP "OPTIONAL" (ENV <>) (BOUND <BOTTOM .EXP>)
+                (OBLIGATORY T) (PBOUND <BOTTOM .PAT>)
+              "AUX" PURE ENDP K BETA ENDE)
+   <COND (<==? <TYPE .PAT> FORM>
+          <.S <INVOKE .PAT .EXP .BOUND .OBLIGATORY .ENV>>)
+         (<EMPTY? .PAT>
+          <OR <==? .EXP .BOUND> <FAIL>>
+          .BOUND)
+         (<MONAD? .PAT>
+          <.S <OR <=? .PAT .EXP> <FAIL>>>)
+         (<MONAD? .EXP>
+          <OR <EMPTY? .EXP> <FAIL>>)   >
+   <FINSPLICE .C .ENV>
+   <HACKPAT .PAT .PBOUND ENDP K BETA>
+   <SET ENDE <POST .EXP .BOUND .K .BETA>>
+   <REPEAT R ("STACK")
+      <COND (<==? .PAT .ENDP> <.R <GOTEND .EXP .ENDE .OBLIGATORY>>)
+            (<==? <TYPE <1 .PAT>> SEGMENT>
+             <THSET EXP <INVOKE <1 .PAT> .EXP .ENDE <AND <==? .PAT .ENDP> .OBLIGATORY>>>)
+            (<==? .EXP .ENDE> <FAIL>)
+            (T <IS1 <1 .PAT> <1 .EXP>>
+               <THSET EXP <REST .EXP>>)   >
+      <THSET PAT <REST .PAT>>   >
+   <REPEAT ("STACK")
+      <COND (<==? .PAT .PBOUND>
+             <.S .EXP>)
+            (T <IS1 <1 .PAT> <1 .EXP>>)   >
+      <THSET PAT <REST .PAT>>
+      <THSET EXP <REST .EXP>>   >  >>\f<DEFINE MATCH1
+ <FUNCTION MATCHER ("STACK" PAT1 PAT2 "OPTIONAL" (ENV1 <>) (ENV2 <>)
+                      (BOUND1 <BOTTOM .PAT1>) (BOUND2  <BOTTOM .PAT2>)
+                      (OBL T))
+   <COND (<==? <TYPE .PAT1> FORM>
+          <COND (<AND <==? <TYPE .PAT2> FORM>
+                      <G? <PRECEDENCE <1 .PAT2>> <PRECEDENCE <1 .PAT1>>>>
+                 <.MATCHER <INVOKE .PAT2 .PAT1 .BOUND1 T .ENV2 .ENV1 <>>>)   >
+          <.MATCHER <INVOKE .PAT1 .PAT2 .BOUND2 .OBL .ENV1 .ENV2 <>>>)
+         (<==? <TYPE .PAT2> FORM>
+          <.MATCHER <INVOKE .PAT2 .PAT1 .BOUND1 T .ENV2 .ENV1 <>>>)
+         (<AND <MONAD? .PAT1> <FULL? .PAT1>>
+          <.MATCHER <OR <=? .PAT1 .PAT2> <FAIL>>>)
+         (<AND <MONAD? .PAT2> <FULL? .PAT2>>
+          <FAIL>)
+         (<AND <EMPTY? .PAT1> <EMPTY? .PAT2>>
+          <.MATCHER .PAT2>)   >
+   <PROG ("STACK" END1 END2 K1 K2 ALPHA1 ALPHA2 BETA1 BETA2 S1 S2 SEG1 SEG2 FORM1 INC)
+      <SPREAD <PATSOFTEN .PAT1 .BOUND1> ALPHA1 SEG1>
+      <SPREAD <PATSOFTEN .PAT2 .BOUND2> ALPHA2 SEG2>
+      <COND (<G? .ALPHA1 .ALPHA2>
+             <COND (<==? .SEG2 .BOUND2>
+                    <FAIL>)
+                   (<SET SEG1 <REST .PAT1 <SET ALPHA1 .ALPHA2>>>)   >)
+            (<G? .ALPHA2 .ALPHA1>
+             <COND (<AND .OBL <==? .SEG1 .BOUND1>>
+                    <FAIL>)
+                   (<SET SEG2 <REST .PAT2 <SET ALPHA2 .ALPHA1>>>)   >)   >
+      <REPEAT R ("STACK")
+         <COND (<==? .PAT1 .SEG1> <.R <>>)
+               (T <MATCH1 <1 .PAT1> <1 .PAT2> .ENV1 .ENV2>)   >
+         <THSET PAT1 <REST .PAT1>>
+         <THSET PAT2 <REST .PAT2>>   >
+      <SPREAD <PATHACK .SEG1 .BOUND1 .ENV1> END1 K1 BETA1 S1>
+      <SPREAD <PATHACK .SEG2 .BOUND2 .ENV2> END2 K2 BETA2 S2>
+      <COND (<G? .BETA1 .BETA2>
+             <OR .OBL <FAIL>>
+             <SET END1 <REST .END1 <SET INC <- .BETA1 .BETA2>>>>
+             <SET K1 <+ .K1 .INC>>
+             <SET BETA1 .BETA2>)
+            (<G? .BETA2 .BETA1>
+             <COND (.OBL
+                    <SET END2 <REST .END2 <SET INC <- .BETA2 .BETA1>>>>
+                    <SET K2 <+ .K2 .INC>>
+                    <SET BETA2 .BETA1>)
+                   (T <OR <==? .PAT2 .END2> <FAIL>>
+                      <SET END2 <POST .END2 .BOUND2 .K1 .BETA1 .BETA2>>)   >)   >
+      <COND (<AND <==? .S1 1> <0? .K1>>
+             <COND (<AND <==? .S2 1> <0? .K2>>
+                    <SET FORM1 <CHTYPE <1 .SEG2> FORM>>
+                    <INVOKE <1 .SEG1> .FORM1 .FORM1 T .ENV1 .ENV2 <>>)
+                   (T <INVOKE <1 .SEG1> .SEG2 .END2 T .ENV1 .ENV2 <>>)  >)
+            (<AND <==? .S2 1> <0? .K2>>
+             <INVOKE <1 .SEG2> .SEG1 .END1 T .ENV1 .ENV2 <>>)
+            (<0? .S2>
+             <COND (<G? .K1 .K2> <FAIL>)
+                   (T <THSET END2
+                             <SEGMATCH .SEG1 .SEG2 .ENV1 .ENV2 .END1 .END2 .OBL>>)   >)
+            (<0? .S1>
+             <COND (<G? .K2 .K1> <FAIL>)
+                   (<SEGMATCH .SEG2 .SEG1 .ENV2 .ENV1 .END2 .END1>)   >)
+            (T <#FUNCTION ("STACK" (UV1 UV2) 
+                           <AND <EMPTY? .UV1> <EMPTY? .UV2> <FAIL>>
+                           <LINKVARS .UV1 .UV2 .SEG1 .SEG2 .ENV1 .ENV2 .END1 .END2>)
+                <UVARS .SEG1 .END1 .ENV1>
+                <UVARS .SEG2 .END2 .ENV2>>)   >
+      <REPEAT ("STACK")
+         <COND (<==? .END1 .BOUND1> <EXIT .MATCHER .END2>)   >
+         <MATCH1 <1 .END1> <1 .END2> .ENV1 .ENV2>
+         <THSET END1 <REST .END1>>
+         <THSET END2 <REST .END2>>   >   >   >>\f<DEFINE SEGMATCH
+ <FUNCTION SMATCHER ("STACK" PAT1 PAT2 ENV1 ENV2 "OPTIONAL" (BOUND1 <BOTTOM .PAT1>)
+                       (BOUND2 <BOTTOM .PAT2>) (OBL T)
+                     "AUX" FORM1)
+   <REPEAT ("STACK")
+      <COND (<==? .PAT1 .BOUND1>
+             <.SMATCHER .PAT2>)
+            (<==? <TYPE <1 .PAT1>> SEGMENT>
+             <THSET PAT2
+                    <INVOKE <1 .PAT1> .PAT2 .BOUND2 <AND <==? <REST .PAT1> .BOUND1> .OBL> .ENV1 .ENV2 <>>>)
+            (<==? .PAT2 .BOUND2> <FAIL>)
+            (T <MATCH1 <1 .PAT1> <1 .PAT2> .ENV1 .ENV2>
+               <THSET PAT2 <REST .PAT2>>)   >
+      <THSET PAT1 <REST .PAT1>>   >   >>\f<DEFINE HACKPAT
+ <FUNCTION P ("STACK" PAT PBOUND ENDV KV BETAV)
+   <REPEAT ("STACK" (END .PAT) (KS 0) (BETAS 0))
+      <COND (<==? .PAT .PBOUND>
+             <SET .KV .KS> <SET .BETAV .BETAS>
+             <SET .ENDV .END>  <EXIT .P <>>)
+            (<==? <TYPE <1 .PAT>> SEGMENT>
+             <SET KS <+ .KS .BETAS>>
+             <SET BETAS 0>
+             <SET END <REST .PAT>>)
+            (T <SET BETAS <+ .BETAS 1>>)>
+      <SET PAT <REST .PAT>>  >  >>
+
+
+<DEFINE POST
+ <FUNCTION ("STACK" L LBOUND K BETA "OPTIONAL" (KOUNT <BLENGTH .L .LBOUND>))
+   <AND <G? <+ .K .BETA> .KOUNT>
+        <FAIL>>
+   <REST .L <- .KOUNT .BETA>>  >>
+
+
+
+<DEFINE BLENGTH
+ <FUNCTION BL ("STACK" L LB "AUX" (K 0))
+   <COND (<==? .L .LB> .K)
+         (T <SET L <REST .L>>
+            <SET K <+ .K 1>>
+            <AGAIN .BL>)>  >>
+
+
+<DEFINE GOTEND
+ <FUNCTION ("STACK" EXP BOUND OBLIGATORY)
+   <OR <==? .EXP .BOUND>
+       <NOT .OBLIGATORY>
+       <FAIL>>
+   .EXP  >>
+\f<DEFINE PATSOFTEN
+ <FUNCTION SOFTENER ("STACK" PAT BOUND "AUX" (ALPHA 0))
+   <REPEAT ("STACK")
+      <COND (<OR <==? .PAT .BOUND> <==? <TYPE <1 .PAT>> SEGMENT>>
+             <.SOFTENER [.ALPHA .PAT]>)   >
+      <SET ALPHA <+ .ALPHA 1>>
+      <SET PAT <REST .PAT>>   >   >>
+
+
+<DEFINE PATHACK
+ <FUNCTION HACKER ("STACK" "BIND" CURENV
+                   PAT PBOUND ENV
+                   "AUX" (END .PAT) (K 0) (BETA 0) (S 0)
+                         PAT1)
+   <FINSPLICE .CURENV .ENV>
+   <REPEAT ("STACK")
+      <COND (<==? .PAT .PBOUND>
+             <.HACKER [.END .K .BETA .S]>)
+            (<==? <TYPE <SET PAT1 <1 .PAT>>> SEGMENT>
+             <COND (<OR <FULL? <UARGS .PAT1>>
+                        <AND <FULL? .PAT1>
+                             <SET ACTR <ACTOR? <1 .PAT1>>>>>
+                    <SET S <+ .S 1>>)   >
+             <SET K <+ .K .BETA>>
+             <SET BETA 0>
+             <SET END <REST .PAT>>)
+            (T <SET BETA <+ .BETA 1>>)   >
+      <SET PAT <REST .PAT>>   >   >>
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nprint.8 b/MUDDLE/nprint.8
new file mode 100644 (file)
index 0000000..e719984
--- /dev/null
@@ -0,0 +1,799 @@
+TITLE  PRINTER ROUTINE FOR MUDDLE
+RELOCATABLE
+.INSRT DSK:MUDDLE >
+.GLOBAL        IPNAME,TYO,FIXB,FLOATB
+.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,NONSPC
+
+FLAGS==0       ;REGISTER USED TO STORE FLAGS
+CARRET==15     ;CARRIAGE RETURN CHARACTER
+ESCHAR=="\     ;ESCAPE CHARACTER
+SPACE==40      ;SPACE CHARACTER
+ATMBIT=200000  ;BIT SWITCH FOR ATOM-NAME PRINT
+NOQBIT=020000  ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC)
+SEGBIT=010000  ;SWITCH TO INDICATE PRINTING A SEGMENT
+SPCBIT=004000  ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER)
+FLTBIT=002000  ;SWITCH TO INDICATE "FLATSIZE" CALL
+HSHBIT=001000  ;SWITCH TO INDICATE "PHASH" CALL
+TERBIT=000400  ;SWITCH TO INDICATE "TERPRI" CALL
+
+P.STUF:        0
+
+PSYM:
+       EXCH A,P.STUFF
+       .VALUE [ASCIZ \1c\17.=P.STUF!\eQîP.STUF/\eQ!:VP \1c]
+       PUSH TP, (A)
+       PUSH TP, 1(A)
+       MCALL 1,PRINT
+       EXCH A,P.STUFF
+       POPJ P,
+
+P.=PUSHJ P, PSYM
+
+\fMFUNCTION     FLATSIZE,SUBR
+       DEFINE FLTMAX
+               2(AB)TERMIN
+       DEFINE FLTSIZ
+               0(TB)TERMIN
+;FLATSIZE TAKES TWO ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS FALSE
+       ENTRY   2
+       HLRZ    A,2(AB)
+       CAIN    A,TFIX
+       JRST    FLAT1
+;IF THE SECOND ARGUMENT IS NOT FIXED POINT LOSE
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WRONG-TYPE
+       JRST    CALER1
+
+FLAT1: PUSH    TP,$TFIX
+       PUSH    TP,[0]  ;THE VALUE IS ACCUMULATED IN FLTSIZ
+       PUSH    P,FLAGS
+       MOVSI   FLAGS,FLTBIT
+       MOVE    A,(AB)  ;IPRINT TAKES ITS ARGUMENT A AND B
+       MOVE    B,1(AB)
+       PUSHJ   P,IPRINT
+       MOVE    A,FLTSIZ
+       MOVE    B,FLTSIZ+1
+       JRST    FINIS
+
+MFUNCTION      PHASH,SUBR
+       DEFINE HSHMAX
+               2(AB)TERMIN
+       DEFINE HSHNUM
+               0(TB)TERMIN
+;PHASH TAKES TWO ARGUMENTS: THE FIRST IS AN OBJECT THE SECOND
+;IS THE MAXIMUM SIZE BEFORE IT GIVES UP AN RETURNS THE HASH NUMBER
+       ENTRY   2
+       HLRZ    A,2(AB)
+       CAIN    A,TFIX
+       JRST    HASH1
+;IF THE SECOND ARGUMENT IS NOT FIXED POINT LOSE
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WRONG-TYPE
+       JRST    CALER1
+
+HASH1: PUSH    TP,$TFIX
+       PUSH    TP,[0]  ;THE VALUE IS ACCUMULATED IN HASHNUM
+       PUSH    P,FLAGS
+       MOVSI   FLAGS,HSHBIT
+       MOVE    A,(AB)  ;IPRINT TAKES ITS ARGUMENT A AND B
+       MOVE    B,1(AB)
+       PUSHJ   P,IPRINT
+       MOVE    A,HSHNUM
+       MOVE    B,HSHNUM+1
+       JRST    FINIS
+
+\fMFUNCTION     PRINT,SUBR
+       ENTRY   
+       PUSH    P,FLAGS ;SAVE THE FLAGS REGISTER
+       MOVSI   FLAGS,SPCBIT    ;INDICATE PRINTING OF SPACE WHEN DONE
+       JRST    PRIN01  ;CALL IPRINT AFTER SAVING STUFF
+
+MFUNCTION      PRINC,SUBR
+       ENTRY   
+       PUSH    P,FLAGS ;SAVE THE FLAGS REGISTER
+       MOVSI   FLAGS,NOQBIT    ;INDICATE PRINC (NO QUOTES OR ESCAPES)
+       JRST    PRIN01  ;CALL IPRINT AFTER SAVING STUFF
+
+MFUNCTION      PRIN1,SUBR
+       ENTRY   
+       PUSH    P,FLAGS ;SAVE FLAGS REGISTER
+       MOVEI   FLAGS,0 ;ZERO (TURN OFF) ALL FLAGS
+       JRST    PRIN01  ;CALL IPRINT AFTER SAVING STUFF
+
+
+MFUNCTION      TERPRI,SUBR
+       ENTRY
+       MOVSI   FLAGS,TERBIT+SPCBIT
+       JUMPGE  AB,DEFCHN       ;IF NO ARG GO GET CURRENT OUT-CHANNEL BINDING
+       CAMG    AB,[-2,,0]
+       JRST    WNA
+       PUSH    TP,$TFIX        ;SAVE ROOM ON STACK FOR ONE CHANNEL
+       PUSH    TP,[0]
+       MOVE    A,(AB)
+       MOVE    B,(AB)+1
+       JRST    COMPT
+
+\fPRIN01:       PUSH    P,C     ;SAVE REGISTERS C,D, AND E
+       PUSH    P,D
+       PUSH    P,E
+       PUSH    TP,$TFIX        ;LEAVE ROOM ON STACK FOR ONE CHANNEL
+       PUSH    TP,[0]
+
+       HLRZ    C,AB    ;GET THE AOBJN COUNT FROM AB
+       CAIN    C,-2    ;SKIP IF NOT JUST ONE ARGUMENT GIVEN
+       JRST    DEFCHN  ;ELSE USE EXISTING BINDING OF "OUTCHAN"
+       CAIE    C,-4    ;ELSE, THERE MUST BE ONLY TWO ARGUMENTS
+       JRST    ARGERR  ;MORE ARGUMENTS IS AN ERROR
+       MOVE    A,(AB)+2
+       MOVE    B,(AB)+3
+COMPT: CAME    A,$TLIST
+       JRST    BINDPT
+       SKIPN   C,(AB)3 ;EMPTY LIST ?
+       JRST    FINIS   ;IF SO, NO NEED TO CONTINUE
+LISTCK:        HRRZ    C,(C)   ;REST OF LIST
+       JUMPE   C,BINDPT        ;FINISHED ?
+       PUSH    TP,$TFIX        ;LEAVE ROOM ON STACK FOR THIS ADDITIONAL CHANNEL
+       PUSH    TP,[0]
+       JRST    LISTCK
+
+BINDPT:        PUSH    TP,[TATOM,,-1]
+       PUSH    TP,MQUOTE OUTCHAN
+       PUSH    TP,A    ;PUSH NEW OUT-CHANNEL
+       PUSH    TP,B
+       PUSH    TP,[0]
+       PUSH    TP,[0]
+       PUSH    P,FLAGS ;THESE WILL GET CLOBBERED BY SPECBIND
+       PUSHJ   P,SPECBIND
+       POP     P,FLAGS
+
+DEFCHN:        MOVE    B,MQUOTE OUTCHAN
+       MOVSI   A,TATOM
+       PUSHJ   P,IDVAL ;GET VALUE OF CHANNEL
+       SETZ    E,      ;CLEAR E FOR SINGLE CHANNEL ARGUMENTS
+       CAMN    A,$TCHAN        ;SKIP IF IT ISN'T A VALID SINGLE CHANNEL
+       JRST    SAVECH
+       CAME    A,$TLIST        ;SKIP IF IT IS A LIST OF CHANNELS
+       JRST    CHNERR  ;CAN'T HANDLE ANYTHING ELSE (FOR NOW)
+       SKIPA   E,B     ;SAVE LIST POINTER IN E
+LOOPCH:        ADDI    FLAGS,2 ;INCREMENT NUMBER OF CHANNELS COLLECTED
+       HLLZ    A,(E)   ;GET TYPE (SHOULD BE CHANNEL)
+       CAME    A,$TCHAN
+       JRST    CHNERR
+       MOVE    B,(E)+1 ;GET VALUE
+       HRRZ    E,(E)   ;UPDATE LIST POINTER
+
+SAVECH:        HRRZ    C,FLAGS ;GET CURRENT CHANNEL COUNT
+       ADDI    C,(TB)  ;APPROPRIATE STACK LOCATION
+       CAIN    C,(TP)+1        ;NEED MORE ROOM ON STACK FOR LIST ELEMENT CHANNELS ?
+       ADD     TP,[2,,2]       ;IF SO, GET MORE STACK ROOM
+       MOVEM   A,(C)   ;SAVE CHANNEL POINTER ON STACK
+       MOVEM   B,(C)+1
+       SKIPN   IOINS(B)        ;SKIP IF I/O INSTRUCTION IS NON-ZERO
+       PUSHJ   P,OPNCHN        ;ELSE TRY TO OPEN THE CHANNEL
+       JUMPE   B,CHNERR        ;ERROR IF IT CANNOT BE OPENED
+       MOVEI   B,DIRECT-1(B)   ;POINT TO DIRECTION
+       PUSHJ   P,CHRWRD
+       JFCL
+       CAME    B,[ASCII /PRINT/]       ;IS IT PRINT
+       JRST    CHNERR  ;ELSE IT IS AN ERROR
+       JUMPN   E,LOOPCH        ;IF MORE CHANNELS ON LIST, GO CONSIDER THEM
+       ADDI    FLAGS,2 ;MAKE FINAL UPDATE OF COUNT
+\f      MOVEI   A,CARRET        ;GET A CARRIAGE RETURN
+       TLNE    FLAGS,SPCBIT    ;TYPE IT ONLY IF BIT IS ONE (PRINT)
+       PUSHJ   P,PITYO
+       TLNE    FLAGS,TERBIT    ;IF A CALL TO "TERPRI" YOU ARE THROUGH
+       JRST    RFALSE
+
+       MOVE    A,(AB)  ;FIRST WORD OF ARGUMENT GOES INTO REG A
+       MOVE    B,1(AB) ;SECOND WORD INTO REG B
+       PUSHJ   P,IPRINT        ;CALL INTERNAL ROUTINE TO PRINT IT
+
+       MOVEI   A,SPACE
+       TLNE    FLAGS,SPCBIT    ;SKIP (PRINT A TRAILING SPACE) IF SPCBIT IS ON
+       PUSHJ   P,PITYO
+
+       MOVE    A,(AB)  ;GET FIRST ARGUMENT TO RETURN AS PRINT'S VALUE
+       MOVE    B,1(AB)
+
+       POP     P,E     ;RESTORE REGISTERS C,D, AND E
+       POP     P,D
+       POP     P,C
+       POP     P,FLAGS ;RESTORE THE FLAGS REGISTER
+       JRST    FINIS
+
+
+
+
+
+
+RFALSE:        MOVSI   A,TFALSE
+       MOVEI   B,0
+       JRST    FINIS
+\fIPRINT:       PUSH    P,C     ;SAVE REGISTER C ON THE P-STACK
+       PUSH    P,FLAGS ;SAVE PREVIOUS FLAGS
+       PUSH    TP,A    ;SAVE ARGUMENT ON TP-STACK
+       PUSH    TP,B
+
+       INTGO           ;ALLOW INTERRUPTS HERE
+       HLRZ    A,-1(TP)        ;GET THE TYPE CODE OF THE ITEM
+
+       CAILE   A,NUMPRI        ;SKIP IF TYPE NOT OUTSIDE OF VALID RANGE
+       JRST    PUNK    ;JUMP TO ERROR ROUTINE IF CODE TOO GREAT
+       JRST    @PTBL(A)        ;USE IT AS INDEX TO TRANSFER TABLE TO PRINT ITEM
+
+DISTBL PTBL,PUNK,[[TATOM,PATOM],[TFORM,PFORM],[TSEG,PSEG],[TFIX,PFIX]
+[TFLOAT,PFLOAT],[TLIST,PLIST],[TVEC,PVEC],[TCHRS,PCHRS],[TCHSTR,PCHSTR]
+[TARGS,PARGS],[TFRAME,PFRAME],[TUVEC,PUVEC],[TDEFER,PDEFER]
+[TUNAS,PUNAS]]
+
+PUNK:  MOVE    C,TYPVEC+1(TVP) ;GET AOBJN-POINTER TO VECTOR OF TYPE ATOMS
+       HLRZ    B,-1(TP)        ;GET THE TYPE CODE INTO REG B
+       LSH     B,1     ;MULTIPLY BY TWO
+       HRL     B,B     ;DUPLICATE IT IN THE LEFT HALF
+       ADD     C,B     ;INCREMENT THE AOBJN-POINTER
+       JUMPGE  C,PRERR ;IF POSITIVE, INDEX > VECTOR SIZE
+
+       PUSHJ   P,RETIF1        ;START NEW LINE IF NO ROOM
+       MOVEI   A,"#    ;INDICATE TYPE-NAME FOLLOWS
+       PUSHJ   P,PITYO
+       MOVE    A,(C)   ;GET TYPE-ATOM
+       MOVE    B,1(C)
+       PUSHJ   P,IPRINT        ;PRINT ATOM-NAME
+       MOVE    B,(TP)  ;RESET THE REAL ARGUMENT POINTER
+       MOVEI   A,SPACE ;PRINT A SEPARATING SPACE
+       PUSHJ   P,PITYO
+
+       HRRZ    A,(C)   ;GET THE STORAGE-TYPE
+       JRST    @UKTBL(A)       ;USE DISPATCH TABLE ON STORAGE TYPE
+
+DISTBS UKTBL,POCTAL,[[S2WORD,PLIST],[S2NWORD,PVEC],[SNWORD,PUVEC]
+[SCHSTR,PCHSTR],[SFRAME,PFRAME],[SARGS,PARGS],[SPVP,PPVP]]
+
+
+
+\f;INTERNAL SUBROUTINE TO HANDLE CHARACTER OUTPUT
+;
+;PRINTER ITYO USED FOR FLATSIZE FAKE OUT
+PITYO: TLNN    FLAGS,FLTBIT
+       JRST    PITYO1
+       AOS     FLTSIZE+1       ;FLATSIZE DOESN'T PRINT
+                       ;INSTEAD IT COUNTS THE CHARACTERS THAT WOULD BE OUTPUT
+       SOSL    FLTMAX+1        ;UNLESS THE MAXIMUM IS EXCEEDED
+       POPJ    P,
+       MOVSI   A,TFALSE        ;IN WHICH CASE IT IMMEDIATELY GIVES UP AND RETURNS FALSE
+       MOVEI   B,0
+       JRST    FINIS
+
+PITYO1:        TLNN FLAGS,HSHBIT
+       JRST ITYO
+       EXCH A,HSHNUM+1
+       ROT A,-7
+       XOR A,HSHNUM+1
+       EXCH A,HSHNUM+1
+       SOSL HSHMAX+1
+       POPJ P,
+       MOVSI A,TFIX
+       MOVE B,HSHNUM+1
+       JRST FINIS
+
+\f;THE REAL THING
+;NOTE THAT THE FOLLOWING CODE HAS BUGS IF IT IS PRINTING OUT LONG
+;CHARACTER STRINGS
+; (NOTE THAT THE ABOVE COMMENT, IF TRUE, SHOULD NOT BE ADMITTED.)
+ITYO:  PUSH    P,FLAGS ;SAVE STUFF
+       PUSH    P,B
+       PUSH    P,C
+ITYOCH:        PUSH    P,A     ;SAVE OUTPUT CHARACTER
+
+       HRRZ    B,FLAGS ;GET CURRENT CHANNEL COUNT
+       ADDI    B,(TB)-1
+       MOVE    B,(B)   ;GET THE CHANNEL POINTER
+
+       CAIE    A,^L    ;SKIP IF THIS IS A FORM-FEED
+       JRST    NOTFF
+       SETZM   LINPOS(B)       ;ZERO THE LINE NUMBER
+       SETZM   CHRPOS(B)       ;       AND CHARACTER NUMBER.
+       XCT     IOINS(B)        ;FIRST DO A CARRIAGE RETURN-LINE FEED
+       MOVEI   A,^L
+       JRST    ITYXT
+
+NOTFF: CAIE    A,^M    ;SKIP IF IT IS A CARRIAGE RETURN
+       JRST    NOTCR
+       SETZM   CHRPOS(B)       ;ZERO THE CHARACTER POSITION
+       XCT     IOINS(B)        ;OUTPUT THE C-R
+       MOVEI   A,^J    ;FOLLOW WITTH A LINE-FEED
+       AOS     C,LINPOS(B)     ;ADD ONE TO THE LINE NUMBER
+       CAMG    C,PAGLN(B)      ;SKIP IF THIS TAKES US PAST PAGE END
+       JRST    ITYXT
+
+       SETZM   LINPOS(B)       ;ZERO THE LINE POSITION
+       XCT     IOINS(B)        ;OUTPUT THE LINE FEED
+       MOVEI   A,^L    ;GET A FORM FEED
+       JRST    ITYXT
+
+NOTCR: CAIN    A,^I    ;SKIP IF NOT TAB
+       JRST    TABCNT
+       CAIN    A,^J    ;SKIP IF NOT LINE FEED
+       JRST    ITYXT   ;ELSE, DON'T COUNT (JUST OUTPUT IT)
+       AOS     CHRPOS(B)       ;ADD TO CHARACTER NUMBER
+
+ITYXT: XCT     IOINS(B)        ;OUTPUT THE CHARACTER
+       POP     P,A     ;RESTORE THE ORIGINAL CHARACTER
+       SUBI    FLAGS,2 ;DECREMENT CHANNEL COUNT
+       TRNE    FLAGS,-1        ;ANY MORE CHANNELS ?
+       JRST    ITYOCH  ;IF SO GO OUTPUT TO THEM
+
+       POP     P,C     ;RESTORE REGS & RETURN
+       POP     P,B
+       POP     P,FLAGS
+       POPJ    P,
+
+TABCNT:        PUSH    P,D
+       MOVE    C,CHRPOS(B)
+       ADDI    C,8.    ;INCREMENT COUNT BY EIGHT (MOD EIGHT)
+       IDIVI   C,8.
+       IMULI   C,8.
+       MOVEM   C,CHRPOS(B)     ;REPLACE COUNT
+       POP     P,D
+       JRST    ITYXT
+
+\fRETIF1:       MOVEI   A,1
+
+RETIF: TLNE    FLAGS,FLTBIT
+       POPJ    P,      ;IF WE ARE IN FLATSIZE THEN ESCAPE
+       TLNE    FLAGS,HSHBIT    ;ALSO ESCAPE IF IN HASH
+       POPJ    P,
+       PUSH    P,FLAGS
+       PUSH    P,B
+RETCH: PUSH    P,A
+
+       HRRZ    B,FLAGS ;GET THE CURRENT CHANNEL COUNT
+       ADDI    B,(TB)-1        ;CORRECT PLACE ON STACK
+       MOVE    B,(B)   ;GET THE CHANNEL POINTER
+       ADD     A,CHRPOS(B)     ;ADD THE CHARACTER POSITION
+       CAMG    A,LINLN(B)      ;SKIP IF GREATER THAN LINE LENGTH
+       JRST    RETXT
+
+       MOVEI   A,^M    ;FORCE A CARRIAGE RETURN
+       SETZM   CHRPOS(B)
+       XCT     IOINS(B)
+       MOVEI   A,^J    ;AND FORCE A LINE FEED
+       XCT     IOINS(B)
+       AOS     A,LINPOS(B)
+       CAMG    A,PAGLN(B)      ;AT THE END OF THE PAGE ?
+       JRST    RETXT
+       MOVEI   A,^L    ;IF SO FORCE A FORM FEED
+       XCT     IOINS(B)
+       SETZM   LINPOS(B)
+
+RETXT: POP     P,A
+       SUBI    FLAGS,2 ;DECREMENT CHANNEL COUNT
+       TRNE    FLAGS,-1        ;ANY MORE CHANNELS ?
+       JRST    RETCH   ;IF SO GO CONSIDER THEM
+
+       POP     P,B
+       POP     P,FLAGS
+       POPJ    P,      ;RETURN
+
+PRETIF:        PUSH    P,A     ;SAVE CHAR
+       PUSHJ   P,RETIF1
+       POP     P,A
+       JRST    PITYO
+
+\f;THIS IS CODE TO HANDLE UNKNOWN DATA TYPES.
+;IT PRINTS "*XXXXXX*XXXXXXXXXXXX*", WHERE THE FIRST NUMBER IS THE
+;TYPE CODE IN OCTAL, THE SECOND IS THE VALUE FIELD IN OCTAL.
+PRERR: MOVEI   A,21.   ;CHECK FOR 21. SPACES LEFT ON PRINT LINE
+       PUSHJ   P,RETIF ;INSERT CARRIAGE RETURN IF NOT ENOUGH
+       MOVEI   A,"*    ;JUNK TO INDICATE ERROR PRINTOUT IN OCTAL
+       PUSHJ   P,PITYO ;TYPE IT
+
+       MOVE    E,[000300,,-2(TP)]      ;GET POINTER INDEXED OFF TP SO THAT
+                               ;TYPE CODE MAY BE OBTAINED FOR PRINTING.
+       MOVEI   D,6     ;# OF OCTAL DIGITS IN HALF WORD
+OCTLP1:        ILDB    A,E     ;GET NEXT 3-BIT BYTE OF TYPE CODE
+       IORI    A,60    ;OR-IN 60 FOR ASCII DIGIT
+       PUSHJ   P,PITYO ;PRINT IT
+       SOJG    D,OCTLP1        ;REPEAT FOR SIX CHARACTERS
+
+PRE01: MOVEI   A,"*    ;DELIMIT TYPE CODE FROM VALUE FIELD
+       PUSHJ   P,PITYO
+
+       HRLZI   E,(410300,,(TP))        ;BYTE POINTER TO SECOND WORD
+                               ;INDEXED OFF TP
+       MOVEI   D,12.   ;# OF OCTAL DIGITS IN A WORD
+OCTLP2:        LDB     A,E     ;GET 3 BITS
+       IORI    A,60    ;CONVERT TO ASCII
+       PUSHJ   P,PITYO ;PRINT IT
+       IBP     E       ;INCREMENT POINTER TO NEXT BYTE
+       SOJG    D,OCTLP2        ;REPEAT FOR 12. CHARS
+
+       MOVEI   A,"*    ;DELIMIT END OF ERROR TYPEOUT
+       PUSHJ   P,PITYO ;REPRINT IT
+
+       JRST    PNEXT   ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+
+POCTAL:        MOVEI   A,14.   ;RETURN TO NEW LINE IF 14. SPACES NOT LEFT
+       PUSHJ   P,RETIF
+       JRST    PRE01   ;PRINT VALUE AS "*XXXXXXXXXXXX*"
+
+\f;PRINT BINARY INTEGERS IN DECIMAL.
+;
+PFIX:  MOVEI   E,FIXB  ;GET ADDRESS OF FIXED POINT CONVERSION ROUTINE
+       MOVE    D,[4,,4]        ;PUT # WORDS RESERVED ON STACK INTO REG F
+       JRST    PNUMB   ;PRINT THE NUMBER
+
+;PRINT SINGLE-PRECISION FLOATING POINT NUMBERS IN DECIMAL.
+;
+PFLOAT:        MOVEI   E,FLOATB        ;ADDRESS OF FLOATING POINT CONVERSION ROUTINE
+       MOVE    D,[6,,6]        ;# WORDS TO GET FROM STACK
+
+PNUMB: HRLI    A,1(P)  ;LH(A) TO CONTAIN ADDRESS OF RETURN AREA ON STACK
+       HRR     A,TP    ;RH(A) TO CONTAIN ADDRESS OF DATA ITEM
+       HLRZ    B,A     ;SAVE RETURN AREA ADDRESS IN REG B
+       ADD     P,D     ;ADD # WORDS OF RETURN AREA TO BOTH HALVES OF SP
+       JUMPGE  P,PDLERR        ;PLUS OR ZERO STACK POINTER IS OVERFLOW
+       PUSHJ   P,(E)   ;CALL ROUTINE WHOSE ADDRESS IS IN REG E
+
+       MOVE    C,(B)   ;GET COUNT 0F # CHARS RETURNED
+       MOVE    A,C     ;MAKE SURE THAT # WILL FIT ON PRINT LINE
+       PUSHJ   P,RETIF ;START NEW LINE IF IT WON'T
+
+       HRLI    B,000700        ;MAKE REG B INTO BYTE POINTER TO FIRST CHAR LESS ONE
+PNUM01:        ILDB    A,B     ;GET NEXT BYTE
+       PUSHJ   P,PITYO ;PRINT IT
+       SOJG    C,PNUM01        ;DECREMENT CHAR COUNT: LOOP IF NON-ZERO
+
+       SUB     P,D     ;SUBTRACT # WORDS USED ON STACK FOR RETURN
+       JRST    PNEXT   ;STORE REGS & POP UP ONE LEVEL TO CALLER
+
+\f;PRINT SHORT (ONE WORD) CHARACTER STRINGS.
+;
+PCHRS: MOVEI   A,3     ;MAX # CHARS PLUS 2 (LESS ESCAPES)
+       TLNE    FLAGS,NOQBIT    ;SKIP IF QUOTES WILL BE USED
+       MOVEI   A,1     ;ELSE, JUST ONE CHARACTER POSSIBLE
+       PUSHJ   P,RETIF ;NEW LINE IF INSUFFICIENT SPACE
+       TLNE    FLAGS,NOQBIT    ;DON'T QUOTE IF IN PRINC MODE
+       JRST    PCASIS
+       MOVEI   A,"!    ;TYPE A EXCL
+       PUSHJ   P,PITYO
+       MOVEI   A,""            ;AND A DOUBLE QUOTE
+       PUSHJ   P,PITYO
+
+PCASIS:        LDB     A,[350700,,(TP)]        ;GET NEXT BYTE FROM WORD
+       TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+       JRST    PCPRNT  ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+       CAIE    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER
+       JRST    PCPRNT  ;ESCAPE THE ESCAPE CHARACTER
+
+ESCPRT:        MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER
+       PUSHJ   P,PITYO 
+
+PCPRNT:        LDB     A,[350700,,(TP)]        ;GET THE CHARACTER AGAIN
+       PUSHJ   P,PITYO ;PRINT IT
+       JRST    PNEXT
+
+
+\f;PRINT DEFERED (INVISIBLE) ITEMS. (PRINTED AS THE THING POINTED TO)
+;
+PDEFER:        MOVE    A,(B)   ;GET FIRST WORD OF ITEM
+       MOVE    B,1(B)  ;GET SECOND
+       PUSHJ   P,IPRINT        ;PRINT IT
+       JRST    PNEXT   ;GO EXIT
+
+;PRINT ATOM NAMES.
+;
+PATOM: TLO     FLAGS,ATMBIT    ;INDICATE ATOM-NAME PRINT OUT
+       HRRZ    B,(TP)  ;GET ADDRESS OF ATOM
+       ADDI    B,2     ;POINT TO FIRST P-NAME WORD
+       HRLI    B,350700        ;MAKE INTO A BYTE POINTER
+       HLRE    A,(TP)  ;GET LENGTH
+       MOVMS   A       ;ABSOLUTE VALUE
+       ADDI    A,-1(B) ;POINT TO LAST WORD
+       HRLI    A,TCHSTR        ;CHANGE TYPE
+       PUSH    TP,A    ;PUT STRING ON STACK
+       PUSH    TP,B
+
+       MOVE    D,[AOS E]       ;GET COUNTING INSTRUCTION
+       SETZM   E       ;ZERO COUNT
+       PUSHJ   P,PCHRST        ;COUNT CHARACTERS & ESCAPES
+       MOVE    A,E     ;GET RETURNED COUNT
+       PUSHJ   P,RETIF ;DO A CARRIAGE RETURN IF NOT ENOUGH ROOM ON THIS LINE
+
+       MOVEM   B,(TP)  ;RESET BYTE POINTER
+       MOVE    D,[PUSHJ P,PITYO]       ;GET OUTPUT INSTRUCTION
+       PUSHJ   P,PCHRST        ;PRINT STRING
+
+       SUB     TP,[2,,2]       ;REMOVE CHARACTER STRING ITEM
+       JRST    PNEXT
+
+\f;PRINT LONG CHARACTER STRINGS.
+;
+PCHSTR:        TLZ     FLAGS,ATMBIT    ;WE ARE NOT USING ATOM-NAME TYPE ESCAPING
+
+       MOVE    D,[AOS E]       ;GET INSTRUCTION TO COUNT CHARACTERS
+       SETZM   E       ;ZERO COUNT
+       PUSHJ   P,PCHRST        ;GO THROUGH STRING, ESCAPING, ETC. AND COUNTING
+       MOVE    A,E     ;PUT COUNT RETURNED IN REG A
+       TLNN    FLAGS,NOQBIT    ;SKIP (NO QUOTES) IF IN PRINC (BIT ON)
+       ADDI    A,2     ;PLUS TWO FOR QUOTES
+       PUSHJ   P,RETIF ;START NEW LINE IF NO SPACE
+
+       TLNE    FLAGS,NOQBIT    ;SKIP (PRINT ") IF BIT IS OFF (NOT PRINC)
+       JRST    PCHS01  ;OTHERWISE, DON'T QUOTE
+       MOVEI   A,""    ;PRINT A DOUBLE QUOTE
+       PUSHJ   P,PITYO
+
+PCHS01:        MOVE    D,[PUSHJ P,PITYO]       ;OUTPUT INSTRUCTION
+       MOVEM   B,(TP)  ;RESET BYTE POINTER
+       PUSHJ   P,PCHRST        ;TYPE STRING
+
+       TLNE    FLAGS,NOQBIT    ;AGAIN, SKIP IF DOUBLE-QUOTING TO BE DONE
+       JRST    PNEXT   ;RESTORE REGS & POP UP ONE LEVEL TO CALLER
+       MOVEI   A,""    ;PRINT A DOUBLE QUOTE
+       PUSHJ   P,PITYO
+       JRST    PNEXT
+
+
+\f;INTERNAL ROUTINE USED TO COUNT OR OUTPUT CHARACTER STRINGS.
+;
+;THE APPROPRIATE ESCAPING CONVENTIONS ARE USED AS DETERMINED BY THE FLAG BITS.
+;
+PCHRST:        PUSH    P,A     ;SAVE REGS
+       PUSH    P,B
+       PUSH    P,C
+       LDB     A,(TP)  ;GET FIRST BYTE
+       SKIPA
+
+PCHR02:        ILDB    A,(TP)  ;GET THE NEXT CHARACTER
+       JUMPE   A,PCSOUT        ;ZERO BYTE TERMINATES
+       HRRZ    C,-1(TP)        ;GET ADDRESS OF DOPE WORD
+       HRRZ    B,(TP)  ;GET WORD ADDRESS OF LAST BYTE
+       CAIL    B,-1(C) ;SKIP IF IT IS AT LEAST TWO BEFORE DOPE WORD
+       JRST    PCSOUT  ;ELSE, STRING IS FINISHED
+
+       TLNE    FLAGS,NOQBIT    ;SKIP IF WE ARE NOT IN PRINC MODE (NOQBIT=0)
+       JRST    PCSPRT  ;IF BIT IS ON, PRINT WITHOUT ESCAPING
+       CAIN    A,ESCHAR        ;SKIP IF NOT THE ESCAPE CHARACTER
+       JRST    ESCPRN  ;ESCAPE THE ESCAPE CHARACTER
+       CAIN    A,""    ;SKIP IF NOT A DOUBLE QUOTE
+       JRST    ESCPRN  ;OTHERWISE, ESCAPE THE """
+       IDIVI   A,CHRWD ;CODE HERE FINDS CHARACTER TYPE
+       LDB     B,BYTPNT(B)     ; "
+       CAIG    B,NONSPC                ;SKIP IF ATOM-BREAKER
+       JRST    PCSPRT  ;OTHERWISE, PRINT IT
+       TLNN    FLAGS,ATMBIT    ;SKIP IF PRINTING AN ATOM-NAME (UNQUOTED)
+       JRST    PCSPRT  ;OTHERWISE, NO OTHER CHARS TO ESCAPE
+
+ESCPRN:        MOVEI   A,ESCHAR        ;TYPE THE ESCAPE CHARACTER
+       XCT     D       
+
+PCSPRT:        LDB     A,(TP)  ;GET THE CHARACTER AGAIN
+       XCT     D       ;PRINT IT
+       JRST    PCHR02  ;LOOP THROUGH STRING
+
+PCSOUT:        POP     P,C     ;RESTORE REGS & RETURN
+       POP     P,B
+       POP     P,A
+       POPJ    P,
+
+
+\f;PRINT AN ARGUMENT LIST
+;CHECK FOR TIME ERRORS
+
+PARGS: MOVEI   B,-1(TP)                ;POINT TO ARGS POINTER
+       PUSHJ   P,CHARGS                ;AND CHECK THEM
+       JRST    PVEC    ; CHEAT TEMPORARILY
+
+
+
+;PRINT A FRAME
+PFRAME:        MOVEI   B,-1(TP)                ;POINT TO FRAME POINTER
+       PUSHJ   P,CHFRM
+       HRRZ    B,(TP)          ;POINT TO FRAME ITSELF
+       HRRZ    B,FSAV(B)               ;GET POINTER TO SUBROUTINE
+       MOVE    B,@-1(B)                ;PICKUP ATOM
+       PUSH    TP,$TATOM
+       PUSH    TP,B            ;SAVE IT
+       MOVSI   A,TATOM
+       MOVE    B,MQUOTE -STACK-FRAME-FOR-
+       PUSHJ   P,IPRINT                ;PRINT IT
+       POP     TP,B
+       POP     TP,A
+       PUSHJ   P,IPRINT                ;PRINT FUNCTION NAME
+       JRST    PNEXT
+
+PPVP:  MOVE    B,MQUOTE -PROCESS-
+       MOVSI   A,TATOM
+       PUSHJ   P,IPRINT
+       MOVE    B,(TP)          ;GET PVP
+       MOVE    A,PROCID(B)
+       MOVE    B,PROCID+1(B)   ;GET ID
+       PUSHJ   P,IPRINT
+       JRST    PNEXT
+\f;PRINT UNIFORM VECTORS.
+;
+PUVEC: MOVEI   A,"!    ;TYPE AN ! AND OPEN SQUARE BRACKET
+       PUSHJ   P,PRETIF
+       MOVEI   A,"[
+       PUSHJ   P,PRETIF
+
+       MOVE    C,(TP)  ;GET AOBJN POINTER TO VECTOR
+       TLNN    C,777777        ;SKIP ONLY IF COUNT IS NOT ZERO
+       JRST    NULVEC  ;ELSE, VECTOR IS EMPTY
+
+       HLRE    A,C     ;GET NEG COUNT
+       MOVEI   D,(C)   ;COPY POINTER
+       SUB     D,A     ;POINT TO DOPE WORD
+       HLLZ    A,(D)   ;GET TYPE
+       PUSH    P,A     ;AND SAVE IT
+
+PUVE02:        MOVE    A,(P)   ;PUT TYPE CODE IN REG A
+       MOVE    B,(C)   ;PUT DATUM INTO REG B
+       PUSHJ   P,IPRINT        ;TYPE IT
+
+       MOVE    C,(TP)  ;GET AOBJN POINTER
+       AOBJP   C,NULVE1        ;JUMP IF COUNT IS ZERO
+       MOVEM   C,(TP)  ;PUT POINTER BACK ONTO STACK
+
+       MOVEI   A,SPACE ;TYPE A BLANK
+       PUSHJ   P,PITYO
+       JRST    PUVE02  ;LOOP THROUGH VECTOR
+
+NULVE1:        SUB     P,[1,,1]        ;REMOVE STACK CRAP
+NULVEC:        MOVEI   A,"!    ;TYPE CLOSE BRACKET
+       PUSHJ   P,PRETIF
+       MOVEI   A,"]
+       PUSHJ   P,PRETIF
+       JRST    PNEXT
+
+\f;PRINT A GENERALIZED VECTOR.
+;
+PVEC:  PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR [
+       MOVEI   A,"[    ;PRINT A LEFT-BRACKET
+       PUSHJ   P,PITYO
+
+       MOVE    C,(TP)  ;GET AOBJN POINTER TO VECTOR
+       TLNN    C,777777        ;SKIP IF POINTER-COUNT IS NON-ZERO
+       JRST    PVCEND  ;ELSE, FINISHED WITH VECTOR
+PVCR01:        MOVE    A,(C)   ;PUT FIRST WORD OF NEXT ELEMENT INTO REG A
+       MOVE    B,1(C)  ;SECOND WORD OF LIST INTO REG B
+       PUSHJ   P,IPRINT        ;PRINT THAT ELEMENT
+
+       MOVE    C,(TP)  ;GET AOBJN POINTER FROM TP-STACK
+       AOBJP   C,PDLERR        ;POSITIVE HERE SERIOUS ERROR! (THOUGH NOT PDL)
+       AOBJN   C,.+2   ;SKIP AND CONTINUE LOOP IF COUNT NOT ZERO
+       JRST    PVCEND  ;ELSE, FINISHED WITH VECTOR
+       MOVEM   C,(TP)  ;PUT INCREMENTED POINTER BACK ON TP-STACK
+
+       MOVEI   A,"     ;PRINT A SPACE
+       PUSHJ   P,PITYO
+       JRST    PVCR01  ;CONTINUE LOOPING THROUGH OBJECTS ON VECTOR
+
+PVCEND:        PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR ]
+       MOVEI   A,"]    ;PRINT A RIGHT-BRACKET
+       PUSHJ   P,PITYO
+       JRST    PNEXT
+
+;PRINT A LIST.
+;
+PLIST: PUSHJ   P,RETIF1        ;NEW LINE IF NO SPACE LEFT FOR "("
+       MOVEI   A,"(    ;TYPE AN OPEN PAREN
+       PUSHJ   P,PITYO
+       PUSHJ   P,LSTPRT        ;PRINT THE INSIDES
+       PUSHJ   P,RETIF1        ;NEW LINE IF NO ROOM FOR THE CLOSE PAREN
+       MOVEI   A,")    ;TYPE A CLOSE PAREN
+       PUSHJ   P,PITYO
+       JRST    PNEXT
+
+
+
+;PRINT AN UNASSIGNED
+
+PUNAS: PUSHJ   P,RETIF1
+       MOVEI   A,"?
+       PUSHJ   P,PITYO
+       JRST    PLIST\fPSEG:     TLOA    FLAGS,SEGBIT    ;PRINT A SEGMENT (& SKIP)
+
+PFORM: TLZ     FLAGS,SEGBIT    ;PRINT AN ELEMENT
+
+PLMNT3:        MOVE    C,(TP)
+       JUMPE   C,PLMNT1        ;IF THE CALL IS EMPTY GO AWAY
+       MOVE    B,1(C)
+       MOVEI   D,0
+       CAMN    B,MQUOTE LVAL
+       MOVEI   D,".
+       CAMN    B,MQUOTE GVAL
+       MOVEI   D,",
+       CAMN    B,MQUOTE QUOTE
+       MOVEI   D,"'
+       CAMN    B,MQUOTE GIVEN
+       MOVEI   D,"?
+       CAMN    B,MQUOTE ALTER
+       MOVEI   D,"_
+       JUMPE   D,PLMNT1                ;NEITHER, LEAVE
+
+;ITS A SPECIAL HACK
+       HRRZ    C,(C)
+       JUMPE   C,PLMNT1        ;NIL BODY?
+
+;ITS VALUE OF AN ATOM
+       HLLZ    A,(C)
+       MOVE    B,1(C)
+       HRRZ    C,(C)
+       JUMPN   C,PLMNT1        ;IF TERE ARE EXTRA ARGS GO AWAY
+
+       PUSH    P,D             ;PUSH THE CHAR
+       PUSH    TP,A
+       PUSH    TP,B
+       TLNN    FLAGS,SEGBIT    ;SKIP (CONTINUE) IF THIS IS A SEGMENT
+       JRST    PLMNT4  ;ELSE DON'T PRINT THE "."
+
+;ITS A SEGMENT CALL
+       PUSHJ   P,RETIF1
+       MOVEI   A,"!
+       PUSHJ   P,PITYO
+
+PLMNT4:        PUSHJ   P,RETIF1
+       POP     P,A             ;RESTORE CHAR
+       PUSHJ   P,PITYO
+       POP     TP,B
+       POP     TP,A
+       PUSHJ   P,IPRINT
+       JRST    PNEXT
+
+\f
+PLMNT1:        TLNN    FLAGS,SEGBIT    ;SKIP IF THIS IS A SEGMENT
+       JRST    PLMNT5  ;ELSE DON'T TYPE THE "!"
+
+;ITS A SEGMENT CALL
+       PUSHJ   P,RETIF1
+       MOVEI   A,"!
+       PUSHJ   P,PITYO
+\rPLMNT5:       PUSHJ   P,RETIF1        
+       MOVEI   A,"<
+       PUSHJ   P,PITYO
+       PUSHJ   P,LSTPRT
+       MOVEI   A,"!
+       TLNE    FLAGS,SEGBIT    ;SKIP IF NOT SEGEMNT
+       PUSHJ   P,PRETIF
+       MOVEI   A,">
+       PUSHJ   P,PRETIF
+       JRST    PNEXT
+
+\fLSTPRT:       INTGO   ;WATCH  OUT FOR GARBAGE COLLECTION!
+       SKIPN   C,(TP)
+       POPJ    P,
+       HLLZ    A,(C)   ;GET NEXT ELEMENT
+       MOVE    B,1(C)
+       HRRZ    C,(C)   ;CHOP THE LIST
+       JUMPN   C,PLIST1
+       PUSHJ   P,IPRINT        ;PRINT THE LAST ELEMENT
+       POPJ    P,
+
+PLIST1:        MOVEM   C,(TP)
+       PUSHJ   P, IPRINT       ;PRINT THE NEXT ELEMENT
+       PUSHJ   P,RETIF1
+       MOVEI   A," 
+       PUSHJ   P,PITYO ;PRINT THE SPACE AFTER THE NEXT ELEMENT
+       JRST    LSTPRT  ;REPEAT
+
+PNEXT: POP     P,FLAGS ;RESTORE PREVIOUS FLAG BITS
+       SUB     TP,[2,,2]       ;REMOVE INPUT ELEMENT FROM TP-STACK
+       POP     P,C     ;RESTORE REG C
+       POPJ    P,
+
+PDLERR:        .VALUE  0       ;P-STACK OVERFLOW, VERY SERIOUS, MUDDLE DIES!
+
+CHNERR:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE BAD-CHANNEL
+       JRST    CALER1
+
+ARGERR:        PUSH    TP,$TATOM       ;TYPE WRONG # ARGUMENTS
+       PUSH    TP,MQUOTE WRONG-NUMBER-OF-ARGUMENTS
+       JRST    CALER1
+
+END
+\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nptest.4 b/MUDDLE/nptest.4
new file mode 100644 (file)
index 0000000..a4b7faf
--- /dev/null
@@ -0,0 +1,35 @@
+<SETG PATH
+ <FUNCTION (START FINISH)
+   <PATH1 .START .FINISH ()>  >>
+
+
+<SETG PATH1
+ <FUNCTION P1 (START FINISH AVOID)
+   <COND (<==? .START .FINISH>
+          (.FINISH))
+         (<MEMBER .START .AVOID> <>)
+         (T (.START
+             !<REPEAT REP (PATH (NODES <GET .START CONNECTED>))
+                 <COND (<EMPTY? .NODES> <EXIT .P1 <>>)
+                       (<SET PATH <PATH1 <1 .NODES> .FINISH (.START !.AVOID)>>
+                        <EXIT .REP .PATH>)
+                       (T <SET NODES <REST .NODES>>)   >>))   >>>
+                        
+
+
+<PUT ALPHA CONNECTED (B D K)>\e
+<PUT B CONNECTED (ALPHA I C)>\e\r\r
+<PUT I CONNECTED (B H J)>\e
+<PUT H CONNECTED (I)>\e
+<PUT J CONNECTED (I)>\e
+<PUT C CONNECTED (B G D)>\e
+<PUT G CONNECTED (C)>\e
+<PUT D CONNECTED (ALPHA C F)>\e
+\r<PUT F CONNECTED (D)>\e
+<PUT K CONNECTED (ALPHA M L)>\e
+<PUT M CONNECTED (K L N O)>\e
+<PUT L CONNECTED (K M)>\e
+<PUT N CONNECTED (M)>\e
+<PUT O CONNECTED (M P OMEGA)>\e
+<PUT P CONNECTED (O)>\e
+<PUT OMEGA CONNECTED (O)>\e\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nread.14 b/MUDDLE/nread.14
new file mode 100644 (file)
index 0000000..2d8e75a
Binary files /dev/null and b/MUDDLE/nread.14 differ
diff --git a/MUDDLE/nuprm.8 b/MUDDLE/nuprm.8
new file mode 100644 (file)
index 0000000..f99afc4
--- /dev/null
@@ -0,0 +1,532 @@
+
+TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL CALER,CALER1,NWORDT,CHARGS,CHFRM,CHLOCI,TFA,TMA,IFALSE,IPUTP,IGETP,WTYP1
+.GLOBAL ITRUTH
+
+
+; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE
+
+PRMTYP:
+
+REPEAT NUMSAT,[0]                      ;INITIALIZE TABLE TO ZEROES
+
+IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE]
+
+LOC PRMTYP+S!A
+P!A==.IRPCN+1
+P!A
+
+TERMIN
+
+LOC PRMTYP+NUMSAT
+
+PNUM==PBYTE+1
+
+; MACRO TO BUILD PRIMITIVE DISPATCH TABLES
+
+DEFINE PRDISP NAME,DEFAULT,LIST
+       TBLDIS NAME,DEFAULT,[LIST]PNUM
+       TERMIN
+
+
+; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL
+
+PTYPE: GETYP   A,(B)   ;CALLE D WITH B POINTING TO PAIR
+       CAIN    A,TILLEG        ;LOSE IF ILLEGAL
+       JRST    ILLCHOS
+
+       PUSHJ   P,SAT           ;GET STORAGE ALLOC TYPE
+       CAIN    A,SARGS         ;SPECIAL HAIR FOR ARGS
+       PUSHJ   P,CHARGS
+       CAIN    A,SFRAME
+       PUSHJ   P,CHFRM
+PTYP1: MOVE    A,PRMTYP(A)     ;GET PRIM TYPE,
+       POPJ    P,
+\f
+
+; PROCESS TYPE ILLEGAL
+
+ILLCHO:        HRRZ    B,1(B)  ;GET CLOBBERED TYPE
+       CAIN    B,TARGS ;WAS IT ARGS?
+       JRST    ILLARG
+       CAIN    B,TFRAME                ;A FRAME?
+       JRST    ILFRAM
+       CAIN    B,TLOCD         ;A LOCATIVE TO AN ID
+       JRST    ILLOC
+
+       LSH     B,1             ;NONE OF ABOVE LOOK IN TABLE
+       ADDI    B,TYPVEC+1(TVP)
+       PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ILLEGAL
+       PUSH    TP,$TATOM
+       PUSH    TP,(B)          ;PUSH ATOMIC NAME
+       MOVEI   A,2
+       JRST    CALER           ;GO TO ERROR REPORTER
+
+; CHECK AN ARGS POINTER
+
+CHARGS:        PUSH    P,A             ;SAVE SOME ACS
+       PUSH    P,B
+       PUSH    P,C
+       MOVE    C,1(B)  ;GET POINTER
+       HLRE    A,C             ;FIND ASSOCIATED FRAME
+       SUBI    C,(A)           ;C POINTS TO FRAME OR FRAME POINTER
+       ANDI    C,-1
+       CAILE   C,(TP)          ;WITHIN STACK?
+       JRST    ILLARG          ;NO, LOSE
+       HLRZ    A,(C)           ;GET TYPE OF NEXT GOODIE
+       CAIE    A,TENTRY        ;MUST BE EITHER ENTRY OR TTB
+       CAIN    A,TTB
+       JRST    CHARG1          ;WINNER
+
+ILLARG:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ILLEGAL-ARGUMENT-BLOCK
+       JRST    CALER1
+
+CHARG1:        CAIN    A,TTB           ;POINTER TO FRAME?
+       MOVE    C,1(C)          ;YES, GET IT
+       CAIN    A,TENTRY                ;POINTS TO ENTRT?
+       MOVEI   C,FRAMLN(C)     ;YES POINT TO END OF FRAME
+       HLRZ    C,OTBSAV(C)     ;GET TIME FROM FRAME
+       HRRZ    B,(B)           ;AND ARGS TIME
+       HRRZ    B,1(B)          ;TIME IS IN INFO CELL
+       CAIE    B,(C)           ;SAME?
+       JRST    ILLARG
+POPBCJ:        POP     P,C
+       POP     P,B
+       POP     P,A
+       POPJ    P,              ;GO GET PRIM TYPE
+\f
+
+
+; CHECK A FRAME POINTER
+
+CHFRM: PUSH    P,A             ;SAVE SOME REGISTERS
+       PUSH    P,B
+       PUSH    P,C
+       HRRZ    C,1(B)          ;GET POINTER PART
+       CAILE   C,(TP)          ;STILL WITHIN STACK
+       JRST    ILFRAM
+       HLRZ    A,FSAV(C)       ;CHECK STILL AN ENTRY BLOCK
+       CAIE    A,TENTRY
+       JRST    ILFRAM
+       HLRZ    A,1(B)          ;GET TIME FROM POINTER
+       HLRZ    C,OTBSAV(C)     ;AND FROM FRAME
+       CAIN    A,(C)           ;SAME?
+       JRST    POPBCJ          ;YES, WIN
+
+ILFRAM:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ILLEGAL-FRAME
+       JRST    CALER1
+
+; CHECK A LOCATIVE TO AN IDENTIFIER
+
+CHLOCI:        PUSH    P,A
+       PUSH    P,B
+       PUSH    P,C
+
+       HRRZ    A,(B)           ;GET TIME FROM POINTER
+       JUMPE   A,POPBCJ        ;ZERO, GLOBAL VARIABLE NO TIME
+       HRRZ    C,1(B)          ;POINT TO STACK
+       HRRZ    C,2(C)
+       CAMN    A,C
+       JRST    POPBCJ
+
+ILLOC: PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE ILLEGAL-LOCATIVE
+       JRST    CALER1
+
+       
+\f
+
+; FUNCTION TO GET THE LENGTH OF LISTS,VECTORS AND CHAR STRINGS
+
+MFUNCTION LENGTH,SUBR
+
+       ENTRY   1
+
+       MOVE    B,AB            ;POINT TO ARGS
+       PUSHJ   P,PTYPE         ;GET ITS PRIM TYPE
+       JUMPE   A,WTYP1         ;IF 1 WORD, LOSE
+       MOVEI   B,0
+       SKIPE   C,1(AB)         ;IF NON-ZERO, FIND LENGTH
+       AOJA    B,@LENTBL(A)
+       JRST    LFINIS          ;OTHERWISE USE 0
+
+PRDISP LENTBL,IWTYP1,[[P2WORD,LNLST],[P2NWORD,LNVEC],[PNWORD,LNUVEC]
+[PARGS,LNVEC],[PCHSTR,LNCHAR]]
+
+LNLST: MOVSI   A,TLIST         ;WILL BECOME INTERRUPTABLE
+       HLLM    A,CSTO(PVP)     ;AND C WILL BE A LIST POINTER
+LNLST1:        INTGO           ;IN CASE CIRCULAR LIST
+       HRRZ    C,(C)           ;STEP
+       JUMPE   C,.+2           ;DONE, RETRUN LENGTH
+       AOJA    B,LNLST1        ;COUNT AND GO
+       SETZM   CSTO(PVP)
+
+
+LFINIS:        MOVSI   A,TFIX          ;LENGTH IS AN INTEGER
+       JRST    FINIS
+
+LNVEC: ASH     C,-1            ;GENERAL VECTOR DIVIDE BY 2
+LNUVEC:        HLRE    B,C             ;GET LENGTH
+       MOVMS   B               ;MAKE POS
+       JRST    LFINIS
+
+LNCHAR:        LDB     D,[360600,,C]   ;GET POSITION FIELD
+       LDB     E,[300600,,C]   ;AND SIZE FIELD
+       MOVEI   A,(E)           ;COPY E
+       IDIVI   D,(E)           ;D=> NUMBER OF BYTES IN WORD-1
+       MOVEI   B,1(D)          ;EXACT # OF BYTES IN 1ST WORD
+       MOVEI   D,36.
+       IDIVI   D,(A)           ;MAX BYTES PER WORD
+       HRRZ    E,(AB)          ;POINT TO DOPE WORD
+       SUBI    E,2(C)          ;NUMBER OF WORDS IN ENTIRE STRING
+       JUMPL   E,LSTCH2        ;NULL STRING
+       ADDI    C,(E)           ;POINT TO LAST WORD
+       JUMPLE  E,LSTCH1        ;IF <0, NONE IN OTHER WORDS
+       IMULI   E,(D)           ;NO. OF CHARS IN THIS PART OF STRING
+       ADDI    B,(E)           ;ADD IN NO. IN 1ST WORD
+
+LSTCH1:        LSH     A,24.           ;START TO BUILD BYTE POINTER TO LAST WORD
+       TLO     A,440000+C
+       HRLI    B,-5            ;MAX OF 5
+       ILDB    0,A             ;GET A BYTE
+       SKIPE   0
+       AOBJN   B,.-2
+
+       HRREI   B,-5(B)         ;FUDGE FOR DOUBLE USE OF WORD 1
+       JUMPGE  B,LFINIS
+LSTCH2:        MOVEI   B,0
+       JRST    LFINIS
+\f
+
+
+MFUNCTION ATOMP,SUBR,ATOM?
+
+       ENTRY   1
+
+       GETYP   A,(AB)
+       CAIE    A,TATOM
+       JRST    IFALSE
+
+IDNT1: MOVE    A,(AB)          ;RETURN THE ATOM
+       MOVE    B,1(AB)
+       JRST    FINIS
+
+MFUNCTION QUOTE,FSUBR
+
+       ENTRY   1
+
+       GETYP   A,(AB)
+       CAIE    A,TLIST         ;ARG MUST BE A LIST
+       JRST    ERRIFS
+       SKIPN   B,1(AB)         ;SHOULD HAVE A BODY
+       JRST    ERRTFA
+
+       GETYP   C,(B)           ;GET TYPE
+       MOVSI   C,(C)           ;TO LH
+
+QUOT2: CAMN    C,$TDEFER       ;DEFERRED?
+       JRST    QUOT1
+       PUSHJ   P,PTYPE         ;CHECK FOR LOSERS
+       MOVE    A,C
+       MOVE    B,1(B)          ;GET DATUM
+       JRST    FINIS
+
+
+QUOT1: HRRZ    B,1(B)          ;POINT TO DEFERRED VALUE
+       GETYPF  C,(B)           ;GET TYPE
+       JRST    QUOT2
+
+MFUNCTION EQ,SUBR,[==?]
+
+       ENTRY   2
+
+       MOVE    B,AB            ;POINT TO FIRST ARG
+       PUSHJ   P,PTYPE         ;CHECK ON IT
+       ADD     B,[2,,2]        ;SAME FOR SECOND
+       PUSHJ   P,PTYPE
+
+       GETYP   A,(AB)          ;GET 1ST TYPE
+       GETYP   C,2(AB)         ;AND 2D TYPE
+       MOVE    B,1(AB)
+       CAIN    A,(C)           ;CHECK IT
+       CAME    B,3(AB)
+       JRST    IFALSE
+
+ITRUTH:        MOVSI   A,TATOM         ;RETURN TRUTH
+       MOVE    B,MQUOTE T
+       JRST    FINIS
+
+IFALSE:        MOVSI   A,TFALSE                ;RETURN FALSE
+       MOVEI   B,0
+       JRST    FINIS
+\f
+
+
+MFUNCTION EMPTY,SUBR,EMPTY?
+
+       ENTRY   1
+
+       MOVE    B,AB
+       PUSHJ   P,PTYPE         ;GET PRIMITIVE TYPE
+
+       JUMPE   A,IFALSE
+       MOVE    B,1(AB)         ;GET THE ARG
+
+       CAIE    A,P2WORD                ;A LIST?
+       JRST    EMPT1           ;NO VECTOR OR CHSTR
+       JUMPE   B,ITRUTH                ;0 POINTER MEANS EMPTY LIST
+       JRST    IFALSE
+
+
+EMPT1: CAIE    A,PCHSTR                ;CHAR STRING?
+       JRST    EMPT2           ;NO, VECTOR
+       JUMPE   B,ITRUTH        ;0 STRING WINS
+       HRRZ    A,(AB)          ;POINT TO DOPE WORD
+       LDB     C,B             ;CHECK POINTED TO CHAR
+       JUMPE   C,ITRUTH
+       CAILE   A,1(B)          ;PAST DOPE WORD?
+       JRST    IFALSE          ;NO, RETURN
+       JRST    ITRUTH
+
+EMPT2: JUMPGE  B,ITRUTH
+       JRST    IFALSE
+
+
+MFUNCTION EQUAL,SUBR,[=?]
+
+       ENTRY   2
+
+       MOVE    C,AB            ;SET UP TO CALL INTERNAL
+       MOVE    D,AB
+       ADD     D,[2,,2]        ;C POINTS TO FIRS, D TO SECOND
+       PUSHJ   P,IEQUAL        ;CALL INTERNAL
+       JRST    IFALSE          ;NO SKIP MEANS LOSE
+       JRST    ITRUTH
+\f
+
+; INTERNAL EQUAL SUBROUTINE
+
+IEQUAL:        MOVE    B,C             ;NOW CHECK THE ARGS
+       PUSHJ   P,PTYPE
+       MOVE    B,D
+       PUSHJ   P,PTYPE
+       GETYP   0,(C)           ;NOW CHECK FOR EQ
+       GETYP   B,(D)
+       MOVE    E,1(C)
+       CAIN    0,(B)           ;DONT SKIP IF POSSIBLE WINNER
+       CAME    E,1(D)          ;DEFINITE WINNER, SKIP
+       JRST    IEQ1
+CPOPJ1:        AOS     (P)             ;EQ, SKIP RETURN
+       POPJ    P,
+
+
+IEQ1:  CAIE    0,(B)           ;SKIP IF POSSIBLE MATCH
+CPOPJ: POPJ    P,              ;NOT POSSIBLE WINNERS
+       JRST    @EQTBL(A)       ;DISPATCH
+
+PRDISP EQTBL,CPOPJ,[[P2WORD,EQLIST],[P2NWORD,EQVEC],[PNWORD,EQUVEC]
+[PARGS,EQVEC],[PCHSTR,EQCHST]]
+
+
+EQLIST:        PUSHJ   P,PUSHCD        ;PUT ARGS ON STACK
+
+EQLST1:        INTGO                   ;IN CASE OF CIRCULAR
+       HRRZ    C,-2(TP)                ;GET FIRST
+       HRRZ    D,(TP)          ;AND 2D
+       CAIN    C,(D)           ;EQUAL?
+       JRST    EQLST2  ;YES, LEAVE
+       JUMPE   C,EQLST3        ;NIL LOSES
+       JUMPE   D,EQLST3
+       HLRZ    0,(C)           ;CHECK DEFERMENT
+       CAIN    0,TDEFER
+       HRRZ    C,1(C)          ;PICK UP POINTED TO CROCK
+       HLRZ    0,(D)
+       CAIN    0,TDEFER
+       HRRZ    D,1(D)          ;POINT TO REAL GOODIE
+       PUSHJ   P,IEQUAL        ;CHECK THE CARS
+       JRST    EQLST3  ;LOSE
+       HRRZ    C,@-2(TP)               ;CDR THE LISTS
+       HRRZ    D,@(TP
+       HRRZM   C,-2(TP)                ;AND STORE
+       HRRZM   D,(TP)
+       JRST    EQLST1
+
+EQLST2:        AOS     (P)             ;SKIP RETRUN
+EQLST3:        SUB     TP,[4,,4]       ;REMOVE CRUFT
+       POPJ    P,
+\f
+
+
+EQVEC: HLRE    A,1(C)          ;GET LENGTHS
+       HLRZ    B,1(D)
+       CAIE    B,(A)           ;SKIP IF EQUAL LENGTHS
+       POPJ    P,              ;LOSE
+       JUMPGE  A,CPOPJ1        ;SKIP RETRUN WIN
+       PUSHJ   P,PUSHCD        ;SAVE ARGS
+
+EQVEC1:        INTGO                   ;IN CASE LONG VECTOR
+       MOVE    C,(TP)
+       MOVE    D,-2(TP)        ;ARGS TO C AND D
+       PUSHJ   P,IEQUAL
+       JRST    EQLST3
+       MOVE    C,[2,,2]        ;GET BUMPER
+       ADDM    C,(TP)
+       ADDB    C,-2(TP)        ;BUMP BOTH POINTERS
+       JUMPL   C,EQVEC1
+       JRST    EQLST2
+
+EQUVEC:        HLRE    A,1(C)          ;GET LENGTHS
+       HLRE    B,1(D)
+       CAIE    A,(B)           ;SKIP IF EQUAL
+       POPJ    P,
+
+       HRRZ    B,1(C)          ;START COMPUTING DOPE WORD LOCN
+       SUB     B,A             ;B POINTS TO DOPE WORD
+       HLRZ    0,(B)           ;GET UNIFORM TYPE
+       HRRZ    B,1(D)          ;NOW FIND OTHER DOPE WORD
+       SUB     B,A
+       HLRZ    B,(B)   ;OTHER UNIFORM TYPE
+       CAIE    0,(B)           ;TYPES THE SAME?
+       POPJ    P,              ;NO, LOSE
+
+       JUMPGE  A,CPOPJ1        ;IF ZERO LENGTH ALREADY WON
+
+       HRLZI   B,(B)           ;TYPE TO LH
+       PUSH    P,B             ;AND SAVED
+       PUSHJ   P,PUSHCD        ;SAVE ARGS
+
+EQUV1: MOVEI   C,1(TP)         ;POINT TO WHERE WILL GO
+       PUSH    TP,(P)
+       PUSH    TP,-3(TP)       ;PUSH ONE OF THE VECTORS
+       MOVEI   D,1(TP)         ;POINT TO 2D ARG
+       PUSH    TP,(P)
+       PUSH    TP,-3(TP)       ;AND PUSH ITS POINTER
+       PUSHJ   P,IEQUAL
+       JRST    UNEQUV
+
+       SUB     TP,[4,,4]               ;POP TP
+       MOVE    A,[1,,1]
+       ADDM    A,(TP)          ;BUMP POINTERS
+       ADDB    A,-2(TP)
+       JUMPL   A,EQUV1         ;JUMP IF STILL MORE STUFF
+       SUB     P,[1,,1]        ;POP OFF TYPE
+       JRST    EQLST2
+
+UNEQUV:        SUB     P,[1,,1]
+       SUB     TP,[10,,10]
+       POPJ    P,
+\f
+
+
+EQCHST:        PUSHJ   P,PUSHCD        ;SAVE ARGS TWICE
+       PUSHJ   P,PUSHCD
+       MCALL   1,LENGTH                ;FIND LENGTH
+       PUSH    P,B             ;AND SAVE
+       MCALL   1,LENGTH
+       POP     P,A             ;RESTORE OLD LENGTH
+       CAIE    A,(B)           ;SAME
+       JRST    EQLST3  ;NO, LOSE
+       JUMPE   A,EQLST2        ;BOTH 0 LENGTH, WINS
+       MOVE    A,(TP)          ;GET BYTE POINTERS
+       MOVE    B,-2(TP)
+       HRRZ    C,-1(TP)        ;POINT TO DOPE WORD
+       HRRZ    D,-3(TP)
+
+       LDB     0,A             ;GET BYTES
+       LDB     E,B
+
+EQCHS2:        CAIG    C,1(A)          ;STILL WINNING?
+       JRST    EQCHS3          ;NO, SEE IF OTHER STRING EMPTY
+       CAIE    0,(E)           ;CHARS EQUAL?
+       JRST    EQCHS4  ;NO, LOSE
+       JUMPE   E,EQLST2        ;NULL CHAR, WINS
+
+       ILDB    0,A             ;GET NEXT CHARS
+       ILDB    E,B
+       JRST    EQCHS2
+
+EQCHS3:        JUMPE   E,EQLST2                ;IF E NULL , WIN
+       CAIG    D,1(B)          ;CHECK OVERFLOW
+       JRST    EQLST2
+       JRST    EQLST3
+
+EQCHS4:        JUMPE   0,EQCHS3                ;SEE IF OTHER EMPTY
+       JRST    EQLST3
+
+
+PUSHCD:        PUSH    TP,(C)
+       PUSH    TP,1(C)
+       PUSH    TP,(D)
+       PUSH    TP,1(D)
+       POPJ    P,
+
+; NTH, AT AND REST
+
+MFUNCTION NTH,SUBR
+
+       ENTRY
+       MOVEI   E,1             ;E IS A SWITCH
+       JRST    INTH
+\f
+
+
+MFUNCTION GET,SUBR
+       ENTRY
+       HLRE A,AB       ;GET -NUM OF A
+       ASH A,-1        ;DIVIDE BY 2
+       AOJGE A,TFA     ;0 OR 1 ARGS IS TOO FEW
+       GETYP   A,2(AB)         ;GET FIRST TYPE
+       CAIE A,TFIX     ;IF INDICATOR IS TFIX THEN WORRY
+       JRST IGETP
+       MOVEI B,(AB)    ;GET OBJECT
+       PUSHJ P,PTYPE
+       MOVEI E,1       ;E IS A SWITCH
+       JRST @IGETBL(A) ;DISPATCH
+PRDISP IGETBL,IIGETP,[[P2WORD,INTH],[P2WORD,INTH],[P2NWORD,INTH],[PARGS,INTH],[PNWORD,INTH],[PCHSTR,INTH]]
+
+MFUNCTION PUT1,SUBR
+       JRST IPUT1
+
+MFUNCTION PUT,SUBR
+IPUT1:  \1cy0C+@y/\11õ`\0\ 4±õ`\0\ 4\817\10\ 1'(ô\f\0\0\ 3õ`\0\ 4\87@@\0\0\ 4,\1a\0\ 6j÷¤\0\ 4\87õ`\0\ 4\877 y/î.0\0\0\ 1:\0\ 1.\vô\a\0­ë \y0)öè<°Wõ`\0\ 4«!<\ 4\0\0øW<°Qô\a<°O.\\0\ 5\a<°Sõ×\0\ 5åöw\80®½õ`\0\ 4©ö\8b\80\ 4\97ös\80®½+\0\0\ 476|y/\1cü?\0\0\ 1+\0\0\ 4N7 y/\10+\0\0\ 4\a|¯/(\1c@\0\0ö\8b\80\b\193|\ 1%zõ`\0\b\1f \ 2y/\18õ\0 \0\ 3öH\80¥õ+\0\0\ 4\ 2y/\18(\ 2@\0\0 \\ 1%zô\10\80¥õô\17\80\0\a+\0\0\ 4\a<°Oõç<°S? \0\0\a <\0\0\0.\\0\ 5u+\0\0\ 4I4^\0\ 4\eök»ïx\0\ 4\a<°QöÈ<°Wa|\ 2\0\0õ`\0\ 4»ô\a<°O.\\0\ 5\a<°Sõ×\0\ 5å+\0\0\ 47`|\ 1\0\0+\0\0\ 4\a<°Oõç<°S? \0\0\a <\0\0\0.\\0\ 5s+\0\0\ 477@y/\12+\0\0\ 4\a<°Q`|\ 1\0\0+\0\0\ 4\a<°Oõç<°S.\\0\ 5s+\0\0\ 4\ 1\80\ 5Õöè\0Kïö \80\0\ 3,z\0\0\0 \ 6\0\ 5föÏ\80\ 5Ë2>\ 1-g+\0\0\ 4k6@y/\12öÈ<°Q,\1a\0\ 5!4>\0\ 5\18!"\ 4\0\0øð¼°Q F\0\ 5\17\80\ 5Ë \1cy.y`|\0\10\0õ`\0\ 4ã6@y/\11õ`\0\ 5\1fõ\86\80\bG,z\0\0\0:\0\0\0"l"\0@\0ö\19\80\0\ 1øð¼°Q \ 4\0\ 5h÷P\0\ 5Í+\0\0\ 5\b \ 6y/%òé\0§Q \12y/&ùð\0\ 5Ñ(\ 4\aï{\17<\ 1')õ\17\0\0\ 11<\10\0\0X\ 4\0\0\aü1\ 3ÿÿ+\0\0\ 5        Q2\ 4D@Q&\ 4D@ F\0\ 5\14\80\ 5Ïòâ\0\ 5Ï\17\ 2\0\ 5g÷@\0\0E D\0\ 5h4H\0\ 5\b÷p\0\ 5ÑöÐ<¯\eö2\ 3ÿÿ+\0\0\ 5\baB\ 6\0\0+\0\0\ 5\bø(\80\ 1ÿûB\ 4Tw=H\0\ 5\11ô\ 1\80\ 5Ëõ\86\80\ 5í+\0\0\ 5\aô\ 1\80\ 5Õ1&\0\0\r?`\0\ 5i,z\0\0\0 \ 4\0\ 5\a\80\ 5Ë`D\a\87÷¡\0\ 4ùmd\ 4\0\0+\0\0\ 5\fùð\0\ 5Ë!$\ 1\0\0øñ<°Q+\0\0\ 4fòé\80§Q/&\ 4\0\04f\0\ 5\rû\ 1\0\0\ 3ô\ 1¼¯Kô\ 4¼¯M+\0\0\ 4w!<\0 \0ø÷<°Qõ`\0\ 4ã÷P\0Kïõb\0\ 5\ 1\80§S B\0\ 5\86\80N§ø\0\0\ 5+ùð\0Kï \ 2\0\ 5nõ`\0\ 5\aöè<°Q,z\0\0\0/\1a\ 1'\1eùð\0Kï+\0\0\ 5\a@@\0\ 5iùð\0\ 5Ëþ\97½\89Õïx\0\ 5\19,z\0\0\0öÈ\0Kï,z\0\0\0ûg\80\0\ 1ûX\0\0\ 1,\1a\0LI\17"\0\0\a`B\ 6\0\0õ`\0\ 5=ùð\0\ 5ß,z\0\0\0ø(\80\ 1ÿôI\80\0\ 1õ\86\80\ 5í,z\0\0\0õ`\0\ 5;ùð\0\ 5ÍôO\80\0\ 1"<\0\a\ 4õÇ\0­ë 2\0\ 3Xô    \80\0\a22\ 1-gõ`\0\ 5m7@I/\1a7@I/\12õ`\0\ 5\ 1$°QöÐ$°O`d\ 1\0\0õ`\0\ 5\v\80\0\ 1`d\ 2\0\0õ`\0\ 5W2<I0)=\ e\0\ 517@I/\11öÐ$¯\e+\0\0\ 514$\ 1'* .\0\0\ 27 I/î=\ e\0\ 51öè$°W+\0\0\ 517 I/\149\ e\0\ 51 .\0\0\ 3öi\80\0\aõ`\0\ 5köQ\80\0\a+\0\0\ 54+@\18\ 5Dõ`\0\ 5\v8\ 5\ 1\80\0\aô\a\80\0       .2\0\ 1l+\0\0\ 5\8f\80\v\9föè<°W,z\0\0\0ô\ 1<°Qad\ 2\0\07@y/\11öÐ<¯\e,z\0\0\0ô\ 1<°Oö)\0\0«õ`\0\ 5\7fõá<°S.\ 4\ 1-uõá\0®\9bõÁ\0\ 5Õ/\ 4\0\ 5jõá\0\ 5åö¹\0\v\9f!$\ 4\0\0øñ<°W÷@\0\ 5çô\ 1<°OöI\0\ 5é,z\0\0\0 ^\0\ 5\11\0\ 5é,z\0\0\03jI0)3jI0)öJ¤°OöJ¤°OöJ¤°O2*I0,2*I0,öð\0§\rõ`\0\ e\18\80§U`b\ 1\0\0õ`\0\ 5±ö\88\80\ 5\99`b\ 2\0\0õ`\0\ 5µZB\0\ 5i,z\0\0\0ûa\0\0\ 1ø)\0\0?$$\0\ 1l6@\0\0\ 1 \1e\0\0\ 1ab\ 2\0\0+\0\0\ 5\ 2<°Oõâ<°S4(\ 1'+ö\92\0\v\9fþ\ 6\0\ 2\81ô\17\80\ 5Ëùð\0\ 5Í.H\0\ 5i!(\ 4\0\0øò<°Qþ\ 6\0\ 4\81,z\0\0\0ú \80\0\ f,\1a\0\r\1eöÈ\0\ 5ßô\10\80\ 5ßõ`\0\v³ô\ 1\0§W6\ 6\19  \v\87\b\ 5Y=d\0\ 5Y\10b\ 1',õ`\0\ 5± ^\ 1&Hø\10\0¦\91@@\ 1&Iùð\0¦\93ûØ\0\0\ 1ô\10\80¦\8f,z\0\0\0\0\0\0\ 3\10\0\0\0\0\ 1ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿò\13x*g\87@\ 5b\0\0\ 4\0\0\0\0\ 4\0\0\0\0\ 4\0\0\0\0\0\0\b\0\0\0 \0\0\0\0 \0\0\0\0\0\0ÿÿÿÿÿ\7f\ eEïÿÿü\ 5Ñÿÿÿÿÿ\87p\vQ\87p\ 5k\0\0\0\ 5\0\0\ 5Ù\87@(r\87p\ 5m\0\0\0\0\ 1\0\0\0\0dÿÿà\187ÿÿü\ 5ßÿÿÿÿÿ\87p\v_\87x\ 5\0\0\0\ 3\87p\vd\87h\ 5s\0\0\0\0\ 1\0\0\0\0\0ÿÿÿÿÿï~@/\1fÿþ\0\ 5í F\0\ 5v B\0\ 5n1"\0\0xö(\80\0-õb\0\ 5ñ÷P\0Kï,z\0\0\0Z\ 6\bR)ûQ\80\ 5Ýùð\0Kïûa\f\0\ 1ö±\0\ 6\ f \ e\0\ 5\ 6\0\ 2¿7,9\17\11+\0\0\v\ 2\80\ 5Ûô\r\9c\97+3*0\ 3~ 69\17\17öÈ\1c\9777`X\0\0+\0\0\ 6;!"\ 4\0\0GB9\17\11þ\ 6\0\ 4¿ "\ 6o/õ\86\80\9de>\0X\0\0!"\ 4\0\0BB9\17\11ô\0\80\ 5Ýòû\80§Yú2\ 4\0\ 1÷P\0Kï,z\0\0\0:\0\0\0\ 6\0\ 2¿ \ 2\0\ 5nûa\84Twö±\80\ 69!&\aïzòë\8c]\eeN\ 6\0\0õ`\0\ 6\1dø+\80\ 1ÿ1N\b\0\0+\b\0\ 6\ eõY\80\ 6\17!&\ 4\0\0GF\bR)þ\ 6\0\ 4¿ \ 6\ 1'-.\ 6\0\ 5nòë\80\0\ 3õ\8e\80\0\aO@\0\ 5\86\80N§@\0\0\ 6\96\80\0\aòû\80\0\ 3ô\v\80\0\ 3òû\80§[þ\ 6\0\ 2¿ \ 2\0\ 5n!$\ 4\0\0BD\bR)ô\ 1À\ 5Ý7 \0\ 5oaf\0@\0õ`\0\ 6; .\0\0\ 1òû\80§[:\0\0\ 5e,\1a\0P{+\0\0\ 6(ùð\0Kï+\0\0\v`1"\0\0xö(\80\0-õb\0\ 6=ûA\0\ 5Ýô1\ 4Twô        \84Twô\ 3\80\ 5×ô\11\80\ 5×XF8\0\0÷@\0\ 5Õ:\0\0\ 5eûa\88\0\ 1ú1\84S\87õ\11\83ÿñö    \80\0\ 3+\b\0\ 6%ô       \0\0÷\17d\ 1'\1fô       \0\0\1fòù\0§?õ\86\80\8f!ùð\0Kïõ`\0\v¿1~\0\ 1lõb\0\ 6\8e\80\0\a3^\0\ 5võ`\0\ 6\1cy.y`|\0\10\0õ`\0\ 6a7@y/\11õ`\0\ 6_!<\0 \0ø÷<°Qõ`\0\ 6\86\80\bG+\0\0\ 6\ 6y/%dN\0\0\ 1¼¯Kõ\v\83ÿÿ.&8\0\0Q&\ 2$@öè\0\0\aQ&\0\ 4@òë\80\0\ 34N\ 1'.aN\ 6\0\0+\0\0\ 6:ÿR\87ô¿ÿþ\0\ 6m(N\aïx0n\0\0\ 1@@\0\ 5o1N\0\0\ 1ô\v\80\0\ 3òû\80\0\ 3÷@<°Sõ\96\80\0\a,z\0\0\0þ\ 6\0\ 4¿ôJ\0\0\ 1ô\ 3\80\ 5½öè\1c\977õ`\0\ 6}6@9\17\17õ`\0\ 6\87ôK\80\0\ 1ô*\83ÿýöè\14\977õ`\0\ 6\85öj\14\97+ûC\80\0\ 5öj\14\97\ 2\14\97+õZ\80\ 6\7fö\8b\80§]ZN\0\ 5\9a\0\v\9f *\0\ fP6@9\17\17 *\0\0\12\80\ 5Ûõ`\0\ 5ù/\1a\ 1'/ \ 2\0\ 5n!.\ 4\0\0BN\bR)ùð\0Kï,z\0\0\0ô,\ 3ÿý76@\ 5_+\0\0\ 6\ 2 \ 5ÁQ\16@\ 5b@l\0\0\ 2ô\14\0\ 5á,\1a\0\ 1\ 4\0\ 5áO@@\ 5_õ\\0\ 6\95,z\0\0\0ô\ 4\0\ 5áö\94\0§_ô\ 2 \ 5Ç4*\ 1'0GJY/\ e "\0\0\0,z\0\0\0ô\ 5\80\0\ fø\10\0\ 5á \ 4Y0( \ 6Y/% \bY/& *\0\0\0(D\aï{\17<\ 1')õ\17\0\0\ 11<\10\0\0Z\ 4\0\0\aü1\ 3ÿÿõ`\0\ 6ËQ&\ 4D@Q(\ 4D@òà\80\0\ 3\17\12\0\0\ 2`B\ 6\0\0õ`\0\ 6Éö\94\80\ 6Éö4\83ÿÿõ`\0\ 6Éõ\8e\80\0\ 5õ\8e\80\0\ 3,:\0\0\ 2,:\0\0\ 1Q6\ 4\0\0@l\0\0\ 2,\1a\0\ 1F,Z\0\0\ 1,Z\0\0\ 2õ\96\80\0\ 3õ\96\80\0\ 5ö\90\80\v\9f÷@\0\0\ 5=d\0\ 6[0j\0\0@õ`\0\v¥ \ 4Y0(/$\ 4\0\0ö\99\0\v¥ *\0\0\ 1¬¯Kô\ 2,¯Mõ`\0\ 6­öð<¯#3^\ 1.5,z\0\0\0:\0h\0\02^\ 1-i3^\ 1-p,z\0\0\02^\ 1-s3^\0W\1a,z\0\0\02^\ 1-l3^\ 1-m,z\0\0\03^\ 1-k,z\0\0\0 \1cy.y`|\0\10\0:\0h\0\0,z\0\0\0ô\a\0§E6@y/\10øç<¯\1dô\ 4<°[ø\84\0§ED\ 2\0\0\ 4þìQþ½ÿþ\0\ 6íø'\0\0\ 14\\0\ 4;-<\0\a\86\80\bGõ`\0\ 4\81ô\ 4<°[ù¤<¯\1dA\ 2\0\0\ 4ø \80§E6@y/\104B\0\am!<\ 1\0\0ø÷<¯\eô\ 4\0\0\ föO!õ`\0\a\ 3úG\0\0\ fG\y/\ fûX\0\0\ f02x\0\0+\0\0\ 49+\0\0\ 477 A/î+\0\0\ 4\a °]`|\ 2\0\0+\0\0\a\b \1e\0\0\ 4õ\86\80       # <\0    . \y.y!<\ 1\0\0øW<¯\eø\10|¯/õ`\0\ 4\81 <\0 \0ø÷\0¦\13+\0\0\ 47öÐ\0\ 5çõ`\0\aQöï\80\0\aõ`\0\a\196@y/\11õ`\0\a9*\1e\ 1%{ö\8f\80\a#3^\ 1%{õ`\0\a\1c\0\0\10ô\17\17 \1c\0\0\18 \y/\fô\a\0\ró \y0'7>\ 1%{õ`\0\a\a\17 \\0\0\10 \1cy/\f \\0\0\18 \1cy0'ô\17\0\róú¯\0\0\ 1øW<¯=,\1a\0\a\1cy.y \\0\0p!<y/\rû\ f\0\r§õO\0\r©ôO\0\0\a \\ 1&O \1e\ 1%{!>y/\ 2õO\80\0\ f+\15\0\0p!<\0 \0üW<°Q+\0\0\a !<\ 2P\0øW<°Q@@y/\11õ`\0\a\19õ\86\80\bG+ \0\0\0õ`\0\a\19þ\ 5\80§a!<\ 2Z\0 \\0îTú¯\0\0\ 1øW\0¯=@@\ 1&O\10D\ 1/\1d+\15\ 1'1:\0\ 1.^! \ 2X@ô\ f\80\0\ 1*>\0\0\aô\a\80§cõ`\80\0\ f7>\0\ 5tõ`\0\a\15ôG<°S.\1c\ 1-uõç\0®\9bõÇ\0\ 5Õ/\1c\0\ 5jõç\0\ 5å.\1c\0\ 5u.\1c\0\ 5s1<\0\0\bõ`\0\a\15!<\ 4\0\0øW<°WO@\0\ 5\10\0\ 5é:\0\0\0'÷ð\0\ 5ç+\0\0\a; >\0\0\0ôM\0\0\ 1!<\ 2\0\02>\ 1-g+\0\0\a9öè<°W7@y/\12+\0\0\a8öo<°Oú¡.ÿ\9fÿÿ\ 4\am+\0\0\a\ 5\0\0\ fô\a<°O.>\0\ 1lõ`\0\ag T\0\ 5t7 \0\0\ 5 <\0\0\0ô\17\0\ 5éö\8b\80\ 4Yõ`\0\a\15ô\ 5<¯Iô\15\0\ 5ãõ\8e\80\0\ 1,:\0\0\ 1õ\8e\80\0\ 34^\0\aLûA\80\0\ fat\ 2\0\0+\0\0\aC`T\ 4\0\0+\0\0\aSZ\ 6\0\0\ 5`t\0 \0õ`\0\a§ \ 4\19/%`t\0\b\0+\0\0\aU "\19.z\17b\ 1'2 Dy/\1fô\ 1<¯Kat\ 1\0\0õ`\0\a\95ô\ 1\0\9eY`T\ 4\0\0õ`\0\a\95ô\ 1(¯Kat\0 \0 \ 4Q/%`t\0\10\0ô\ 1(¯Kô\11<¯?\10Dy/\1dòè\80§eö\10\80\0\aõb\0\a\9bp       y/îô@\80\0\ f&"\0\ 1l!$\ 4\0\0(D\b\0\0p\16\0\0\ 1õ\96\80\0\ 3,Z\0\0\ 1õ\96\80\0\ 1,z\0\0\0öá\0\9e\ 1(¯K "\0\aV+\0\0\aE "\19/\ 2+\0\0\a\7fÚ®Ûïx\0\a^7@y/\10+\0\0\ 4<D\1cy0.ø'<¯\1f4\\0\ 4<-<\0\a\86\80\bGõ`\0\ 4\81 <\0\0\0*\1cy/\ f \10\0\0\aA\10y0.GPy/\ fD\1cy0.l<\ 4\0\0+\0\0\ap!*\ 2\0\06@y/\11ür¼°Q+\0p\0\0!*\0\10\0ür¼°Q+\0p\0\0 \r\0\0\a \1cy0C+@y/\11+\0\0\ 47+\0(\0\0+\b\0\alõb\0\aÙ <\0\0\0*\1cy/\ eô\ 4<°[A\10\0\0\aGPy/\ eD\1c\0\0\ 4öè<¯Eõ`\0\b\15:\0\0\0! 4\0\0\0õ\86\80\ay\10f\ 1'37\10y.yõ`\0\aýö\90\80\b\15öè<¯1l"\0\b\0ò\19\0§gm"\0\10\0õ`\0\aý\10d\ 1'4õ`\0\añõ`\0\aý@@y/\10."\0\0\ 1 By.y\10By/\1d÷@\0\0Aõ`\0\ 4\81d|\ 4\0\0õ`\0\aûG\y/\ e,z\0\0\0G\y/\ f,z\0\0\0\10By/\1dõ\86\80\a÷òï\0§iõ\ f\ 3ÿÿd\\0\0 ö༯M \ 2y/&Q"\ 2$@7 \0\0\aQ"\0\ 4@òê\80\0\ 14J\0\ 6|úG\f¯=`|\0\0 +\0\0\b\vR\1cy.yõ\17\ 3ÿûX\1cy.yô\17<¯;!<\0\ 2\0ø÷<¯=!<\0\10\0ø÷<°Qõ`\0\a\17õ\86\80\a÷ "\0\0\ 2Gby/\ eõ`\0\ 6ç \\ 1%z \1cy/\18(\1c@\0\0ô\17\0¥õô\17\80\0\a+\0\0\ 473\\ 1%z+\0\0\b\13 \ 2y/\18õ\0£ÿýöH\80¥õ+\0\0\ 47õ`\0\ 4¥ \ 2y/\18(\ 2@\0\0õ`\0\b\ f\0\ 4\81X\y/\11+\0\0\ 47!"\0\0\ 1 >\0\0\0.>\0\ 1l2>\ 1-g,z\0\0\07@y/\12+\0\0\b\17\17<\ 1'55\\0\b\17ô\ 1\1dø!\0\0\ 1GDy/\ e+\0\0\b\17üä\80\0   ô\ 4\80§kô\14¼¯ISbDU8ïx\0\b\1eþ\ 6\0\ 2\81,\1a\0\b!õ`\0\v³üä\80\0 ô\ 4\80§kô\14¼¯I\10By/\1d,:\0\0\ 5,\1a\0\a<,Z\0\0\ 5,z\0\0\0÷@\0\0C4~\ 1'6 <\0\ 1l&^\0\0\a$<\0\ 1löw\0\0\ f7@y/\12+\b\0\b\1cy/î`|\0 \0õb\0\bQöÐ<¯\eõ`\0\v¥öß<¯#+\0\0\b\1cy/\röW\0§mõ`\0\b\1cy.ya|\0\10\0õ`\0\ba@@y/\11!<\ 2P\0øW<°Q:\0h\0\0,z\0\0\06@y/\11+\0\0\b\1c\ 1'7 \y/\r,z\0\0\0ø\10<¯#ø\108¯#+\0\0\b+7@y/\11,z\0\0\0öW\0§Iõ`\0\bo!<\0\ 1\0G\y/\v \1cy.y`|\0\10\0õb\0\b\a\0§m \y/\r \1cy.y \y/!>\1cy/\v \y.yø\10<¯I@@y/\11!<\ 2p\0øW<°Q6\y/\1a+\0\0\v( <y/\ 2Q<y.zõO<¯\13õ`\0\v¥ö\10\83ÿÿ3B\ 1%{,z\0\0\0öÐ\0¦\8fõ\86\80¤Óõ\8e\80\0\ fô\a\80\0\ 1 \ 2\ 1%{þ\ 6\0\ 2\81õ\86\80\bG+\0\0\bI÷@<¯\eþ\ 6\0\ 4\81ô\0\80\0\ fõ\96\80\0\ f,z\0\0\0öÐ<¯#õ`\0\b\9döÐ\ 4¯#+\0\0PMû\90¼¯#û\17\84¯#öÐ\0¦\8fõ\86\80¤ÓöÐ\ 4¯#,\1a\0      võ`\0\b\8fô\0\80\0\ fõ\96\80\0\ föÐ\0¦\8fõ\86\80¤ÓöÐ\ 4¯#,\1a\0      võ`\0\b\83ö\10\83ÿÿ3B\ 1%{,z\0\0\0÷À\ 4¯\e,z\0\0\0þ\ 6\0\ 2\81 \1e\ 1%{ <\0\b\0G\y/\ eõ`\0\ e\11õ\8e\80\0\ föï@¦\8b!<\ 6\0\0,\1a\0\bfõ`\0\bÇöï@¦\8bõ`\0\bÉô\a\0§oô\17<¯%S<\0\10\0û\ f\0\0\ 1 \y.y <y/\ 2Q<\0    &ý4þ«Uïx\0\b^õO<¯\13ô\a<¯%ô\17\rø\10|¯/ø\10\e÷G\0¦\8b0<\ 1&Eô\ f\0¦\85ô\17\0¦\8b>@\ 1&Fõ`\0\b¯õ\96\80\0\ f,z\0\0\0ô\17¸\0\ 1 \1cp\0\0+\0\0\b[ >\0\0\02>\ 1-gõ`\0\bÓ7@y/\12+\0\0\bo.>\0\ 1lõ`\0\bÍ7 \ 1'\ 3,z\0\0\0 >\0\ 1l.\1e\ 1-g,:\0\0\a \1c\ 10(ö?<®Á+\0\0\bu,Z\0\0\aùð<­C*\1e\ 1-g,\1a\0\bx <y.hô\17<®áø\10<®Áú/<®ÁX<y.a*<y.hQ<y/\ 2û\ f\ 5@@y/\ 2õO<¯\13õ`\0\v¥ \1eo\87/\1a\ 1'8!<\0\0@øW\0¦\13!<\ 4\0\0õ`\0\ 3ÍO@y/\12 \y/\144<\0     %õ\8e\80\0\ fô\ f\82\0\ 1ú7¸F\13!>\ 4\0\0B^pF\1dõ\96\80\0\ fõÏ\0­íô\17<¯/ø\10<°Q@@y0)ø\10<°Sø\10<°Oùð<°YO@y0-@@y0( <y/g \y/&.<\0\0 ô\17<¯M <y/'Q<\0\0@ \y/%.<\0\0 ô\17<¯K@@y/'!<y/'û\ f<¯OõO<°M!<\ 2\ 5\ f\13ô\17\15!<\ 1\0\0ô\17\eùð<¯!ø\10<¯5O@y/\eô\a\0§qô\17<¯7@@y/\1dô\ f<¯;ú/;ÿÿõO<¯Aô/\0\0\ 5ô\17<¯= \1c\ 1\1e- \y/ !<\0\ 2\10ô\17<¯A \1cy/\12 \y/\13õ\8e\80\0\ 1,:\0\0\ 1õ\8e\80\0\ 3õ\8e\80\0\ 5ô        ¼¯5öÈ\f\0\ 1-*\0\ 1\96\80\0\ 5õ\96\80\0\ 3,Z\0\0\ 1õ\96\80\0\ 1@@y/\1c@@y/\16ùð<¯9!<\0\10\0 \y.yQ<\aìX<y0/ \y0/ø\10\1dø\10\1fô\a\0§m \y/\rõ0¾æ\93ïx\0    \1eô\ f\0\ 1' \y/îûX<¯Eùð<¯\19@@y/\ e@@y/\ fO@y/\10@@y/\11ø\10<¯-@@y/\17ø\10<¯1ø\10<°]ùð<®ó,z\0\0\0 <\ 1.\r+\0\0\b}+ \0\0\0ñ\b\80\0\a+\0\0\0\0\b`\0\0\ 5ñ\10\0\0\e\b\ 2\0\0\ 1+\0\10\0\0ð\0\13>sCS\1d\19wQ\ 6\1eLW@\0\0\0\0Y>\f@\0\0\0\0\0\aø\0\0\0\ fÿÿÿÿÿð\0\0\0\ 1 \1e\ 1%{ô\b\80       ]ô\10\80\r© \1ay0/ $\0\0\0,\1a\0\1a\1e\ 1%{!<\0   &X<y.zõO<¯\ 3ô\a<¯%ô\17<®ý \1c\ 1'9ô\17\0\r©!<\ 1\0\0B\y/î+\0\0îdôK\80\0\ 1õ\86\80  \81,\1a\0Yr,\1a\0Wm3^\0a ,\1a\0^kõ\86\80V\91õ\86\80\ 1\0<¯5û@\80®½öp\80\0\ fùð\0®½3^\ 1.5O@\ 1.5õ\86\80G\85ô\r<®Á,\1a\0\18\14y.h÷%\0    } .\0\0\0õ\8e\80\0\aX^h\0\0 "\0\0\0ûB\84¯!6@    /\120Jx\0\0õ`\0      \9fõ\8e\80\0\ 1ô\a\80\0\ 1,\1a\0\ f\ 5\0\0\r \1ay0/,:\0\0\ 5öè+ÿÿõ`\0 ¥õ\86\80    o \1ah\0\0öè7ÿÿõ`\0  \9d $\0\0\0,\1a\0\1a\ 3<¯-ô\ 1<¯/.L\10\0\15 \fy/\17.L\10\0\86\80 §þ\ 6\0\ 4\81õ\96\80\0\ 1Z\1eh\0\0."\0\ 1l3"\ 1-g+\0\0   BZ\1eh\0\0/\1a\ 1'8,z\0\0\0õ\86\80     \81õ`\0    \91 "x\0\0Q"\ 3\0\0,\1a\0\1cR+ \0\0\0ô\ f\0\0\ 1òÿ\0§s "\0\0\06@  /\12õ\86\80   ¿."\0\ 1l3"\ 1-g+\0\0  Wþ\ 6\0\ 2\81öÐ<°Oõb\0  µöÏ<¯\19õ`\0       ç@@y/\12ùð<¯\eô\0\80\0\ f \1e\ 1%{û$\7fÎ\83ïx\0   ^!<\0\0@ø÷\0¦\13,z\0\0\0,:\0\0\ 1,:\0\0\ 5@@\0\0\ 1õ\86\80\1a9,\1a\0 d,Z\0\0\ 56@\0\0\ 1õ\86\80\b¥+\0\0\vP[\1cP\0\0öW\0\0\ f+\0\0      oZ\1cP\0\0[\1cp\110a\\ 4\ 2\0,z\0\0\0ý±\ 3ÿÿõ\86\80\b\83Z\1cP\0\07 p\110õ`\0    Ùö½\0    ÛZ\1c\0\0\ 5õï\ 4®Áô\a8B÷G\      /\ f@@P\0\0,z\0\0\0 <\0\01 \P\0\0,z\0\0\0öè<¯\19,z\0\0\0öW<¯\19,z\0\0\0Z\1cP\0\0[\1cp\110`\\ 1\0\10@@P\0\0,z\0\0\0O@p\1d(^\ 2p\1d\109B\0   \O@p\1d\10+\0\0       \þ\ 6\0\ 2\81+@\0îT7>\ 1%{õb\0     ï \y0C \y/      ,Zy.y <y/\ 2õO<¯\11 \1cy.y7\1cw\87 \1cp\0\0X=\0\0\aü\8f\0\0\1f \y/\11h<\ 2\\0a|\aïpõ`\0       ÷!<\ 2\10\0øW<°Qöè<¯#+\0\0\r\ 3ô\a¼¯\13O@\ 1&Nþ\ 6\0\b\ 1õb\0
+\ 5ô\a\0\r§öW\0§Iõ`\0
+\v!<\0\ 1\0ø÷\0\r©÷Ç\0\r©õ\86\80\bw+\0\0\r\ 1ô\a<¯#õ`\0\ e\1fþ\ 6\0\ 4¿öÐ\0¦\8fõ\86\80¤Ó+Ah\0\0,\1a\0    vþ\ 6\0\ 2¿+Ah\0\0+\0\0\r\bõ`\0\v¥öÐ\0¦\8fõ\86\80¤Ó <\0\0\bQ\h\0\0 =h\0\07!h\0\0õ`\0
+%ûg8\0\ 1ø/\0\0?$<\0\ 1l3\\ 1%{+\b\0\r\126!h\0\0,\1a\0     vþ\ 6\0\ 2\81:Ah\0\0õ`\0
+% =h\0\0õ\8e\80\0\ f,:\0\0\a \1c\ 1%{&<\0\ 1l.<\ 6\0\0 \1e\ 1%{Q\1cy/\1aõ\96\80\0\ fô7<\0\ 1 \1c\ 1%{Z^q/\1aõ\96\80\0\ f+\0\0\vY <\0\0\bQ\h\0\0+\0\0\r\15þ\ 6\0\ 4\81ü\9cßT±ïx\0\r\1eöÐ\0¦\8fõ\86\80¤Ó+Ah\0\0,\1a\0        vþ\ 6\0\ 2\81+Ah\0\0õ`\0
+;õ`\0\v¥öÐ\0¦\8fõ\86\80¤Ó <\0\0\bQ\h\0\0!<\ 4\0\0õ\86\80
+\11öèwÿÿG]h\0\0 \1ch\0\06 p\0\0þ\ 6\0\ 4¿ =h\0\0,:\0\0\ 3 ,\ 6\0 ,\1a\0\rt,Z\0\0\ 3õ`\0\v¥öÐ\0¦\8fõ\86\80¤Óõ\8e\80\0\ 1,:\0\0\ 1,:\0\0\ 2 <y/\ 2õO<¯\13ûG7ÿýõ\86\80
+m,\1a\0   vûG7ÿý \ 2p\0\0`b\a~\0+\0\0\r>\17$\ 1':òê\0§u6@\0\0\ 1.\ 2\10\0\0ûX\0\0\ 10(\0\0\ 1õb\0
+iõp\10
+\81õ`\0
+\83*\\0\r\ 2p\0\0`b\a~\0õ`\0\v¥\17$\ 1':òê\0§uö\91\0
+uõÁ\0\0\ f.\ 2\11/\ 20(\0\0\ 1+\b\0\r;+@ \r=,z\0\0\0÷'\0
+m6 \b\0\0\b\0\0,Z\0\0\ 2,Z\0\0\ 1õ\96\80\0\ 1/\1a\ 1'8+\0p\0\0õ\86\80
+\87,\1a\0\rG[\ 2\0\0\a4B\0\r\86\80\v\a=\ 2\0\rB:@\b\0\0,z\0\0\0*\ 2\0\0\aõ\86\80
++õb\0
+\8b*\ 2\0\0\aõ`\0\v¥þ\ 6\0\ 2¿7 \b\0\0+\0\0\v`!$\ 4\0\0GD\b\0\0þ\ 6\0\ 4¿*\ 2\0\0\a,:\0\0\ 3 ,\ 6\0 ,\1a\0\rt,Z\0\0\ 3+\0\0\rF,:\0\0\ 3 ,\ 6\ 1@õ`\0
+á \1dh\0\0ú/7ÿÿ,:\0\0\ 3 ,\ 4\0@,\1a\0\rt,Z\0\0\ 3õ`\0\v¥,:\0\0\ 3 ,\ 6\ 1 õ`\0
+á,:\0\0\ 3 ,\ 6\0`õ`\0
+á,:\0\0\ 3 ,\ 6\ 1`õ`\0
+á \1dh\0\0ú/7ÿÿ,:\0\0\ 3 ,\ 6\0@,\1a\0\rt,Z\0\0\ 3õ`\0\v¥,:\0\0\ 3 ,\ 6\ 1\0õ\86\80
+¹,Z\0\0\ 3õ`\0\v¥õ\8e\80\0\ f,:\0\0\ 4ô\f\91sDl\bXïx\0\r^öð \0\ 1+\0\0\rd.0\0\0\ 1öð \0\ 1+\0\0\rd.0\0\0\ 1öð \0\ 1+\0\0\rd.0\0\0\ 1öð \0\ 1+\0\0\rdõb\0
+Ç \1doï~þ\ 6\0\ 2\81,:p\0\0,Z@\0\0 Pp\0\0Q\@\0\0 \1c@\0\0ü\17\ 3ÿÿQPp\0\0þ\ 6\0\ 4\81õ`\0
+ù,:\0\0\ 3 ,\ 2\ 1@õ`\0
+á,:\0\0\ 3 ,\ 6\0 õ`\0
+á,:\0\0\ 3 ,\0\0\0,\1a\0\rt,Z\0\0\ 3,z\0\0\0,:\0\0\ 3 ,\ 2\0@õ`\0
+á*\fh\0\0ô\awÿÿ =\0\0\a*\fh\0\0,\1a\0\rt,Z\0\0\ 3õ`\0\v¥õ\8e\80\0\ f \1e\ 1%{,:\0\0\ 4ô\f\91öð \0\ 1+\0\0\r|.0\0\0\ 1öð \0\ 1+\0\0\r|.0\0\0\ 1öð \0\ 1+\0\0\r|.0\0\0\ 1öð \0\ 1+\0\0\r|õb\0
+÷ \@\0\0ô\a\0\0\ f&<\0\ 1\1e\ 1%{Q\1cy/\1aG\1c\0\0\ 3ô7 \0\ 1ZPy/\1aõ`\0\vÃ,:\0\0\a7\y/\1a+\0\0\v\86\80\v\a+\0\0\v\ 1:\0h\0\0õ\8e\80\0\ f \1e\ 1%{l>\ 4\0\07\y/\1aõb\0\v\v,\1a\0\v\a+\0\0\vV,:\0\0\aô\a8\0\ 1Z\y/\1a,\1a\0\v\v,Z\0\0\aö\1f\0®Áø\108\0\ 1,z\0\0\0õ\8e\80\0\ 1 \ 2\0\0\a\17<\ 1';`b\ 4\0\05>\0\v\ fab\ 2\0\0+\0\0\vO5>\0\v\96\80\0\ 1+\0p\v\10+\0\0\v\14+\0\0\v\17+\0\0\v#+\0\0\v\1cõ`\0\v;õ`\0\vCõ`\0\v+õ`\0\v\a7ÿÿO@p\0\0,z\0\0\0ô\awÿÿO@p\0\0,z\0\0\0ô\awÿÿõ\8e\80\0\ 1!"\ 4\0\0BBp\0\0+\0\0\v\awÿÿõ\8e\80\0\ 1ô(\83ÿÿ.Bp\0\0+\0\0\v\awÿÿ>\0p\0\0,z\0\0\0ùð\0¦e~f/\1a\eïx\0\v\1eô'wÿÿY\p\0\0!`\0\0\aü\17\ 3ÿÿP\p\0\0ø\10\0¦e,z\0\0\0ô\awÿÿ:\0p\0\0,z\0\0\0ô\a7ÿÿ \1cp\0\05>\0\v%+\0p\0\0Z\y.yü\1f\ 3ÿÿû7<¯\11l~\ 2\0\0+\b\0\v',z\0\0\0õ\8e\80\0\ f,:\0\0\aô\a8\0\ 1Z\y/\1a,\1a\0\v\v,Z\0\0\aX\1eh\0\0ö\1f\0®Áø\108\0\ 16\y/\1aõ`\0\vQ/\1a\ 1'8e~\ 2\0\0+\0\0\b?öØ\0¦\8f@@y/#õ`\0\bc,:\0\0\aõ\8e\80\0\ f,:\0\0\ 4 \1e\ 1%{7^y/\1a+\b\0\v3ûDwÿýô\ f\0\0\ 13^\0\0\ 4+\0\0\v7ûG¼\0\ 1ö\97\80§w÷'\0\vi,Z\0\0\ 4õ\96\80\0\ fõ\86\80\v\81÷@7ÿÿ+\0\0\v\8e\80\0\ f \1e\ 1%{,:\0\0\a7\y/\1aõb\0\vw,\1a\0\v=õ`\0\v«,:\0\0\ 4ûD8\0\ 1ZPy/\1aö\1f\0®Áø\108\0\ 1,Z\0\0\ 4,z\0\0\0õ\86\80\v\87,\1a\0\v\a,z\0\0\0õ\86\80\v\87,\1a\0\v=,z\0\0\0õ\8e\80\0\ f \1e\ 1%{l>\ 4\0\0,:\0\0\ 4 \10\0\0\aô\ f<¯3<P\0\v\a8\0\ 1=p\0\v\10\0\0\aûG8\0\ 1,:y/\1aõpwÿýZ\1cy/\1aû\17 \0\ 1,Zy/\1a+\0\0\v\1cy/\1a+Ao\87+\0\0\va,Z\0\0\ 1÷`7ÿÿ,Z\0\0\ 1õ\96\80\0\ 1,z\0\0\0,Z\0\0\ 1,z\0\0\0:\0h\0\0;\0h\0\0õ\96\80\0\ 3:\0h\0\0,z\0\0\0÷@7ÿÿõ\96\80\0 ,z\0\0\0÷`7ÿÿ,Z\0\0\aõ\96\80\0\ f,z\0\0\0,Z\0\0\a,z\0\0\0þ\ 6\0\ 4\81+\0\0\vR:\0h\0\0þ\ 6\0\ 4\81,z\0\0\0:\0h\0\0þ\ 6\0\ 4\81õ`\0\v\aþ\ 6\0\ 4\87,z\0\0\0:\0h\0\0þ\ 6\0\ 4\9fl0\v\18rïx\b\v^,z\0\0\0þ\ 6\0\ 4\8f,z\0\0\0:\0h\0\0þ\ 6\0\ 4¿,z\0\0\0:\0o\87,Z\0\0\ 4õ\96\80\0\ f,z\0\0\0÷@7ÿÿ/\1a\ 1'8,z\0\0\0/\1a\ 1'<,z\0\0\0õæ\80§y,z\0\0\0/\1a\ 1'\1e,z\0\0\0O\18r*D\0\0\0\0\0O\18sH\18ð\0\0\0\ 1O\18pL|\0\0\0\0\ 1O\18Tn\ 4ð\0\0\0\ 3ùæ9\1dÏ\0\0\0\0\ 2ùæ._Ïð\0\0\0\ 5ùæ0ÿ]\0\0\0\0\ 3O\18r@\ 5ð\0\0\0\aùæ4\1f;\0\0\0\0\ 4O\18Zh^ð\0\0\0      O\18b\17;\0\0\0\0\ 5ùæ7ZÉð\0\0\0\vO\18ZsJ\0\0\0\0\ 6O\18K#Jð\0\0\0\rùæ7)Ï\0\0\0\0\aO\18h\1c\0\0\0\ fùæ0ÿ+\0\0\0\0\bO\18a\9dð\0\0\0\11O\18rK]\0\0\0\0        O\18r\0\0\0\0\13O\18l]O\0\0\0\0\rùæ1n\8bð\0\0\0\15ùæ-6#\0\0\0\0\vùæ%¤íð\0\0\0\17ùæ7[\19\0\0\0\0\fO\18rE}ð\0\0\0\19O\18ZG-\0\0\0\0îO\18Jw-ð\0\0\0\eùæ-_\95\0\0\0\0\ eùæ%\8f\95ð\0\0\0\1dùæ-b]\0\0\0\0\ fùæ%\92\0\0\0\1fO\18\lD\0\0\0\0\10O\18fNDð\0\0\0!O\18lW\1a\0\0\0\0\11O\18B\1f\bð\0\0\0#O\18LL\14\0\0\0\0\12ùæ1]\8bð\0\0\0%O\18Z(\ 1\0\0\0\0\13O\18JX\ 1ð\0\0\0'ùæ-(\ 3\0\0\0\0\14ùæ%X\ 3ð\0\0\0)O\18PP(\0\0\0\0\15O\18PP<ð\0\0\0+O\18Zl$\0\0\0\0 O\18Znd\0\0\0\0(O\18Zn(\0\0\0\00O\18h5I\0\0\0\0@O\19@:D\0\0\ 4\0\0O\19AX\18ð\0\ 2\0\ 1O\19>\|\0\0\ 4\0\ 1O\19"~\ 4ð\0\ 2\0\ 3ùæ`-Ï\0\0\ 4\0\ 2ùæUoÏð\0\ 2\0\ 5òÙKÛÿÿþ\0\f;ùæX\ f]\0\0\ 4\0\ 3O\19@P\ 5ð\0\ 2\0\aùæ[/;\0\0\ 4\0\ 4O\19(x^ð\0\ 2\0 O\190';\0\0\ 4\0\ 5ùæ^jÉð\0\ 2\0\vO\19)\ 3J\0\0\ 4\0\ 6O\19\193Jð\0\ 2\0\rùæ^9Ï\0\0\ 4\0\aO\196,oð\0\ 2\0\ fùæX\ f+\0\0\ 4\0\bO\190\ f\1dð\0\ 2\0\11O\19@[]\0\0\ 4\0       O\19@\10\0\ 2\0\13O\19:mO\0\0\ 4\0\rùæX~\8bð\0\ 2\0\15ùæTF#\0\0\ 4\0\vùæL´íð\0\ 2\0\17ùæ^k\19\0\0\ 4\0\fO\19@U}ð\0\ 2\0\19O\19(W-\0\0\ 4\0îO\19\19\a\0\ 2\0\eùæTo\95\0\0\ 4\0\ eùæL\9f\95ð\0\ 2\0\1dùæTr]\0\0\ 4\0\ fùæL¢]ð\0\ 2\0\1fO\19*|D\0\0\ 4\0\10O\194^Dð\0\ 2\0!O\19:g\1a\0\0\ 4\0\11O\19\10/\bð\0\ 2\0#O\19\1a\\14\0\0\ 4\0\12ùæXm\8bð\0\ 2\0%O\19(8\ 1\0\0\ 4\0\13O\19\18h\ 1ð\0\ 2\0'ùæT8\ 3\0\0\ 4\0\14ùæLh\ 3ð\0\ 2\0)O\19\1e`(\0\0\ 4\0\15O\19\1e`<ð\0\ 2\0+\ f\13'U@\b\0\0\0\0\ f\16}U@\b \0\0\0\ f\16}V\10\b@\0\0\0\ f\131Y\ñ\10\0\0\ 1ñåC'ÿ\b@\0\0\ 1\ f\19.,\19ñ\10\0\0\ 3ñæPµ5\b@\0\0\ 2ñæPµ\eñ\10\0\0\ 5ñãæl×ñ\10\0\0\añæ\9c¯\85\b@\0\0\ 4\ f\ e@<|ñ\10\0\0 \ f\10*l|\b@\0\0\ 5ñäÓÁuñ\10\0\0\v\ f\13'@A\b@\0\0\ 6ñä\ 4\9f\85ñ\10\0\0\r\ f\10(qA\b@\0\0\añæ(ª\8fñ\10\0\0\ f\ f\18Q&4\b@\0\0\b\ f\12\16l\0ñ\10\0\0\11ñæ\9d\97_\b@\0\0       ñä{ö+ñ\10\0\0\13\ f\13(oH\b@\0\0\rñä{õ        ñ\10\0\0\15ñæPµ       \b@\0\0\vñä
+§Iñ\10\0\0\17ñåsæE\b@\0\0\f÷\84`\9e\93ÿþ\ 4\f»ñä{Ы\b@\0\0îñåH¸Gñ\10\0\0\e\ f\18R.'\b@\0\0\ eñæúyÏñ\10\0\0\1dñæ©OW\b@\0\0\ f\ f\18S\1d\10\0\0\1f\ f\ e<\ed\b@\0\0\10\ f\ f9\14d\b@\0\0\11ñã\9f:Iñ\10\0\0#ñä\ 6¾I\b@\0\0\12ñæ8\ 6\10\0\0%ñæ(5\7f\b@\0\0\13\ f\12=vTñ\10\0\0'\ f\10n@\ 4\b@\0\0\14ñäÓÙ\rñ\10\0\0)ñæ7q[\b@\0\0\15ñæ`=\17ñ\10\0\0+ñåÚ\8a\8f\b@\0\0\16ñã\9e\1c\10\0\0-\ f\1a73+\b@\0\0\17\ f\13'>cñ\10\0\0/ñäØÙÅ\b@\0\0\18ñåbgÿñ\10\0\01\ f\e'\12\13\b@\0\0\19ñå\8dcEñ\10\0\03\ f\16\1af\ 4\b@\0\0\1a\ f\18S1\fñ\10\0\05ñä
+P\83\b@\0\0\e\ f\19'*?ñ\10\0\07\ f\ e<\e\\b@\0\0\1c\ f\16\18'$ñ\10\0\09\ f\11)\ 5x\b@\0\0\1d\ f\10{x\18ñ\10\0\0;\ f\18R?t\b@\0\0\1e\ f\13\16\a\10\0\0=ñæ­SÏ\b@\0\0\1f\ f\1aE\17\vñ\10\0\0?\ f\18yMJ\b@\0\0 \ f\18``gñ\10\0\0Añæ(5\83\b@\0\0!\ f\18Ng\13ñ\10\0\0C\ f\18M5D\b@\0\0"\ f\10\1czMñ\10\0\0E\ f\19CRh\b@\0\0#\ f\ f7\1ax\b`\0\0\0ñä
+¦ë\bb\0\0\0ñæ\84\0\8b\bf\0\0\0ñæÁÌg\bh\0\0\0\ f\1aZlh\bj\0\0\0\ f\ fRk,\bl\0\0\0\ f\1a\b\0G\bn\0\0\0\ f\10(o*\bp\0\0\0ñäS\8d?\br\0\0\0\ f\10(q\88t\0\0\0\ f\19@M[\bv\0\0\0\ f\15\ePx\bx\0\0\0\ f\e&%\b\bz\0\0\0ñååJ\17\b|\0\0\0\ f\1aX$8    \0\0\0\0ñãÄ÷\8d        \0\0\0ñæ^å\8f       @\0\0\0ñã\8f5µ       `\0\0\0\ f\1aR% \0\0\0\0\0\ f\e\ 3G@÷W\17²ßïx\0î\1dð\0\0\0\ 1\ f\1aî\ 6`\0\0\0\0\ 1\ f\1171 ð\0\0\0\ 3ñæ§(g\0\0\0\0\ 2ñäùxgð\0\0\0\ 5\ f\15DfD\0\0\0\0\ 3\ f\1aY\ 1\0\0\0\añåßaE\0\0\0\0\ 4\ f\13%]0ð\0\0\0       \ f\15L*8\0\0\0\0\ 5\ f\19A/4ð\0\0\0\vñäÔ\8f;\0\0\0\0\ 6ñã\9c\ f\0\0\0\r\ f\192\b,\0\0\0\0\a\ f\17>\ 2\0\0\0\ f\ f\15D^\\0\0\0\0\bñåba\1dð\0\0\0\11\ f\1a\U\b\0\0\0\0       \ f\1aE\16\18ð\0\0\0\13\ f\18r X\0\0\0\0\r\ f\15gE\ð\0\0\0\15\ f\13\15uJ\0\0\0\0\v\ f\ e8E\ 4ð\0\0\0\17\ f\19A;t\0\0\0\0\f\ f\1aZo\bð\0\0\0\19ñäͦ#\0\0\0\0îñã\95&#ð\0\0\0\eñäÑo]\0\0\0\0\ eñã\98ï]ð\0\0\0\1dñäÑÞ\8b\0\0\0\0\ fñã\99^\8bð\0\0\0\1f\ f\13vu \0\0\0\0\10\ f\16}E ð\0\0\0!\ f\18\10\0\0\0\0\11\ f\vNZ@ð\0\0\0#\ f\ elf \0\0\0\0\12\ f\15b\1d\0\0\0%\ f\13\11@(\0\0\0\0\13\ f\ e @(ð\0\0\0'\ f\13\11@<\0\0\0\0\14\ f\ e @<ð\0\0\0)\ f\10\ e\f@\0\0\0\0\15\ f\10\ e\12\0\0\0+\ f\13&k \0\0\0\0 \ f\13'O \0\0\0\0(\ f\13'<@\0\0\0\00\ f\17E^h\0\0\0\0@1~\0\ 1l+\b\0îL \1ay0/\10d\ 1'=ô\a\0\r©a|\0\10\0õb\0\r\9dò\19\80§{4\\0îwú/¸\0\ 1ú/\0\r©\10d\ 1'>û7\80\r©ò\18\80§}\10b\ 1'?ò\18\80§\7fõa@\r©+ \0\0\0þ\0\0\9f/p\1c\0\80õb\0\r«\10d\ 1'@7>\ 1%{+\b\0îWò\19\0§\81 <\0\0\0\10d\ 1'Aöè<¯Eõ`\0\rë7<\0\0\10+\0\0îvöO\0§\83+\0\0îw2<\ 1'BöO\0§\85÷\81A\80\ 3ïx\bî]õ`\0\r\97ö·\80\r¿ 0\0\0\0*\10\ 1/\1aô\14\0§\11 \y/#õ\17\ 3ÿå \1ay0/Z\ 6\0\0\10\174\ 1'Cô\15<°U,\ep\ e\1c+\0\0îd÷@\0\r© \1e\ 1%{öÐ<¯Iõ\86\80\b93^\ 1&Höø\0¦\8f+\0\0îhöÈ\0¦\93+\0\0îq6@y/\1aõb\0\rÑö·\80\rÛ <\0\0\0õG\0§\11 \\ 1/\1aþ\a\80\0\ 1õb\0\r× >\0\0\0ò\18\80§\87õ`\0\r§7@y0I6@y0Jõb\0\rÝ7@y0K6@y0L+\b\0îp+\0\0îk7@y/#+\0\0îhùð\0¦\93ø\10\0¦\91@@\ 1&I+\0\0îhõ\86\80\eÙ\17<\ 1'Dõ`\0\rÁöç\0§\89!<\0T\0õ`\0\r»ô\a\0\r©a|\0\10\0+\b\0îx!<\0P\0õ`\0\r»\0\0\0\0\0p\1c\0\80õb\0\rõ\10d\ 1'@7>\ 1%{+\b\0î|ò\19\0§\81 <\0\0\0\10d\ 1'Aöè<¯Eõ`\0\rë \1c\0\0\18\10d\ 1'Eô\ 6\80\róô\16\80\r©az\0\10\0õb\0\ e\ 3õ\17\ 3ÿåö7\0\0Gõ`\0\ e       ò\19\80§\8bõ`\0\r\9f\10By/\1d!:y/\1dX\1a\0\0\18ûG\80\0\r\10d\ 1'F+\0\0îRþ\ 6\0\ 2\81 \1e\ 1%{ö×<¯#õ`\0\ e\1f \1e\ 1%{þ\ 6\0\ 2\816@y/\1a+\b\0\ e\v <y/\ 2Q<y.zõO<¯\13ô\a\0\r© \y.yô\a\0§mô\17\0\r§+\0\0\r\ 1ö¿\0§\8d \ 2q/\11õ踯#2B\ 1'Gõb\0\ e#@@q/\11ø\10<¯#÷@<¯\eø\108¯#õ`\0\ e\13õ\86\80\v\ 1öç\0§\8f!<\0\0\10G\y/\ e \1e\ 1%{öÐ<¯Iõ\86\80\b9öè<¯Eõ`\0\ e\13 \1c\0\0\10\10l\ 1'=õ`\0\ e\13 \1cy/gü\1f\ 3ÿÿõ\86\80\eÙõ`\0\ e\13ôÜÈq+ÿþ\0\ e\1e\ 1%{õ\86\80\v\ 1õ`\0\ e- <\0 \0+\0\0\ e\16õ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eIõ¯\0\ eI/<\0\ e\1fô\ 3<°U \1e\ 1%{\17l\ 1'HõÃ\0\0\ fòÿ\0§\91õ\86\80\v\ 1 <\0\ 1\0+\0\0\ e\16þ\ 6\0\ 2\81\10By/\1d!"\0\ 3|øP¼¯=\10Dy/\1dõ`\0\ e)\0\0\0\ e\0\0\10\0\0\13ãð\0\0\14/\0\0\0\ e\0\0\ e\0\0\12§ð\0\0\ e\0\0\ e\0\0\ e\0\0\ e\85 <\0\ 4\0G\y/\ eõ`\0\ e\13ô\ 5\0\0\ 104\0\0\bõ`\0\10Ùô\15<°U:\0h\0\0Z\ 6\0\0\ 1ô\0\80\0\ f&"\0\ 1l5D\ 1'IõÍ<®Á[\ 2P\0\0Z\ 4P\0\0+\ 1\10\12\1dZ\ 4\0\0\10ô\0¼°Uò\18\80§\93>\0h\0\00"\0\0\bõ`\0\10Ùõȼ®Á[\ e\b\0\0Z\12\b\0\0ö\94\80\ e\11\ 4\0\bH\110ah\0\0@õ`\0\v¥ô\11\1c\96Û!(\0\0 øò\1c\95\võ`\0\v¥ \ e\0\0\10ø-\0\0\a\172\ 1'Jòê\0§\95+\ 1P\ e\0\0\ e\95\0\0\0\ e\0\0\ e\95 \0\0\ eN0\0\0\ eN@\0\0\ eN@\0\0\ eI@\0\0\ eIö4\80\0\7fõ`\0\ e)+\0\0\ eNl.\0\0\10\10b\ 1'K.\ 6\ 1'8ü\19\83ÿÿ:\0h\0\0ò\19\0§\97û\ 3\80\0\ 36&I#'+\0\0\ e\11\90\0\13öÈ\0\0\ 3õ`\0\ e\19\80\0\a,z\0\0\0õ`\0\v¥öè$£Íõ`\0\ e)õ`\0\ e¡ \ 6\0\0\ 1ô\0\80\0\ fô\v\80\0\ 1ô      \0\0      +\0\0\ eW,\1a\0\ et .\0\0\0\10f\ 1'Lò\19\80§\99[\18\10\110`P\ 2\0\0õ`\0\ eí`X\0\0 õ`\0\ eÏdP\ 4\0\0l\ e\0\0\ 1`N\0\0\ 1`X\ 5\0\0ÿ\92ÇÈ\9fÿþ\0\ e¹aX\ 5\ 2\0+\0\0\ e"`X\ 1\0\0 \ 2\b\1d\f\0\0-õ`\0\ eÓòê\1c\ f\11÷\8a\0\ e\8a\0\ eÅòé\90\ f\15\10b\ 1'M+\0\18\0\0\17&\0\ f\võÁ\80§\9b\10b\ 1'NaN\0\0\ 1ô\ 1@\0\ 3`N\0\0\ 1ô\11@\0\ 3aN\0\0\ 1ò\19\0§\9d,z\0\0\00P\0\0\ 5,z\0\0\0 "\0@\0õ`\0\ eÝ`N\0\0\ 1õ`\0\ e)/0\0\0 ö\8c\0\ e)00\0\0\10+\0\0\ erdP\0\0\bõ`\0\ eßõÌ\ 4®Á \ 2@\0\0\10d\ 1'O,z\0\0\0ô\ 5\0\0\ 1õÍ ®Áô\ 1\80\0    Z\ 4P\0\0+\0\0\12T00\0\0\18õ`\0\ eÿõÌ\ 4®±+\0\0\ enZ\ 6\0\0\10õÍ<®Á[\ 2P\0\0Z\ 4P\0\0,z\0\0\0`P\ 4\0\0ý\9b\80\0\ 1õ`\0\ e\18\80§\9f\10d\ 1'P,:\0\0\ 1õ\8e\80\0\ 3õ\8e\80\0\ 1õ\8e\80\0\a \ 6\0\0\ 4,\1a\0\ e\96\80\0\aõ\96\80\0\ 1õ\96\80\0\ 3,Z\0\0\ 1ò\18\80§\9fõ\\0\ eñ,z\0\0\01p\0\ 1 10\0\0 õ`\0\ e\86\80
+\19ð\0\0Kïõ\8e\80\0      2\b\0\0 "Gàõ\86\80H\97õ\86\80\v\aø)\0\ 1ÿòù\80§¡l$ \0\0(H\aïvl$ \0\0G\ 2\0\0\ 1õ\96\80\0   õ`\0\ eÝø\82 \ f\17ø\ 2 \ f\17ô\ 2 \ f\17ó\82 \ f\17ô\8e \ f\17ð\ e \ f\17õ=2\01(\0\ 2@9õ\0\0\0\0\0\0\0\0\0c)v|\02)z5\0.!t$\0\0\ 1@[Q|\10\0\0õ>&\81\8f(\0\0\0+õ?"\80[õ?"\80[õ>\8e\80eõ>Æ\80_ú=OÏWõ\0\ 1@qõ\0\0\0UQv0\0\01v@\06(\0\ 2@/õ\0\ 1@]õ\0\0\0\0\0\0Wø>\17\ f\87õ?&\80]õ?&\80])|%\0.)|%\0.)|=\0/)|=\0/õ=\82\80yQv\10\0\03kM\15Aÿþ\0\ f9(\0\ 2@<õ\0\ 1A\8dQ|wOiQ}P\0\0){E\ 1M){E\ 1Mõ>þ\81\9bõ>þ\81\9b){=\ 1Mõ>ú\81\9b(\0\ 2AN5H\0\ f$öð\ 4°O,z\0\0\0õ`\0\ fIôJ\0\0\ 1õ\86\80\b\83\17h\ 1'Qõ`\0\b¥õ\86\80\b\83l(\0\10\0ü\8a\0
+\1föè\ 4¯1l(\0\b\0 H  .yõ`\0\b¥ \b       /\1ed(\aï|ò\19\0§£,z\0\0\0þ\ 6\0\ 2\813B\ 1%{\10B   /\1dd(\aï|l(\0\0\ 2 H  /\1e3B\ 1%{\10@       /\1dõ`\0\v³XH       /\1d,z\0\0\0úB\ 4¯;õ\12\0\0\ 5û\ 2\ 4¯;õ`\0\ fU&"\0\ 1lõ`\0\ eÝþ\ 6\0\ 2\81\10By/\1dòê\0§O(H\a\87õÂ\ 4¯-þ\ 6\0\ 4\81õ`\0\ f\92\0\ e\86\80\b\83,\1a\0\ f;õ`\0\ f\81ô\12\ 4¯%þ\ 6\0\ 4\81õ`\0\b¥ \ 4    /\12 *\0\0\0þ\ 6\0\ 2\812D)/\12õ`\0\ f}ör\14¯%,z\0\0\0.*\0\ 1l3*\ 1-gõ`\0\ fyõ`\0\v¥õ\86\80\b¥öP\80\0\ 5õ`\0\ e)õ`\0\v³\17(\ 1'Rõ`\0\ fU\17h\ 1'R,z\0\0\0öw\80\0\ 1õ`\0\ f\8fõ\86\80\b\83!$\0@\0øñ\ 4¯\eõ\86\80\b¥õÊ\0\ 3ÿ(H\aï{ \ 4\0\0\ 2õ\8e\80\0\ 1õ\86\80
+\9d\0\0\0\ fPõG\80\0\ 1,\1a\0H>+ \0\0\0õ\86\80\vs/\1a\ 1'8õG\80\0\ 1öw\80\0\ 1,z\0\0\0!,\0@\0øS\ 4¯\e,z\0\0\0õ\96\80\0\ 1 \1e\ 1%{õ`\0\ f\9b6@\0\0\ 2 H    /\13,z\0\0\0d\b\0\f\12\ 4¯\1dô      \0\ 1'`H\0\0\ 4h\ 4\0\0\18`h\0\ 1\0h\ 4\0\ 1@XD       /îü\13\80\0\ 1p                /î,z\0\0\0õ\ 2\ 3ÿÝ H  /\106@\0\0\ 2ü3\80\0\ 1,z\0\0\0õ`\0\19'öä\0§¥ø,\0\0\ 1ÿ5\9b\93Ëÿþ\0\ f¹ô     \ 4°[+@A'S6@      /\10+\0\0\ fZ,z\0\0\0öä\0§¥ø,\0\0\ 1 $        0.+\0\0\ f]úB\ 4¯!õ`\0\ fUd\b\0\fC+\0\0\00."\a\87õÈ\80\0\ 3."\a\87ø,\0\0\ 1+@@\ ff,z\0\0\0Gh       /\ fBh    /\ fõ@\80\0\ f\17(\ 1'Hõ@\80\0\ fõ`\0\ fUõ@\80\0\ f\17h\ 1'Hõ@\80\0\ f,z\0\0\0[\1cy/\1d(\\0\0\ 5û\17<¯1,z\0\0\0ûB\ 4¯1õ`\0\ f\0\80\r©\10b\ 1'Uòé\80§«ö\11\80\0\19ö1\80\01õ`\0\10\aö\11\80\0\e+\0\0\ f}\17&\ 1'V1F\0\0lõ`\0\ fõ`b\0\ 1põ`\0\ e\ 5\0\0\ 1õ\86\80\15­ Ty0Fh4\ 2\\0at\a~\0+\0\0\10\ 2öÐ\0¦\8fõ\86\80¤Óõ`\0\ fó,\1a\0\10\ 6,\1a\0  v,z\0\0\0!"\ 4\0\0øð¼°Q+ \0\0\0,\1a\0        võb\0\ fù\17$\ 1'V1D\0\0Wõ`\0\ féö1\0\0­õ`\0\ fõûa\80\0\ 1ü\81\80\7f?0F\a\0põ`\0\ e)õ`\0\ féõ\86\80\10\17ò\18\80§­+\0\0\ fo\17$\ 1'Wò\18\80§¯d"\0\ 1pl"\0\ 1`õ`\0\ fé\10Dy/\1d \fy0F\10n\ 1'X+\0\0\10\r"$\0\0\ 1.Dy/\v@@y/\11õ`\0\v¥\10f\0\0\ 3,z\0\0\0õ`\0\v¥,:\0\0\aô\a\0\r§3\\ 1'7,\1a\0PM,Z\0\0\a,z\0\0\0Z\ 6\0\0\10ø\10<°Uò\18\80§± 6\0\0\ 2\17v\ 1'Y+\0\0\10\16Z\ 6\0\0\10õÍ<®Áõ\8e\80\0\ 3,\1a\0\18\96\80\0\ 3ò\18\80§±\176\ 1'Y1V\0\0\ 2+\0\0\10p ,y0Dú+\f\0\ 3ô\f\18\0\ 3ò\18\80§³\10b\ 1'Zò\18\80§µ \by/\13ûb\80\0\ 1S"\b\0\01V\0\0\ 27@y0D+\0\0\10)5D\0\10)ûE\17Ë\8fÿþ\0\10\ 3\0\0\ 3bL\ 1'[õ`\0\10ÙõË<®Á \100\0\0[\10@\110`P\0\0\10õ`\0\1d      aP\ 2\ 4\0õ`\0\v¥[\120\0\0*\ 2\0\0\ 1õA\0\0\ 3aP\ 2\0\0õ`\0\10M &\ 6]\bZ\ eI\ 2'òû\80§·,:\ 1'\õ`\0\10Oô   \82Lëõ\8e\80§¹Q&(\0\0ô
+\80\0\ 1õ`\0\10\86\80\eá+\0\0\10\12<¯'ûx\0\0\ 1Q"(\0\0õ\8e\80\0\ 1,:\0\0\ 1õ\8e\80\0\ 3ô)\ 3ÿÝûA\88\13\8b0F\b\0\0õY\0\10[5d\0\10>\17&\ 1']1V\0\0\ 25F\0\10=!&\ 4\0\0ü\18\80\0\ 1
\ No newline at end of file
diff --git a/MUDDLE/nutil.1 b/MUDDLE/nutil.1
new file mode 100644 (file)
index 0000000..5b9bf7f
--- /dev/null
@@ -0,0 +1,230 @@
+<SETG DEFINE
+ <FUNCTION ("STACK" FUNNAME  DEF)
+   <SETG .FUNNAME .DEF>
+   <PRINT .FUNNAME>   >>
+
+
+<DEFINE FRAMEN 
+  <FUNCTION ("STACK" N)
+   <COND (<0? .N> <FRAME>)
+         (T <FRAME <FRAMEN <- .N 1>>>)>>>\e
+
+
+
+<DEFINE CLEANUP
+  <FUNCTION CF ("STACK" ) 
+    <FINALIZE>
+    <BUMPER>>>
+
+
+<DEFINE BUMPER
+  <FUNCTION ()
+   <FAILPOINT FP ("STACK" )
+      <> ("STACK" M A)
+      <RESTORE .FP (FAILURE CAUGHT WITH M = .M AND A = .A)>>   >>
+
+
+
+<DEFINE THSET
+  <FUNCTION ("STACK" VAR\  VAL "AUX" (OV <RLVAL .VAR\ >))
+      <FAILPOINT ()
+         <SET .VAR\  <RLVAL VAL>>
+         ("STACK" M A)
+         <SET .VAR\  <RLVAL OV>>
+         <FAIL .M .A>>   >>
+
+
+<DEFINE THDELQ
+ <FUNCTION ("STACK" ELT L)
+   <COND (<EMPTY? .L> .L)
+         (<==? .ELT <1 .L>>
+          <CHTYPE <REST .L> <TYPE .L>>)
+         (T <THDELQ1 .ELT .L>)   >>>
+
+
+<DEFINE THDELQ1
+ <FUNCTION ("STACK" ELT L)
+   <COND (<EMPTY? <REST .L>> .L)
+         (<==? <2 .L> .ELT> <THPUTREST .L <REST .L 2>>)
+         (T <THDELQ1 .ELT <REST .L>>)   >  >>
+
+
+<DEFINE THPUTREST
+ <FUNCTION ("STACK" LIST1 LIST2)
+   <FAILPOINT ("STACK" (OREST <REST .LIST1>))
+      <PUTREST .LIST1 .LIST2>
+      ("STACK" M A)
+      <PUTREST .LIST1 .OREST>
+      <FAIL .M .A>   >>>
+
+
+<DEFINE THPUT
+ <FUNCTION ("STACK" THING IND "OPTIONAL" PROP)
+   <FAILPOINT ("STACK" (OPROP <GET .THING .IND>))
+      <COND (<ASSIGNED? PROP>
+             <PUT .THING .IND .PROP>)
+            (T <PUT .THING .IND>)   >
+      ("STACK" M A)
+      <COND (.OPROP <PUT .THING .IND .OPROP>)
+            (<PUT .THING .IND>)   >
+      <FAIL .M .A>   >>>
+
+
+<DEFINE THSETLOC
+ <FUNCTION ("STACK" LOC VAL "AUX" (OVAL <IN .LOC>))
+   <FAILPOINT ()
+      <SETLOC .LOC <RLVAL VAL>>
+      ("STACK" M A)
+      <SETLOC .LOC <RLVAL OVAL>>
+      <FAIL .M .A>   >>>\f<DEFINE FALSE
+  <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> FALSE>  >>
+
+
+<DEFINE FORM
+  <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> FORM>  >>
+
+<DEFINE UNASSIGNED
+  <FUNCTION ("STACK" "ARGS" A) <CHTYPE <EVAL .A> UNASSIGNED>  >>
+
+<DEFINE SEGMENT
+  <FUNCTION ("STACK" "REST" 'A) <CHTYPE <EVAL .A> SEGMENT>  >>
+
+<DEFINE CONSTRUCTOR
+ <FUNCTION ("STACK" TYPE)
+   <GET .TYPE 'CONSTRUCTOR>   >>
+
+
+<PUT LIST CONSTRUCTOR ,CONSL>
+<PUT FORM CONSTRUCTOR ,FORM>
+<PUT FALSE CONSTRUCTOR ,FALSE>
+<PUT VECTOR  CONSTRUCTOR ,CONSV>
+<PUT SEGMENT CONSTRUCTOR ,SEGMENT>
+<PUT UVECTOR CONSTRUCTOR ,CONSU>
+
+
+
+<DEFINE AVAL
+  <FUNCTION ("STACK" ATOM)
+   <COND (<GASSIGNED? .ATOM> <GVAL .ATOM>)
+         (<LVAL .ATOM>)>  >>
+\f<DEFINE CLIP
+ <FUNCTION ("STACK" VAR)
+   <FAILPOINT CLIPPER ("STACK" (VAL ..VAR))
+      <FAIL> 
+      ("STACK")
+      <COND (<EMPTY? .VAL> <FAIL>)
+            (<RESTORE .CLIPPER
+                      <PROG1 <1 .VAL>
+                             <SET .VAR <SET VAL <REST .VAL>>>>>)   >>  >>
+
+
+<DEFINE FULL?
+ <FUNCTION ("STACK" FOO) <NOT <EMPTY? <RLVAL FOO>>>>>
+
+
+<DEFINE FINSPLICE
+ <FUNCTION ACT ("STACK" CURRENTENV NEWENV)
+   <PROG1 <SPLICE .CURRENTENV .NEWENV>
+          <FINALIZE .ACT>>   >>
+
+
+<DEFINE ENVIRON
+ <FUNCTION ("STACK" "BIND" FOO) .FOO>>\f<DEFINE RESET
+ <FUNCTION ("STACK" VAR)
+   <FAILPOINT ("STACK" (VAL <RLVAL .VAR>)) <> ("STACK")
+      <SET .VAR <RLVAL VAL>>
+      <FAIL>>  >>
+
+<DEFINE PROG1
+ <FUNCTION ("STACK" "REST" A) <1 .A>   >>
+
+
+<DEFINE PROG2
+ <FUNCTION ("STACK" "REST" A) <2 .A>   >>\f<DEFINE MULTILEVEL
+ <FUNCTION ("STACK" OBJECT)
+   <AND <NOT <MONAD? .OBJECT>>
+        <MEMQ <TYPE .OBJECT> '(LIST FORM VECTOR SEGMENT VECTOR)>>   >>
+
+<DEFINE REVERSE 
+ <FUNCTION REV ("STACK" L "OPTIONAL" (CFUNC <CONSTRUCTOR <TYPE .L>>)
+                "AUX" (RESULT ()))
+   <COND (<EMPTY? .L> <.CFUNC !.RESULT>)
+         (T <SET RESULT (<1 .L> !.RESULT)>
+            <SET L <REST .L>>
+            <AGAIN .REV>)   >   >>
+
+
+<DEFINE NCONC
+ <FUNCTION ("STACK" "REST" LSTUPL)
+   <COND (<EMPTY? .LSTUPL> ())
+         (T <CHTYPE <NCONC1 .LSTUPL> <TYPE <1 .LSTUPL>>>)   >>>
+
+
+<DEFINE NCONC1
+ <FUNCTION ("STACK" LSTUPL)
+   <COND (<EMPTY? <REST .LSTUPL>> <1 .LSTUPL>)
+         (T <NCONC2 <1 .LSTUPL> <REST .LSTUPL>>)   >>>
+
+
+<DEFINE NCONC2
+ <FUNCTION ("STACK" L1 LREST)
+   <COND (<EMPTY? .L1> <NCONC1 .LREST>)
+         (T <PUTREST .L1 <NCONC2 <REST .L1> .LREST>>)   >>>\f<DEFINE ANOTHER
+ <FUNCTION ("STACK" OBJ BOUND)
+   <FAILPOINT FP ("STACK")
+     .OBJ ("STACK")
+     <AND <==? .OBJ .BOUND> <FAIL>>
+     <RESTORE .FP <SET OBJ <REST .OBJ>>>>  >>
+
+
+\f<DEFINE MAPCAR
+ <FUNCTION MAPPER ("STACK" FUN "REST" EXPS "AUX" (RESULT ()) RES1 LAS)
+   <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
+   <COND (<EMPTY? .RESULT>
+          <SET LAS <SET RESULT (.RES1)>>)
+         (T <PUTREST .LAS <SET LAS (.RES1)>>)   >
+   <AGAIN .MAPPER>   >>
+
+
+<DEFINE MAPC
+ <FUNCTION MAPPER ("STACK" FUN "REST" EXPS "AUX" (RESULT ()))
+   <REPEAT ("STACK") <APPLY .FUN <LISTFIRSTS .EXPS>>>   >>
+
+
+<DEFINE MAPCAN
+ <FUNCTION MAPPER ("STACK" FUN "REST" EXPS 
+                   "AUX" (RESULT ()) RES1 LAS1)
+   <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
+   <COND (<EMPTY? .RESULT>
+          <SET RESULT .RES1>)
+         (T <PUTREST .LAS1 .RES1>)   >
+   <SET LAS1 <LAST .RES1>>
+   <AGAIN .MAPPER>   >>
+
+
+<DEFINE LISTFIRSTS
+ <FUNCTION ("STACK" EXPTUPL)
+   <COND (<EMPTY? .EXPTUPL> ())
+         (<EMPTY? <SET RES1 <1 .EXPTUPL>>> <.MAPPER .RESULT>)
+         ((<PROG1 <1 .RES1>
+                  <PUT .EXPTUPL 1 <REST .RES1>>>
+           !<LISTFIRSTS <REST .EXPTUPL>>))   >   >>
+
+
+<DEFINE LAST
+ <FUNCTION L ("STACK" EXP)
+   <COND (<EMPTY? .EXP> ())
+         (<EMPTY? <REST .EXP>> .EXP)
+         (T <SET EXP <REST .EXP>>
+            <AGAIN .L>)   >>>\f<DEFINE BOTTOM
+ <FUNCTION ("STACK" THING)
+   <COND (<MONAD? .THING> .THING)
+         (<==? <TYPE .THING> LIST> ())
+         (T <REST .THING <LENGTH .THING>>)>  >>
+
+
+
+
+<DEFINE SPREAD
+ <FUNCTION ("STACK" VEC "REST" VARS)
+   <MAPC ,SET .VARS .VEC>   >>\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/nuuoh.12 b/MUDDLE/nuuoh.12
new file mode 100644 (file)
index 0000000..687fba2
--- /dev/null
@@ -0,0 +1,158 @@
+TITLE UUO HANDLER FOR MUDDLE
+RELOCATABLE
+.INSRT MUDDLE >
+
+;GLOBALS FOR THIS PROGRAM
+
+.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC
+.GLOBAL BCKTRK,SPCSTE,CNTIN2
+
+;SETUP UUO DISPATCH TABLE HERE
+
+UUOTBL:        ILLUUO
+
+IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL]]
+UUFOO==.IRPCNT+1
+IRP UUO,DISP,[UUOS]
+.GLOBAL UUO
+UUO=UUFOO_33
+DISP
+.ISTOP
+TERMIN
+TERMIN
+
+REPEAT 100-.IRPCNT,ILLUUO
+
+
+UUOH:
+LOC 41
+       JSR     UUOH
+LOC UUOH
+       0
+       JRST    UUOPUR          ;GO TO PURE CODE FOR THIS
+
+;SEPARATION OF PURE FROM IMPURE CODE HERE
+
+UUOPUR:        PUSH    P,C
+       LDB     C,[330900,,40]
+       JRST    @UUOTBL(C)      ;DISPATCH BASED ON THE UUO
+
+;HANDLER FOR DEBUGGING CALL TO PRINT
+
+DODP:
+       POP     P,C
+       PUSH    TP, @40
+       AOS     40
+       PUSH    TP,@40
+       PUSH P,0
+       PUSH P,1
+       PUSH P,2
+       PUSH P,3
+       PUSH P,4
+       PUSH P,5
+       PUSH P,40
+       MCALL   1,PRINT
+       POP P,40
+       POP P,5
+       POP P,4
+       POP P,3
+       POP P,2
+       POP P,1
+       POP P,0
+       JRST    2,@UUOH
+
+;CALL HANDLER
+
+DMCALL:        MOVEM   SP,SPSAV(TB)    ;STORE VITALS INTO CURRENT FRAME
+       MOVE    C,UUOH          ;PICK UP PCWORD
+       MOVEM   C,PCSAV(TB)     ;SAVE IN CURRENT FRAME
+       LDB     C,[270400,,40]  ;GET AC FIELD OF UUO
+COMCAL:        LSH     C,1             ;TIMES 2
+       MOVEM   C,(P)           ;SAVE
+       HRLI    C,(C)           ;TO BOTH SIDES
+       SUBM    TP,C            ;NOW HAVE TP TO SAVE
+       MOVEM   C,TPSAV(TB)     ;SAVE IT
+       MOVEI   AB,1(C)         ;BUILD THE AB POINTER
+       MOVN    C,(P)           ;NEGATE NUMBER OF ARGS
+       HRLI    AB,(C)          ;HAVE A REAL AB POINTER
+       MOVSI   C,TENTRY        ;SET UP ENTRY WORD
+       HRR     C,40            ;POINT TO CALLED SR
+       PUSH    TP,C            ;START HACKING FRAME
+       PUSH    TP,TB
+       PUSH    TP,AB
+       PUSH    TP,SP
+       PUSH    TP,P
+       PUSH    TP,TP
+       PUSH    TP,PP
+       PUSH    TP,[0]
+CALDON:        SUB     P,[1,,1]        ;POP STACK
+       MOVEM   P,PSAV(TB)
+       MOVEM   PP,PPSAV(TB)            ;SAVE PLANNER PDL
+       HRRI    TB,(TP)         ;SETUP NEW TB
+       AOBJP   TB,CALLIT               ;GO TO CALLED SR
+       TLNE    TB,-1   ;TIME OVERFLOW?
+       JRST    CALLIT  ;NO, GOT TO CALLED GOODIE
+
+;TIME OVERFLOW, CALL THE GARBAGE COLLECTOR
+
+       MOVEM   TP,TIMOUT       ;POINT TO UNHAPPY PDL
+       PUSHJ   P,AGC   ;AND COLLECT GARBAGE
+       HRLI    TB,TIMOUT       ;CONTAINS CURRENT TIME
+       SETZM   TIMOUT
+CALLIT:        INTGO                   ;CHECK FOR INTERRUPTS
+       JRST    (C)
+
+
+;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS
+
+DACALL:        MOVEM   SP,SPSAV(TB)    ;SETUP THE OLD FRAME
+       MOVE    C,UUOH          ;GET PC WORD
+       MOVEM   C,PCSAV(TB)     ;AND SAVE
+       LDB     C,[270400,,40]  ;GOBBLE THE AC LOCN INTO C
+       IOR     C,[MOVE C,0]    ;SETUP INS
+       EXCH    C,(P)           ;PUT INS ON STACK AND RESTORE C
+       XCT     (P)             ;C NOW HAS NO. OF ARGS
+       JRST    COMCAL          ;JOIN MCALL
+
+;HANDLE OVERFLOW IN THE TP
+
+TPLOSE:        ADD     TP,[-PDLBUF,,0] ;USE BUFFER
+       HLRE    C,TP            ;GET -LENGTH
+       MOVEI   D,1(TP)         ;COPY TP
+       SUB     D,C             ;D POINTS TO DOPE WORD
+       MOVEM   D,TPGROW        ;SAVE FOR NEXT GARBAGE COLLECTION
+       SETOM   INTFLG          ;CAUSE AN INTERRUPT NEXT TIME
+       JRST    CALDON
+
+;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS)
+
+FINIS: MOVE    C,OTBSAV(TB)
+       MOVE    E,SPSAV(C)      ;RESTORE BINDINGS
+       CAIE    E,(SP)
+       PUSHJ   P,SPCSTE        ;IF NECESSARY
+       HRR     C,OTBSAV(TB)    ;CHECK PP GROWTH
+       CAME    PP,PPSAV(C)
+       JRST    BCKTR1          ;SAVE TP FRAME
+CNTIN1:        HRR     TB,OTBSAV(TB)   ;RESTORE BASE
+CNTIN2:        MOVE    TP,TPSAV(TB)    ;START HERE FOR FUNNY RESTART
+       MOVE    P,PSAV(TB)
+       MOVE    AB,ABSAV(TB)    ;AND GET OLD ARG POINTER
+       JRST    2,@PCSAV(TB)    ;AND RETURN
+BCKTR1:        PUSH    TP,A            ;SAVE VALUE TO BE RETURNED
+       PUSH    TP,B            ;SAVE FRAME ON PP
+       PUSHJ   P,BCKTRK
+       POP     TP,B
+       POP     TP,A
+       JRST    CNTIN1
+CONTIN:        CAME    SP,SPSAV(TB)
+       PUSHJ   P,SPECST
+       JRST    CNTIN2
+
+
+ILLUUO:        .VALUE
+
+OPC:   0
+JPC:   0
+
+END
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/omatch.1 b/MUDDLE/omatch.1
new file mode 100644 (file)
index 0000000..1e052a0
--- /dev/null
@@ -0,0 +1,456 @@
+<SETG FRAMEN 
+  <FUNCTION (N)
+   <COND (<0? .N> <FRAME>)
+         (T <FRAME <FRAMEN <- .N 1>>>)>>>\e
+
+
+
+<SETG CLEANUP
+  <FUNCTION CF () 
+    <FINALIZE>
+    <BUMPER>>>
+
+
+<SETG BUMPER
+  <FUNCTION ()
+   <FAILPOINT FP ()
+      <> (M A)
+      <RESTORE .FP (FAILURE CAUGHT WITH M = .M AND A = .A)>>   >>
+
+
+
+<SETG THSET
+  <FUNCTION (VAR VAL "AUX" (OV <RLVAL .VAR>))
+      <FAILPOINT ()
+         <SET .VAR <RLVAL VAL>>
+         (M A)
+         <SET .VAR <RLVAL OV>>
+         <FAIL .M .A>>   >>
+
+
+<SETG INSTANTIATE
+  <FUNCTION ("BIND" CUR EXP "OPTIONAL" (ENV <>)
+               "AUX" (TP <TYPE .EXP>) VAL EXP1)
+   <SPLICE .CUR .ENV>
+   <COND (<==? .TP FORM>
+          <EVAL <CHTYPE <INSTANTIATE <CHTYPE .EXP LIST>>
+                        FORM>>)
+         (<MEMQ .TP '(ACTORFORM SACTORFORM)>
+          <COND (<==? <SET EXP1 <1 .EXP>> GIVEN>
+                 <OR <AND <ASSIGNED? <2 .EXP>>
+                          <LVAL <2 .EXP>>>
+                     .EXP>)
+                (<==? .EXP1 ALTER>
+                 <THSET <2 .EXP> ?()>
+                 <CHTYPE (GIVEN <2 .EXP>) .TP>)
+                (<==? .EXP1 VEL>
+                 <FAILPOINT FP ((PATS <REST .EXP>) P1)
+                     <FAIL> ()
+                     <AND <EMPTY? .PATS> <FAIL>>
+                     <SET P1 <1 .PATS>>
+                     <SET PATS <REST .PATS>>
+                     <RESTORE .FP <INSTANTIATE .P1>>>)
+                (<==? .EXP1 BE>
+                 <OR <EVAL <2 .EXP>> <FAIL>>
+                 .EXP)
+                (<==? .EXP1 ET>
+                 <OR <AND <EMPTY? <REST .EXP>> .EXP>
+                     <REPEAT R ((P1 <2 .EXP>) (PATS <REST .EXP 2>))
+                          <AND <EMPTY? .PATS>
+                               <EXIT .R <INSTANTIATE .P1>>>
+                          <MATCH1 .P1 <1 .PATS>>
+                          <SET PATS <REST .EXP>>   >>)
+                (T .EXP)>)
+        (<MONAD? .EXP> .EXP)
+        (<==? <TYPE <SET EXP1 <1 .EXP>> > SEGMENT>
+         (!<EVAL <CHTYPE .EXP1 FORM>>
+          !<INSTANTIATE <REST .EXP>>))
+        (<==? <TYPE .EXP1> SACTORFORM>
+         <SET VAL <INSTANTIATE .EXP1>>
+         <OR <AND <MEMQ <TYPE .VAL> '(ACTORFORM SACTORFORM)>
+                  (<CHTYPE .VAL SACTORFORM>
+                   !<INSTANTIATE <REST .EXP>>)>
+             (!.VAL !<INSTANTIATE <REST .EXP>>)>)
+        (T (<INSTANTIATE .EXP1> !<INSTANTIATE <REST .EXP>>))>   >>\f<SETG FALSE
+  <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> FALSE>  >>
+
+
+<SETG FORM
+  <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> FORM>  >>
+
+<SETG UNASSIGNED
+  <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> UNASSIGNED>  >>
+
+<SETG SEGMENT
+  <FUNCTION ("REST" 'A) <CHTYPE <EVAL .A> SEGMENT>  >>
+
+<SETG ACTOR
+  <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR>  >>
+
+<SETG ACTOR-FUNCTION
+  <FUNCTION ("ARGS" A) <CHTYPE .A ACTOR-FUNCTION>  >>
+
+<SETG INVOKE
+  <FUNCTION ("BIND" CUR AFORM OBJECT 
+             "OPTIONAL" (BOUNDARY <BOTTOM .OBJECT>) (OBLIGATORY T) (ENV <>)
+             "AUX" ACTOR)
+   <SPLICE .CUR .ENV>
+   <COND (<ATOM? <1 .AFORM>>
+          <SET ACTOR <AVAL <1 .AFORM>>>)
+         (<SET ACTOR <EVAL <1 .AFORM>>>)>
+   <COND (<==? <TYPE .ACTOR> ACTOR-FUNCTION>
+          <EVAL <FORM <CHTYPE .ACTOR FUNCTION>
+                      '.OBJECT
+                      '.BOUNDARY
+                      .OBLIGATORY
+                      !<REST .AFORM>>>)
+         (<==? <TYPE .ACTOR> ACTOR>
+          <ERROR ATTEMPT-TO-INVOKE-ACTOR>)
+         (<ERROR NON-INVOKABLE-TYPE>)>  >>
+
+
+<SETG AVAL
+  <FUNCTION (ATOM)
+   <COND (<GASSIGNED? .ATOM> <GVAL .ATOM>)
+         (<LVAL .ATOM>)>  >>
+
+
+<SETG ACTOR?
+  <FUNCTION (EXP)
+   <AND <ATOM? .EXP> <SET EXP <AVAL .EXP>>>
+   <MEMQ <TYPE .EXP> '(ACTOR ACTOR-FUNCTION)>  >>\f<SETG ACTORSUBST1
+  <FUNCTION AS (AFORM PURESWITCH
+                "AUX" (A1 <1 .AFORM>) (TP <TYPE .AFORM>) 
+                      (A2 <OR <EMPTY? <REST .AFORM>> <2 .AFORM>>))
+   <COND (<==? .A1 GIVEN>
+          <COND (<ASSIGNED? .A2>
+                 <SET .PURESWITCH T>
+                 <LVAL .A2>)
+                (T <SET .PURESWITCH <FALSE .A2>>
+                   .AFORM)>)         
+         (<==? .A1 ALTER>
+          <THSET .A2 ?()>
+          <SET .PURESWITCH <FALSE .A2>>
+          <CHTYPE (GIVEN .A2) .TP>)
+         (<==? .A1 VEL>
+          <PROG ((PAT <ANOTHERPAT <REST .AFORM> .PURESWITCH>))
+             <COND (<OR ..PURESWITCH
+                        <NOT <==? <TYPE .PAT> FORM>>>
+                    .PAT)
+                   (<CHTYPE .PAT .TP>)>>)
+         (<==? .A1 BE>
+          <OR <EVAL .A2> <FAIL>>
+          <CHTYPE '<?> .TP>)
+         (<==? .A1 ET>
+          <AND <EMPTY? <REST .AFORM>>
+               <EXIT .AS <CHTYPE '<?> .TP>>>
+          <REPEAT R ((PATS <REST .AFORM 2>) (SPATS ())
+                     (BEG ()) (P <>))
+             <COND (<EMPTY? <SET BEG <CHOMP PATS .BEG P>>>
+                    <SET .PURESWITCH <>>
+                    <EXIT .R <CHTYPE (ET !.SPATS) .TP>>)
+                   (<OR .P <NOT <EMPTY? .P>>>
+                    <SET .PURESWITCH .P>
+                    <SET A2 <1 .BEG>>
+                    <REPEAT RESTRICT ()
+                       <AND <EMPTY? .SPATS> <EXIT .RESTRICT <>>>
+                       <MATCH1 .A2 <1 .SPATS>>
+                       <SET SPATS <REST .SPATS>>  >
+                    <REPEAT ()
+                       <AND <EMPTY? <SET BEG <CHOMP PATS .BEG P>>>
+                            <EXIT .R .A2>>
+                       <MATCH1 .A2 <1 .BEG>>  >)
+                   (T <SET SPATS (<1 .BEG> !.SPATS)>)>  >)
+         (.AFORM)>   >>\f<SETG ANOTHERPAT
+  <FUNCTION (PATSVAL PURESWITCH
+             "AUX" (VAL1 <CLIP PATSVAL>))
+   <COND (<SET .PURESWITCH <MONAD? .VAL1>>
+           .VAL1)
+         (<==? <TYPE .VAL1> FORM>
+          <COND (<ACTOR? <1 .VAL1>>
+                 <ACTORSUBST1 .VAL1 .PURESWITCH>)
+                (<SET .PURESWITCH T>
+                 <EVAL <ACTORSUBST .VAL1>>)   >)
+         (T .VAL1)   >   >>
+
+
+<SETG CLIP
+  <FUNCTION (VAR "AUX" (VAL ..VAR))
+   <COND (<EMPTY? .VAL> <FAIL>)>
+   <PROG1 <1 .VAL> <SET .VAR <REST .VAL>>>   >>\f<SETG CHOMP
+ <FUNCTION CHOMP ("BIND" C VAR ENDVAR BEG PURESWITCH "OPTIONAL" (ENV <>)
+                  "AUX" (VAL ..VAR) VAL1)
+   <COND (<OR <EMPTY? .BEG>
+              <EMPTY? <SET BEG <REST .BEG>>>
+              <==? .BEG .VAL>>
+          <COND (<OR <MONAD? .VAL> <==? .VAL .ENDVAR>>
+                 <SET .PURESWITCH <>>
+                 <EXIT .CHOMP ()>)>
+          <THSET .VAR <REST .VAL>>
+          <COND (<SET .PURESWITCH <MONAD? <SET VAL1 <1 .VAL>>>>
+                 .VAL)
+                (<==? <TYPE .VAL1> FORM>
+                 <SPLICE .C .ENV>
+                 (<COND (<ACTOR? <1 .VAL1>>
+                         <ACTORSUBST1 .VAL1 .PURESWITCH>)
+                        (<SET .PURESWITCH T>
+                         <EVAL <ACTORSUBST .VAL1 >>)   >))
+                (<==? <TYPE .VAL1> SEGMENT>
+                 <SPLICE .C .ENV>
+                 <SET VAL1
+                      <COND (<ACTOR? <1 .VAL1>>
+                             <SET VAL1 <ACTORSUBST1 .VAL1 .PURESWITCH>>
+                             <OR <AND <OR ..PURESWITCH
+                                          <NOT <==? <TYPE .VAL1> SEGMENT>>>
+                                      .VAL1>
+                                 (.VAL1)>)
+                            (<SET .PURESWITCH T>
+                             <EVAL <ACTORSUBST .VAL1>>)   >>
+                 <COND (<EMPTY? .VAL1>
+                        <SET BEG ()>
+                        <SET .VAR <SET VAL <REST .VAL>>>
+                        <AGAIN .CHOMP>)
+                       (T .VAL1)>)
+                (T .VAL)>)
+         (.BEG)>   >>
+
+<SETG RESET
+ <FUNCTION (VAR)
+   <FAILPOINT ((VAL <RLVAL .VAR>)) <> ()
+      <SET .VAR <RLVAL VAL>>
+      <FAIL>>  >>
+
+<SETG PROG1
+ <FUNCTION ("REST" A) <1 .A>   >>\f<SETG ACTORSUBST
+ <FUNCTION A ("BIND" C EXP "OPTIONAL" (ENV <>)
+              "AUX" (PURE <>) TP EXP1)
+   <OR <MULTILEVEL .EXP> <EXIT .A .EXP>>
+   <SPLICE .C .ENV>
+   <COND (<ACTORFORM? <SET EXP1 <1 .EXP>>>
+          <SET TP <TYPE .EXP1>>
+          <SET EXP1 <ACTORSUBST1 .EXP1 PURE>>
+          <AND <==? .TP SEGMENT>
+               <OR .PURE <NOT <==? <TYPE .EXP1> FORM>>>
+               <EXIT .A
+                     <<CONSTRUCTOR <TYPE .EXP>>
+                      !.EXP1
+                      !.<ACTORSUBST <REST .EXP>>>>>)
+         (T <SET EXP1 <ACTORSUBST .EXP1>>)   >
+   <<CONSTRUCTOR <TYPE .EXP>> .EXP1 !.<ACTORSUBST <REST .EXP>>>   >>
+
+
+<SETG MULTILEVEL
+ <FUNCTION (OBJECT)
+   <AND <NOT <MONAD? .OBJECT>>
+        <MEMQ <TYPE .OBJECT> '(LIST FORM VECTOR SEGMENT VECTOR)>>   >>
+
+
+<SETG ACTORFORM?
+ <FUNCTION (EXP)
+   <AND <MEMQ <TYPE .EXP> '(FORM SEGMENT)>
+        <NOT <EMPTY? .EXP>>
+        <ACTOR? <1 .EXP>>>  >>
+
+
+<SETG GIVEN
+ <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY VAR
+                  "AUX" (VAL <RLVAL .VAR>))
+   <AND <==? <TYPE <RLVAL VAL>> UNASSIGNED>
+        <REPEAT R ((V <CHTYPE <RLVAL VAL> LIST>))
+           <AND <EMPTY? .V> <EXIT .R <>>>
+           <SET BOUNDARY <IS2 <1 <1 .V>> .OBJECT .BOUNDARY .OBLIGATORY <2 <1 .V>>>>
+           <SET OBLIGATORY T>
+           <SET V <REST .V>>  >>
+   <COND (<ASSIGNED? .VAR>
+          <COND (<OR <MONAD? .OBJECT> .OBLIGATORY>
+                 <OR <=? ..VAR .OBJECT> <FAIL>>)
+                (T
+                 <SET BOUNDARY <PREFIX1 ..VAR () .OBJECT .BOUNDARY>>)>)
+         (T <THSET .VAR
+                   <UPTO .OBJECT
+                         <COND (<OR <MONAD? .OBJECT> .OBLIGATORY>
+                                .BOUNDARY)
+                               (T <SET BOUNDARY 
+                                       <ANOTHER .OBJECT .BOUNDARY>>)>>>)>
+   .BOUNDARY  >>
+
+
+
+<SETG BE
+ <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY PRED)
+   <OR .PRED <FAIL>>
+   <COND (.OBLIGATORY .BOUNDARY)
+         (T <ANOTHER .OBJECT .BOUNDARY>)>  >>
+
+
+
+<SETG ?
+ <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY "OPTIONAL" (N <>))
+   <COND (.OBLIGATORY
+          <OR <NOT .N> <==? .N <BLENGTH .OBJECT .BOUNDARY>> <FAIL>>
+          .BOUNDARY)
+         (.N
+          <COND (<G? .N <BLENGTH .OBJECT .BOUNDARY>>
+                 <FAIL>)
+                (T <REST .OBJECT .N>)>)
+         (T <ANOTHER .OBJECT .BOUNDARY>)>  >>
+
+
+
+<SETG ALTER
+ <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY VAR)
+   <THSET .VAR
+          <UPTO .OBJECT
+                <COND (<OR <MONAD? .OBJECT> .OBLIGATORY>
+                       .BOUNDARY)
+                      (T <SET BOUNDARY
+                              <ANOTHER .OBJECT .BOUNDARY>>)>>>
+   .BOUNDARY  >>
+
+
+<SETG VEL
+ <ACTOR-FUNCTION (OBJECT BOUNDARY OBLIGATORY "ARGS" A)
+   <ERROR VEL-UNDER-CONSTRUCTION> >>\f<SETG ANOTHER
+ <FUNCTION (OBJ BOUND)
+   <FAILPOINT FP ()
+     .OBJ ()
+     <AND <==? .OBJ .BOUND> <FAIL>>
+     <RESTORE .FP <SET OBJ <REST .OBJ>>>>  >>
+
+
+
+<SETG HACKPAT
+ <FUNCTION P (PAT ENDV KV BETAV)
+   <REPEAT ((END .PAT) (KS 0) (BETAS 0))
+      <COND (<EMPTY? .PAT>
+             <SET .KV .KS> <SET .BETAV .BETAS>
+             <SET .ENDV .END>  <EXIT .P <>>)
+            (<==? <TYPE <1 .PAT>> SEGMENT>
+             <SET KS <+ .KS .BETAS>>
+             <SET BETAS 0>
+             <SET END <REST .PAT>>)
+            (T <SET BETAS <+ .BETAS 1>>)>
+      <SET PAT <REST .PAT>>  >  >>
+
+
+<SETG POST
+ <FUNCTION (L LBOUND K BETA "AUX" (KOUNT <BLENGTH .L .LBOUND>))
+   <AND <G? <+ .K .BETA> .KOUNT>
+        <FAIL>>
+   <REST .L <- .KOUNT .BETA>>  >>
+
+
+
+<SETG BLENGTH
+ <FUNCTION BL (L LB "AUX" (K 0))
+   <COND (<==? .L .LB> .K)
+         (T <SET L <REST .L>>
+            <SET K <+ .K 1>>
+            <AGAIN .BL>)>  >>
+
+<SETG PREFIX1
+ <FUNCTION P (L1 TERM1 L2 TERM2)
+   <COND (<OR <EMPTY? .L1> <==? .L1 .TERM1>>
+          <EXIT .P .L2>)
+         (<==? .L2 .TERM2> <FAIL>)>
+   <OR <=? <1 .L1> <1 .L2>> <FAIL>>
+   <SET L1 <REST .L1>>   <SET L2 <REST .L2>>
+   <AGAIN .P>  >>
+
+
+<SETG CONSTRUCTOR
+ <FUNCTION (TYPE)
+   <GET .TYPE 'CONSTRUCTOR>   >>
+
+
+<PUT LIST CONSTRUCTOR ,CONSL>
+<PUT FORM CONSTRUCTOR ,FORM>
+<PUT VECTOR  CONSTRUCTOR ,CONSV>
+<PUT SEGMENT CONSTRUCTOR ,SEGMENT>
+<PUT UVECTOR CONSTRUCTOR ,CONSU>\f<SETG IS1
+ <FUNCTION S ("BIND" C PAT EXP
+              "OPTIONAL" (BOUND <BOTTOM .EXP>) (OBLIGATORY T) (ENV <>)
+              "AUX" (BEG ()) PURE ENDP BETA ENDE K ENDP1)
+   <COND (<EMPTY? .PAT> <EXIT .S <OR <EMPTY? .EXP> <FAIL>>>)
+         (<MONAD? .PAT>
+          <EXIT .S <OR <=? .PAT .EXP> <FAIL>>>)
+         (<MONAD? .EXP>
+          <OR <EMPTY? .EXP> <FAIL>>)>
+   <SPLICE .C .ENV>
+   <SET ENDP1 <BOTTOM .PAT>>
+   <REPEAT R ()
+      <COND (<EMPTY? <THSET BEG <CHOMP PAT .ENDP1 .BEG PURE>>>
+             <EXIT .S <GOTEND .EXP .BOUND .OBLIGATORY>>)
+            (.PURE
+             <THSET EXP <PREFIX1 .BEG .PAT .EXP .BOUND>>
+             <SET BEG ()>)
+            (<==? <TYPE <1 .BEG>> SEGMENT>
+             <EXIT .R <>>)
+            (T <IS2 <1 .BEG> <1 .EXP>>
+               <THSET EXP <REST .EXP>>)>  >
+   <HACKPAT .PAT ENDP K BETA>
+   <SET ENDE <POST .EXP .BOUND .K .BETA>>
+   <REPEAT R ()
+      <COND (.PURE
+             <THSET EXP <PREFIX1 .BEG .PAT .EXP .ENDE>>
+             <SET BEG ()>)
+            (<==? <TYPE <1 .BEG>> SEGMENT>
+             <THSET EXP <INVOKE <1 .BEG>
+                                .EXP
+                                .ENDE
+                                <AND <==? .PAT .ENDP> .OBLIGATORY>>>)
+            (<==? .EXP .ENDE> <FAIL>)
+            (T <IS2 <1 .BEG> <1 .EXP>>
+               <THSET EXP <REST .EXP>>)>
+      <COND (<EMPTY? <THSET BEG <CHOMP PAT .ENDP .BEG PURE>>>
+             <EXIT .R <OR <==? .EXP .ENDE> <NOT .OBLIGATORY> <FAIL>>>)>   >
+   <THSET ENDE .EXP>
+   <REPEAT ()
+      <COND (<EMPTY? <THSET BEG <CHOMP ENDP .ENDP1 .BEG PURE>>>
+             <EXIT .S .ENDE>)
+            (.PURE
+             <OR <=? <1 .BEG> <1 .ENDE>> <FAIL>>)
+            (T <IS2 <1 .BEG> <1 .ENDE>>) >
+      <SET ENDE <REST .ENDE>>  >  >>\f<SETG GOTEND
+ <FUNCTION (EXP BOUND OBLIGATORY)
+   <OR <==? .EXP .BOUND>
+       <NOT .OBLIGATORY>
+       <FAIL>>
+   .EXP  >>
+
+
+<SETG IS2
+ <FUNCTION (PAT EXP "OPTIONAL" (BOUND <BOTTOM .EXP>) (OBLIGATORY T) (ENV <>))
+   <COND (<==? <TYPE .PAT> FORM>
+          <INVOKE .PAT .EXP .BOUND .OBLIGATORY .ENV>)
+         (<IS1 .PAT .EXP .BOUND .OBLIGATORY .ENV>)  >  >>
+
+
+<SETG UPTO
+ <FUNCTION (EXP1 EXP2)
+   <COND (<MONAD? .EXP1>
+          .EXP1)
+         (<==? .EXP1 .EXP2>
+          ())
+         ((<1 .EXP1> !<UPTO <REST .EXP1> .EXP2>))>  >>
+
+
+<SETG IS
+ <FUNCTION S ('PAT EXP "AUX" (PURE <>))
+   <COND (<ACTORFORM? .PAT>
+          <SET PAT <ACTORSUBST1 .PAT PURE>>
+          <AND .PURE
+               <EXIT .S <=? .PAT .EXP>>>
+          <FAILPOINT ()
+             <PROG1 T <INVOKE .PAT .EXP>>
+             () <>>)
+         (T <FAILPOINT ()
+               <PROG1 T <IS1 .PAT .EXP>>
+               () <>>)>  >>
+
+
+<SETG BOTTOM
+ <FUNCTION (THING)
+   <COND (<MONAD? .THING> <>)
+         (<==? <TYPE .THING> LIST> ())
+         (T <REST .THING <LENGTH .THING>>)>  >>\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/pfunct.12 b/MUDDLE/pfunct.12
new file mode 100644 (file)
index 0000000..273feed
--- /dev/null
@@ -0,0 +1,26 @@
+<SETG PFUNCT <FUNCTION (OBLST CHAN)
+       <PROG (A B C D E (F 0))
+               <SET A 1>
+               <SET B <LENGTH .OBLST>>
+
+L2             <SET C <.A .OBLST>>
+L1             <COND (<=? .C ()> <GO FOO>)>
+
+               <COND (<GASSIGNED? <SET D <1 .C>>>
+                       <SET E <TYPE <GVAL .D>>>
+                       <COND (<OR <=? .E SUBR><=? .E FSUBR>>
+                               <PRIN1 .D .CHAN>
+                               <PRINC "  " .CHAN>
+                               <PRIN1 .E .CHAN>
+                               <COND (<=? 5 <SET F <+ .F 1>>> <SET F 0> <TERPRI .CHAN><TERPRI .CHAN>)
+                                       (ELSE <PRINC "  " .CHAN>
+                                       <SET FO <FLATSIZE .D 24>>
+                                       <COND (<1? .FO> <PRINC "                " .CHAN>)
+                                               (<L? .FO 10><PRINC "    " .CHAN>)>)>)>)>
+               <SET C <REST .C>>
+               <GO L1>
+FOO            <SET A <+ .A 1>>
+               <COND (<1? <- .A .B>> <RETURN "DONE">)>
+               <GO L2>
+>>>
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/pprint.1 b/MUDDLE/pprint.1
new file mode 100644 (file)
index 0000000..b408a23
--- /dev/null
@@ -0,0 +1,401 @@
+ "MUDDLE PRETTY-PRINT, FRAME-SCANNER, AND OTHER ROUTINES"
+<PRINC "/PPRINT/FRAMES">
+<BLOCK (<ROOT>)>
+
+"These atoms are placed in the ROOT oblist to allow general
+       access to their functions" 
+M
+<COND (<NOT <GASSIGNED? NULL!->> <SETG NULL <INTERN <ATOM <ASCII 127>> <GET INITIAL OBLIST>>>)>
+PPRINF
+SPECBEF
+SPECAFT
+FORMS
+PPRINT
+EPRINT
+FRAMES
+FRATM
+FRM
+INDENT-TO
+LINPOS
+LINLNT
+PAGPOS
+PAGLNT
+QUICKPRINT
+PP     ;"OBLIST"
+
+<ENDBLOCK>
+
+\f<BLOCK (<MOBLIST PP 37> <ROOT>)>
+
+
+<SETG FRAMES   ;"Prints FUNCT and ARGS for -n- frames down" 
+    <FUNCTION ("OPTIONAL" (HOW-MANY 999) (FIRST 1))
+       <SPEEDSEL>
+       <SET SPECBEF 0>
+       <SET SPECAFT 0> ;"To make compatible with MEDDLE."
+       <REPEAT ((F <FRM .FIRST>) M (COMELE ,COMPONENTS))
+               <COND (<0? .HOW-MANY>  <RETURN "FUNCT---ARGS">)
+                       (<==? <FUNCT .F> TOPLEVEL> <RETURN TOPLEVEL>)>
+               <AND <==? <TYPE <VALUE <FUNCT .F>>> FSUBR>
+                       <==? <FUNCT <FRAME .F>> EVAL>
+                       <==? <TYPE <1 <ARGS <FRAME .F>>>> FORM>
+                       <==? <FUNCT .F> <1 <1 <ARGS <FRAME .F>>>>>
+                               <GO SKIPIT>>
+               <PRINT .FIRST>
+               <PRINC <FUNCT .F>>
+               <PRINC "        ">
+               <SET M 0>
+               <FORMS  ;"Calling an internal PPRINT routine"   <ARGS .F>>
+       SKIPIT  <SET F <FRAME .F>>
+               <SET HOW-MANY <- .HOW-MANY 1>>
+               <SET FIRST <+ .FIRST 1>>
+       >>>
+
+<DEFINE FRATM!- ("OPTIONAL" (HOW-MANY 9999) (FIRST 1))
+       <REPEAT ((F <FRM .FIRST>) (DEPTH!-FR 1) AF)
+               <COND (<L? .HOW-MANY .DEPTH!-FR> <RETURN "FRAME---FUNCTION">)
+                     (<==? <FUNCT .F> TOPLEVEL> <RETURN TOPLEVEL>)>
+               <AND    <==? <FUNCT .F> EVAL>
+                       <1? <LENGTH <ARGS .F>>>
+                       <==? <TYPE <SET AF <1 <ARGS .F>>>> FORM>
+                       <==? <TYPE <1 .AF>> ATOM>
+                       <==? <TYPE <OR <AND <GASSIGNED? <1 .AF>> ,<1 .AF>>
+                                       <AND <ASSIGNED? <1 .AF> .F> <LVAL <1 .AF> .F>>>>
+                               FUNCTION>
+                       <PRINT .DEPTH!-FR>
+                       <PRINC !"       >
+                       <PRIN1 <1 .AF>>>
+               <SET F <FRAME .F>>
+               <SET DEPTH!-FR <+ .DEPTH!-FR 1>> >>
+
+<SETG FRM <FUNCTION (I)
+       <REPEAT ((F <FRAME>))
+               <COND   (<0? .I> <RETURN .F>)
+                       (<==? <FUNCT .F> TOPLEVEL>
+                        <PRINT .I>
+                        <PRINC "FRAMES FROM ">
+                        <RETURN .F>)>
+               <SET F <FRAME .F>>
+               <SET I <- .I 1>>>>>
+
+<SETG LINPOS   ;"Line position selector"       14>
+<SETG LINLNT   ;"Line length selector"         13>
+<SETG PAGPOS   ;"Page position selector"       16>
+<SETG PAGLNT   ;"Page length selector"         15>
+<SET QUICKPRINT        ;"Speed selector."              T>
+\f<SETG TABS    ;"The n'th element is a string of n-1 tab characters"
+     ["" "     " "             " "                     "
+"                              "
+"                                      "
+"                                              "
+"                                                      "
+"                                                              "
+"                                                                      "
+"                                                                              "
+"                                                                                      "
+"                                                                                              "]>
+
+
+
+
+<SETG SPACES   ;"The n'th element is a string of n-1 space characters"
+     ["" " " "  " "   " "    " "     " "      " "       "]>
+
+
+
+
+
+
+<SETG INDENT-TO <FUNCTION ( N "EXTRA" (NOW <LINPOS .OUTCHAN>))
+                       ;"Print tabs and spaces to get to column -n-"
+       <COND (<G? .N .NOW>
+               <PRINC <<- </ .N 8> </ .NOW 8 > -1> ,TABS>>
+               <PRINC <<- .N <LINPOS .OUTCHAN> -1> ,SPACES>>)>>>
+\f<SETG COMPONENTS      ;"Print the components of a structure in a column" 
+      <FUNCTION (L "OPTIONAL" (OM <+ .M 1>) (STOP 0))
+       <REPEAT ((N <LINPOS .OUTCHAN>) (M 0))
+               <AND <EMPTY? <REST .L>> <SET M .OM>>
+               <FORMS <1 .L>>
+               <COMMENTS>
+               <COND (<EMPTY? <SET L <REST .L>>><RETURN DONE>)>
+               <AND <==? .STOP .L> <RETURN DONE>>
+               <TERPRI>
+               <INDENT-TO .N>>>>
+
+<SETG ELEMENTS ;"Print the components of a structure in a line."
+     <FUNCTION (L "OPTIONAL" (M <+ .M 1>) (STOP 0))
+       <COND (<EMPTY? .L>)
+             (.QUICKPRINT
+               <REPEAT ()
+                       <PRIN1 <1 .L>>
+                       <AND <OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN T>>
+                       <PRINC !" >>)
+             (ELSE
+               <REPEAT ((N <LINPOS .OUTCHAN>) COM)
+                       <FORMS <1 .L>>
+                       <SET COM <COMMENTS>>
+                       <COND (<OR <EMPTY? <SET L <REST .L>>> <==? .L .STOP>> <RETURN DONE>)>
+                       <COND (.COM <TERPRI> <INDENT-TO .N>)>
+                       <PRINC !" >>)>>>
+
+
+
+<SETG SLOWFORMS <FUNCTION (L "AUX" (COMELE ,COMPONENTS))       ;"Pprint an object."
+       <COND   (<MONAD? .L> <PRIN1 .L>)                        ;"If its a MONAD, just print it."
+               (ELSE
+                <COND  (<FLATSIZE .L <MIN 59 <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>>>
+                         <SET COMELE ,ELEMENTS>)> ;"If it fits, use ELEMENTS, else COMPONENTS."
+                <<GET <TYPE .L> PPRINT ;"Snarfed from BKD."
+                       '#FUNCTION (()
+                               <PRINC "#">
+                               <PRIN1 <TYPE .L>>
+                               <SLOWFORMS <CHTYPE .L <PRIMTYPE .L>>>)>>)>>>
+
+
+<SETG FASTFORMS        ;"Pprint one item at the current page location"
+      <FUNCTION (L)
+       <COND (<MONAD? .L> <PRIN1 .L>)
+             (<FLATSIZE .L <MIN 59 <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>>>
+               <PRIN1 .L>)
+             (ELSE <<GET <TYPE .L> PPRINT
+\r                 '#FUNCTION ( ()
+                               <PRINC "#">
+                               <PRIN1 <TYPE .L>>
+                               <FASTFORMS <CHTYPE .L <PRIMTYPE .L>>>)>>)>>>
+
+\f<SETG COMMENTS <FUNCTION ("AUX" MARG CMNT) ;"Prints comments.  If no comment, returns false"
+       <COND (<SET CMNT <GET <REST .L 0> COMMENT>>
+               <SET MARG <COND (<EMPTY? <REST .L>> .M) (0)>>
+               <COND (<NOT <FLATSIZE .CMNT <- <LINLNT .OUTCHAN>
+                                               <LINPOS .OUTCHAN>
+                                               .MARG
+                                               2>>>
+                               <TERPRI>)>
+               <INDENT-TO <- <MAX 2 <- <LINLNT .OUTCHAN>
+                                       <FLATSIZE .CMNT 9999>
+                                       .MARG>>
+                               2>>
+               <PRINC " ;">
+               <PRIN1 .CMNT>)>>>
+
+
+<SETG SPEEDSEL <FUNCTION ()    ;"Check QUICKPRINT and select speed."
+       <OR <ASSIGNED? QUICKPRINT> <SET QUICKPRINT T>>
+       <SETG FORMS <COND (.QUICKPRINT ,FASTFORMS)
+                         (ELSE ,SLOWFORMS)>>>>
+\f"The following functions define the way to pprint a given data type"
+"They are PUT on the appropriate type name"
+"FORM is a special case - see next page."
+
+<PUT LIST PPRINT
+       <FUNCTION () <PRINC "("> <.COMELE .L > <PRINC ")">>>
+
+<PUT VECTOR PPRINT
+       <FUNCTION () <PRINC "[">  <.COMELE .L > :L<PRINC "]">>>
+
+<PUT FUNCTION PPRINT
+       <FUNCTION () <PRINC "#FUNCTION (" >
+                    <FUNCBODY .L <LINPOS .OUTCHAN>>
+                    <PRINC ")">>>
+
+
+<PUT UVECTOR PPRINT
+       <FUNCTION ()    <PRINC %<STRING !"! !"[>>
+                       <.COMELE .L <+ .M 2>>
+                       <PRINC %<STRING !"! !"]>>>>
+
+<PUT SEGMENT PPRINT
+       <FUNCTION () <PRINC !"! > <FORMS <CHTYPE .L FORM>>>>
+
+<PUT STRING PPRINT
+       <FUNCTION () <PRIN1 .L>>>
+
+<PUT TUPLE PPRINT <GET VECTOR PPRINT>>
+
+<PUT ARGUMENTS PPRINT <GET VECTOR PPRINT>>
+
+<PUT LOCD PPRINT <FUNCTION () <PRINC "#LOCD "> <FORMS <IN .L>>>>
+
+<PUT RSUBR PPRINT <FUNCTION ()
+       <PRINC "<RSUBR '">
+       <SET M <+ .M 1>>
+       <<GET VECTOR PPRINT>>
+       <PRINC ">">>>
+\f<DEFINE FUNCBODY FBA (L P "AUX" (M <+ .M 1>) (TEM %<>))
+       <COND (<EMPTY? .L>)
+             (ELSE
+               <COND (<==? <TYPE <1 .L>> ATOM>
+                       <OR <CHECK <1 .L> -1> <TERPRI> <INDENT-TO .P>>
+                       <PRIN1 <1 .L>> <PRINC !" >
+                       <AND <EMPTY? <SET L <REST .L>>> <EXIT .FBA T>>)>
+               <COND (<==? <TYPE <1 .L>> LIST> <SET TEM <PRINARGL <1 .L> .P>> <SET L <REST .L>>)>
+               <COND (.TEM <COMPONENTS .L .M>)
+                     (<CHECK .L -1> <PRINC !" > <ELEMENTS .L .M>)
+                     (ELSE <TERPRI> <INDENT-TO .P> <COMPONENTS .L .M>)>)>>
+
+<DEFINE CHECK (IT FUDGE) <FLATSIZE .IT <MIN <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M .FUDGE>>>>
+
+<DEFINE PRINARGL (L PB "AUX" POS Q (OL .L))
+       <COND (<CHECK .L -2> <PRINC "("> <ELEMENTS .L> <PRINC ")"> %<>)
+             (ELSE
+               <OR <CHECK <SET Q <ABUNCH L>> -1> <TERPRI> <INDENT-TO .PB>>
+               <PRINC "(">
+               <SET POS <LINPOS .OUTCHAN>>
+               <REPEAT ((NOTFIRST %<>) (N <+ .M 1>))
+                       <OR .Q <RETURN T>>
+                       <COND (<==? <TYPE .Q> STRING>
+                               <COND (.NOTFIRST <TERPRI> <INDENT-TO .POS>)>
+                               <PRIN1 .Q>
+                               <PRINC !" >)
+                             (<CHECK .Q -2> <ELEMENTS .OL .N .L>)
+                             (ELSE <COMPONENTS .OL .N .L>)>
+                       <SET NOTFIRST T>
+                       <SET OL .L>
+                       <SET Q <ABUNCH L>>>
+               <PRINC ")">
+               <TERPRI>
+               <INDENT-TO .PB>)>>
+
+<DEFINE ABUNCH (ATM "AUX" T)
+       <COND (<EMPTY? ..ATM> %<>)
+             (<==? <TYPE <1 ..ATM>> STRING>
+               <SET T <1 ..ATM>>
+               <SET .ATM <REST ..ATM>>
+               .T)
+             (ELSE
+               <STACKFORM ,LIST .T
+                       <COND (<EMPTY? ..ATM> %<>)
+                             (<==? <TYPE <1 ..ATM>> STRING> %<>)
+                             (ELSE <SET T <1 ..ATM>> <SET .ATM <REST ..ATM>>)>>)>>
+\f"How to print FORM and its special cases."
+"Special cases for FORM are PUT on the appropriate function."
+
+<PUT FORM PPRINT <FUNCTION () <<GET <1 .L> SPECFORM ',NORMFORM>>>>
+
+<DEFINE NORMFORM ("AUX" (PN <+ 1 <LINPOS .OUTCHAN>>))
+                       <PRINC "<" >
+                       <FORMS <1 .L>>
+                       <COND (<==? .COMELE ,ELEMENTS> <COMEND>)
+                             (<FORMAHEAD .L> <COMMENTS> <TERPRI> <INDENT-TO .PN>
+                               <COND (<FLATSIZE <REST .L> <- <LINLNT .OUTCHAN>
+                                                               <LINPOS .OUTCHAN>
+                                                               .M 3>>
+                                               <ELEMENTS <REST .L>>)
+                                     (T <COMPONENTS <REST .L>>)>)
+                             (T <COMEND>)>
+                       <PRINC ">">>
+
+
+<SETG COMEND <FUNCTION ("AUX" (PPN <LINPOS .OUTCHAN>))
+       <COND (<COMMENTS> <TERPRI> <INDENT-TO .PPN>)>
+       <COND (<EMPTY? <REST .L>>)
+             (<PRINC !" > <.COMELE <REST .L>>)> >>
+
+
+<DEFINE FORMAHEAD (ML "AUX" (AVSP <- <LINLNT .OUTCHAN> <LINPOS .OUTCHAN> .M>))
+       <COND (<AND <==? <TYPE <1 .ML>> FORM>
+                   <NOT <EMPTY? <REST .ML>>>
+                   <NOT <FLATSIZE <1 .ML> <MIN 59 .AVSP>>>>
+              T)
+             (ELSE
+              <REPEAT ()
+                 <COND (<L? <LENGTH .ML> 2> <RETURN #FALSE ()>)
+                       (<NOT <==? <TYPE <2 .ML>> FORM>> <RETURN #FALSE ()>)
+                       (<FLATSIZE <1 <2 .ML>>
+                                  <- <SET AVSP
+                                          <- .AVSP
+                                             3
+                                             <FLATSIZE <1 .ML> 99999999>>>
+                                     3>>
+                        <SET ML <2 .ML>>)
+                       (ELSE <RETURN T>)>>)>>
+
+
+<PUT LVAL SPECFORM <FUNCTION () <DAMMIT !".>>>
+
+<PUT GVAL SPECFORM <FUNCTION () <DAMMIT !",>>>
+
+<PUT QUOTE SPECFORM <FUNCTION () <DAMMIT !"'>>>
+
+<DEFINE DAMMIT (Q)
+       <COND (<==? 2 <LENGTH .L>>
+               <PRINC .Q>              ;"No fucking comments printed on . , or ' "
+               <COND   (<EMPTY? <REST .L>>)
+                       (<.COMELE <REST .L>>)>)
+             (ELSE <NORMFORM>)>>
+
+<PUT FUNCTION SPECFORM <FUNCTION ()
+       <PRINC "<FUNCTION ">
+       <FUNCBODY <REST .L> <- <LINPOS .OUTCHAN> 2>>
+       <PRINC ">">>>
+
+<PUT DEFINE SPECFORM <FUNCTION ()
+       <PRINC "<DEFINE ">
+       <SET POS <LINPOS .OUTCHAN>>
+       <COND (<EMPTY? <SET L <REST .L>>>)
+             (ELSE
+               <PRIN1 <1 .L>>
+               <PRINC !" >
+               <FUNCBODY <REST .L> .POS>)>
+       <PRINC ">">>>
+
+<PUT REPEAT SPECFORM <FUNCTION ("AUX" (CPOS <+ <LINPOS .OUTCHAN> 3>))
+       <PRINC "<REPEAT ">
+       <FORMS <2 .L>>
+       <TERPRI>
+       <INDENT-TO .CPOS>
+       <.COMELE <REST .L 2>>
+       <PRINC ">">>>
+\f<SETG PPRINT <FUNCTION PPRINT  (L "OPTIONAL" (OUTCHAN .OUTCHAN))
+       <COND (<NOT <==? <TYPE .L> ATOM>> <EPRINT .L>)
+             (<GASSIGNED? .L>
+               <COND (<==? <TYPE ,.L> FUNCTION>
+                       <EPRINT <FORM DEFINE .L !,.L>>)
+                     (<==? <TYPE ,.L> RSUBR>
+                       <EPRINT <FORM SETG .L <FORM RSUBR <FORM QUOTE <CHTYPE ,.L VECTOR>>>>>)
+                     (ELSE <EPRINT <FORM SETG .L <FORM QUOTE ,.L>>>)>)
+             (<AND <BOUND? .L> <ASSIGNED? .L>>
+               <EPRINT
+                <FORM SET .L
+                            <COND (<==? <TYPE ..L> FUNCTION>
+                                       <FORM FUNCTION !..L>)
+                                  (<==? <TYPE ..L> RSUBR>
+                                       <FORM RSUBR <CHTYPE ..L VECTOR>>)
+                                  (ELSE <FORM QUOTE ..L>)>>>)
+             (ELSE <PRINT .L> #FALSE ("NAKED ATOM?"))>>>
+
+<SETG EPRINT <FUNCTION (L "EXTRA" (M 0) (COMELE ,COMPONENTS))
+       <SPEEDSEL>
+       <TERPRI>
+       <FORMS .L>
+       <TERPRI>
+       ,NULL   ;"Null atom returned" >>
+
+<DEFINE PPRINF FACT (INF "OPTIONAL" (OUTF ("" "" "TPL"))
+                       "AUX" (INCH <OPEN  "READ" !.INF>)
+                               OUTCH NULLO)
+       <OR .INCH <EXIT .FACT "BAD FILE NAME?">>
+       <PUT <SET OUTCH <OPEN "PRINT" !.OUTF>> 13 100>
+       <PUT <SET NULLO <OPEN "PRINT" "" "" "NUL">> 13 100>
+       <REPEAT ((BOTH (<PUT .OUTCH 15 99999> <PUT .NULLO 15 99999>))
+                 Q)
+               <PPRINT <SET Q <READ '<RETURN T> .INCH>>
+                       <PUT .NULLO 16 <16 .OUTCH>>>
+               <AND <G? <16 .NULLO> 58> <PRINC <ASCII 12> .BOTH>>
+               <PPRINT .Q .OUTCH>>
+       <CLOSE .INCH>
+       <CLOSE .OUTCH>
+       <CLOSE .NULLO>
+       "DONE">
+
+
+
+<ENDBLOCK>
+
+
+
+<COND (<LOOKUP "PPRINT" <1 .OBLIST>> <SETG PPRINT ,PPRINT!-> <REMOVE PPRINT>)>
+<COND (<LOOKUP "FRAMES" <1 .OBLIST>> <SETG FRAMES ,FRAMES!-> <REMOVE FRAMES>)>
+<COND (<LOOKUP "FRM" <1 .OBLIST>> <SETG FRM ,FRM!-> <REMOVE FRM>)>
+<COND (<LOOKUP "PPRINF" <1 .OBLIST>> <SETG PPRINF ,PPRINF!-> <REMOVE PPRINF>)>
+\f\f\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ð`Á\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ð`Á\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ð`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\að`Á\83\a
\ No newline at end of file
diff --git a/MUDDLE/ptest.13 b/MUDDLE/ptest.13
new file mode 100644 (file)
index 0000000..f566d4a
--- /dev/null
@@ -0,0 +1,49 @@
+<SETG FRAMEN 
+  <FUNCTION (N)
+   <COND (<0? .N> <FRAME>)
+         (T <FRAME <FRAMEN <- .N 1>>>)>>>\e
+
+
+<SETG PATH 
+ <FUNCTION TL (START FINISH)
+   <PROG ((VAL <FAILPOINT () <PATH1 .START .FINISH ()>
+                    ()
+                    <EXIT .TL <>>   >))
+    <FINALIZE .TL>
+    <RETURN .VAL>>>>\e
+
+
+<SETG PATH1
+ <FUNCTION  (START FINISH AVOID)
+   <COND (<==? .START .FINISH>
+          (.FINISH))
+         (<MEMBER .START .AVOID>
+          <FAIL>)
+         (T (.START 
+             !<PATH1
+               <FAILPOINT FP (N (NODES <GET .START CONNECTED>))
+                        <FAIL> ()
+                        <COND (<EMPTY? .NODES> <FAIL>)
+                              (<SET N <1 .NODES>>
+                               <SET NODES <REST .NODES>>
+                               <RESTORE .FP .N>)>   >
+               .FINISH
+               (.START !.AVOID)>))>>   >\e
+
+
+<PUT ALPHA CONNECTED (B D K)>\e
+<PUT B CONNECTED (ALPHA I C)>\e\r\r
+<PUT I CONNECTED (B H J)>\e
+<PUT H CONNECTED (I)>\e
+<PUT J CONNECTED (I)>\e
+<PUT C CONNECTED (B G D)>\e
+<PUT G CONNECTED (C)>\e
+<PUT D CONNECTED (ALPHA C F)>\e
+\r<PUT F CONNECTED (D)>\e
+<PUT K CONNECTED (ALPHA M L)>\e
+<PUT M CONNECTED (K L N O)>\e
+<PUT L CONNECTED (K M)>\e
+<PUT N CONNECTED (M)>\e
+<PUT O CONNECTED (M P OMEGA)>\e
+<PUT P CONNECTED (O)>\e
+<PUT OMEGA CONNECTED (O)>\e\f\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/ptrace.7 b/MUDDLE/ptrace.7
new file mode 100644 (file)
index 0000000..3ffdc60
--- /dev/null
@@ -0,0 +1,114 @@
+<DEFINE TRACE
+ <FUNCTION ("REST" 'SPECS)
+   <MAPCAR ,TRACE1 .SPECS>   >>
+
+
+<DEFINE UNTRACE 
+ <FUNCTION ("REST" PROCNS "AUX" OTYP)
+   <MAPCAR 
+       #FUNCTION ((PROCN)
+                  <SET OTYP <TYPE ,.PROCN>>
+                  <SETG .PROCN <2 <1 <LAST <1 ,.PROCN>>>>>
+                  <COND (<==? .OTYP ACTOR-FUNCTION>
+                         <SETG .PROCN <CHTYPE ,.PROCN ACTOR-FUNCTION>>)   >
+                  .PROCN)
+       .PROCNS>  >>\f<DEFINE TRACE1
+ <FUNCTION TR1 (SPEC "AUX" PROCN ARGL PROC SPEC1)
+   <COND (<ATOM? .SPEC>
+          <SET SPEC (.SPEC EN '<DISPLAY .*ARGS> EX '<DISPLAY .*VAL>)>)   >
+   <SET PROCN <1 .SPEC>>
+   <OR <MEMQ <TYPE <SET PROC ,.PROCN>> '(SUBR FSUBR FUNCTION ACTOR-FUNCTION)>
+       <.TR1 <ERROR MEANINGLESS-TRACE-REQUEST .PROCN>>>
+   <SETG .PROCN
+    <CHTYPE ((!<SET ARGL <ARGDECLS .PROC>>
+              "AUX" !<COND (<MEMQ <TYPE .PROC> '(FUNCTION ACTOR-FUNCTION)>
+                            ((*ARGS <ARGVALS .ARGL>)))>
+                    *VAL
+                    (*OFUNC <COND (<==? <TYPE .PROC> ACTOR-FUNCTION>
+                                   <CHTYPE .PROC FUNCTION>)
+                                  (.PROC)  >))
+             !<COND (<SET SPEC1 <MEMQ EN .SPEC>>
+                     (<FORM PRINT (ENTERING .PROCN)>
+                      !<UPTONEXTATOM <REST .SPEC1>>))>
+             !<COND (<SET SPEC1 <MEMQ FO .SPEC>>
+                     (<FORM FAILPOINT ()
+                            <>
+                            '(*MES *ACT)
+                            <FORM PRINT (FAILING OUT OF .PROCN)>
+                            !<UPTONEXTATOM <REST .SPEC1>>
+                            '<FAIL .*MES .*ACT>   >))   >
+             '<SET *VAL <APPLY .*OFUNC (!.*ARGS)>>
+             !<COND (<SET SPEC1 <MEMQ FI .SPEC>>
+                     (<FORM FAILPOINT ()
+                            <>
+                            '(*MES *ACT)
+                            <FORM PRINT (FAILING INTO .PROCN)>
+                            !<UPTONEXTATOM <REST .SPEC1>>
+                            '<FAIL .*MES .*ACT>   >))   >
+             !<COND (<SET SPEC1 <MEMQ EX .SPEC>>
+                     (<FORM PRINT (EXITING .PROCN)>
+                      !<UPTONEXTATOM <REST .SPEC1>>))   >
+             <FORM LVAL *VAL>   )
+            <COND (<==? <TYPE .PROC> ACTOR-FUNCTION> ACTOR-FUNCTION)
+                  (FUNCTION)   >>>
+   .PROCN   >>\f<DEFINE ARGDECLS
+ <FUNCTION (PROC "AUX" (TP <TYPE .PROC>) DECLS R)
+   <COND (<==? .TP SUBR>
+          '("REST" *ARGS))
+         (<==? .TP FSUBR>
+          '("REST" '*ARGS))
+         (T <AND <ATOM? <1 .PROC>> <SET PROC <REST .PROC>>>
+            <SET DECLS <1 .PROC>>
+            <COND (<OR <SET R <MEMBER "AUX" .DECLS>>
+                       <SET R <MEMBER "ACT" .DECLS>>>
+                   <UPTO .DECLS .R>)
+                  (.DECLS)   >)   >   >>
+
+
+<DEFINE ARGVALS
+ <FUNCTION (ARGL)
+   <MAPCAN
+      #FUNCTION ((DECL "AUX" (TP <TYPE  .DECL>))
+                 <COND (<==? .TP STRING> ())
+                       ((<FORM LVAL
+                               <COND (<ATOM? .DECL> .DECL)
+                                     (<==? .TP FORM>
+                                      <LEGALFORMDECL .DECL>)
+                                     (<==? .TP LIST>
+                                      <OR <==? <LENGTH .DECL> 2> 
+                                          <TRCOMPLAIN .PROCN>>
+                                      <SET DECL <1 .DECL>>
+                                      <COND (<ATOM? .DECL> .DECL)
+                                            (<==? .TP FORM>
+                                             <LEGALFORMDECL .DECL>)
+                                            (T <TRCOMPLAIN .PROCN>)>)   >>))   >)
+      .ARGL>   >>
+
+
+<DEFINE LEGALFORMDECL
+ <FUNCTION (DECL)
+   <COND (<AND <==? <LENGTH .DECL> 2>
+               <==? <1 .DECL> QUOTE>
+               <ATOM? <2 .DECL>>>
+          <2 .DECL>)
+         (<TRCOMPLAIN .PROCN>)   >   >>
+
+
+<DEFINE TRCOMPLAIN
+ <FUNCTION (PROCN)
+   <PRINT (MEANINGLESS PARAMETER DECLARATION IN .PROCN)>
+   <.TR1 (.PROCN *NOT TRACED*)>   >>\f<DEFINE UPTONEXTATOM
+ <FUNCTION (L)
+   <COND (<OR <EMPTY? .L> <ATOM? <1 .L>>> ())
+         ((<1 .L> !<UPTONEXTATOM <REST .L>>))   >>>
+
+
+<DEFINE DISPLAY
+ <FUNCTION ("REST" 'ITEMS)
+   <MAPC
+      #FUNCTION ((ITEM)
+                 <PRINT .ITEM>
+                 <PRINC "= " >
+                 <PRIN1 <EVAL .ITEM>>)
+      .ITEMS>
+   <TERPRI>   >>\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/putget.21 b/MUDDLE/putget.21
new file mode 100644 (file)
index 0000000..88aeb8e
--- /dev/null
@@ -0,0 +1,259 @@
+
+TITLE GETPUT ASSOCIATION FUNCTIONS FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+; COMPONENTS IN AN ASSOCIATION BLOCK
+
+ITEM==0        ;ITEM TO WHICH INDUCATOR APPLIES
+VAL==2         ;VALUE
+INDIC==4       ;INDICATOR
+NODPNT==6              ;IF NON ZERO POINTS TO CHAIN
+PNTRS==7       ;POINTERS NEXT (RH) AND PREV (LH)
+
+ASOLNT==8      ;NUMBER OF WORDS IN AN ASSOCIATION BLOCK
+
+.GLOBAL ASOVEC ;POINTER TO HASH VECTOR IN TV
+.GLOBAL ASOLNT,ITEM,INDIC,VAL,TMA,TFA,NODPNT,NODES,IPUTP,IGETP,PUT
+
+MFUNCTION GETP,SUBR,[GETPROP]
+
+       ENTRY
+
+IGETP: CAML    AB,[-2,,0]      ;DONT SKIP IF TOO FEW
+       JRST    TFA
+       CAMG    AB,[-6,,0]      ;SKIP IF WITHIN RANGE
+       JRST    TMA
+       MOVE    C,2(AB) ;GET INDICATOR TYPE
+       MOVE    D,3(AB)         ;AND VALUE
+       PUSHJ   P,IGET  ;SEE IF ASSOCIATION EXISTS
+       JUMPE   B,CHFIN ;IF 0, NONE EXISTS
+       MOVE    A,VAL(B)        ;ELSE RETURN VALUE
+       MOVE    B,VAL+1(B)
+CFINIS:        JRST    FINIS
+
+CHFIN: CAML    AB,[-4,,0]      ;IS 3RD ARG SUPPLIED?
+       JRST    FINIS   ;NO, RETURN FALSE
+       PUSH    TP,4(AB)                ;YES, EVAL IT
+       PUSH    TP,5(AB)
+       MCALL   1,EVAL
+       JRST    FINIS
+
+
+; FUNCTION TO MAKE AN ASSOCIATION
+
+MFUNCTION PUTP,SUBR,[PUTPROP]
+
+       ENTRY
+
+IPUTP: HLRE    A,AB            ;GET -NUM OF A
+       ASH     A,-1            ;DIVIDE BY 2
+       AOJGE   A,TFA   ;0 OR 1 ARGS IS TOO FEW
+       AOJE    A,REMAS         ;TWO ARGS, REMOVE AN ASSOC
+       AOJL    A,TMA           ;MORE THAN 3 TOO MANY
+       PUSH    P,CFINIS        ;CAUSE FINIS TO BE POPPED TO
+
+IPUT:  MOVE    C,2(AB) ;GET INDICATOR TYPE AND VALUE
+       MOVE    D,3(AB)
+IPUT1: PUSHJ   P,IGET  ;SEE IF THIS ONE EXISTS
+
+       JUMPE   B,NEWASO        ;JUMP IF NEED NEW ASSOCIATION BLOCK
+       MOVE    C,5(AB) ;GET NEW VALUE
+       MOVEM   C,VAL+1(B)      ;STORE IT
+       MOVE    A,4(AB) ;GET VALS TYPE
+       MOVEM   A,VAL(B)
+ITMRET:        MOVE    A,(AB)
+       MOVE    B,1(AB)
+CPOPJ: POPJ    P,
+
+; HERE TO CREATE A NEW ASSOCIATION
+
+NEWASO:        MOVSI   A,TUVEC ;GET VECTOR TYPE
+       SKIPE   D       ;D>0 MEANS SOME EXIST IN CHAIN
+       MOVSI   A,TASOC ;IN THIS CASE USE DIFFERENT TYPE
+       PUSH    TP,A    ;AND SAVE
+       PUSH    TP,C
+       PUSH    P,D     ;SAVE INDICATOR
+       PUSH    TP,$TFIX        ;GET ARG FOR VECTOR CALL
+       PUSH    TP,[ASOLNT]
+       MCALL   1,UVECTOR
+       MOVSI   A,400000+SASOC  ;CLOBBER THE UNIFORM TYPE
+       MOVEM   A,ASOLNT(B)
+
+;NOW SPLICE IN CHAIN
+
+       MOVE    C,(TP)  ;RESTORE SAVED VALUE
+       POP     P,E     ;RESTORE SWITCH
+       JUMPE   E,PUT1  ;NO OTHERS EXISTED IN THIS BUCKET
+       HRLZM   C,PNTRS(B)              ;CLOBBER PREV POINTER
+       HRRM    B,PNTRS(C)              ;AND NEXT POINTER
+       JRST    .+2
+
+PUT1:  HRRZM   B,(C)   ;STORE INTO VECTOR
+       MOVE    C,AB    ;COPY ARG POINTER
+       SUB     TP,[2,,2]               ;POP TP JUNK
+       MOVEI   A,0     ;AND COPY POINTER
+
+PUT2:  MOVE    D,(C)   ;START COPYING
+       MOVEM   D,@CLOBTB(A)
+       ADDI    A,1
+       AOBJN   C,PUT2  ;NOTE *** DEPENDS ON ORDER IN VECTOR ***
+
+       MOVE    C,B             ;RETURN  POINTER TO ASSOC. IN C
+       JRST    ITMRET
+       MOVE    A,2(AB)
+       POPJ    P,
+
+
+;HERE TO REMOVE AN ASSOCIATION
+
+REMAS: MOVE    C,2(AB)         ;GET INDIC
+       MOVE    D,3(AB)
+       PUSHJ   P,IGET          ;LOOK IT UP
+       JUMPE   B,FINIS ;NEVER EXISTED, IGNORE
+       HRRZ    A,PNTRS(B)      ;NEXT POINTER
+       HLRZ    E,PNTRS(B)              ;PREV POINTER
+       SKIPE   A               ;DOES A NEXT EXIST?
+       HRLM    E,PNTRS(A)      ;YES CLOBBER ITS PREV POINTER
+       SKIPN   D               ;SKIP IF NOT FIRST IN BUCKET
+       MOVEM   A,(C)           ;FIRST STORE NEW ONE
+       SKIPE   D               ;OTHERWISE
+       HRRM    A,PNTRS(E)      ;PATCH NEXT POINTER IN PREVIOUS
+       HRRZ    A,NODPNT(B)     ;SEE IF MUST UNSPLICE NODE
+       HLRZ    E,NODPNT(B)
+       SKIPE   A
+       HRLM    E,NODPNT(A)     ;SPLICE
+       JUMPE   E,PUT4          ;FLUSH IF NO PREV POINTER
+       HRRZ    C,NODPNT(E)     ;GET PREV'S NEXT POINTER
+       CAIN    C,(B)           ;DOES IT POINT TO THIS NODE
+       HRLM    A,NODPNT(E)     ;YES, SPLICE
+       GETYP   C,VAL(E)                ;CHECK VAL
+       HRRZ    D,VAL+1(E)
+       CAIN    C,TASOC         ;IS IT AN ASSOCIATION
+       CAIE    D,(B)           ;AND DOES IT POINT TO THIS NODE
+       JRST    PUT4            ;NO
+       HRRZM   A,VAL+1(E)      ;YES, CLOBBER
+PUT4:  MOVE    A,VAL(B)                ;RETURN VALUE
+       SETZM   NODPNT(B)
+       SETZM   PNTRS(B)
+       MOVE    B,VAL+1(B)
+       JRST    FINIS
+
+
+;INTERNAL GET FUNCTION CALLED BY PUT AND GET
+;(AB) AND 1(AB) ARE THE ITEM
+;C AND D ARE THE INDICATOR
+
+IGET:  PUSH    TP,C            ;SAVE C AND D
+       PUSH    TP,D
+       MOVE    A,C             ;BUILD UP HASH IN A
+       XOR     A,D
+       XOR     A,(AB)
+       XOR     A,1(AB)         ;NOW HAVE A HASH
+       MOVMS   A
+       HLRE    B,ASOVEC+1(TVP) ;GET LENGTH OF HASH VECTOR
+       MOVMS   B
+       IDIVI   A,(B)           ;RELATIVE BUCKET NOW IN B
+       HRLI    B,(B)           ;IN CASE GC OCCURS
+       ADD     B,ASOVEC+1(TVP) ;POINT TO BUCKET
+       MOVEI   D,0             ;SET FIRST SWITCH
+       SKIPN   A,(B)   ;GET CONTENTS OF BUCKET (DONT SKIP IF EMPTY)
+       JRST    GFALSE
+
+       MOVSI   0,TASOC         ;FOR INTGOS, MAKE A TASOC
+       HLLZM   0,ASTO(PVP)
+
+IGET1: INTGO           ;IN CASE CIRCULARITY EXISTS
+       GETYPF  0,ITEM(A)       ;GET ITEMS TYPE
+\r      MOVE    E,ITEM+1(A)
+       CAMN    0,(AB)          ;COMPARE TYPES
+       CAME    E,1(AB) ;AND VALUES
+       JRST    NXTASO          ;LOSER
+       MOVE    0,INDIC(A)      ;MOW TRY INDICATORS
+       MOVE    E,INDIC+1(A)
+       CAMN    0,-1(TP)
+       CAME    E,(TP)
+       JRST    NXTASO
+
+       SKIPN   D               ;IF 1ST THEN
+       MOVE    C,B             ;RETURN POINTER IN C
+       MOVE    B,A             ;FOUND, RETURN ASSOCIATION
+       MOVSI   A,TASOC
+IGRET: SUB     TP,[2,,2]
+       SETZM   ASTO(PVP)
+       POPJ    P,
+
+NXTASO:        MOVEI   D,1             ;SET SWITCH
+       MOVE    C,A             ;CYCLE
+       HRRZ    A,PNTRS(A)      ;STEP
+       JUMPN   A,IGET1
+
+       MOVSI   A,TFALSE
+       MOVEI   B,0
+       JRST    IGRET
+
+GFALSE:        MOVE    C,B     ;PRESERVE VECTOR POINTER
+       MOVSI   A,TFALSE
+       SETZB   B,D
+       JRST    IGRET
+
+; FUNCTION TO DO A PUT AND ALSO ADD TO THE NODE FOR THIS GOODIE
+
+MFUNCTION PUTN,SUBR
+
+       ENTRY
+
+       CAML    AB,[-4,,0]      ;WAS THIS A REMOVAL
+       JRST    PUT
+
+       PUSHJ   P,IPUT          ;DO THE PUT
+       SKIPE   NODPNT(C)       ;NODE CHAIN EXISTS?
+       JRST    FINIS
+
+       PUSH    TP,$TASOC               ;NO, START TO BUILD
+       PUSH    TP,C
+CHPT:  MOVE    C,$TCHSTR
+       MOVE    D,CHQUOTE NODE
+       PUSHJ   P,IGET
+       JUMPE   B,MAKNOD        ;NOT FOUND, LOSE
+NODSPL:        MOVE    C,(TP)          ;HERE TO SPLICE IN NEW NODE
+       MOVE    D,VAL+1(B)      ;GET POINTER TO NODE STRING
+       HRRM    D,NODPNT(C)     ;CLOBBER
+       HRLM    B,NODPNT(C)
+       SKIPE   D               ;SPLICE ONLY IF THERE IS SOMETHING THERE
+       HRLM    C,NODPNT(D)
+       MOVEM   C,VAL+1(B)      ;COMPLETE NODE CHAIN
+       MOVE    A,2(AB)         ;RETURN VALUE
+       MOVE    B,3(AB)
+       JRST    FINIS
+
+MAKNOD:        PUSHJ   P,NEWASO        ;GENERATE THE NEW ASSOCIATION
+       MOVE    A,@CHPT         ;GET UNIQUE STRING
+       MOVEM   A,INDIC(C)              ;CLOBBER IN INDIC
+       MOVE    A,@CHPT+1
+       MOVEM   A,INDIC+1(C)
+       MOVE    B,C             ;POINTER TO B
+       HRRZ    C,NODES+1(TVP)          ;GET POINTER TO CHAIN OF NODES
+       HRRZ    D,VAL+1(C)      ;SKIP DUMMY NODE
+       HRRM    B,VAL+1(C)      ;CLOBBER INTO CHAIN
+       HRRM    D,NODPNT(B)
+       SKIPE   D               ;SPLICE IF ONLY SOMETHING THERE
+       HRLM    B,NODPNT(D)
+       HRLM    C,NODPNT(B)
+       MOVSI   A,TASOC         ;SET TYPE OF VAL TO ASSOCIATION
+       MOVEM   A,VAL(B)
+       SETZM   VAL+1(B)
+       JRST    NODSPL  ;GO SPLICE ITEM ONTO NODE
+CLOBTB:        ITEM(B)
+       ITEM+1(B)
+       INDIC(B)
+       INDIC+1(B)
+       VAL(B)
+       VAL+1(B)
+
+
+
+END
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/readch.10 b/MUDDLE/readch.10
new file mode 100644 (file)
index 0000000..f4d5191
--- /dev/null
@@ -0,0 +1,240 @@
+
+TITLE READC TELETYPE DEVICE HANDLER FOR MUDDLE
+
+RELOCATABLE
+
+.INSRT MUDDLE >
+
+.GLOBAL BUFRIN,CHRCNT,SYSCHR,ECHO,BYTPTR,ERASCH,KILLCH,BRKCH,AGC
+.GLOBAL IOIN2,READC,WRONGT,WRONGD,WRONGC,CALER1,BRFCHR,ESCAP,TTYOPE,TYI,TYO
+.GLOBAL RRESET,TTICHN,TTOCHN,CHANNO,STATUS
+
+TTYOUT==1
+TTYIN==2
+
+
+; READC IS CALLED BY PUSHJ P,READC
+; B POINTS TO A TTY FLAVOR CHANNEL
+; ONE CHARACTER IS RETURNED IN  A
+; BECOMES INTERRUPTABLE IF NO CHARACTERS EXISTS
+
+READC: PUSH    P,E             ;SAVE E FROM DEATH
+       MOVE    E,BUFRIN(B)     ;GOBBLE POINTER TO BUFFER AND INFO
+       SOSGE   CHRCNT(E)       ;ANY CHARS LEFT?
+       PUSHJ   P,INCHAR        ;NO, GO READ SOME
+       ILDB    A,BYTPTR(E)     ;GOBBLE ONE
+       POP     P,E             ;RESTORE E
+       POPJ    P,
+
+; HERE TO ASK SYSTEM FOR SOME CHARACTERS
+
+INCHAR:        IRP     A,,[0,C,D]      ;SAVE ACS
+       PUSH    P,A
+       TERMIN
+       CLEARM  CHRCNT(E)       ;NO CHARS IN BUFFER
+       MOVE    D,[010700,,BYTPTR(E)]   ;MAKE A BYTE POINTER TO START OF BUFFER
+       HLRE    0,E             ;FIND END OF BUFFER
+       SUBM    E,0
+       ANDI    0,-1            ;ISOLATE RH
+
+INCHR1:        PUSHJ   P,GETCH         ;GET A CHARACTER
+       CAMN    A,ESCAP(E)              ;ESCAPE CHAR?
+       JRST    DOESCP
+       CAMN    A,BRFCHR(E)             ;BUFFER PRINT CHAR
+       JRST    CLEARQ          ;MAYBE CLEAR SCREEN
+       CAMN    A,BRKCH(E)      ;IS THIS A BREAK?
+       JRST    DONE            ;YES, DONE
+       CAMN    A,ERASCH(E)     ;ARE IS IT ERASE?
+       JRST    ERASE           ;YES, GO PROCESS
+       CAMN    A,KILLCH(E)     ;OR KILL
+       JRST    KILL
+
+INCHR2:        PUSHJ   P,PUTCHR        ;PUT ACHAR IN BUFFER
+       JRST    INCHR1
+
+DONE:  IDPB    A,D             ;STORE 
+       MOVE    D,[010700,,BYTPTR(E)]   ;RESET BYTER
+       MOVEM   D,BYTPTR(E)
+       IRP     A,,[D,C,0]
+       POP     P,A
+       TERMIN
+       POPJ    P,
+
+
+ERASE: SUBI    A,177           ;IS THE ERASE RUBOUT
+       SKIPN   CHRCNT(E)       ;ANYTHING IN BUFFER?
+       JRST    BARFCR  ;NO, MAYBE TYPE CR
+
+       SOS     CHRCNT(E)       ;DELETE FROM COUNT
+       JUMPN   A,NECHO ;DONT ECHO IF ERASE OTHER THAN RUBOUT
+       LDB     A,D             ;RE-GOBBLE LAST CHAR
+       SKIPE   C,ECHO(E)       ;DOES AN ECHO INS EXIST?
+       XCT     C               ;YES, ECHO
+
+NECHO: ADD     D,[70000,,0]    ;DECREMENT BYTE POINTER
+       JUMPGE  D,INCHR1        ;AND GO ON, UNLESS BYTE POINTER LOST
+       SUB     D,[430000,,1]   ;FIX UP BYTE POINTER
+       JRST    INCHR1
+
+; HERE TO KILL THE WHOLE BUFFER
+
+KILL:  CLEARM  CHRCNT(E)       ;NONE LEFT NOW
+       MOVE    D,[010700,,BYTPTR(E)]   ;RESET POINTER
+
+BARFCR:        MOVE    A,ERASCH(E)     ;GET THE ERASE CHAR
+       CAIE    A,177           ;IS IT RUBOUT?
+       JRST    INCHR1          ;NO, DO NOT TYPE A CR
+       MOVEI   A,15                    ;GET THE CR
+       SKIPE   C,ECHO(E)       ;ECHO INS IN C
+       XCT     C
+       JRST    INCHR1
+
+DOESCP:        PUSHJ   P,PUTCHR        ;PUT INTO BUFFER
+       PUSHJ   P,GETCH         ;GET NEXT ONE
+       JRST    INCHR2  ;INSERT IT AND GO ON
+
+CLEARQ:        MOVEI   A,0             ;INSERT A NULL CHAR
+       IDPB    A,D             ;DEPOSIT A 0 TERMINATOR
+       MOVE    A,STATUS(B)     ;CHECK CONSOLE KIND
+       ANDI    A,77
+       CAIN    A,2             ;DATAPOINT?
+       PUSHJ   P,CLR           ;YES, CLEAR SCREEN
+       MOVEI   A,15            ;C.R.
+       MOVE    C,[010700,,BYTPTR(E)]   ;POINT TO START OF BUFFER
+       SKIPN   ECHO(E)         ;ANY ECHO INS?
+       JRST    NECHO
+
+       XCT     ECHO(E) ;WRITE OUT C.R.
+
+       ILDB    A,C                     ;GOBBLE CHAR
+       JUMPE   A,NECHO
+       XCT     ECHO(E)         ;ECHO IT
+       JRST    .-3             ;DO FOR ENTIRE BUFFER
+
+CLR:   SKIPN   C,ECHO(E)       ;ONLY IF INS EXISTS
+       POPJ    P,
+       MOVEI   A,20            ;ERASE SCREEN
+       XCT     C
+       MOVEI   A,103
+       XCT     C
+       POPJ    P,
+
+PUTCHR:        AOS     CHRCNT(E)       ;COUNT THIS CHARACTER
+       IBP     D               ;BUMP BYTE POINTER
+       CAIG    0,@D            ;DONT SKIP IF BUFFER FULL
+       PUSHJ   P,BUFULL                ;GROW BUFFER
+       DPB     A,D             ;CLOBBER BYTE POINTER IN
+       POPJ    P,
+
+; BUFFER FULL, GROW THE BUFFER
+
+BUFULL:        MOVEI   E,1000          ;GET GROWTH SPECS
+       HRRM    E,@0
+       PUSH    TP,$TCHAN       ;SAVE B
+       PUSH    TP,B
+       PUSHJ   P,AGC           ;GROW THE VECTOR
+       MOVE    B,(TP)          ;RESTORE CHANNEL POINTER
+       SUB     TP,[2,,2]       ;AND REMOVE CRUFT
+       MOVE    E,BUFRIN(B)     ;GET AUX BUFFER POINTER
+       HLRE    0,E             ;RECOMPUTE 0
+       SUBM    E,0
+       ANDI    0,-1
+       POPJ    P,
+
+GETCH: SOSGE   C,SYSCHR(E)     ;ANY CHARS IN SYSTEM?
+       JRST    ENBL            ;NO, ENABLE INTERRUPTS
+       XCT     IOIN2(E)        ;YES, GOBBLE ONE
+       POPJ    P,              ;AND RETURN
+
+ENBL:  MOVSI   A,TCHAN         ;SET A'S TYPE
+       MOVEM   A,BSTO(PVP)
+       ENABLE                  ;ENABLE INTERRUPTS
+       XCT     IOIN2(E)
+       DISABLE                 ;GOT A CHARACTER, DISABLE INTERRUPTS
+       SETZM   BSTO(PVP)
+       POPJ    P,
+
+; SUBROUTINE TO FLUSH BUFFER
+
+RRESET:        MOVE    E,BUFRIN(B)             ;GET AUX BUFFER
+       SETZM   CHRCNT(E)
+       SETZM   SYSCHR(E)
+       MOVE    D,[010700,,BYTPTR(E)]   ;RESET BYTE POINTER
+       MOVEM   D,BYTPTR(E)
+       MOVE    D,CHANNO(B)     ;GOBBLE CHANNEL
+       LSH     D,23.           ;POSITION
+       IOR     D,[.RESET 0]
+       XCT     D               ;RESET ITS CHANNEL
+       POPJ    P,
+
+; SUBROUTINE TO ESTABLISH ECHO IOINS
+
+MFUNCTION ECHOPAIR,SUBR
+
+       ENTRY   2
+
+       HLRZ    A,(AB)          ;CHECK ARG TYPES
+       HLRZ    C,(AB)
+       CAIN    A,TCHAN         ;IS A CHANNEL
+       CAIE    C,TCHAN         ;IS C ALSO
+       JRST    WRONGT          ;NO, ONE OF THEM LOSES
+
+       MOVE    A,1(AB)         ;GET CHANNEL
+       MOVE    B,DIRECT(A)     ;GET DIRECTION
+       CAME    B,CHQUOTE READ
+       JRST    WRONGD
+       LDB     C,[600,,STATUS(A)]      ;GET A CODE
+       CAILE   C,2             ;MAKE SURE A TTY FLAVOR DEVICE
+       JRST    WRONGC
+       MOVE    D,3(AB)         ;GET OTHER CHANNEL
+       MOVE    E,DIRECT(D)     ;AND ITS DIRECTION
+       CAME    E,CHQUOTE PRINT
+       JRST    WRONGD
+
+       MOVE    B,BUFRIN(A)     ;GET A'S AUX BUFFER
+       MOVE    C,IOINS(D)      ;AND C'S IO INS
+       MOVEM   C,ECHO(B)               ;CLOBBER
+       MOVE    A,(AB)
+       MOVE    B,1(AB)         ;RETURN 1ST ARG
+       JRST FINIS
+
+TTYOPEN:       .OPEN   TTYIN,[SIXBIT /   TTY/]
+       .VALUE
+       .OPEN   TTYOUT,[SIXBIT /  !TTY/]        ;AND OUTPUT
+       .VALUE
+       .STATUS TTYOUT,A                ;CHECK IT OUT
+       ANDI    A,77            ;GET DEVICE
+       CAIE    A,2             ;IF 2, CAN OPEN IN DISPLAY MODE
+       JRST    SETCHN
+       .CLOSE  TTYOUT,
+       .OPEN   TTYOUT,[21,,(SIXBIT /TTY/)]
+       .VALUE
+       
+SETCHN:        MOVE    B,TTICHN+1(TVP) ;GET CHANNEL
+       MOVEI   A,TTYIN         ;GET ITS CHAN #
+       MOVEM   A,CHANNO(B)
+       .STATUS TTYIN,STATUS(B) ;CLOBBER STATUS
+
+       MOVE    B,TTOCHN+1(TVP) ;GET OUT CHAN
+       MOVEI   A,TTYOUT
+       MOVEM   A,CHANNO(B)
+       .STATUS TTYOUT,STATUS(B)
+       POPJ    P,
+
+TYI:   .IOT    TTYIN,A
+       POPJ    P,
+
+TYO:   .IOT    TTYOUT,A
+       POPJ    P,
+
+
+WRONGD:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE WROND-DIRECTION-CHANNEL
+       JRST    CALER1
+
+WRONGC:        PUSH    TP,$TATOM
+       PUSH    TP,MQUOTE NOT-A-TTY-TYPE-CHANNEL
+       JRST    CALER1
+
+END
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/reader.117 b/MUDDLE/reader.117
new file mode 100644 (file)
index 0000000..8fdb9b2
Binary files /dev/null and b/MUDDLE/reader.117 differ
diff --git a/MUDDLE/revtes.4 b/MUDDLE/revtes.4
new file mode 100644 (file)
index 0000000..2f0f2f3
--- /dev/null
@@ -0,0 +1,10 @@
+<DEFINE REV 
+ <ACTOR (EXP "AUX" FRONT BACK)
+   <WHEN (() .EXP)
+         ((_FRONT !_BACK)
+          <BE <IS? (!<REV .BACK> ?FRONT) .EXP>>)   >>>
+
+
+<DEFINE PAL
+ <ACTOR ("AUX" END)
+   <VEL () (_END) (_END !<PAL> ?END)>   >>\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/sptest.6 b/MUDDLE/sptest.6
new file mode 100644 (file)
index 0000000..e5dd328
--- /dev/null
@@ -0,0 +1 @@
+<DEFINE STEST <FUNCTION ("STACK" A B C) [.A .B .C]>>\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/stctst.2 b/MUDDLE/stctst.2
new file mode 100644 (file)
index 0000000..5b39cb9
--- /dev/null
@@ -0,0 +1,43 @@
+<SETG PATH 
+ <FUNCTION TL ("STACK" START FINISH)
+   <PROG ("STACK" (VAL <FAILPOINT () <PATH1 .START .FINISH ()>
+                    ("STACK")
+                    <EXIT .TL <>>   >))
+    <FINALIZE .TL>
+    <RETURN .VAL>>>>\e
+
+
+<SETG PATH1
+ <FUNCTION  ("STACK" START FINISH AVOID)
+   <COND (<==? .START .FINISH>
+          (.FINISH))
+         (<MEMBER .START .AVOID>
+          <FAIL>)
+         (T (.START 
+             !<PATH1
+               <FAILPOINT FP ("STACK" N (NODES <GET .START CONNECTED>))
+                        <FAIL> ("STACK")
+                        <COND (<EMPTY? .NODES> <FAIL>)
+                              (<SET N <1 .NODES>>
+                               <SET NODES <REST .NODES>>
+                               <RESTORE .FP .N>)>   >
+               .FINISH
+               (.START !.AVOID)>))>>   >\e
+
+
+<PUT ALPHA CONNECTED (B D K)>\e
+<PUT B CONNECTED (ALPHA I C)>\e\r\r
+<PUT I CONNECTED (B H J)>\e
+<PUT H CONNECTED (I)>\e
+<PUT J CONNECTED (I)>\e
+<PUT C CONNECTED (B G D)>\e
+<PUT G CONNECTED (C)>\e
+<PUT D CONNECTED (ALPHA C F)>\e
+\r<PUT F CONNECTED (D)>\e
+<PUT K CONNECTED (ALPHA M L)>\e
+<PUT M CONNECTED (K L N O)>\e
+<PUT L CONNECTED (K M)>\e
+<PUT N CONNECTED (M)>\e
+<PUT O CONNECTED (M P OMEGA)>\e
+<PUT P CONNECTED (O)>\e
+<PUT OMEGA CONNECTED (O)>\e\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/tentab.1 b/MUDDLE/tentab.1
new file mode 100644 (file)
index 0000000..da346e9
--- /dev/null
@@ -0,0 +1,193 @@
+ ; TABLE OF POWERS OF TEN
+       TITLE TENTAB
+       1PASS
+       .LIBRA TENTAB,ITENTB
+       .GLOBA TENTAB,ITENTB
+
+TENTAB:        REPEAT 39. 10.0^<.RPCNT-1>
+
+MUM=1
+ITENTB:        REPEAT 11. 10.^<.RPCNT-1>
+
+END
+\f\ 3\f\ 3\ 3MENTED MODULES:
+;      GTUNIT - GETS A UNIT OF TEXT AND RETURNS VALUE
+;      CONVRT - DOES THE ACTUAL CONVERSION
+;      LXINIT - SETS UP LEXICON FILES
+;CHANNEL DEFS
+
+MLXCHN==1      ;CHANNEL FOR MAIN LEXICON
+ALXCHN==2      ;AUXILIARY LEXICON
+TYIC==3
+TTYIN==3
+TYOC==4
+TYOC1==4
+TTYOUT==4
+ALT==5
+NWCHN==6
+\f;SECTION TO START THE SYSTEM
+
+GO:    .OPEN   TYIC,[SIXBIT /   TTY/]
+       .VALUE
+       .OPEN   TYOC,[SIXBIT /  !TTY/]
+       .VALUE
+       PASCR   [ASCIZ /ENTER LEXICON NAMES/]
+       PUSHJ   P,LXINIT
+
+;CODE HERE FOR MAIN LOOP OF LEXICONTEXT (LISTENER)
+\f;SUBROUTINE TO INITIALIZE THE SYSTEM BY OPENING LEXICON FILES
+
+;FIRST FILE IS MAIN LEXICON
+;SECOND FILE IS AUXILIARY LEXICON
+;THIRD FILE IS NEW LCXICON; IF IT IS NOT FOUND, IT WILL BE CREATED
+       ;IF IT IS FOUND, NEW WORDS WILL BE APPENDED
+
+LXINIT:        PUSH    P,A     ;SAVE AC A
+       SKIPE   LXFMFL
+       JRST    LSETMN
+       PASC    [ASCIZ /MAIN LEXICON: /]
+LSETMN:        PUSHJ   P,RCMD  ;READ A FILE NAME
+       PUSHJ   P,SCNAME
+       SKIPN   A,SCN1  ;NO NAME GIVEN MEANS THERE IS NO MAIN LEXICON
+       JRST    AUXNM   ;AND JUST SKIP THIS STEP
+       MOVEM   A,MLXNM+1       ;SET UP FIRST NAME
+       SKIPN   A,SCN2  ;SEE IF ANY SECOND NAME GIVEN
+       MOVE    A,[SIXBIT /MAINLX/]     ;IF NOT SET UP DEFAULT SECOND NAME
+       MOVEM   A,MLXNM+2       ;SET UP SECOND NAME
+       .OPEN   MLXCHN,MLXNM    ;OPEN THE MAIN LEXICON FILE
+       .VALUE          ;REPLACE BY ERROR PROCEDURE EVENTUALLY
+AUXNM: SKIPE   LXFMFL
+       JRST    LSETAU
+       PASC    [ASCIZ /AUXILIARY LEXICON: /]
+       PUSHJ   P,RCMD  ;READ SECOND FILE NAME
+       PUSHJ   P,SCNAME
+LSETAU:        SKIPN   A,SCN1  ;NO AUXILIARY LEXICON?
+       JRST    NWNM    ;NO, JUST SET UP NEW LEXICON THEN
+       MOVEM   A,ALXNM+1       ;SET UP FIRST NAME
+       SKIPN   A,SCN2  ;SET UP SECOND NAME AS ABOVE
+       MOVE    A,[SIXBIT /AUXLEX/]
+       MOVEM   A,ALXNM+2
+       .OPEN   ALXCHN,ALXNM    ;OPEN AUXILIARY LEXICON FILE
+       .VALUE          ;REPLACE BY ERROR PROCEDURE
+\f;SECTION TO OPEN NEW LEXICON FILE
+
+NWNM:  SKIPE   LXFMFL
+       JRST    LSETNW
+       PASC    [ASCIZ /NEW LEXICON: /]
+       PUSHJ   P,RCMD  ;READ THIRD FILE NAME
+       PUSHJ   P,SCNAME
+LSETNW:        SKIPN   A,SCN1  ;ANY NAME GIVEN?
+       JRST    READY   ;NEW LEXICON WILL BE SET UP LATER
+       MOVEM   A,NWLXNM+1      ;SET UP NAME
+       SKIPN   A,SCN2
+       MOVE    A,[SIXBIT /NEWLEX/]
+       MOVEM   A,NWLXNM+2      ;SET UP SECOND NAME
+       MOVE    A,[SIXBIT /  &DSK/]     ;READ IMAGE BLOCK
+       MOVEM   A,NWLXNM
+       PUSHJ   P,NWLXOP        ;GO TELL CONVRT ABOUT NEW LEXICON FILE
+
+;SECTION TO READ IN B-BLOCKS
+
+READY: SKIPN   MLXNM+1 ;IS THERE A MAIN LEXICON?
+       JRST    RDAUXB  ;NO READ AUX B-BLOCKS THEN
+       .ACCES  MLXCHN,[0]
+       MOVE    A,[-26.,,MBBASE]
+       .IOT    MLXCHN,A        ;READ IN MAIN LEXICON B-BLOCK
+RDAUXB:        SKIPN   ALXNM+1
+       JRST    BLKSRD  ;ALL DONE
+       .ACCES  ALXCHN,[0]
+       MOVE    A,[-26.,,ABBASE]
+       .IOT    ALXCHN,A
+BLKSRD:        SETZM   MENMAP
+       SETZM   AENMAP
+       MOVE    A,[377777,,777777]
+       MOVEM   A,MBGMAP
+       MOVEM   A,ABGMAP
+       PASCR   [ASCIZ /READY/]
+       POP     P,A
+       POPJ    P,
+
+MLXNM: SIXBIT /  &DSK/
+       0
+       0
+ALXNM: SIXBIT /  &DSK/
+       0
+       0
+LXFMFL:        0
+\fTITLE GTUNIT - MODULE TO GET A UNIT OF TEXT FROM THE USER
+
+;INPUT MODULE - GETS INPUT AND RETURNS LEXICON VALUES
+;AS 36-BIT QUANTITIES
+;IF THE ITEM RECEIVED IS THE ESCAPE CHARACTER TO GO TO EDIT
+;MODE, RETURNS ARGP=0, OTHERWISE ARGP CONTAINS ACTUAL LEXICON
+;VALUE
+
+;CALLS CONVRT TO CONVRT AN ASCII STRING TO A VALUE IF A WORD
+;IS THE NEXT ITEM
+
+;BUILDS LITERALS FROM PUNCTUATION,,ETC. AND PACKS THEM
+;4 TO A WORD, 7BIT ASCII, IN FORMAT FOR BYTE MANIPULATION
+;LEFTMOST PART OF WORD CONTAINS TYPE CODE FOR A LITERAL
+;THIS MODULE MAKES A CALL UP TO A ROUTINE LITOUT
+;WHENEVER SUCH A LITERAL WORD SHOULD BE PLACED IN OUTPUT STREAM
+
+;USES REVISED GETITM ROUTINE WHICH TREATS SPACES AND C.R. AS PUNCT.
+;ASSUMES TTY CHANNELS OPEN ON CHANNELS TTYOUT, TTYIN
+
+;DEFINE THE ESCAPE CHARACTER
+ESCAPE==0
+
+\f;ENTER TO GET A UNIT OF TEXT AND RETURN A VALUE IN ARGP
+
+GTUNIT:        SAVEB   A,D
+GTCHNK:        CALL    GETITM,[0,ITYPE]        ;GET A CHUNK OF INPUT INTO B
+       CAIN    ITYPE,3         ;IS IT A STRING (WORD)
+       JRST    WRDGOT  ;YES, CONVERT TO LEXICON VALUE
+       CAIN    ITYPE,4 ;IS IT PUNCTUATION
+       JRST    PNCGOT  ;YES, GO BUILD LITERAL
+       JRST    GTCHNK  ;FOR NOW, IGNORE ALL OTHER TYPES
+
+WRDGOT:        PUSHJ   P,LITDMP        ;CLEAR ANY LITERAL BUFFER
+       MOVE    ARGP,A  ;SET UP POINTER TO HEAD OF THE CHARACTER STRING
+       SOS     A
+       PUSHJ   P,CONVRT        ;AND CONVERT TO A VALUE
+RRRET: RESTB   A,D     ;EXIT SEQUENCE
+       POPJ    P,      ;EXIT WITH VALUE IN ARGP
+
+PNCGOT:        CAIN    A,ESCAPE        ;IS IT THE ESCAPE CHARACTER?
+       JRST    MODCHG  ;YES, CHANGE MODE
+       PUSHJ   P,LITADD        ;ADD TO LITERAL BUFFER
+       JRST    RRRET   ;AND RETURN
+
+
+LITDMP:        CAMN    C,[350700,,D]   ;SEE IF BUFFER HAS ANYTHING IN IT
+       POPJ    P,      ;NO, JUST RETURN
+       MOVE    ARGP,D  ;YES, SEND OUT THE LITERAL
+       PUSHJ   P,LITOUT
+       MOVE    C,[350700,,D]   ;RESET BUFFER
+       POPJ    P,
+LITADD:        IDPB    A,D     ;PUT CHARACTER IN THE LITERAL BUFFER IN D
+CAMN   C,[000700,,D]   ;FULL?
+PUSHJ  P,LITDMP        ;YES, DUMP IT
+POPJ   P,
+
+;CODE HERE TO CHANGE MODES
+MODCHG:        .BREAK  ;FOR DEBUGGING
+\f      TITLE GETITM
+; THIS PROGRAM READS ITEMS FROM THE INPUT STREAM
+; RETURNING THEM ONE AT A TIME TO THE USER WITH
+; A TYPE CODE
+
+
+
+       .GLOBA READCH,TENTAB,ITENTB,FLUSHI,GETERR
+
+
+;THIS DEFINED FOR ACTUAL TTY ROUTINE
+
+
+
+; CODES FOR CHARACTER TYPES
+
+OCDIG=1
+DECDIG=2
diff --git a/MUDDLE/tester.putget b/MUDDLE/tester.putget
new file mode 100644 (file)
index 0000000..de720cf
--- /dev/null
@@ -0,0 +1,93 @@
+;"TESTER FOR PUT-GET ASSOCIATIONS"
+;"MAKES RANDOM ASSOCIATIONS THEN CHECKS LATER TO SEE IF MISSING"
+
+<SETG TEST <FUNCTION ("OPTIONAL" (COUNT <MIN>) (OUTCHAN .OUTCHAN)
+       "EXTRA" (X ()) (Y ()) (Z ()))
+       <REPEAT (I)
+               <SET I <MIN 1000 <MOD <RANDOM> .COUNT>>>
+               <SET COUNT <- .COUNT .I>>
+               <MAKE-ASSOCS .I>
+               <IVECTOR 5000>  ;"CALL GARBAGE COLLECTOR"
+               <CHECK-ASSOCS .I TENTATIVE>
+               <COND (<L? .COUNT 1> <RETURN "DONE">)>>
+       <CHECK-ASSOCS <LENGTH .X> FINAL>>>
+
+<SETG MAKE-ASSOCS <FUNCTION (I)
+       <REPEAT ()
+               <SET X (<MAKE-OBJ> !.X)>
+               <SET Y (<MAKE-OBJ> !.Y)>
+               <SET Z (<MAKE-OBJ> !.Z)>
+               <PUT <1 .X> <1 .Y> <1 .Z>>      ;"DO THE ASSOCIATION"
+               <CHECK-ASSOCS 1 INITIAL>
+               <COND (<0? <DEC I>> <RETURN "DONE">)>>>>
+
+<SETG MAKE-OBJ <FUNCTION ("EXTRA" (N <MOD <RANDOM> 19>))
+       <COND   (<0? .N> <IVECTOR <MOD <RANDOM> 10> <MAKE-OBJ>>)
+               (<1? .N> <IUVECTOR <MOD <RANDOM> 10> <MAKE-OBJ>>)
+               (<L? .N 3> <ILIST <MOD <RANDOM> 10> <MAKE-OBJ>>)
+               (<L? .N 4> <ISTRING <MOD <RANDOM> 10> !"A>)
+               (<L? .N 5> <<+ 1 <MOD <RANDOM> <LENGTH .X>>> .X>)
+               (<L? .N 6> <<+ 1 <MOD <RANDOM> <LENGTH .Y>>> .Y>)
+               (<L? .N 7> <<+ 1 <MOD <RANDOM> <LENGTH .Z>>> .Z>)
+               (<L? .N 10> <ATOM <ISTRING <MOD <RANDOM> 10>
+                               <ASCII <MOD <RANDOM> 127>>>>)
+               (<L? .N 16> <CHTYPE <RANDOM> FLOAT>)
+               (<L? .N 19> <ASCII <MOD <RANDOM> 127>>)>>>
+
+
+<SETG CHECK-ASSOCS <FUNCTION (I LEVEL)
+       <REPEAT ((X .X) (Y .Y) (Z .Z))
+               <COND (<NOT <==? <GET <1 .X> <1 .Y>>
+                               <1 .Z>>>
+                       <PRINT .LEVEL>
+                       <PRIN1 LOSER>
+                       <TERPRI>
+                       <PRINT-ASSOC 0>
+                       <PUT .X 1 0>
+                       <PUT .Y 1 0>
+                       <PUT .Z 1 0>)>
+               <CHOP X>
+               <CHOP Y>
+               <CHOP Z>
+               <COND (<0? <DEC I>> <RETURN "DONE">)>>>>
+
+
+<PUT 0 0 0>
+
+
+<SETG PRINT-ASSOC <FUNCTION (K)
+       <INDENT-TO .K>
+       <PRINC "ITEM: ">
+       <PRINT-IT <1 .X> <+ .K 10>>
+       <INDENT-TO .K>
+       <PRINC "INDIC: ">
+       <PRINT-IT <1 .Y> <+ .K 10>>
+       <INDENT-TO .K>
+       <PRINC "VALUE: ">
+       <PRINT-IT <1 .Z> <+ .K 10>>>>
+
+
+
+<SETG PRINT-IT <FUNCTION (IT K)
+       <PRINC <TYPE .IT>>
+       <COND   (<MONAD? .IT> <TERPRI>)
+               (ELSE
+                <PRINC " LENGTH: ">
+                <PRINC <LENGTH .IT>>
+                <PRINC " OF:">
+                <TERPRI>
+                <INDENT-TO .K>
+                <PRINT-IT <1 .IT> <+ .K 10>>)>
+       <COND (<MEMQ .IT <REST .X>>
+               <INDENT-TO .K>
+               <PRINC "***SHARED ITEM">
+               <TERPRI>)>
+       <COND (<MEMQ .IT <REST .Y>>
+               <INDENT-TO .K>
+               <PRINC "***SHARED INDIC">
+               <TERPRI>)>
+       <COND (<MEMQ .IT <REST .Z>>
+               <INDENT-TO .K>
+               <PRINC "***SHARED VALUE">
+               <TERPRI>)>>>
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/testsp.4 b/MUDDLE/testsp.4
new file mode 100644 (file)
index 0000000..df6a2a0
--- /dev/null
@@ -0,0 +1,18 @@
+<SETG ENVIRON 
+  <FUNCTION ("BIND" E) .E>>
+
+
+<SET E0 <ENVIRON>>
+
+<PROG ((A 100) E1)
+   <SET E1 <ENVIRON>>
+   <PRINT .A>
+   <PROG ((A 10) E2)
+      <SET E2 <ENVIRON>>
+      <PRINT .A>
+      <PROG ((A 1) E3)
+         <PRINT .A>
+         <SPLICE <ENVIRON> .E1>
+         <PRINT .A>>
+      <PRINT .A>>
+   <PRINT .A>>\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/ts.midas b/MUDDLE/ts.midas
new file mode 100644 (file)
index 0000000..e25d8ac
Binary files /dev/null and b/MUDDLE/ts.midas differ
diff --git a/MUDDLE/ts.muddle b/MUDDLE/ts.muddle
new file mode 100644 (file)
index 0000000..95b2b6f
Binary files /dev/null and b/MUDDLE/ts.muddle differ
diff --git a/MUDDLE/ts.nplnnr b/MUDDLE/ts.nplnnr
new file mode 100644 (file)
index 0000000..6334183
Binary files /dev/null and b/MUDDLE/ts.nplnnr differ
diff --git a/MUDDLE/ts.omuddl b/MUDDLE/ts.omuddl
new file mode 100644 (file)
index 0000000..d896dbe
Binary files /dev/null and b/MUDDLE/ts.omuddl differ
diff --git a/MUDDLE/ts.plannr b/MUDDLE/ts.plannr
new file mode 100644 (file)
index 0000000..a825c96
Binary files /dev/null and b/MUDDLE/ts.plannr differ
diff --git a/MUDDLE/ts.stink b/MUDDLE/ts.stink
new file mode 100644 (file)
index 0000000..968ef3a
Binary files /dev/null and b/MUDDLE/ts.stink differ
diff --git a/MUDDLE/util.21 b/MUDDLE/util.21
new file mode 100644 (file)
index 0000000..859d2c3
--- /dev/null
@@ -0,0 +1,230 @@
+<SETG DEFINE
+ <FUNCTION (FUNNAME  DEF)
+   <SETG .FUNNAME .DEF>
+   <PRINT .FUNNAME>   >>
+
+
+<DEFINE FRAMEN 
+  <FUNCTION (N)
+   <COND (<0? .N> <FRAME>)
+         (T <FRAME <FRAMEN <- .N 1>>>)>>>\e
+
+
+
+<DEFINE CLEANUP
+  <FUNCTION CF () 
+    <FINALIZE>
+    <BUMPER>>>
+
+
+<DEFINE BUMPER
+  <FUNCTION ()
+   <FAILPOINT FP ()
+      <> (M A)
+      <RESTORE .FP (FAILURE CAUGHT WITH M = .M AND A = .A)>>   >>
+
+
+
+<DEFINE THSET
+  <FUNCTION (VAR\  VAL "AUX" (OV <RLVAL .VAR\ >))
+      <FAILPOINT ()
+         <SET .VAR\  <RLVAL VAL>>
+         (M A)
+         <SET .VAR\  <RLVAL OV>>
+         <FAIL .M .A>>   >>
+
+
+<DEFINE THDELQ
+ <FUNCTION (ELT L)
+   <COND (<EMPTY? .L> .L)
+         (<==? .ELT <1 .L>>
+          <CHTYPE <REST .L> <TYPE .L>>)
+         (T <THDELQ1 .ELT .L>)   >>>
+
+
+<DEFINE THDELQ1
+ <FUNCTION (ELT L)
+   <COND (<EMPTY? <REST .L>> .L)
+         (<==? <2 .L> .ELT> <THPUTREST .L <REST .L 2>>)
+         (T <THDELQ1 .ELT <REST .L>>)   >  >>
+
+
+<DEFINE THPUTREST
+ <FUNCTION (LIST1 LIST2)
+   <FAILPOINT ((OREST <REST .LIST1>))
+      <PUTREST .LIST1 .LIST2>
+      (M A)
+      <PUTREST .LIST1 .OREST>
+      <FAIL .M .A>   >>>
+
+
+<DEFINE THPUT
+ <FUNCTION (THING IND "OPTIONAL" PROP)
+   <FAILPOINT ((OPROP <GET .THING .IND>))
+      <COND (<ASSIGNED? PROP>
+             <PUT .THING .IND .PROP>)
+            (T <PUT .THING .IND>)   >
+      (M A)
+      <COND (.OPROP <PUT .THING .IND .OPROP>)
+            (<PUT .THING .IND>)   >
+      <FAIL .M .A>   >>>
+
+
+<DEFINE THSETLOC
+ <FUNCTION (LOC VAL "AUX" (OVAL <IN .LOC>))
+   <FAILPOINT ()
+      <SETLOC .LOC <RLVAL VAL>>
+      (M A)
+      <SETLOC .LOC <RLVAL OVAL>>
+      <FAIL .M .A>   >>>\f<DEFINE FALSE
+  <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> FALSE>  >>
+
+
+<DEFINE FORM
+  <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> FORM>  >>
+
+<DEFINE UNASSIGNED
+  <FUNCTION ("ARGS" A) <CHTYPE <EVAL .A> UNASSIGNED>  >>
+
+<DEFINE SEGMENT
+  <FUNCTION ("REST" 'A) <CHTYPE <EVAL .A> SEGMENT>  >>
+
+<DEFINE CONSTRUCTOR
+ <FUNCTION (TYPE)
+   <GET .TYPE 'CONSTRUCTOR>   >>
+
+
+<PUT LIST CONSTRUCTOR ,CONSL>
+<PUT FORM CONSTRUCTOR ,FORM>
+<PUT FALSE CONSTRUCTOR ,FALSE>
+<PUT VECTOR  CONSTRUCTOR ,CONSV>
+<PUT SEGMENT CONSTRUCTOR ,SEGMENT>
+<PUT UVECTOR CONSTRUCTOR ,CONSU>
+
+
+
+<DEFINE AVAL
+  <FUNCTION (ATOM)
+   <COND (<GASSIGNED? .ATOM> <GVAL .ATOM>)
+         (<LVAL .ATOM>)>  >>
+\f<DEFINE CLIP
+ <FUNCTION (VAR)
+   <FAILPOINT CLIPPER ((VAL ..VAR))
+      <FAIL> 
+      ()
+      <COND (<EMPTY? .VAL> <FAIL>)
+            (<RESTORE .CLIPPER
+                      <PROG1 <1 .VAL>
+                             <SET .VAR <SET VAL <REST .VAL>>>>>)   >>  >>
+
+
+<DEFINE FULL?
+ <FUNCTION (FOO) <NOT <EMPTY? <RLVAL FOO>>>>>
+
+
+<DEFINE FINSPLICE
+ <FUNCTION ACT (CURRENTENV NEWENV)
+   <PROG1 <SPLICE .CURRENTENV .NEWENV>
+          <FINALIZE .ACT>>   >>
+
+
+<DEFINE ENVIRON
+ <FUNCTION ("BIND" FOO) .FOO>>\f<DEFINE RESET
+ <FUNCTION (VAR)
+   <FAILPOINT ((VAL <RLVAL .VAR>)) <> ()
+      <SET .VAR <RLVAL VAL>>
+      <FAIL>>  >>
+
+<DEFINE PROG1
+ <FUNCTION ("REST" A) <1 .A>   >>
+
+
+<DEFINE PROG2
+ <FUNCTION ("REST" A) <2 .A>   >>\f<DEFINE MULTILEVEL
+ <FUNCTION (OBJECT)
+   <AND <NOT <MONAD? .OBJECT>>
+        <MEMQ <TYPE .OBJECT> '(LIST FORM VECTOR SEGMENT VECTOR)>>   >>
+
+<DEFINE REVERSE 
+ <FUNCTION REV (L "OPTIONAL" (CFUNC <CONSTRUCTOR <TYPE .L>>)
+                "AUX" (RESULT ()))
+   <COND (<EMPTY? .L> <.CFUNC !.RESULT>)
+         (T <SET RESULT (<1 .L> !.RESULT)>
+            <SET L <REST .L>>
+            <AGAIN .REV>)   >   >>
+
+
+<DEFINE NCONC
+ <FUNCTION ("REST" LSTUPL)
+   <COND (<EMPTY? .LSTUPL> ())
+         (T <CHTYPE <NCONC1 .LSTUPL> <TYPE <1 .LSTUPL>>>)   >>>
+
+
+<DEFINE NCONC1
+ <FUNCTION (LSTUPL)
+   <COND (<EMPTY? <REST .LSTUPL>> <1 .LSTUPL>)
+         (T <NCONC2 <1 .LSTUPL> <REST .LSTUPL>>)   >>>
+
+
+<DEFINE NCONC2
+ <FUNCTION (L1 LREST)
+   <COND (<EMPTY? .L1> <NCONC1 .LREST>)
+         (T <PUTREST .L1 <NCONC2 <REST .L1> .LREST>>)   >>>\f<DEFINE ANOTHER
+ <FUNCTION (OBJ BOUND)
+   <FAILPOINT FP ()
+     .OBJ ()
+     <AND <==? .OBJ .BOUND> <FAIL>>
+     <RESTORE .FP <SET OBJ <REST .OBJ>>>>  >>
+
+
+\f<DEFINE MAPCAR
+ <FUNCTION MAPPER (FUN "REST" EXPS "AUX" (RESULT ()) RES1 LAS)
+   <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
+   <COND (<EMPTY? .RESULT>
+          <SET LAS <SET RESULT (.RES1)>>)
+         (T <PUTREST .LAS <SET LAS (.RES1)>>)   >
+   <AGAIN .MAPPER>   >>
+
+
+<DEFINE MAPC
+ <FUNCTION MAPPER (FUN "REST" EXPS "AUX" (RESULT ()))
+   <REPEAT () <APPLY .FUN <LISTFIRSTS .EXPS>>>   >>
+
+
+<DEFINE MAPCAN
+ <FUNCTION MAPPER (FUN "REST" EXPS 
+                   "AUX" (RESULT ()) RES1 LAS1)
+   <SET RES1 <APPLY .FUN <LISTFIRSTS .EXPS>>>
+   <COND (<EMPTY? .RESULT>
+          <SET RESULT .RES1>)
+         (T <PUTREST .LAS1 .RES1>)   >
+   <SET LAS1 <LAST .RES1>>
+   <AGAIN .MAPPER>   >>
+
+
+<DEFINE LISTFIRSTS
+ <FUNCTION (EXPTUPL)
+   <COND (<EMPTY? .EXPTUPL> ())
+         (<EMPTY? <SET RES1 <1 .EXPTUPL>>> <.MAPPER .RESULT>)
+         ((<PROG1 <1 .RES1>
+                  <PUT .EXPTUPL 1 <REST .RES1>>>
+           !<LISTFIRSTS <REST .EXPTUPL>>))   >   >>
+
+
+<DEFINE LAST
+ <FUNCTION L (EXP)
+   <COND (<EMPTY? .EXP> ())
+         (<EMPTY? <REST .EXP>> .EXP)
+         (T <SET EXP <REST .EXP>>
+            <AGAIN .L>)   >>>\f<DEFINE BOTTOM
+ <FUNCTION (THING)
+   <COND (<MONAD? .THING> .THING)
+         (<==? <TYPE .THING> LIST> ())
+         (T <REST .THING <LENGTH .THING>>)>  >>
+
+
+
+
+<DEFINE SPREAD
+ <FUNCTION (VEC "REST" VARS)
+   <MAPC ,SET .VARS .VEC>   >>\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/vers.2 b/MUDDLE/vers.2
new file mode 100644 (file)
index 0000000..dd1c8d1
--- /dev/null
@@ -0,0 +1,17 @@
+
+<FLOAD "EDITOR" ">">
+
+
+<DEFINE VERSION ()
+       <REPEAT ((OB <ERRORS>) SUB)
+               <COND (<EMPTY? .OB><RETURN DONE>)>
+               <SET SUB <1 .OB>>
+L2             <COND (<EMPTY? .SUB><GO L1>)>
+               <PRIN1 <1 .SUB>>
+               <PRINC " VERSION ">
+               <PRIN1 ,<1 .SUB>>
+               <TERPRI>
+               <SET SUB <REST .SUB>>
+L1             <SET OB <REST .OB>>>>
+
+\f\ 3\f
\ No newline at end of file
diff --git a/MUDDLE/}msgs}.muddle b/MUDDLE/}msgs}.muddle
new file mode 100644 (file)
index 0000000..e69de29
index ed8917be83bc8f494695bc41e628da6585967a17..e09a9789b99ebc1cf653fe34cc4bc668b75e0d9d 100644 (file)
--- a/README.md
+++ b/README.md
@@ -1,3 +1,6 @@
-MIDAS Muddle for TOPS-20.
+## PDP-10 Muddle written in MIDAS assembly language
 
+`<mdl.int>` contains Muddle for TOPS-20, from around 1981.
 There should also be support for ITS, but it won't build as is.
+
+`MUDDLE` contains Muddle for ITS, from around 1973.