--- /dev/null
+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
--- /dev/null
+<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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+
+<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
--- /dev/null
+
+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
--- /dev/null
+"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
--- /dev/null
+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
--- /dev/null
+
+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
--- /dev/null
+ "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
--- /dev/null
+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
--- /dev/null
+
+\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 <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 <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 <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 <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 <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 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 <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
--- /dev/null
+
+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
--- /dev/null
+
+<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
--- /dev/null
+<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
--- /dev/null
+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
--- /dev/null
+<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
--- /dev/null
+<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
--- /dev/null
+<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
--- /dev/null
+;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
--- /dev/null
+;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
--- /dev/null
+ "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
--- /dev/null
+;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
--- /dev/null
+<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
--- /dev/null
+<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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+
+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
--- /dev/null
+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
--- /dev/null
+<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
--- /dev/null
+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
--- /dev/null
+<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
--- /dev/null
+
+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\ 5rô\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\ 47ô\a|¯/(\1c@\0\0ö\8b\80\b\193|\ 1%zõ`\0\b\1f \ 2y/\18õ\0 \0\ 3öH\80¥õ+\0\0\ 47 \ 2y/\18(\ 2@\0\0 \\ 1%zô\10\80¥õô\17\80\0\a+\0\0\ 47ô\a<°Oõç<°S? \0\0\a <\0\0\0.\\0\ 5u+\0\0\ 4I4^\0\ 47þ\eök»ïx\0\ 4Yô\a<°QöÈ<°Wa|\ 2\0\0õ`\0\ 4»ô\a<°O.\\0\ 5rô\a<°Sõ×\0\ 5å+\0\0\ 47`|\ 1\0\0+\0\0\ 47ô\a<°Oõç<°S? \0\0\a <\0\0\0.\\0\ 5s+\0\0\ 477@y/\12+\0\0\ 47ô\a<°Q`|\ 1\0\0+\0\0\ 47ô\a<°Oõç<°S.\\0\ 5s+\0\0\ 47ô\ 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\ 5fô\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\ 5gô\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\ 5hô\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\ 5nõ\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\ 5kô\ 1$°QöÐ$°O`d\ 1\0\0õ`\0\ 5kô\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\ 5k \v8\ 5Dô\ 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\ 5tô\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\ 5Vô\ 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\ 5lð\0\0\ 5Ù\87@(r\87p\ 5m\0\0\0\0\ 1\0\0\0\0dÿÿà\187ÿÿü\ 5ßÿÿÿÿÿ\87p\v_\87x\ 5qð\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\ 5mþ\ 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\ 5oõ\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\ 6Sõ\8e\80\0\a3^\0\ 5võ`\0\ 6a \1cy.y`|\0\10\0õ`\0\ 6a7@y/\11õ`\0\ 6_!<\0 \0ø÷<°Qõ`\0\ 6aõ\86\80\bG+\0\0\ 6G \ 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\ 5mö\9a\0\v\9f *\0\ fP6@9\17\17 *\0\0dô\12\80\ 5Ûõ`\0\ 5ù/\1a\ 1'/ \ 2\0\ 5n!.\ 4\0\0BN\bR)ùð\0Kï,z\0\0\0ô,\ 3ÿý76@\ 5_+\0\0\ 6Oô\ 2 \ 5ÁQ\16@\ 5b@l\0\0\ 2ô\14\0\ 5á,\1a\0\ 1Fô\ 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\afõ\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öＯ!õ`\0\a\ 3úG\0\0\ fG\y/\ fûX\0\0\ f02x\0\0+\0\0\ 49+\0\0\ 477 A/î+\0\0\ 47ô\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\aCô\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\ 5tø\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\a8ô\ 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\9eYô\ 1(¯K "\0\aV+\0\0\aE "\19/\ 2+\0\0\aEù\7fÚ®Ûïx\0\a^7@y/\10+\0\0\ 4<D\1cy0.ø'<¯\1f4\\0\ 4<-<\0\afõ\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\b3 \1cy/\röW\0§mõ`\0\bi \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\bqô\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\ 5pû\ 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\1aT \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\ 1Cð\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\1aXô\ 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\r0 \ 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\07 \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\ 1l
\1e\ 1%{Q
\1cy/
\1aG
\1c\0\0\ 3ô7
\0\ 1ZPy/
\1aõ`
\0\vÃ,:
\0\0\a7\y/
\1a+
\0\0\vWõ
\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\vOõ
\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\v3ô
\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\vOô
\awÿÿõ
\8e\80\0\ 1ô(
\83ÿÿ.Bp
\0\0+
\0\0\vOô
\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\vWõ
\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\vLô
\a8
\0\ 1=p
\0\vG
\10\0\0\aûG8
\0\ 1,:y/
\1aõpwÿýZ
\1cy/
\1aû
\17 \0\ 1,Zy/
\1a+
\0\0\va
\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
\1coð
\0\0\0\ fùæ0ÿ+
\0\0\0\0\bO
\18a
\9dð
\0\0\0\11O
\18rK]
\0\0\0\0 O
\18r
\0Gð
\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@
\10Gð
\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\ 6gñ\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\ 1Hð\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>\ 2fð\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\18p \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\ e9 \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\ e6ð\0\0\10#ð\0\0\13ãð\0\0\14/\0\0\0\ eVð\0\0\ ecð\0\0\12§ð\0\0\ esð\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\ eEû\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\ eEð\0\0\ e\95\0\0\0\ eNô\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\ eRõ\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\ eWõ\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\0gô\0\0\0aõ\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\0Yõ\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\ fUö\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\fCô\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\ fUô\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\109ô\ 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\10mõ\86\80\eá+\0\0\10hô\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
--- /dev/null
+<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
--- /dev/null
+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
--- /dev/null
+<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
--- /dev/null
+<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
--- /dev/null
+ "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
--- /dev/null
+<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
--- /dev/null
+<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
--- /dev/null
+
+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
--- /dev/null
+
+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
--- /dev/null
+<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
--- /dev/null
+<DEFINE STEST <FUNCTION ("STACK" A B C) [.A .B .C]>>\f\ 3\f
\ No newline at end of file
--- /dev/null
+<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
--- /dev/null
+ ; 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
--- /dev/null
+;"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
--- /dev/null
+<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
--- /dev/null
+<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
--- /dev/null
+
+<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
-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.
projects / pdp10-muddle.git / commitdiff