From: Lars Brinkhoff Date: Sun, 18 Feb 2018 07:14:53 +0000 (+0100) Subject: ITS Muddle. X-Git-Url: https://jxself.org/git/?p=pdp10-muddle.git;a=commitdiff_plain;h=39c5769144e7f2a58076bdb973d2c80fa603345c ITS Muddle. --- diff --git a/MUDDLE/_test.plannr b/MUDDLE/_test.plannr new file mode 100644 index 0000000..0c9b385 --- /dev/null +++ b/MUDDLE/_test.plannr @@ -0,0 +1,14 @@ +STINK +0MNLOAD >$ +$9B/JUMPA SETUP +$Y PLANNR LOSS +$G + $9B/JUMPA START +$Y PLANNR WIN +$G + +"> + + +"> +  \ No newline at end of file diff --git a/MUDDLE/actor.45 b/MUDDLE/actor.45 new file mode 100644 index 0000000..4a9b75c --- /dev/null +++ b/MUDDLE/actor.45 @@ -0,0 +1,524 @@ + >> + + >> + + >> + '(ACTOR ACTOR-FUNCTION)> + .EXP> >> + + '(FORM SEGMENT)> + > + >> >> + + + 0> >> + + +) + (OBL T) (ENV <>) (OBJENV <>) (PURE? T) + (UV1 ) + "AUX" (UV2 ())) + > + FACTOR>> + <.INVOKER >) + (.PURE? + >) >) + (.OBL + FORM> + >> + FACTOR>> + <.INVOKER T <> .OBJENV .ENV .UV2>>) >) + (T >) >) + (T .OBJENV >>) > + > + .BOUND >> >>>> + > + > + .BOUND) + (T .OBJECT .BOUND>) >) + (.OBL + .BOUND>) + (T .BOUND <>>) >) + (<==? ACTOR-FUNCTION> + + + '.OBJECT '.BOUND '.OBL '.PURE? ' + ' !>>) + (<==? ACTOR> + + + ((BODY > 2) (1) >>)) + + (.OBJECT .BOUND .OBL .PURE? .OBJENV !.BODY)> >) + (T ) > >> ) RS (VALRS ()) (UV ()) PURESOFAR NEWVAL + NEWBOUND (VARLOC ) VARFORM RS2) + + >) + (T T .BOUNDARY>) > + <.GA .BOUNDARY>) + (.PURE? + <.GA .OBJECT .BOUNDARY>>) + (T <.GA .BOUND <>>>) >) > + LIST>> + + > + + <.GA .BOUNDARY>) > + >> + <==? .VARLOC + 2 .VAR> .OBJENV>>> + <.GA .BOUNDARY>) + (> + ) + (T + + <.CHECK <>>> + > > + ) + (<==? <1 .RS1> PATTERN> + .OBJECT <3 .RS1> .BOUNDARY .OBLIGATORY>) + (T + .OBJECT <3 .RS1> .OBJENV + > .BOUNDARY + .OBLIGATORY>) >> + + + + <.GA .BOUNDARY>) + (> + LIST> + .RS>> + ) >) + (T ) >>) > + >> + +
.OBJECT .BOUND .OBL? + .PURE? .ENV .OBJENV> >> + + + + +>> >> + + + + + >> + + + + +) + "AUX" UV) + + <==? .N > + >) + (> + .UV> + >> + <==? .N > >) + ( ) + (T > .OBJECT + <> .OBJENV .FORM1 .BOUND>) > + .BOUND) + (.PURE? + > ) + (T ) >) + (T ) >) + (T + .OBJENV>> + > >) > + .BOUND) > >> + + + <.ACTITER ) + (T ) >>) > + .OBJECT .ENV .BOUND .OBL?>) + (T + .OBJECT + .ENV + .OBJENV + > + .BOUND + .OBL?>) >> + + > > >> + + + + + +)) + .BOUND .OBL?>) + (T .OBJENV .BOUND .OBL?>) > >> + + + + +>>) + (T .OBJENV>) >> > + ) + (T .OBJENV>) > + .NAY-SAYER>> + () + <.NAY-SAYER .BOUND> >>> + + ) NEWBOUND) + ) + (.PURE? .OBJECT <> .BOUND .OBL?>) + (T .OBJECT <> .OBJENV + > .BOUND .OBL?>) >> + () .WA>> + + (.OBJECT .NEWBOUND T .PURE? .ENV .OBJENV !)> + .NEWBOUND >> + + >>) + (> + .PURE?> + >) + + (> + .VARFORM .ENV> + ) + (T ) >) + (.PURE? + >>>) + ( .OBJENV >> + .PURE?> + >) + (T ) > + .BOUND >> + + +> + ) + (T ) > >> + + + LIST>) + UNASSIGNED>> >> <==? .L1 .TERM1>> + ) + (<==? .L2 .TERM2> )> + <1 .L2>> > + > > + >> + + + +) + (PURELOC <>) + "AUX" V P (LP ) (CONSTRUCT >) + (BOUND )) + + > + + + () + ) + (<==? > SEGMENT> + .LP>> + + > + ) > + .BOUNDLOC>> + >>) + (.EV? P>> + >>> + >> + >) + (T >>> + >>> + > + >>>>) >>> >> ) (BOUND ) + "AUX" V P (LP )) + + ) + (<==? > SEGMENT> + .LP>> + + > + ) > + >>>) + (T >>) > >>> ) (ENV <>) + (LUV )) + + FORM> + ) + ( + + .EXP) + (T ) >>> + + +) + "AUX" (RESULT ()) (P ()) P1 (LP1 ) EXP1) + + <.INSTLP >>>) + (<==? >> SEGMENT> + ,CONSL> + !.RESULT)>) + (T !.RESULT)>) > + >> + > + >> + + +>> + > + .F) + ( >>>> + + ) + (> + > + .F) + (<==? .A1 ,ALTER> + >> ?()> + > + ) + (<==? .A1 ,GIVEN> + >>> + + ) + (T > + .F) >) + (T > + .F) >>> ) (ENV <>) + "AUX" UA ACTR VAR) + + FORM> + >> .UA) + ( 2> + >>> + + >>>> + > + (.VAR)) >) + (<==? .ACTR ,ALTER> + >> ?()> + (.VAR)) >) >) + (<==? .EXP .BOUND> ()) + (T > .BOUND>>) >>> + + +) + "AUX" VAR) + + + '(FORM SEGMENT)> + <==? <1 .F> LVAL> + >> + > >> + (.VAR)) + (T ) >) > >> + + + FORM> + <==? 2> + <==? <1 .OBJECT> GIVEN> + >>> + .RES> >> + + + FORM> + + SEGMENT> <.UNC T>>) + .OBJECT> + <>>> >> .OBJECT) + (T + >>) > >> + + + .RES) + (T !.RES)> + > + ) >>> + + +)) + .PAT) + ( .BEG) + (T > + !) + >>> + > + .PAT) >>> + + + .RESULT) + (T !.RESULT)> + > + ) >>> + + + T) + ( <>) + (T > + ) >>> )) + >> + >>) + (<==? <1 .RS1> PATTERN> + .OBJECT <3 .RS1> .BOUNDARY>) + () > + > > + >> + > + VALUE> + > + )) + >> + >> UNASSIGNED> + >>>) > + > > + <3 .VALRS1> <4 .VALRS1> <5 .VALRS1> + <6 .VALRS1> <7 .VALRS1>> + > > >> + + + >> + > + > + <==? <1 .R1> PATTERN> + <==? .ENV <3 .R1>> + <=UPTO? <2 .R1> .EXP .BOUND>> + <.CHECK T>) > + > > >> + + + > + <=? .EXP1 .EXP2>) + ( > <>) + ( <==? .EXP2 .BOUND>) + (<==? .EXP2 .BOUND> <>) + (<=? <1 .EXP1> <1 .EXP2>> + > > + ) >>) >>> ) (BOUND2 ) + "AUX" (LOCS + >)) + <.LINKER .LOCS>> + + > LIST>) UNASSIGNED>> + > > >> + + + ()) + (T + > !.LOCS)> + > + <.GEN .LOCS>> >) >>>  \ No newline at end of file diff --git a/MUDDLE/agc.168 b/MUDDLE/agc.168 new file mode 100644 index 0000000..0182add --- /dev/null +++ b/MUDDLE/agc.168 @@ -0,0 +1,1834 @@ +TITLE AGC MUDDLE GARBAGE COLLECTOR +;SYSTEM WIDE DEFINITIONS GO HERE +.GLOBAL PDLBUF,VECTOP,VECBOT,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,WRONGT +.GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,TMA,TFA,PPGROW + +; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR + +.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS + + +PDLBUF=100 +TPMAX==5000 ;PDLS LARGER THAN THIS WILL BE SHRUNK +PMAX==1000 ;MAXIMUM PSTACK SIZE +TPMIN==100 ;MINIMUM PDL SIZES +PMIN==100 +TPGOOD==2000 ; A GOOD STACK SIZE +PGOOD==1000 + +RELOCATABLE +.INSRT MUDDLE > + +TYPNT=AB ;SPECIAL AC USAGE DURING GC +F=TP ;ALSO SPECIAL DURING GC +LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN + +;FUNCTION TO CONSTRUCT A LIST +MFUNCTION CONS,SUBR + ENTRY 2 + HLRZ A,2(AB) ;GET TYPE OF 2ND ARG + CAIE A,TLIST ;LIST? + JRST BADTYP ;NO , COMPLAIN + HLRZ A,(AB) ;GET TYPE OF FIRST + PUSHJ P,NWORDT ;GET NO. OF WORDS NEEDED FOR DATUM + SOJN A,CDEFER ;GREATER THAN 1, MUST MAKE DEFERRED POINTER + MOVEI A,2 ;SET UP CALL TO CELL + PUSHJ P,CELL + HLLZ A,(AB) ;TYPE OF FIRST ARG + MOVE C,1(AB) ;GET DATUM +CFINIS: PUSHJ P,CLOBIT ;STORE + JRST FINIS + +;HERE TO STORE IN PAIR + +CLOBIT: HRR A,3(AB) ;GET CDR +CLOBT1: MOVEM A,(B) ;STORE FIRST + MOVEM C,1(B) ;AND SECOND + MOVSI A,TLIST ;GET FINAL TYPE + POPJ P, + +;HERE FOR A DEFERRED CONS + +CDEFER: MOVEI A,4 ;NEED 4 CELLS + PUSHJ P,CELL + MOVE A,(AB) ;GET COMPLETE 1ST WORD + MOVE C,1(AB) ;AND SECOND + PUSHJ P,CLOBT1 ;STORE + MOVE C,B ;POINT TO DEFERRED PAIR WITH C + ADDI B,2 ;POINT TO OTHER PAIR + MOVSI A,TDEFER ;GET TYPE + JRST CFINIS + + +;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, + + +;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 + BADTYP: PUSH TP,$TATOM ;ARGUMENT OF TYPE ATOM + PUSH TP,MQUOTE 2ND-ARGUMENT-NOT-A-LIST + JRST CALER1 ;OFF TO ERROR HANDLER + + + ;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 + + ;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 + BDTYPV: 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 + + +; 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 + +; 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 + +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 + ;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 + + ;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 + + + +; 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, + +;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,],[S2NWORD,VECTMK],[SPSTK,TPMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECTMK] +[SLOCID,],[SCHSTR,],[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 + + +; 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 + +; 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 + +; 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 + + +; 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+] ;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 + +;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 + + ;HERE WHEN A VECTOR POINTER IS BAD + +VECTB1: MOVEI B,[ASCIZ /AGC -- VECTOR POINTS OUTSIDE VECTOR SPACE +/] + PUSHJ P,MSGTYP + .VALUE 0 + + + +; 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 + +;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, + + + + + +;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 + + ;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, + + ;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, + +;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 + + ;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 + + ;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 + + +; 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 + +; 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 + + +;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 + + ;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 + ;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 + +;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, + ;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 + ;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 + ;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 -- TRANSFER2YU 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, + ;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 + VECZE4: 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 + VECZE5: HRLZM F,(A) ;STORE THE NEW SIZE IN DOPEWD + JRST VECZE2 + +;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 ;BUCKET 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, + VCMLOS: 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 +  \ No newline at end of file diff --git a/MUDDLE/arith.58 b/MUDDLE/arith.58 new file mode 100644 index 0000000..1e1e933 --- /dev/null +++ b/MUDDLE/arith.58 @@ -0,0 +1,626 @@ +TITLE ARITHMETIC PRIMITIVES FOR MUDDLE + +;BKD + +;DEFINES MUDDLE PRIMITIVES: FIX,FLOAT,ATAN,IEXP,LOG, +; G?,L?,0?,1?,+,-,*,/,MAX,MIN,ABS,SIN,COS,SQRT,RANDOM, +; TIME,SORT. + +RELOCATABLE + +.INSRT MUDDLE > + +O=0 + + +DEFINE TYP1 + (AB) TERMIN +DEFINE VAL1 + (AB)+1 TERMIN + +DEFINE TYP2 + (AB)+2 TERMIN +DEFINE VAL2 + (AB)+3 TERMIN + +DEFINE TYP3 + (AB)+4 TERMIN +DEFINE VAL3 + (AB)+5 TERMIN + +DEFINE TYPN + (D) TERMIN +DEFINE VALN + (D)+1 TERMIN + + +YES: MOVSI A,TATOM ;RETURN PATH FOR 'TRUE' + MOVE B,MQUOTE T + JRST FINIS + +NO: MOVSI A,TFALSE ;RETURN PATH FOR 'FALSE' + MOVEI B,NIL + JRST FINIS + + ;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) + + ;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 + ;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 + ;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 + ;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 + ;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 + ;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 + MFUNCTION 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 + MFUNCTION 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 + MFUNCTION 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 + ;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 + ;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 + ;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 +  \ No newline at end of file diff --git a/MUDDLE/atomhk.27 b/MUDDLE/atomhk.27 new file mode 100644 index 0000000..4e5f9ef Binary files /dev/null and b/MUDDLE/atomhk.27 differ diff --git a/MUDDLE/book.3 b/MUDDLE/book.3 new file mode 100644 index 0000000..5ade565 --- /dev/null +++ b/MUDDLE/book.3 @@ -0,0 +1,481 @@ +V ORG P-K4 V KP P-K4 V 2W1 N-KB3 V 2B1 N-KB3 V 3W1 P-Q4 V 3B1 NXP +V 4W1 B-Q3 V 4B1 P-Q4 V 5W1 NXP V 5B1 B-Q3 V 6W1 O-O V 6B1 O-O +V 7W1 N-Q2 B-KB4 R-K1 BXN PXB B-N3 N-B3 E Q-K2 R-K1 E E E E E E +P-QB4 BXN PXB NXBP E E E E E NXN BXN N-Q2 NXN E E E E +N-KB3 QN-B3 N-B3 P-B3 E E N-K5 P-B4 L 7W1 P-QB4 BXN PXB +N-QB3 P-B4 B-B4 P-KN4 PXP E E E E B-KB4 B-K3 E E +PXP QXP Q-B3 B-B4 QXB QXB N-B3 N-B4 +QXQ NXQ L 7W1 N-QB3 NXN PXN N-Q2 P-KB4 +P-QB4 E E R-K1 Q-R5 P-N3 Q-R6 B-B1 Q-B4 N-N4 N-N3 +N-K3 Q-B3 B-Q3 P-KR3 N-N4 BXN QXB QR-K1 +L 7W1 R-K1 BXN PXB N-QB3 B-KB4 N-B4 N-B3 N-N5 +B-KB1 P-Q5 N-K4 NXN L 7W1 P-KB3 N-B4 L 6B1 +N-QB3 NXN PXN P-QB4 O-O P-B5 B-K2 N-B3 L 6B1 +BXN PXB N-B4 N-B3 L 6W1 Q-K2 BXN PXB N-B4 +L 6W1 N-QB3 NXN PXN O-O O-O N-Q2 P-KB4 P-QB4 L 5B1 B-K3 +Q-K2 N-Q3 O-O B-K2 R-K1 O-O NXP E E Q-B1 N-QB3 O-O Q-R5 P-KB4 +N-K2 E E E E E E N-Q2 B-KB4 NXN BXN O-O N-Q2 B-B3 +Q-R5 P-KN3 Q-R6 BXB PXB N-B4 BXN BXB N-B3 +P-KB3 N-Q4 PXP RXP L 5B1 N-QB3 NXN PXN Q-K2 +V 7B10 P-KB4 P-KB3 B-Q3 O-O O-O +PXN BPXP RXR QXR BXKP PXB Q-QB4 E E E E E E E E +Q-K2 PXN BPXP Q-R5 P-N3 Q-R6 PXB B-N5 Q-K5 B-B6 +L 7B10 Q-K2 O-O V 8B10 N-Q3 R-K1 QXQ RXQ +K-Q1 N-Q2 B-KB4 N-N3 BXB PXB L 8B10 P-N3 +BXN PXB R-K1 P-KB4 P-KB3 E E E E QXB Q-Q2 L 5B1 N-Q2 +Q-K2 NXN BXN E E Q-K2 BXN PXB B-B4 NXN BXN +P-KB3 B-N3 P-KB4 N-B3 P-B3 O-O-O B-K3 P-Q5 E E +Q-KN4 K-N1 B-N5 N-N5 P-B5 N-B7 K-B1 QXP B-KB4 Q-K5 + L 5B1 B-K2 O-O O-O +P-QB4 B-K3 N-QB3 N-KB3 P-B5 E E E E N-KB3 N-QB3 PXP BXBP E E E E +P-QB3 PXP PXP BXN PXB N-QB3 L 5W1 PXP N-B4 O-O B-K2 +N-B3 P-QB3 N-K2 NXB QXN P-B3 E E E E +N-Q4 NXB QXN O-O P-B4 P-B3 B-Q2 N-R3 L 4W1 PXP P-Q4 QN-Q2 +N-B4 N-N3 NXN RPXN N-B3 P-R3 B-K2 L 3B1 +P-Q3 N-B3 E E P-Q4 PXQP PXP B-QN5 P-B3 PXP Q-R4 N-B3 PXP NXP PXB +Q-B3 E E E E E E PXP B-QB4 Q-K2 B-K2 P-B4 P-B3 L 3B1 PXP P-K5 +N-K5 QXP P-Q4 PXG NXQP B-Q3 N-B3 Q-KB4 V 8B2 Q-K2 B-K3 P-KN3 +N-B3 B-K3 O-O B-N2 KR-K1 O-O QB-B5 L 8B2 P-KN3 O-O B-N2 N-B3 +O-O B-K3 B-K3 B-QB5 P-N3 B-R3 N-K2 QR-Q1 L 3W1 B-B4 NXP N-B3 +NXN QPXN P-QB3 NXP P-Q4 O-O B-Q3 R-K1 B-K3 B-Q3 N-Q2 +L 3W1 N-B3 B-N5 V 4W2 B-B4 N-B3 N-Q5 NXP Q-K2 +N-B3 NXKP O-O E E E E E E O-O +O-O N-Q5 NXN BXN P-Q3 P-B3 B-R4 E E E E E E +P-Q3 BXN PXB P-Q4 PXP NXP Q-K1 N-N3 E E B-Q2 B-N5 +R-K1 Q-Q3 Q-K2 QR-K1 E E R-N1 N-N3 B-QN5 QR-K1 BXN PXB +P-B4 BXN QXB NXP L 4W2 NXP O-O N-Q3 BXN QPXB NXP +B-K2 P-Q3 E E E E E E N-B3 BXN QPXB NXP B-Q3 P-Q4 +P-KR3 N-QB3 E E E E E E E E P-Q3 P-Q4 P-QR3 BXN +PXB R-K1 P-KB4 PXP E E E E E E E E B-K2 +R-K1 N-Q3 BXN QPXB NXP O-O P-Q4 B-B4 N-QB3 P-B3 +N-B3 Q-Q2 B-B4 E E E E E E B-K3 N-Q2 N-B4 QN-B3 +P-B4 PXP E E E E E E N-B4 P-QB3 B-K3 N-Q3 B-Q3 B-B4 +L 3W1 NXP P-Q3 V 4W3 N-KB3 NXP V 5W2 P-Q4 P-Q4 B-Q3 B-K2 V 7W2 +P-B4 B-QN5 QN-Q2 BXN BXB O-O O-O B-N5 B-B4 N-QB3 R-K1 +NXQP BXN PXB QXN PXN QXQ KRXQ BXP R-Q7 L 7W2 O-O N-QB3 V 8W2 P-B4 +N-N5 B-K2 PXP BXP O-O E E E E PXP NXB QXN QXP R-K1 B-KB4 +N-K5 P-KR3 E E N-B3 NXN QXN P-QB3 B-Q2 B-K3 +R-K5 Q-B5 Q-K3 Q-B7 E E E E E E R-K5 Q-Q2 P-Q5 +O-O PXP PXP L 8W2 R-K1 B-KN5 V 9W2 BXN PXB RXP BXN PXB P-KB4 E E +QXB NXP Q-Q3 N-K3 L 9W2 P-B3 P-B4 P-B4 B-R5 V 11WA P-KN3 + B-B3 PXP NXQP BXN O-O E E Q-R4 Q-Q2 QXQ KXQ +NXN BXN BXN QR-K1 L 11WA B-K3 O-O PXP N-N5 N-B3 BXN PXB +N-N4 E E E E P-Q6 NXB QXN BXN PXB NXQP E E E E E E E E +P-KN3 P-KB5 PXBP NXBP BXN BXB KXB RXP QN-Q2 Q-R5 K-N1 BXN NXB +Q-N5 K-B2 QR-KB1 R-K3 NXP B-K2 Q-R5 K-N2 R-KN5 K-R1 Q-B7 + L 11WA R-B1 PXP BXP Q-B3 +V 13WA Q-K1 O-O-O NXB QXN P-B3 QXQ RXQ NXP PXB N-QB7 +R-B1 NXR N-R3 N-Q7 BXN RXB RXN PXP L 13WA B-K2 O-O-O B-K3 P-B5 NXB +BXB QXB QXN P-KN3 Q-R6 BXP KR-K1 L 13WA N-B3 O-O-O N-Q5 +BXN NXQ BXQ NXN NXP L 11WA PXP BXBP K-B1 BXR PXN BXN V 14WA +PXB QXP Q-K2 O-O-O PXP K-N1 KXB KR-K1 PXN RXP BXR Q-N8 Q-B1 +R-Q8 L 14WA QXQB QXP PXP R-Q1 B-QN5 P-B3 BXP K-K2 BXN PXB +B-N5 K-K1 Q-K3 R-KB1 L 11WA BXN QPXB P-Q5 N-K4 Q-R4 + P-QN4 QXNP P-B3 PXP NXN PXN KBXP KXB +Q-R5 K-B1 O-O PXB Q-R6 L 11WA R-K2 NXQP NXN BXP E E E +E E E P-KR3 B-R4 P-B4 B-R5 L 9W2 +P-B4 N-B3 N-B3 PXP E E PXP QXP N-B3 BXN NXQ BXQ NXB NXN RXB O-O-O +B-QB4 N/B3-Q4 L 5W2 Q-K2 Q-K2 P-Q3 N-KB3 +V 7W5 N-B3 QXQ BXQ P-KN3 O-O B-N2 E E B-K3 P-B3 O-O B-N2 +E E B-Q4 B-N2 E E B-B4 P-Q4 E E O-O-O B-N2 KR-K1 O-O +E E E E E E N-QN5 N-R3 E E B-N5 B-N2 O-O-O P-B3 KR-K1 O-O +L 7W5 B-N5 QN-Q2 QXQ BXQ N-B3 P-B3 O-O-O O-O E E E E E E N-B3 QXQ BXQ +P-KR3 B-R4 P-KN4 B-N3 B-N2 E E E E BXN NXB N-QN5 K-Q1 E E E E +B-Q2 P-KN3 O-O-O B-N2 E E E E B-B4 P-KN3 O-O-O B-N2 P-KR3 +N-N3 L 5W2 N-B3 NXN QPXN B-K2 B-Q3 N-B3 B-KB4 B-N5 P-KR3 B-R4 +P-KN4 B-N3 L 5W2 P-Q3 N-KB3 P-Q4 B-K2 L 5W2 P-B4 B-K2 P-Q4 O-O +B-Q3 P-Q4 O-O N-QB3 L 4W3 N-B4 NXP V 5W3 N-B3 NXN NPXN P-KN3 +B-K2 B-N2 O-O O-O P-Q4 N-Q2 N-K3 N-N3 P-QB4 B-K3 P-QB3 P-KB4 +L 5W3 P-Q3 N-KB3 P-Q4 B-K2 B-Q3 O-O O-O N-B3 P-QB3 R-K1 B-N5 +P-Q4 N-K3 N-K5 BXB NXB + + L 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 + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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-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 + + 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 + + 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 + + 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 + + L 2B2 P-KN3 P-Q4 B-N2 N-B3 PXP +NXP N-QB3 B-K3 N-B3 NXN NPXN P-K5 + + 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 + + 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 + + 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 + + L KP P-Q3 P-Q4 E E P-KN3 P-Q4 E E P-Q4 PXP +N-KB3 P-Q4 NXP N-KB3 + + L KP N-QB3 N-KB3 P-K4 B-N5 T 3B2 + + 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 + L 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + L ORG P-KN3 N-KB3 B-N2 P-Q4 N-KB3 T 3B4 + + 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 + + +  \ No newline at end of file diff --git a/MUDDLE/book.4 b/MUDDLE/book.4 new file mode 100644 index 0000000..7484f8a --- /dev/null +++ b/MUDDLE/book.4 @@ -0,0 +1,532 @@ +P-K4 V KP P-K4 V 2W1 N-KB3 V 2B1 N-KB3 V 3W1 P-Q4 V 3B1 NXP V 4W1 B-Q3 V 4B1 P-Q4 V 5W1 NXP V 5B1 B-Q3 V 6W1 O-O V 6B1 O-OV 7W1 N-Q2 B-KB4 R-K1 BXN PXB B-N3 N-B3 +E Q-K2 R-K1 +E E E E E E P-QB4 BXN PXB NXBP +E E E E E NXN BXN N-Q2 NXN +E E E E N-KB3 QN-B3 N-B3 P-B3 +E E N-K5 P-B4 +L 7W1 P-QB4 BXN PXB N-QB3 P-B4 B-B4 P-KN4 PXP +E E E E B-KB4 B-K3 +E E PXP QXP Q-B3 B-B4 QXB QXB N-B3 N-B4 QXQ NXQ +L 7W1 N-QB3 NXN PXN N-Q2 P-KB4 P-QB4 +E E R-K1 Q-R5 P-N3 Q-R6 B-B1 Q-B4 N-N4 N-N3 N-K3 Q-B3 B-Q3 P-KR3 N-N4 BXN QXB QR-K1 +L 7W1 R-K1 BXN PXB N-QB3 B-KB4 N-B4 N-B3 N-N5 B-KB1 P-Q5 N-K4 NXN +L 7W1 P-KB3 N-B4 +L 6B1 N-QB3 NXN PXN P-QB4 O-O P-B5 B-K2 N-B3 +L 6B1 BXN PXB N-B4 N-B3 +L 6W1 Q-K2 BXN PXB N-B4 +L 6W1 N-QB3 NXN PXN O-O O-O N-Q2 P-KB4 P-QB4 +L 5B1 B-K3 Q-K2 N-Q3 O-O B-K2 R-K1 O-O NXP +E E Q-B1 N-QB3 O-O Q-R5 P-KB4 N-K2 +E E E E E E N-Q2 B-KB4 NXN BXN O-O N-Q2 B-B3 Q-R5 P-KN3 Q-R6 BXB PXB N-B4 BXN BXB N-B3 P-KB3 N-Q4 PXP RXP +L 5B1 N-QB3 NXN PXN Q-K2 V 7B10 P-KB4 P-KB3 B-Q3 O-O O-O PXN BPXP RXR QXR BXKP PXB Q-QB4 +E E E E E E E E Q-K2 PXN BPXP Q-R5 P-N3 Q-R6 PXB B-N5 Q-K5 B-B6 +L 7B10 Q-K2 O-O V 8B10 N-Q3 R-K1 QXQ RXQ K-Q1 N-Q2 B-KB4 N-N3 BXB PXB +L 8B10 P-N3 BXN PXB R-K1 P-KB4 P-KB3 +E E E E QXB Q-Q2 +L 5B1 N-Q2 Q-K2 NXN BXN +E E Q-K2 BXN PXB B-B4 NXN BXN P-KB3 B-N3 P-KB4 N-B3 P-B3 O-O-O B-K3 P-Q5 +E E Q-KN4 K-N1 B-N5 N-N5 P-B5 N-B7 K-B1 QXP B-KB4 Q-K5 +L 5B1 B-K2 O-O O-O P-QB4 B-K3 N-QB3 N-KB3 P-B5 +E E E E N-KB3 N-QB3 PXP BXBP +E E E E P-QB3 PXP PXP BXN PXB N-QB3 +L 5W1 PXP N-B4 O-O B-K2 N-B3 P-QB3 N-K2 NXB QXN P-B3 +E E E E N-Q4 NXB QXN O-O P-B4 P-B3 B-Q2 N-R3 +L 4W1 PXP P-Q4 QN-Q2 N-B4 N-N3 NXN RPXN N-B3 P-R3 B-K2 +L 3B1 P-Q3 N-B3 +E E P-Q4 PXQP PXP B-QN5 P-B3 PXP Q-R4 N-B3 PXP NXP PXB Q-B3 +E E E E E E PXP B-QB4 Q-K2 B-K2 P-B4 P-B3 +L 3B1 PXP P-K5 N-K5 QXP P-Q4 PXG NXQP B-Q3 N-B3 Q-KB4 V 8B2 Q-K2 B-K3 P-KN3 N-B3 B-K3 O-O B-N2 KR-K1 O-O QB-B5 +L 8B2 P-KN3 O-O B-N2 N-B3 O-O B-K3 B-K3 B-QB5 P-N3 B-R3 N-K2 QR-Q1 +L 3W1 B-B4 NXP N-B3NXN QPXN P-QB3 NXP P-Q4 O-O B-Q3 R-K1 B-K3 B-Q3 N-Q2 +L 3W1 N-B3 B-N5 V 4W2 B-B4 N-B3 N-Q5 NXP Q-K2 N-B3 NXKP O-O +E E E E E E O-O O-O N-Q5 NXN BXN P-Q3 P-B3 B-R4 +E E E E E E P-Q3 BXN PXB P-Q4 PXP NXP Q-K1 N-N3 +E E B-Q2 B-N5 R-K1 Q-Q3 Q-K2 QR-K1 +E E R-N1 N-N3 B-QN5 QR-K1 BXN PXB P-B4 BXN QXB NXP +L 4W2 NXP O-O N-Q3 BXN QPXB NXP B-K2 P-Q3 +E E E E E E N-B3 BXN QPXB NXP B-Q3 P-Q4 P-KR3 N-QB3 +E E E E E E E E P-Q3 P-Q4 P-QR3 BXN PXB R-K1 P-KB4 PXP +E E E E E E E E B-K2 R-K1 N-Q3 BXN QPXB NXP O-O P-Q4 B-B4 N-QB3 P-B3 N-B3 Q-Q2 B-B4 +E E E E E E B-K3 N-Q2 N-B4 QN-B3 P-B4 PXP +E E E E E E N-B4 P-QB3 B-K3 N-Q3 B-Q3 B-B4 +L 3W1 NXP P-Q3 V 4W3 N-KB3 NXP V 5W2 P-Q4 P-Q4 B-Q3 B-K2 V 7W2 P-B4 B-QN5 QN-Q2 BXN BXB O-O O-O B-N5 B-B4 N-QB3 R-K1 NXQP BXN PXB QXN PXN QXQ KRXQ BXP R-Q7 +L 7W2 O-O N-QB3 V 8W2 P-B4 N-N5 B-K2 PXP BXP O-O +E E E E PXP NXB QXN QXP R-K1 B-KB4N-K5 P-KR3 +E E N-B3 NXN QXN P-QB3 B-Q2 B-K3 R-K5 Q-B5 Q-K3 Q-B7 +E E E E E E R-K5 Q-Q2 P-Q5 O-O PXP PXP +L 8W2 R-K1 B-KN5 V 9W2 BXN PXB RXP BXN PXB P-KB4 +E E QXB NXP Q-Q3 N-K3 +L 9W2 P-B3 P-B4 P-B4 B-R5 V 11WA P-KN3 B-B3 PXP NXQP BXN O-O +E E Q-R4 Q-Q2 QXQ KXQ NXN BXN BXN QR-K1 +L 11WA B-K3 O-O PXP N-N5 N-B3 BXN PXB N-N4 +E E E E P-Q6 NXB QXN BXN PXB NXQP +E E E E E E E E P-KN3 P-KB5 PXBP NXBP BXN BXB KXB RXP QN-Q2 Q-R5 K-N1 BXN NXB Q-N5 K-B2 QR-KB1 R-K3 NXP B-K2 Q-R5 K-N2 R-KN5 K-R1 Q-B7 +L 11WA R-B1 PXP BXP Q-B3 V 13WA Q-K1 O-O-O NXB QXN P-B3 QXQ RXQ NXP PXB N-QB7 R-B1 NXR N-R3 N-Q7 BXN RXB RXN PXP +L 13WA B-K2 O-O-O B-K3 P-B5 NXB BXB QXB QXN P-KN3 Q-R6 BXP KR-K1 +L 13WA N-B3 O-O-O N-Q5 BXN NXQ BXQ NXN NXP +L 11WA PXP BXBP K-B1 BXR PXN BXN V 14WA PXB QXP Q-K2 O-O-O PXP K-N1 KXB KR-K1 PXN RXP BXR Q-N8 Q-B1 R-Q8 +L 14WA QXQB QXP PXP R-Q1 B-QN5 P-B3 BXP K-K2 BXN PXB B-N5 K-K1 Q-K3 R-KB1 +L 11WA BXN QPXB P-Q5 N-K4 Q-R4 P-QN4 QXNP P-B3 PXP NXN PXN KBXP KXB Q-R5 K-B1 O-O PXB Q-R6 +L 11WA R-K2 NXQP NXN BXP +E E E +E E E P-KR3 B-R4 P-B4 B-R5 +L 9W2 P-B4 N-B3 N-B3 PXP +E E PXP QXP N-B3 BXN NXQ BXQ NXB NXN RXB O-O-O B-QB4 N/B3-Q4 +L 5W2 Q-K2 Q-K2 P-Q3 N-KB3 V 7W5 N-B3 QXQ BXQ P-KN3 O-O B-N2 +E E B-K3 P-B3 O-O B-N2 +E E B-Q4 B-N2 +E E B-B4 P-Q4 +E E O-O-O B-N2 KR-K1 O-O +E E E E E E N-QN5 N-R3 +E E B-N5 B-N2 O-O-O P-B3 KR-K1 O-O +L 7W5 B-N5 QN-Q2 QXQ BXQ N-B3 P-B3 O-O-O O-O +E E E E E E N-B3 QXQ BXQ P-KR3 B-R4 P-KN4 B-N3 B-N2 +E E E E BXN NXB N-QN5 K-Q1 +E E E E B-Q2 P-KN3 O-O-O B-N2 +E E E E B-B4 P-KN3 O-O-O B-N2 P-KR3 N-N3 +L 5W2 N-B3 NXN QPXN B-K2 B-Q3 N-B3 B-KB4 B-N5 P-KR3 B-R4 P-KN4 B-N3 +L 5W2 P-Q3 N-KB3 P-Q4 B-K2 +L 5W2 P-B4 B-K2 P-Q4 O-O B-Q3 P-Q4 O-O N-QB3 +L 4W3 N-B4 NXP V 5W3 N-B3 NXN NPXN P-KN3 B-K2 B-N2 O-O O-O P-Q4 N-Q2 N-K3 N-N3 P-QB4 B-K3 P-QB3 P-KB4 +L 5W3 P-Q3 N-KB3 P-Q4 B-K2 B-Q3 O-O O-O N-B3 P-QB3 R-K1 B-N5 P-Q4 N-K3 N-K5 BXB NXB + P-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 +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 + +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 + +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 + +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 + +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 + +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 + +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 + +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 + +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 + +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 + +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 + +L 2B2 P-KN3 P-Q4 B-N2 N-B3 PXP NXP N-QB3 B-K3 N-B3 NXN NPXN P-K5 + +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 + +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 + +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 + +L KP P-Q3 P-Q4 +E E P-KN3 P-Q4 +E E P-Q4 PXP N-KB3 P-Q4 NXP N-KB3 + +L KP N-QB3 N-KB3 P-K4 B-N5 T 3B2 + +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 L 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 + +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 + +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 + + +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 + +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 + +L ORG P-KN3 N-KB3 B-N2 P-Q4 N-KB3 T 3B4 + +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 +  \ No newline at end of file diff --git a/MUDDLE/c.ubd026 b/MUDDLE/c.ubd026 new file mode 100644 index 0000000..185ab52 --- /dev/null +++ b/MUDDLE/c.ubd026 @@ -0,0 +1,390 @@ + + + + + + (SEVERITY STR "TUPLE" TEXT) + + + + + + ) + (<==? > ATOM> >) + (ELSE >)> + ;"Space" + > + ) + (<==? .SEVERITY STOP> )>> + + + + + + + +>> + +>> + + + + + +> + > + >> + + + + + + + > + > + +>> + > + > >>> + + + +> + >> + +> + > + >> + +> + + + >> + +> + > + >> + >> + + WORD> + >> + >>> + > + >) + (ELSE + > + -1>> + >>)>> + +> + .PRINFLG >> + +> + +> + > + > + + 2>>> + 1>>>> + +> + > + >> + + + +>> + + + + > + + + + + + + (NAME "OPTIONAL" (PFLG <>) "NAME" COMPILER) + ATOM>> + ) + (> + ) + ( FUNCTION>> + )> + > ;"Recursive calls" + > + ;"Remove" + > + + + > + > + + + >>> + + + LIST> > + > + + > + ATOM> + + + + + + ) + (<==? .MODE EXTRA> + + + + ) + (<==? .MODE OPTIONAL> + > + > + + + + + + + + + + ) + (ELSE )>) + ( LIST> <==? 2>> + + + > + > + + ) + (<==? .MODE OPTIONAL> + > + > + + > + + + + + > + + + + ) + (ELSE + )>) + (<==? STRING> + ) + ( <=? .ITEM "AUX">> + ) + (ELSE + + )>) + (ELSE )> + > >> + > + + + > + > ATOM> ;"Activation name ?" + + > + > + > + > > + > ;"Go do the real compilation for this object" + ;"Next object in the body" + >> + > + +) AGAIN:TAG EXIT:TAG) + + > > + > ATOM> + + > + > + EXTRA> + > > + >> + > + > ATOM> >> + > + > >> + > + + > + +)) + ) + (ELSE + > + > > + + > + + )>> + + + ;"Is there some function to compile this object ?" + THIS:TYPE> + ;"Is there some function for this type ?" + ,REFERENCE!-SETUP> + .OBJECT>> + + + + + >> + THIS:OBJECT >> + )) + < + ;"Do we know how to apply this ?" + APPLY:TYPE> + ;"Apply this type ?" + APPLY:PRIMTYPE> + ;"This primtype ?" + + ;"Otherwise go to eval with form" + + >> + .OBJ>>>> + + ;"Try again with the global value if possible" + + ) + ( > + ;"Else with local value" + + + ) + (ELSE + + + ;"Otherwise go to EVAL with the form" + + )>>> + + > > + > + + >>>> + > ;"Get atomic name of RSUBR" + + + + > > + > + + >>>> + 2>> + > + > ;"Get the structure" + + ;"Get the indicator" + + >> + + + 2> + > + > + >> + > ) + (<==? 1> + > + + ) + (ELSE )>>> + 2>> + > + >>> + )) + > > + > + >> + > + > + + > > + >> + + + > >> + >> + ,TEST:TRUE!-SETUP T>>> + ,TEST:FALSE!-SETUP #FALSE ()>>>> + + + + +                                                                              \ No newline at end of file diff --git a/MUDDLE/comp.envr b/MUDDLE/comp.envr new file mode 100644 index 0000000..01ade44 Binary files /dev/null and b/MUDDLE/comp.envr differ diff --git a/MUDDLE/create.14 b/MUDDLE/create.14 new file mode 100644 index 0000000..b16a28b --- /dev/null +++ b/MUDDLE/create.14 @@ -0,0 +1,109 @@ + +TITLE PROCESS-HACKER FOR MUDDLE + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL ICR,NAPT,IGVAL,CHKARG,RESFUN,RETPROC + +MFUNCTION CREATE,SUBR + + ENTRY 1 + GETYP A,(AB) ;GET TYPE OF ARG + ;MUST BE SOME APPLIABLE TYPE + CAIE A,TSUBR ;SUBR? + CAIN A,TEXPR ;EXPR? + JRST OKFUN + CAIE A,TFSUBR ;FSUBR? + CAIN A,TFUNARG ;FUNARG? + JRST OKFUN + CAIE A,TFIX ;CALL TO GET? (ALLOWING THIS IS QUESTIONABLE) + JRST NAPT ;NO, ERROR - NON-APPLIABLE TYPE +OKFUN: + + PUSHJ P,ICR ;CREATE A NEW PROCESS + MOVE C,TPSTO+1(B) ;GET ITS SRTACK + PUSH C,[TENTRY,,RETPROC] + PUSH C,[1,,0] ;TIME + PUSH C,[0] + PUSH C,SPSTO+1(B) + PUSH C,PSTO+1(B) + MOVE D,C + ADD D,[3,,3] + PUSH C,D ;SAVED STACK POINTER + PUSH C,PPSTO+1(B) ; + PUSH C,[RETPROC] + MOVEM C,TPSTO+1(B) ;STORE NEW TP + HRRI D,1(C) ;MAKE A TB + HRLI D,2 ;WITH A TIME + MOVEM D,TBINIT+1(B) + MOVEM D,TBSTO+1(B) ;SAVE ALSO FOR SIMULATED START + MOVE C,(AB) ;STORE ARG + MOVEM C,RESFUN(B) ;INTO PV + MOVE C,1(AB) + MOVEM C,RESFUN+1(B) + JRST FINIS + +MFUNCTION RETPROC,SUBR +; WHO KNOWS WHAT THIS SHOULD REALLY DO +;PROBABLY, JUST AN EXIT +;FOR NOW, PRINT OUT AN ERROR MESSAGE + PUSH TP,$TATOM + PUSH TP,MQUOTE ATTEMPT-TO-RETURN-OUT-OF-PROCESS + JRST CALER1 + + + + + + +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 +  \ No newline at end of file diff --git a/MUDDLE/editor.8 b/MUDDLE/editor.8 new file mode 100644 index 0000000..d38f0cb --- /dev/null +++ b/MUDDLE/editor.8 @@ -0,0 +1,140 @@ +"MUDDLE EDITOR, PRETTY-PRINT, AND OTHER ASSORTED ROUTINES" + +%%)> +FRAMES +LINPOS +LINLNT +PAGPOS +PAGLNT +LPT +TPL +1+ +1- +INC +DEC +CHOP +DEFINE +PPRINT +EPPRINT +EDITOR +%% + "PAGE 2" +%% )>> + +) + (ELSE )>)> + > + .NAME >> + +)(SMALL 1)) + )> + > + + > + + > + > + >>> + + + + + + +>> +>> + +>>> + +>>> + +>>> + + +>> + +) + (.DEFAULT )>>> + "PAGE 3" + + + + + + + + +)) + + -1> .TABS>> + 8> -1> .SPACES>>)>>> + +)) + > + >>)> + + >>> + + + "PAGE 4" + .M>> + ) + + + + (<==? FORM> + > + + <+ .M 1>> + ">) + (<==? LIST> + > + ) + (<==? VECTOR> + > + ) + (<==? FUNCTION> + + > + " >) + ( ) + (ELSE + > + + > + )> +>> + "PAGE 5" + + + >) + ( + >) + (ELSE UNASSIGNED)>>> + + + + + + DONE>> + +%% + +  \ No newline at end of file diff --git a/MUDDLE/eval.234 b/MUDDLE/eval.234 new file mode 100644 index 0000000..ede3105 --- /dev/null +++ b/MUDDLE/eval.234 @@ -0,0 +1,2054 @@ +TITLE EVAL -- MUDDLE EVALUATOR + +RELOCATABLE + +; GERALD JAY SUSSMAN, 1971 + +.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME +.GLOBAL IGVAL,CHKARG,SWAP,NXTDCL,TPOVFL,CHFRM +.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA +.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS + +.INSRT MUDDLE > + + MFUNCTION EVAL,SUBR + INTGO + HLRZ A,AB ;GET NUMBER OF ARGS + CAIE A,-2 ;EXACTLY 1? + JRST AEVAL ;EVAL WITH AN ALIST + HLRZ A,(AB) ;GET TYPE OF ARG + CAILE A,NUMPRI ;PRIMITIVE? + JRST NONEVT ;NO + JRST @EVTYPT(A) ;YES-DISPATCH + +SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE + MOVE B,1(AB) + JRST FINIS ;TO SELF-EG NUMBERS + +;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL. + +MFUNCTION VALUE,SUBR + JSP E,CHKAT + PUSHJ P,IDVAL + JRST FINIS + +IDVAL: PUSH TP,A + PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE PUSHJ P,ILVAL ;LOCAL VALUE FINDER + CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED + JRST RIDVAL ;DONE - CLEAN UP AND RETURN + JUMPN B,UNAS ;IF UNASSIGNED - ERROR + POP TP,B ;GET ARG BACK + POP TP,A + PUSHJ P,IGVAL + CAMN A,$TUNBOUND + JRST UNBOU + POPJ P, +RIDVAL: SUB TP,[2,,2] + POPJ P, + + +;GETS THE LOCAL VALUE OF AN IDENTIFIER + +MFUNCTION LVAL,SUBR + JSP E,CHKAT + PUSHJ P,ILVAL + CAME A,$TUNBOUND + JRST FINIS + JUMPN B,UNAS + JRST UNBOU + + +; 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 + + + +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]] + + + +;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 + + +; 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 + + +; 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 + + + +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 + + + +;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 + + + +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 + + +; 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) + + + +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 + + + +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 + + + + +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 + + + +;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 + 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 + + +;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. + + IGLOC: 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, + + + + +;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 + + + + +;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 + + + +; 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 + DCLGO: IRP A,,[ARGDO,TUPLDO,CALDO,OPTDO,ACTDO,AUXDO,ACTDO,AUXDO] + A + DCLS2==DCLS2+1 + TERMIN + +IFN ,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 + + + + +;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 + + + +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, + + + +; 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 + + + +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) + 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 + + + + +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 + + + +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 + + + +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, + + + + +; 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 + + + +;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, + + + +;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, + + + +;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 + 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, + + + + +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 + + + +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 + + + + +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 + + + + +;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, + + + + +;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, + + + +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 + + + +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 + + +;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 +***  \ No newline at end of file diff --git a/MUDDLE/filtrn.5 b/MUDDLE/filtrn.5 new file mode 100644 index 0000000..d78c405 --- /dev/null +++ b/MUDDLE/filtrn.5 @@ -0,0 +1,121 @@ + +TITLE FILTRN + +TYIC==1 +TYOC==2 +INC==3 + +A=1 +B=2 +C=3 +D=4 +E=5 +F=6 +G=7 +P=17 + +NCHRS==60. + +BFLNT==200 +LPDL==40 + + +FILTRN: MOVE P,[-LPDL,,PDL] ;GET A PDL + .OPEN TYIC,[SIXBIT / $TTY/] + .VALUE [ASCIZ /:LOGOUT /] + .OPEN TYOC,[SIXBIT / %TTY/] + .VALUE [ASCIZ /:LOGOUT /] + + .IOT TYOC,["\] ;ACKNOLEDGE + + MOVEI B,4*6 ;PREPARE TO READ FILE STUFF + MOVE A,[440600,,PTRF] ;GET POINT BYTER + +GETIF: .IOT TYIC,C + SUBI C,40 ;CONVERT TO SIXBIT + IDPB C,A ;INTO BUFFER + SOJN B,GETIF ;DO ALL CHARS + + SKIPE PTRF+3 ;SYSNAME GIVEN? + .SUSET [.SSNAM,,PTRF+3] ;NO USE CURRENT + MOVSI A,6 ;GET BLOCK IMAGE INPUT MODE + HLLM A,PTRF ;AND CLOBBER IN + + .OPEN INC,PTRF ;OPEN THE FILE + SKIPA A,["/] ;NEGATIVE ACK + MOVEI A,"\ ;POS ACKN + + .IOT TYOC,A ;SEND DOWN + CAIE A,"\ ;SKIP IF A WIINER + + .VALUE [ASCIZ /:LOGOUT +/] + + .IOT TYIC,A ;WAIT FOR HIM TO RE-ACK + CAIE A,"\ + .VALUE [ASCIZ /:LOGOUT /] + + +NXTBB: MOVE A,[-BFLNT,,BUFR] ;SETUP ITO POINTER + .IOT INC,A + MOVEI B,6*BFLNT ;NUMBER OF 6 BIT CHRS + JUMPGE A,GOTIT ;NOT EOF YET, JUMP + SETOM EOF ;AT END OF FILE + MOVEI B,(A) ;COMPUTE REMAINING + SUBI B,BUFR + IMULI B,6 ;CONVERT TO 6 BIT CHRS + +GOTIT: MOVE C,[440600,,BUFR] ;POINT TO BUFFER +NXTB: MOVEI G,NCHRS ;GET MAX MESSAGE LNT + CAIL G,(B) ;IF GRT THAN LEFT + MOVEI G,(B) ;USE REMAINS + SUBI B,(G) ;AND SHRINK TOTAL + ADDI G,40 ;CONVERT TO ASCII + .IOT TYOC,G + SUBI G,40 + + MOVEI D,0 ;INIT CHECKSUM + +LOOP: ILDB A,C ;READ A CHAR + ADDI D,(A) ;UPDATE CKS + ADDI A,40 ;CONV TO ASCII + .IOT TYOC,A ;TO NEXT MACHINE + SOJN G,LOOP ;COUNT DOWN + + ANDI D,77 ;CUT CKS + ADDI D,40 + .IOT TYOC,D ;SEND THE CKS + .IOT TYIC,D ;WAIT FOR ACK + + CAIE A,"\ + .VALUE [ASCIZ /:LOGOUT /] + + JUMPN B,NXTB ;STILL MORE IN BUFFER + + SKIPN EOF + JRST NXTBB ;MORE IN FILE, READ IT + + .IOT TYOC,[40] ;SEND EOF HACK + + SETZM EOF + .VALUE [ASCIZ /:LOGOUT /] + +PTRF: 0 + 0 + 0 + 0 + +BUFR: BLOCK BFLNT + +PDL: BLOCK LPDL + +EOF: 0 +FOO: +0 +PAT: +PATCH: BLOCK 30 + +END FILTRN + + +  \ No newline at end of file diff --git a/MUDDLE/flodyn.1 b/MUDDLE/flodyn.1 new file mode 100644 index 0000000..4afe42a --- /dev/null +++ b/MUDDLE/flodyn.1 @@ -0,0 +1,89 @@ + "DYNAMIC LOADER - USES 2 LIBRARY FILES AND RELATIVE ACCESS POINTERS" + +"Expects ERROR to have been SETGd to the proper thing. See FLODYN bootstrapper." + + + )>> + + +"Each library specification is a vector of four elements." + +>> + +"Library setup." + +)) + > + + > + <3 .LIBVEC>>> + > + <3 .LIBVEC>>> + >>)> + .LIBVEC> + +"Initializer." + + >>> >> + > + >>> >> + " "DSK" "MUDDLE")>> + "DONE"> + + + +"Error checker. Calls dynamic loader." + +> + <==? UNBOUND-VARIABLE!-ERRORS <1 .TR>> + <==? VALUE <3 .TR>> + >>) + (ELSE )>>> + + +"Real dynamic loader." + +) T1) + >> + > + >) + ( + > + + > + >> + ) + ( ) + (ELSE >)>)>> + +"Loader from directories." + +" !.WHERE>)) + >> + +"Loader from libraries" +"Expects USEROB to have been given a GVAL by BOOT." + + >>> >>> + + <+ <4 .LIBR> <<- > -1> <2 .LIBR>>>> + <3 .LIBR> .ROBL>>> + ATOM> ,.TLS) (ELSE .TLS)>)>> + + + +" "DSK" "MUDDLE") + ("LF" ">" "DSK" "MUDDLE") + ("FRAMES" ">" "DSK" "MUDDLE") + ("PPRINT" ">" "DSK" "MUDDLE")>> + +)) ,SPECF>>>> + + +  ð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒ \ No newline at end of file diff --git a/MUDDLE/fopen.63 b/MUDDLE/fopen.63 new file mode 100644 index 0000000..f1ae706 --- /dev/null +++ b/MUDDLE/fopen.63 @@ -0,0 +1,545 @@ +TITLE OPEN - CHANNEL OPENER FOR MUDDLE + +RELOCATABLE + +;C. REEVE JAN 1971 + +.INSRT MUDDLE > + +;THIS PROGRAM HAS TWO ENTRIES. FOPEN,FCLOSE AND FDELETE. +;THESE SUBROUTINES HANDLE I/O STREAMS FOR THE MUDDLE SYSTEM. + +; FOPEN - OPENS A FILE FOR EITHER READING OR WRITING. IT TAKES +; FIVE OPTINAL ARGUMENTS AS FOLLOWS: + +; FOPEN (,,,,) +; +; - DIRECTION EITHER READ (INPUT) OR PRINT (OUPUT). DEFAULT IS READ + +; - FIRST FILE NAME. DEFAULT INPUT OR OUTPUT. + +; - SECOND FILE NAME. DEFAULT MUDDLE. + +; - DEVICE FROM WHICH TO OPEN. DEFAULT IS DSK. + +; - 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 + + ;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 + + ;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 + +;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, + + +;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 + + +;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 + +  \ No newline at end of file diff --git a/MUDDLE/graphs.ura001 b/MUDDLE/graphs.ura001 new file mode 100644 index 0000000..20a73fc --- /dev/null +++ b/MUDDLE/graphs.ura001 @@ -0,0 +1,227 @@ + + > .P>> + > + LFX + )> + > + > )> + 0>> + )> + > + > >)> + > <* 0.5 <+ !.YM>>)> + NAS + LSC <- <.N .X> <1 .HPTS> >> + 500>>> + <- <.N .Y> <2 .HPTS> >> + 400>>> + > + >> )> + + + <- 0.0 <1 .HPTS>>> 500>>> >> + > )> )> + + <- 0.0 <2 .HPTS>>> 400>>> >> + > )> )> + + " + YMAX + " <2 .YM> " + SCALE + " .SCALE )> + >>> + ) (BIG <1 .X>) (SMALL <1 .X>)) + .BIG> > )> + .SMALL> > )> + > + )> + >>> + + + + + + + + + + + + "MOBIUS TRANGLE" + >> + + .Y> + > + >>> + >>>> + SET Q <+ .Q .I>> + > )> + >>>> .Y> + > + >>> + >>>> + > + > )> + >>>> + >> )> + > )> + + + > + )> + )> + > + >)> + >>>> + >>>> + >>>> ) + >> + >> + )> + > + + + LOOP <.N .Y>> )> + > + + )> + + ZAP + + >>> + + >>>>> + )> > + >>> + + + + + >> + )> + >> + + > + >> + > + > + + LOOP <- .X 500>> 40>> + > + )> + > + + >>> + > + > + > + >>> + + LOOP <- .X 500>> 10>> + > + > + > + )> + > + + >>> + + LOOP 10>> + > + )> + > + + >>> + > + + > + >>> + > + + LOOP )> + ;"ALL GOOD FUNCTIONS RETURN SOMETHING + THEREFORE SEND RETURNS 1." + >> + > + + >>> + + >> + >> + >> + >> + >> + > + > + > + > + + >>> +  \ No newline at end of file diff --git a/MUDDLE/initm.42 b/MUDDLE/initm.42 new file mode 100644 index 0000000..72cacb1 --- /dev/null +++ b/MUDDLE/initm.42 @@ -0,0 +1,423 @@ + +TITLE INITIALIZATION FOR MUDDLE + +RELOCATABLE + +LAST==1 ;POSSIBLE CHECKS DONE LATER + +.INSRT MUDDLE > + +.LIFL +.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 + +;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 + +;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 \0/9\] + MOVE D,[ASCII \B!Qî\] + MOVE E,[ASCIZ \*\] ;TERMINATE + JRST @1(P) ;GO DO IT + +; 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 + +; 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 + + +; 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 + + +;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 + + +  \ No newline at end of file diff --git a/MUDDLE/mapper.9 b/MUDDLE/mapper.9 new file mode 100644 index 0000000..153fb0f --- /dev/null +++ b/MUDDLE/mapper.9 @@ -0,0 +1,80 @@ + + + + + +> + +"LIST SPLICER NCONC" + + .L2) + ( .L1) + (T 1>> + .L2> + .L1)>> + + +"MULTIPLE LIST SPLICER" + + ()) + (T ) (ANS <.T .L>)) + >> )> + .ANS>>>)>>> + + + + 'NONE-OF-YOUR-BUSINESS) + (<==? > FIX> <<1 .L> .L>) + (T < .L>)>> + +"GENERALIZED MAPPER FUNCTION ACCORDING TO THE GOSPEL OF SUSSMAN" + + + + >> + )> + <.INMAP .L1> + >> + > + )> + >> + >>> + >>>>> + + +"SPECIFIC INVOCATIONS OF *MAP" + +> + +> + +> + +> + +> + +> +  \ No newline at end of file diff --git a/MUDDLE/match.18 b/MUDDLE/match.18 new file mode 100644 index 0000000..f1810e5 --- /dev/null +++ b/MUDDLE/match.18 @@ -0,0 +1,216 @@ + + T >> + + + T> + () + <> >>> + + + + T >> + + + T> + () + <> >>> + + + .EXP> + () + >>> ) (BOUND ) + (OBLIGATORY T) (PBOUND ) + "AUX" PURE ENDP K BETA ENDE) + FORM> + <.S >) + ( + > + .BOUND) + ( + <.S >>) + ( + >) > + + + > + <.R >) + (<==? > SEGMENT> + .EXP .ENDE .OBLIGATORY>>>) + (<==? .EXP .ENDE> ) + (T <1 .EXP>> + >) > + > > + + <.S .EXP>) + (T <1 .EXP>>) > + > + > > >> ) (ENV2 <>) + (BOUND1 ) (BOUND2 ) + (OBL T)) + FORM> + FORM> + > >>> + <.MATCHER >>) > + <.MATCHER >>) + (<==? FORM> + <.MATCHER >>) + ( > + <.MATCHER >>) + ( > + ) + ( > + <.MATCHER .PAT2>) > + ALPHA1 SEG1> + ALPHA2 SEG2> + + + ) + (>>) >) + ( + > + ) + (>>) >) > + <.R <>>) + (T <1 .PAT2> .ENV1 .ENV2>) > + > + > > + END1 K1 BETA1 S1> + END2 K2 BETA2 S2> + + > + >>> + > + ) + ( + >>> + > + ) + (T > + >) >) > + <0? .K1>> + <0? .K2>> + FORM>> + .FORM1 .FORM1 T .ENV1 .ENV2 <>>) + (T .SEG2 .END2 T .ENV1 .ENV2 <>>) >) + ( <0? .K2>> + .SEG1 .END1 T .ENV1 .ENV2 <>>) + (<0? .S2> + ) + (T >) >) + (<0? .S1> + ) + () >) + (T <#FUNCTION ((UV1 UV2) + > + ) + + >) > + ) > + <1 .END2> .ENV1 .ENV2> + > + > > > >> ) + (BOUND2 ) (OBL T) + "AUX" FORM1) + + <.SMATCHER .PAT2>) + (<==? > SEGMENT> + .PAT2 .BOUND2 .BOUND1> .OBL> .ENV1 .ENV2 <>>>) + (<==? .PAT2 .BOUND2> ) + (T <1 .PAT2> .ENV1 .ENV2> + >) > + > > >> + + >) + (<==? > SEGMENT> + > + + >) + (T >)> + > > >> + + +)) + .KOUNT> + > + > >> + + + + .K) + (T > + > + )> >> + + + + + > + .EXP >> + <==? > SEGMENT>> + <.SOFTENER [.ALPHA .PAT]>) > + > + > > >> + + + + + <.HACKER [.END .K .BETA .S]>) + (<==? >> SEGMENT> + > + + >>>> + >) > + > + + >) + (T >) > + > > >> +  \ No newline at end of file diff --git a/MUDDLE/medcom.2 b/MUDDLE/medcom.2 new file mode 100644 index 0000000..33f861f --- /dev/null +++ b/MUDDLE/medcom.2 @@ -0,0 +1,41 @@ +Commands: +NAME ARGS MEANING +? none Type this summary out. +O 1 Open object; takes ATOM, LOCATIVE, or CURSOR. +HERE 1,ATOM save your current CURSOR as the LVAL of ARG. +UT none Up Top -- go to the place you were just after O. +& none "Ampersand print" (normally done automatically). + none (Empty command) equivalent to &. +Q none Quit -- return to MUDDLE. +^K 1 Exit from MUDDLE and VALRET arg (STRING or ATOM). +P none (P)PRINT the next object. +PA 1,FIX (P)PRINT the object arg levels above position. +PT none (P)PRINT the whole object open. +V none toggle Verbosity. +R 1,FIX move Right arg objects. +L 1,FIX move Left arg objects. +B none move to the Back of the object. +F none move to the Front of the object. +U 1,FIX move Up arg levels (and to the left). +D 1,FIX move Down arg levels (and to the right). +UR 1,FIX move Up arg levels (and to the right). +DL 1,FIX move Down arg levels (and to the left). +S 1,any Search -- tree-walk right until you find arg. +-S 1,any Search left -- tree-walk left until you find arg. +WR 1,FIX Walk Right arg positions. +WL 1,FIX Walk Left arg positions. +C 1,any Change the next object to arg. +I any,any Insert args to the left of the cursor. +K 1,FIX Kill (delete) the next arg objects. +K: none Remove the "brackets" around the next object. +I: 2 Make the next (arg 2) objects into a TYPE (arg 1). +C: 1,TYPE Change the Type of the next object to arg. +SC 1,any Put arg on next object as a comment. +PC none Print comment on next object. +BK any,any BreaKpoint on next object; args typed at break. +KB none Kill all Breakpoints in open object. +OB any,ATOM BLOCK to list of OBLISTs whose names are given. +EB none ENDBLOCK. +OB? none type names of OBLISTs in current list of OBLISTs. + returns you to MEDDLE from a higher level. +  \ No newline at end of file diff --git a/MUDDLE/meddle.3 b/MUDDLE/meddle.3 new file mode 100644 index 0000000..99c0a70 --- /dev/null +++ b/MUDDLE/meddle.3 @@ -0,0 +1,370 @@ +" "DSK" > + + +XMED!- +MMED!- +MEDDLE!- + + )> +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 +BK KB + + + )> + + + + + +) + (CLLN <- <13 .OUTCHAN> 4>) + (OBPDL ()) + (VERBSW #FALSE ())) + + )>> + +> + + O>)) + > + OBANDCURS> <==? CURSOR> >) + (ELSE .HOW)>) + (ELSE #FALSE ("BAD TYPE"))>> + +> + +> + +)) + + > + > + > > + !.LOBS)> + >> + > + > + >> + + > + > > + + >) + ( >) + (ELSE '#FALSE ("UNASSIGNED"))>> + + + > + > > + + 2>)) + + <1 .CO!-M>) (T .CO!-M)>) + ( 3>> ) + (ELSE <.RI .LST!-M>)>> + + > + + '#FALSE ("RIGHT-EDGE")) (ELSE <.CI!-M .CO!-M>)>> + > + + + >) + (T " "DSK" "MUDDLE">)> + + ) + (ELSE )>> + + + + >>) + (ELSE >>)>> + +>> + + > + + > + + > >> + + STRING> .ARG) (ELSE )>>> + +" "DSK" "MUDDLE">)) + .FIL>>> + + ) + (ELSE #FALSE("Where's my file???"))>> + + ATOM> + ) OBANDCURS>>) + (ELSE #FALSE ("ARG NOT ATOM"))>> + + > + > OBLIST> <1 .BLK>) + ( OBLIST>) + (ELSE )>> + > > + + .BLOK> '()) (ELSE ())>)> + + > + + > + + #FALSE ("NO MORE BLOCKS")) + (ELSE + > + > + > + > + + )>> + + > + + OBLIST>> + > >> + > T> + + > + + 5>> + 5>> + + + + > .CI!-M> + > + > + > + > + ) + (ELSE + > .CLLN) + (ELSE <- .CLLN 2 .CLLN>>)>)) + + >) + ( 4> >> + >) + (ELSE >> + >)> + >>> + .LLN> >>) + (ELSE + >> + .LLN> >>)> + ) (VIC .FSL)) + <1 .VIC>> ) + (>> + 1 + 1>>>> + -4>> + + )>> + >>>)>> + +)) + 1 + .LLN>) + (ELSE 1 .OBJ>> 4)>>> + > .STOP> >>>>> + + + + > + > + >)) + > + ) + ( > + + >) + (ELSE >)> + + >> + > + > + +>)) + ) + ( '![ATOM FIX FLOAT]>) + (<==? .WHICH CLOSEBRAK> !"?>>) + (ELSE + + > + + !"?>>)>> + + + > + + + + + "> + > + T> +) (T #FALSE ("RIGHT-EDGE"))>> +) (T #FALSE ("LEFT-EDGE"))>> +> +> + > >)> + > +> +> +> +> +> +> + +)) + ) + (>) + (ELSE )> + > >> + + >> +>> + +)) + ) + (ELSE #FALSE ("NOT-FOUND"))>> + + .NTYP>> T> + +)) + + )> + > + +) LINS) + > #FALSE ("NOT-STRUCTURED")) + (ELSE >> > )>> + + )> + !.OBJ> .NTYPE>> + + #FALSE ("RIGHT-EDGE")) + ( > COMMENT .COMM> "put.") + (T > COMMENT> "Removed.")>> + '#FALSE ("RIGHT-EDGE")) + (ELSE ) FORM>> + "busted")>> + + + > + ) + (ELSE )>> + + "DONE"> + + + + ) + (ELSE + > + > + +> + + + +> + +) + (ROB (.TOB !.NOB)) + (UTOP <1 .NOB>) + FRST CMND FLIST EFLIST) + ;"FLUSH THE CRETINOUS INITIAL ALTMODE." + > + P2GO + + P1GO <1 ,ALTGETTER>> + + + )> + >>>> + )) + > + > .UTOP> + >> + > + !"> > + ) + (> <1 .COB>> + >>>> + .TOB> .UTOP>> + + )> + .TOB> > + >> + ,SPECS>> + + >) + (ELSE )>>>)>> + >) + (ELSE )> + > + >> + + + + +> > ,XMED!-> )> +  \ No newline at end of file diff --git a/MUDDLE/medpp.1 b/MUDDLE/medpp.1 new file mode 100644 index 0000000..78c0eab --- /dev/null +++ b/MUDDLE/medpp.1 @@ -0,0 +1,81 @@ + +"File to convert a PPRINT with comments to a MEDPP." +"PPRINT MUST!!! be loaded FIRST!!!" + +"Add the ATOMs needed for intercommunication with MEDDLE." +)> +"Cursor arrangements." +MEDDLE_CURSOR +SPECBEF +SPECAFT +"Other." +PRINE + + "Now add and change things within PPRINT." + )> + +MEDSW ;"The existence of this atom in PP shows that MEDPP has been loaded." + + + + + + >> + +) (STOP 0)) + > ;"So cursor point can be recognized." + ) (M 0)) + > > + > + > + > + + >> <==? .L .STOP>> > + + >>> + + +) (STOP 0)) + ) + (ELSE + > ;"So cursor point can be recognized." + ) COM) + > + > + > + > + >> <==? .L .STOP>> > + )> + >)>>> + + + ) + (<==? STRING> ) + ( >> + ) + (ELSE )> + ,NULL>> ;"The rubout atom is there." + + +>)) + + .SPECBEF> > + > + > + ) + ( + <- + + .M 3>> + >) + (T >)>) + (T )> + ">>> + + +  ð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒ \ No newline at end of file diff --git a/MUDDLE/microm.1 b/MUDDLE/microm.1 new file mode 100644 index 0000000..ba64793 --- /dev/null +++ b/MUDDLE/microm.1 @@ -0,0 +1,165 @@ + + )> +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 + + + )> + + + + + + )> + T>> + + + + + +>> + +> >> + +>>> + +> + > + > + > + > + T>> + )) + <==? .T >>>> + +)) + <==? .T >>>> + + + #FALSE("NO-RIGHT")) + (ELSE )>>> + + + #FALSE("NO-LEFT")) + (ELSE #FALSE()>)>>> + +> #FALSE("MONAD")) + (ELSE + + > + >> + >)>>> + + #FALSE("TOP")) + (ELSE > )>>> + + #FALSE("TOP")) + (ELSE >> )>>> + +> + > + > + T>> + >>> +
    >>> + +>> +>> + + <=? .IT <.CI .CO>>> + ) + (<.DOWN>) (<.ACROSS 1>) (<.UP>) + (ELSE )>>>> + +>> +>> + + ) + (<.DOWN>) (<.ACROSS 1>) (<.UP>) + (ELSE )>>>> + ) (LIT ) (OCI .CI)) + > + > + LIST> + T) + (ELSE + > > + )>) + (ELSE + + (.CO .IT ) + (.RCI .LIT <- .CL+1 .CI>)> + >> + )>>> + + + <+ .CI .N -1>>>) + (LCO ) (OCI .CI)) + > + LIST> ) + (ELSE + + (.CO .RCO) + (<- .CI 1> .LCO)> + >> + )>>> + + >> ) + (ELSE > .L> T)>>> + + + +)) + + > <1? >> <1 .CO>) + (ELSE .CO)>>) + (ELSE )> + <2 .LST>> .CO>)> + T>> + +>) (N <- .CI 1>)) + > .CO>>>> + + #FALSE ("RIGHT-EDGE")) + (ELSE .N>)>>> + +) (N <1 .NL>) (IX 0)) + ;"Actual structure hacker. STACKFORMs FN, gobbling <1 .NL> members from <1 .OL> 'till gone." + + >> + ) + (ELSE + >>>> + )> + + >>> + >>)>>) + (ELSE > > >)>>>> + +  ð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒ \ No newline at end of file diff --git a/MUDDLE/mproc.save b/MUDDLE/mproc.save new file mode 100644 index 0000000..cd09743 --- /dev/null +++ b/MUDDLE/mproc.save @@ -0,0 +1,208 @@ +;THESE SECTIONS OF CODE HAVE BEEN ABLATED FROM NEVAL 114 +;SO THAT THE TIDE OF HISTORY MAY WASH OVER THE BONES OF THE MULTI- +;PROCESSED AGGRESSORS + + +;THE FIRST IS THE WAY THE SYSTEM USED TO DO EVALUATIONS WITH +;RESPECT TO FRAMES-- NOW CALLED EWRTFM. + + 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 + MCALL 2,EVAL + POPJ P,  \ No newline at end of file diff --git a/MUDDLE/muddle.196 b/MUDDLE/muddle.196 new file mode 100644 index 0000000..f73305a --- /dev/null +++ b/MUDDLE/muddle.196 @@ -0,0 +1,916 @@ +;CONVENTIONS USED IN ALL INTERNAL MUDDLE PROGRAMS + +;FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE +;WITH EXPLICIT CHECKS +;FOR PENDING INTERRUPTS + + +; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST +;BE ABSOLUTELY PURE. +;BETWEEN ANY TWO INSTRUCTIONS OF +;INTERRUPTABLE CODE THERE MAY +;BE AN INTERUPT IN WHICH +;A COMPACTING GARBAGE COLLECTION IS CALLED +;AND THEN THE PROCESS WHICH WAS RUNNING IS +;PASSIVATED AND ANOTHER RESUMED. + +; ALL ATOM HEADERS WILL BE REFERRED TO IN ASSEMBLED CODE BY +; MQUOTE +; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING: + +; MCALL N, ;SEE MCALL MACRO + +; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE FUNINESS + + + + ; 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 + + + ;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 + ; 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 +; OBJ +; VD-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN + + + ;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,, +; ATOMIC NAME + +;AN ATOM IS A VECTOR WITH 3 ELEMENTS AS FOLLOWS + +; TYPE OF VALUE TYPES ARE FULL WORD QUANTITIES +; VALUE +; TLIST,, +; 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 +; ;CAN BE REFERENCED SYMBOLICALLY AS LERR(PVP) + +; TTB,,0 +; ;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) + + + + IF1 [ +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 ,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 + + ;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 +] + ;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 + + +;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 +] + +;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 + ;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 + + + +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==-,,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 + + + + ;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 + + + + + ;MACRO TO DEFINE A FUNCTION ATOM + +DEFINE MFUNCTION NAME,TYPE,PNAME + (TVP) +NAME": + VECTGO DUMMY1 + IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM, + IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM, + 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 + + +CHRWD==5 + +IFN READER,[ +NCHARS==177 +;CHARACTER TABLE GENERATING MACROS + +DEFINE SETSYM WRDL,BYTL,COD + WRD!WRDL==& + WRD!WRDL==\<_<<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==/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,\ + TERMIN + TERMIN + +DEFINE INCRCH OCOD,LIST + IRPC CHAR,,[LIST] + DUM3=="CHAR + DUM1==DUM3/5 + DUM2==DUM3-DUM1*5 + SETSYM \DUM1,\DUM2,\ + TERMIN + TERMIN + RMT [EXPUNGE DUM1,DUM2,DUM3 + REPEAT NWRDS,KILLWD \.RPCNT + REPEAT CHRWD,KILMSK \.RPCNT +] + +TERMIN + +INITCH +] + +;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==&77 + REST== + IFN N,IFGE <31-N>,IFGE ,TOTAL==TOTAL*10.+ + 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==<<<&77>+40>_29.> + B==<&77> + IFN B,A==A+<_22.> + B==<&77> + IFN B,A==A+<_15.> + B==<&77> + IFN B,A==A+<_8.> + B==<&77> + IFN B,A==A+<_1.> + A + IFN ,<+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 \ + RADIX 10. + .GSSET 0 + REPEAT TOTAL,XXP + RADIX 8 +TERMIN + +DEFINE XXP \A + EXPUNGE A + TERMIN + ;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,[,,] + PUSH PP,A + MOVEM TP,TPSAV(TB) ;MAKE SURE TP SLOT IS CORRECT + MOVE E,TB + PUSHJ P,BCKTRE ;COPY FRAME +TERMIN  \ No newline at end of file diff --git a/MUDDLE/muddle.init b/MUDDLE/muddle.init new file mode 100644 index 0000000..b475959 --- /dev/null +++ b/MUDDLE/muddle.init @@ -0,0 +1,40 @@ + "BOOTSTRAP FOR DYNAMIC FLOADER" + +"Expects floader to be FLOADYN > DSK:MUDDLE; +FLODYN must SETG RERR to the function it must be +for real floading. The RERR here calls the new one +after FLOADing it." + + +ELSE!- MUTS!- PPRINT!- FRAMES!- FRM!- PPRINF!- MMED!- XMED!- MEDDLE!- + + )>> + + + +>> + +> + <==? UNBOUND-VARIABLE!-ERRORS <1 .TR>> + <==? VALUE <3 .TR>>> + " "DSK" "MUDDLE"> + ) + (ELSE )>> + +"Function to allow user library OBLIST specification. +In here so INIT files can use it." + +> + + + + + + + + + '![!"Y !"y]> ) + ()> + +  ð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒ \ No newline at end of file diff --git a/MUDDLE/muddle.old b/MUDDLE/muddle.old new file mode 100644 index 0000000..f585ac3 --- /dev/null +++ b/MUDDLE/muddle.old @@ -0,0 +1,899 @@ +;CONVENTIONS USED IN ALL INTERNAL MUDDLE PROGRAMS + +;FOR EFFICIENCY THE STANDARD MODE OF RUNNING IS UNINTERRUPTABLE +;WITH EXPLICIT CHECKS +;FOR PENDING INTERRUPTS + + +; FOR INTERRUPTS TO WORK IN INTERRUPTABLE CODE, IT MUST +;BE ABSOLUTELY PURE. +;BETWEEN ANY TWO INSTRUCTIONS OF +;INTERRUPTABLE CODE THERE MAY +;BE AN INTERUPT IN WHICH +;A COMPACTING GARBAGE COLLECTION IS CALLED +;AND THEN THE PROCESS WHICH WAS RUNNING IS +;PASSIVATED AND ANOTHER RESUMED. + +; ALL ATOM HEADERS WILL BE REFERRED TO IN ASSEMBLED CODE BY +; MQUOTE +; FUNCTION CALLS TO INITIAL FUNCTIONS WILL BE CALLED USING THE FOLLOWING: + +; MCALL N, ;SEE MCALL MACRO + +; UNLESS PNAME IS NOT A VALID MIDAS SYMBOL, IN WHICH CASE FUNINESS + + + + ; 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 + + + ;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 + ; 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 +; OBJ +; VD-VECTOR DOPE--SIGN-G.C.; BITS 1-17 ARE 2*N+1,,18-35 G.C. RELOCATION EITHER UP OR DOWN + + + ;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,, +; ATOMIC NAME + +;AN ATOM IS A VECTOR WITH 3 ELEMENTS AS FOLLOWS + +; TYPE OF VALUE TYPES ARE FULL WORD QUANTITIES +; VALUE +; TLIST,, +; 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 +; ;CAN BE REFERENCED SYMBOLICALLY AS LERR(PVP) + +; TTB,,0 +; ;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) + + + + IF1 [ +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 ,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 +] + ;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 + + + ;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 + + +;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 +] + +;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 + ;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 + + + +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==-,,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 + + + + ;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 + + + + + ;MACRO TO DEFINE A FUNCTION ATOM + +DEFINE MFUNCTION NAME,TYPE,PNAME + (TVP) +NAME": + VECTGO DUMMY1 + IFSE [PNAME],MAKAT NAME,T!TYPE,NAME,SYSTEM, + IFSN [PNAME],MAKAT [PNAME]T!TYPE,NAME,SYSTEM, + 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 + + +CHRWD==5 + +IFN READER,[ +NCHARS==177 +;CHARACTER TABLE GENERATING MACROS + +DEFINE SETSYM WRDL,BYTL,COD + WRD!WRDL==& + WRD!WRDL==\<_<<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==/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,\ + TERMIN + TERMIN + +DEFINE INCRCH OCOD,LIST + IRPC CHAR,,[LIST] + DUM3=="CHAR + DUM1==DUM3/5 + DUM2==DUM3-DUM1*5 + SETSYM \DUM1,\DUM2,\ + TERMIN + TERMIN + RMT [EXPUNGE DUM1,DUM2,DUM3 + REPEAT NWRDS,KILLWD \.RPCNT + REPEAT CHRWD,KILMSK \.RPCNT +] + +TERMIN + +INITCH +] + +;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==&77 + REST== + IFN N,IFGE <31-N>,IFGE ,TOTAL==TOTAL*10.+ + 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==<<<&77>+40>_29.> + B==<&77> + IFN B,A==A+<_22.> + B==<&77> + IFN B,A==A+<_15.> + B==<&77> + IFN B,A==A+<_8.> + B==<&77> + IFN B,A==A+<_1.> + A + IFN ,<+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 \ + RADIX 10. + .GSSET 0 + REPEAT TOTAL,XXP + RADIX 8 +TERMIN + +DEFINE XXP \A + EXPUNGE A + TERMIN +  \ No newline at end of file diff --git a/MUDDLE/multi.test b/MUDDLE/multi.test new file mode 100644 index 0000000..52f2b4a --- /dev/null +++ b/MUDDLE/multi.test @@ -0,0 +1,12 @@ + + PROC2FUN>>> + +> + + + + >> + + + +  \ No newline at end of file diff --git a/MUDDLE/nactor.1 b/MUDDLE/nactor.1 new file mode 100644 index 0000000..12ee558 --- /dev/null +++ b/MUDDLE/nactor.1 @@ -0,0 +1,524 @@ + >> + + >> + + >> + '(ACTOR ACTOR-FUNCTION)> + .EXP> >> + + '(FORM SEGMENT)> + > + >> >> + + + 0> >> + + +) + (OBL T) (ENV <>) (OBJENV <>) (PURE? T) + (UV1 ) + "AUX" (UV2 ())) + > + FACTOR>> + <.INVOKER >) + (.PURE? + >) >) + (.OBL + FORM> + >> + FACTOR>> + <.INVOKER T <> .OBJENV .ENV .UV2>>) >) + (T >) >) + (T .OBJENV >>) > + > + .BOUND >> >>>> + > + > + .BOUND) + (T .OBJECT .BOUND>) >) + (.OBL + .BOUND>) + (T .BOUND <>>) >) + (<==? ACTOR-FUNCTION> + + + '.OBJECT '.BOUND '.OBL '.PURE? ' + ' !>>) + (<==? ACTOR> + + + ((BODY > 2) (1) >>)) + + (.OBJECT .BOUND .OBL .PURE? .OBJENV !.BODY)> >) + (T ) > >> ) RS (VALRS ()) (UV ()) PURESOFAR NEWVAL + NEWBOUND (VARLOC ) VARFORM RS2) + + >) + (T T .BOUNDARY>) > + <.GA .BOUNDARY>) + (.PURE? + <.GA .OBJECT .BOUNDARY>>) + (T <.GA .BOUND <>>>) >) > + LIST>> + + > + + <.GA .BOUNDARY>) > + >> + <==? .VARLOC + 2 .VAR> .OBJENV>>> + <.GA .BOUNDARY>) + (> + ) + (T + + <.CHECK <>>> + > > + ) + (<==? <1 .RS1> PATTERN> + .OBJECT <3 .RS1> .BOUNDARY .OBLIGATORY>) + (T + .OBJECT <3 .RS1> .OBJENV + > .BOUNDARY + .OBLIGATORY>) >> + + + + <.GA .BOUNDARY>) + (> + LIST> + .RS>> + ) >) + (T ) >>) > + >> + + .OBJECT .BOUND .OBL? + .PURE? .ENV .OBJENV> >> + + + + +>> >> + + + + + >> + + + + +) + "AUX" UV) + + <==? .N > + >) + (> + .UV> + >> + <==? .N > >) + ( ) + (T > .OBJECT + <> .OBJENV .FORM1 .BOUND>) > + .BOUND) + (.PURE? + > ) + (T ) >) + (T ) >) + (T + .OBJENV>> + > >) > + .BOUND) > >> + + + <.ACTITER ) + (T ) >>) > + .OBJECT .ENV .BOUND .OBL?>) + (T + .OBJECT + .ENV + .OBJENV + > + .BOUND + .OBL?>) >> + + > > >> + + + + + +)) + .BOUND .OBL?>) + (T .OBJENV .BOUND .OBL?>) > >> + + + + +>>) + (T .OBJENV>) >> > + ) + (T .OBJENV>) > + .NAY-SAYER>> + ("STACK") + <.NAY-SAYER .BOUND> >>> + + ) NEWBOUND) + ) + (.PURE? .OBJECT <> .BOUND .OBL?>) + (T .OBJECT <> .OBJENV + > .BOUND .OBL?>) >> + ("STACK") .WA>> + + (.OBJECT .NEWBOUND T .PURE? .ENV .OBJENV !)> + .NEWBOUND >> + + >>) + (> + .PURE?> + >) + + (> + .VARFORM .ENV> + ) + (T ) >) + (.PURE? + >>>) + ( .OBJENV >> + .PURE?> + >) + (T ) > + .BOUND >> + + +> + ) + (T ) > >> + + + LIST>) + UNASSIGNED>> >> <==? .L1 .TERM1>> + ) + (<==? .L2 .TERM2> )> + <1 .L2>> > + > > + >> + + + +) + (PURELOC <>) + "AUX" V P (LP ) (CONSTRUCT >) + (BOUND )) + + > + + + ("STACK") + ) + (<==? > SEGMENT> + .LP>> + + > + ) > + .BOUNDLOC>> + >>) + (.EV? P>> + >>> + >> + >) + (T >>> + >>> + > + >>>>) >>> >> ) (BOUND ) + "AUX" V P (LP )) + + ) + (<==? > SEGMENT> + .LP>> + + > + ) > + >>>) + (T >>) > >>> ) (ENV <>) + (LUV )) + + FORM> + ) + ( + + .EXP) + (T ) >>> + + +) + "AUX" (RESULT ()) (P ()) P1 (LP1 ) EXP1) + + <.INSTLP >>>) + (<==? >> SEGMENT> + ,CONSL> + !.RESULT)>) + (T !.RESULT)>) > + >> + > + >> + + +>> + > + .F) + ( >>>> + + ) + (> + > + .F) + (<==? .A1 ,ALTER> + >> ?()> + > + ) + (<==? .A1 ,GIVEN> + >>> + + ) + (T > + .F) >) + (T > + .F) >>> ) (ENV <>) + "AUX" UA ACTR VAR) + + FORM> + >> .UA) + ( 2> + >>> + + >>>> + > + (.VAR)) >) + (<==? .ACTR ,ALTER> + >> ?()> + (.VAR)) >) >) + (<==? .EXP .BOUND> ()) + (T > .BOUND>>) >>> + + +) + "AUX" VAR) + + + '(FORM SEGMENT)> + <==? <1 .F> LVAL> + >> + > >> + (.VAR)) + (T ) >) > >> + + + FORM> + <==? 2> + <==? <1 .OBJECT> GIVEN> + >>> + .RES> >> + + + FORM> + + SEGMENT> <.UNC T>>) + .OBJECT> + <>>> >> .OBJECT) + (T + >>) > >> + + + .RES) + (T !.RES)> + > + ) >>> + + +)) + .PAT) + ( .BEG) + (T > + !) + >>> + > + .PAT) >>> + + + .RESULT) + (T !.RESULT)> + > + ) >>> + + + T) + ( <>) + (T > + ) >>> )) + >> + >>) + (<==? <1 .RS1> PATTERN> + .OBJECT <3 .RS1> .BOUNDARY>) + () > + > > + >> + > + VALUE> + > + )) + >> + >> UNASSIGNED> + >>>) > + > > + <3 .VALRS1> <4 .VALRS1> <5 .VALRS1> + <6 .VALRS1> <7 .VALRS1>> + > > >> + + + >> + > + > + <==? <1 .R1> PATTERN> + <==? .ENV <3 .R1>> + <=UPTO? <2 .R1> .EXP .BOUND>> + <.CHECK T>) > + > > >> + + + > + <=? .EXP1 .EXP2>) + ( > <>) + ( <==? .EXP2 .BOUND>) + (<==? .EXP2 .BOUND> <>) + (<=? <1 .EXP1> <1 .EXP2>> + > > + ) >>) >>> ) (BOUND2 ) + "AUX" (LOCS + >)) + <.LINKER .LOCS>> + + > LIST>) UNASSIGNED>> + > > >> + + + ()) + (T + > !.LOCS)> + > + <.GEN .LOCS>> >) >>>  \ No newline at end of file diff --git a/MUDDLE/nagc.17 b/MUDDLE/nagc.17 new file mode 100644 index 0000000..d310f8c --- /dev/null +++ b/MUDDLE/nagc.17 @@ -0,0 +1,1835 @@ +TITLE AGC MUDDLE GARBAGE COLLECTOR +;SYSTEM WIDE DEFINITIONS GO HERE +.GLOBAL PDLBUF,VECTOP,VECBOT,PDLEX,PDLEXP,GCFLG,GCPDL,GETNUM,PARNEW,WRONGT +.GLOBAL PGROW,TPGROW,TIMOUT,MAINPR,TMA,TFA,PPGROW + +; GLOBALS ASSOCIATE WITH THE ASSOCIATION VECTOR + +.GLOBAL ASOVEC,ASOLNT,ITEM,INDIC,VAL,NWORDT,NODPNT,PNTRS +.GLOBAL CELL + + +PDLBUF=100 +TPMAX==5000 ;PDLS LARGER THAN THIS WILL BE SHRUNK +PMAX==1000 ;MAXIMUM PSTACK SIZE +TPMIN==100 ;MINIMUM PDL SIZES +PMIN==100 +TPGOOD==2000 ; A GOOD STACK SIZE +PGOOD==1000 + +RELOCATABLE +.INSRT MUDDLE > + +TYPNT=AB ;SPECIAL AC USAGE DURING GC +F=TP ;ALSO SPECIAL DURING GC +LPVP=SP ;SPECIAL FOR GC, HOLDS POINTER TO PROCESS CHAIN +LINF=TB ;SPECIAL FOR GC, HOLDS POINTER TO INFO CELL CHAIN +;FUNCTION TO CONSTRUCT A LIST +MFUNCTION CONS,SUBR + ENTRY 2 + HLRZ A,2(AB) ;GET TYPE OF 2ND ARG + CAIE A,TLIST ;LIST? + JRST BADTYP ;NO , COMPLAIN + HLRZ A,(AB) ;GET TYPE OF FIRST + PUSHJ P,NWORDT ;GET NO. OF WORDS NEEDED FOR DATUM + SOJN A,CDEFER ;GREATER THAN 1, MUST MAKE DEFERRED POINTER + MOVEI A,2 ;SET UP CALL TO CELL + PUSHJ P,CELL + HLLZ A,(AB) ;TYPE OF FIRST ARG + MOVE C,1(AB) ;GET DATUM +CFINIS: PUSHJ P,CLOBIT ;STORE + JRST FINIS + +;HERE TO STORE IN PAIR + +CLOBIT: HRR A,3(AB) ;GET CDR +CLOBT1: MOVEM A,(B) ;STORE FIRST + MOVEM C,1(B) ;AND SECOND + MOVSI A,TLIST ;GET FINAL TYPE + POPJ P, + +;HERE FOR A DEFERRED CONS + +CDEFER: MOVEI A,4 ;NEED 4 CELLS + PUSHJ P,CELL + MOVE A,(AB) ;GET COMPLETE 1ST WORD + MOVE C,1(AB) ;AND SECOND + PUSHJ P,CLOBT1 ;STORE + MOVE C,B ;POINT TO DEFERRED PAIR WITH C + ADDI B,2 ;POINT TO OTHER PAIR + MOVSI A,TDEFER ;GET TYPE + JRST CFINIS + + +;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, + + +;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 + BADTYP: PUSH TP,$TATOM ;ARGUMENT OF TYPE ATOM + PUSH TP,MQUOTE 2ND-ARGUMENT-NOT-A-LIST + JRST CALER1 ;OFF TO ERROR HANDLER + + + ;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 + + ;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 + BDTYPV: 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 + + +; 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 + +; 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 + +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 + ;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 + + ;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 + + + +; 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 + + +;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,],[S2NWORD,VECTMK],[SPSTK,TPMK] +[SFRAME,],[SBYTE,],[SATOM,ATOMK],[SPVP,VECTMK] +[SCHSTR,],[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 + + +; 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 + +; 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 ;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 + + +; 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+] ;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 + ; 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 ;HERE WHEN A VECTOR POINTER IS BAD + +VECTB1: MOVEI B,[ASCIZ /AGC -- VECTOR POINTS OUTSIDE VECTOR SPACE +/] + PUSHJ P,MSGTYP + .VALUE 0 + + + +; 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 + +;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, + + + + + +;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 + + ;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, + + ;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, + +;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 + + ;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 + + ;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 + +; 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 +; 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 + + +;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 + + ;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 + ;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, +;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, + ;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 + ;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 + ;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 -- TRANSFER2YU 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, + ;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 + VECZE4: 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 + VECZE5: HRLZM F,(A) ;STORE THE NEW SIZE IN DOPEWD + JRST VECZE2 + +;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 ;BUCKET 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, + VCMLOS: 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 +  \ No newline at end of file diff --git a/MUDDLE/neval.222 b/MUDDLE/neval.222 new file mode 100644 index 0000000..b59a860 --- /dev/null +++ b/MUDDLE/neval.222 @@ -0,0 +1,2966 @@ +TITLE EVAL -- MUDDLE EVALUATOR + +RELOCATABLE + +; GERALD JAY SUSSMAN, 1971 +; DREW MCDERMOTT, 1972 + +.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP +.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM +.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA +.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL +.GLOBAL PDLBUF,MESS,FACTI,ITRUTH,FLFLG,PDLOSS,AGC +.GLOBAL PGROW,TPGROW,PDLGRO,SPCSTE,CNTIN2 + +.INSRT MUDDLE > + + MFUNCTION EVAL,SUBR + INTGO + HLRZ A,AB ;GET NUMBER OF ARGS + CAIE A,-2 ;EXACTLY 1? + JRST AEVAL ;EVAL WITH AN ALIST +NORMEV: HLRZ A,(AB) ;GET TYPE OF ARG + CAILE A,NUMPRI ;PRIMITIVE? + JRST NONEVT ;NO + JRST @EVTYPT(A) ;YES-DISPATCH + +SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE + MOVE B,1(AB) + JRST FINIS ;TO SELF-EG NUMBERS + +;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL. + +MFUNCTION VALUE,SUBR + JSP E,CHKAT + PUSHJ P,IDVAL + JRST FINIS + +IDVAL: PUSH TP,A + PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE + PUSHJ P,ILVAL ;LOCAL VALUE FINDER + CAMN A,$TUNAS + JRST UNAS + CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED + JRST RIDVAL ;DONE - CLEAN UP AND RETURN + POP TP,B ;GET ARG BACK + POP TP,A + PUSHJ P,IGVAL + CAMN A,$TUNBOUND + JRST UNBOU + POPJ P, +RIDVAL: SUB TP,[2,,2] + POPJ P, + +;GETS THE LOCAL VALUE OF AN IDENTIFIER + +MFUNCTION LVAL,SUBR + JSP E,CHKAT +LVAL2: PUSHJ P,ILVAL + CAMN A,$TUNBO + JRST UNBOU ;UNBOUND + CAMN A,$TUNAS + JRST UNAS ;UNASSIGNED + JRST FINIS ;OTHER + + +MFUNCTION RLVAL,SUBR + JSP E,CHKAT + PUSHJ P,ILVAL + CAME A,$TUNBO + JRST FINIS + PUSH TP,(AB) ;IF UNBOUND, + PUSH TP,1(AB) ;BIND IT GLOBALLY TO ?() + PUSH TP,$TUNAS + PUSH TP,[0] + MCALL 2,SET + JRST FINIS + + +MFUNCTION UNASSP,SUBR,[UNASSIGNED?] + JSP E,CHKAT + PUSHJ P,ILVAL + CAMN A,$TUNBO + JRST UNBOU + CAME A,$TUNAS + JRST IFALSE + JRST FINIS + +; 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 + + + +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]] + + ;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 MFUNCTION SPLICE,SUBR + ENTRY 2 ; + 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 _ + MOVSI D,TSP + MOVEM D,(B) + MOVEM D,2(B) + MOVE D,3(AB) + MOVEM D,1(B) ;> + MOVEM SP,3(B) ; + 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, MFUNCTION 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 + +;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) + ;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 + ;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, ;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 _ + 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 _ + 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, ;THESE THREE CONSTRUCTOR FUNCTIONS ARE USED +;TO SIMULATE "VARIABLE BRACKETS"; FOR EXAMPLE, +;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 + +;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 + 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 + + +;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. + + IGLOC: 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, + + + + +;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 + + + MFUNCTION 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 _ + 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 _ > + JRST BIPROG ;NOW EXECUTE BODY AS PROG ;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 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 ;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 ;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 + ;"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 ;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) _ + 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 ;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 _ + 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. ), 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 ;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 ;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, ;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 _ + 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 ; 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 + +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 = ALLOWED + TRO 0,QUO ;QUO _ ON + MOVEM 0,SWTCHS-1(P) + HRRZ A,(A) ;A _ + JUMPE A,MPD ; 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 + ;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 +;>, AND ERRING IF > 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, + + + + ;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, ;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 ; + 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] + + ;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, + + + +;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 + 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, + + + + +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 + +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 + + + + +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, + +;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, + + + + +;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, + + +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 + + + +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 + ;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 + MFUNCTION 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) + 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) + 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 + MFUNCTION 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 MFUNCTION 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 + +;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 +***  \ No newline at end of file diff --git a/MUDDLE/neval.nostac b/MUDDLE/neval.nostac new file mode 100644 index 0000000..2750d8c --- /dev/null +++ b/MUDDLE/neval.nostac @@ -0,0 +1,2875 @@ +TITLE EVAL -- MUDDLE EVALUATOR + +RELOCATABLE + +; GERALD JAY SUSSMAN, 1971 +; DREW MCDERMOTT, 1972 + +.GLOBAL PROCID,LPROG,GLOBSP,GLOBASE,SPBASE,TPBASE,PTIME,SWAP +.GLOBAL IGVAL,CHKARG,NXTDCL,TPOVFL,CHFRM +.GLOBAL ILVAL,CALER,CALER1,ER1ARG,SPECBIND,SPECSTORE,WRONGT,ERRTMA +.GLOBAL IDVAL,EVECTO,EUVECT,CHARGS,BCKTRK,CELL +.GLOBAL PDLBUF,MESS,FACTI,ITRUTH,FLFLG,PDLOSS,AGC +.GLOBAL PGROW,TPGROW,PDLGRO + +.INSRT MUDDLE > + + MFUNCTION EVAL,SUBR + INTGO + HLRZ A,AB ;GET NUMBER OF ARGS + CAIE A,-2 ;EXACTLY 1? + JRST AEVAL ;EVAL WITH AN ALIST +NORMEV: HLRZ A,(AB) ;GET TYPE OF ARG + CAILE A,NUMPRI ;PRIMITIVE? + JRST NONEVT ;NO + JRST @EVTYPT(A) ;YES-DISPATCH + +SELF: MOVE A,(AB) ;TYPES WHICH EVALUATE + MOVE B,1(AB) + JRST FINIS ;TO SELF-EG NUMBERS + +;EVALUATES A IDENTIFIER -- GETS LOCAL VALUE IF THERE IS ONE, OTHERWISE GLOBAL. + +MFUNCTION VALUE,SUBR + JSP E,CHKAT + PUSHJ P,IDVAL + JRST FINIS + +IDVAL: PUSH TP,A + PUSH TP,B ;SAVE ARG IN CASE NEED TO CHECK GLOBAL VALUE + PUSHJ P,ILVAL ;LOCAL VALUE FINDER + CAMN A,$TUNAS + JRST UNAS + CAME A,$TUNBOUND ;IF NOT UNBOUND OR UNASSIGNED + JRST RIDVAL ;DONE - CLEAN UP AND RETURN + POP TP,B ;GET ARG BACK + POP TP,A + PUSHJ P,IGVAL + CAMN A,$TUNBOUND + JRST UNBOU + POPJ P, +RIDVAL: SUB TP,[2,,2] + POPJ P, + +;GETS THE LOCAL VALUE OF AN IDENTIFIER + +MFUNCTION LVAL,SUBR + JSP E,CHKAT +LVAL2: PUSHJ P,ILVAL + CAMN A,$TUNBO + JRST UNBOU ;UNBOUND + CAMN A,$TUNAS + JRST UNAS ;UNASSIGNED + JRST FINIS ;OTHER + + +MFUNCTION RLVAL,SUBR + JSP E,CHKAT + PUSHJ P,ILVAL + CAME A,$TUNBO + JRST FINIS + PUSH TP,(AB) ;IF UNBOUND, + PUSH TP,1(AB) ;BIND IT GLOBALLY TO ?() + PUSH TP,$TUNAS + PUSH TP,[0] + MCALL 2,SET + JRST FINIS + + +MFUNCTION UNASSP,SUBR,[UNASSIGNED?] + JSP E,CHKAT + PUSHJ P,ILVAL + CAMN A,$TUNBO + JRST UNBOU + CAME A,$TUNAS + JRST IFALSE + JRST FINIS + +; 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 + + + +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]] + + ;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 MFUNCTION SPLICE,SUBR + ENTRY 2 ; + 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 _ + MOVSI D,TSP + MOVEM D,(B) + MOVEM D,2(B) + MOVE D,3(AB) + MOVEM D,1(B) ;> + MOVEM SP,3(B) ; + 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, MFUNCTION 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 + +;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) + ;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 + ;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, ;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 _ + 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 _ + 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, ;THESE THREE CONSTRUCTOR FUNCTIONS ARE USED +;TO SIMULATE "VARIABLE BRACKETS"; FOR EXAMPLE, +;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 + +;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 + 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 + + +;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. + + IGLOC: 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, + + + + +;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 + + + MFUNCTION 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 _ + 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 _ > + JRST BIPROG ;NOW EXECUTE BODY AS PROG + +;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 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 ;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 ;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 + ;"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 ;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) _ + 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 ;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 _ + 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. ), 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 ;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, ;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 _ + 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 ; 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 + +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 = ALLOWED + TRO 0,QUO ;QUO _ ON + MOVEM 0,SWTCHS-1(P) + HRRZ A,(A) ;A _ + JUMPE A,MPD ; 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 + ;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 +;>, AND ERRING IF > 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, + + + + ;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, + +;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 ; + 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, + + + +;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 + 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, + + + + +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 + +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 + + + + +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, + +;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, + + + + +;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, + + +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 + + + +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 + ;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 + MFUNCTION 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) + 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) + 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 + MFUNCTION 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 MFUNCTION 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 + +;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 +***  \ No newline at end of file diff --git a/MUDDLE/ninter.4 b/MUDDLE/ninter.4 new file mode 100644 index 0000000..27debb8 --- /dev/null +++ b/MUDDLE/ninter.4 @@ -0,0 +1,668 @@ + +TITLE INTERRUPT HANDLER FOR MUDDLE + +RELOCATABLE + +;C. REEVE APRIL 1971 + +.INSRT MUDDLE > + +PDLGRO==10000 ;AMOUNT TO GROW A PDL THAT LOSES +NINT==72. ;MAXIMUM NUMBER OF INTERRUPTS POSSIBLE + +;SET UP LOCATION 42 TO POINT TO TSINT + +ZZZ==. ;SAVE CURRENT LOCATION + +LOC 42 +î JSR TSINT ;GO TO HANDLER + +LOC ZZZ + +; GLOBALS NEEDED BY INTERRUPT HANDLER + +.GLOBA GCFLG ;TELLS WHETHER OR NOT GARBAGE COLLECTOR IS RUNNING +.GLOBA GCINT ;TELLS GARBAGE COLLECTOR TO SIMULATE AN INTERRUPT +.GLOBAL INTNUM,INTVEC ;TV ENTRIES CONCERNING INTERRUPTS +.GLOBAL AGC ;CALL THE GARBAGE COLLECTOR +.GLOBAL VECNEW,PARNEW,GETNUM ;GC PSEUDO ARGS +.GLOBAL GCPDL ;GARBAGE COLLECTORS PDL +.GLOBAL VECTOP,VECBOT ;DELIMIT VECTOR SPACE +.GLOBAL PDLBUF ;AMOUNT OF PDL GROWTH +.GLOBAL PGROW ;POINTS TO DOPE WORD OF NEXT PDL TO GROW +.GLOBAL TPGROW ;POINTS TO NEXT MUDDLE PDL TO GROW +.GLOBAL PPGROW ;BLOWN PLANNER PDL +.GLOBAL PLDGRO ;SEE ABOVE +.GLOBAL CALER1,TMA,TFA +.GLOBAL BUFRIN,CHANL0,SYSCHR ;CHANNEL GLOBALS +.GLOBAL IFALSE,TPOVFL,PDLOSS +.GLOBAL FLFLG ;-1 IFF INTERRUPT IN FAIL + + +.GLOBAL INTINT ;CALLED BY INITIALIZER TO TAKE CARE OF INT PCS + +.GLOBAL MSGTYP,TYI,IFLUSH,OCLOS,ERRET ;SUBROUTINES USED +;BEGINNING OF ACTUAL INTERRUPT HANDLER (MUST BE IMPURE) + +TSINT: 0 ;INTERRUPT BITS GET STORED HERE +TSINTR: 0 ;INTERRUPT PC WORD STORED HERE + JRST TSINTP ;GO TO PURE CODE + +; SOFTWARE INTERNAL INTERRUPTS JSR TO HERE + +LCKINT: 0 + JRST DOINT + +;THE REST OF THIS CODE IS PURE + +TSINTP: SOSGE INTFLG ; SKIP IF ENABLED + SETOM INTFLG ;DONT GET LESS THAN -1 + + MOVEM A,TSAVA ;SAVE TWO ACS + MOVEM B,TSAVB + MOVE A,TSINT ;PICK UP INT BIT PATTERN + JUMPL A,2NDWORD ;DONT CHECK FOR PDL OVERFLOW ETC. IF SIGN BIT ON + + TRZE A,200000 ;IS THIS A PDL OVERFLOW? + JRST IPDLOV ;YES, GO HANDLE IT FIRST + +IMPCH: TRZE A,20000 ;IS IT A MEMORY PROTECTION VIOLATION? + JRST IMPV ;YES, GO HANDLE IT + + TRZE A,40 ;ILLEGAL OP CODE? + JRST ILOPR ;YES, GO HANDLE + +;DECODE THE REST OF THE INTERRUPTS USING A TABLE + +2NDWORD: + JUMPL A,GC2 ;2ND WORD? + IORM A,PIRQ ;NO, INTO WORD 1 + JRST GCQUIT ;AND DISMISS INT + +GC2: TLZ A,400000 ;TURN OFF SIGN BIT + IORM A,PIRQ2 + TRNE A,177777 ;CHECK FOR CHANNELS + JRST CHNACT ;GO IF CHANNEL ACTIVITY + +GCQUIT: SKIPGE INTFLG ;SKIP IF INTERRUPTS ENABLED + JRST INTDON ;NO, DEFER REAL HANDLING UNTIL LATER + + MOVE A,TSINTR ;PICKUP RETURN WORD + MOVEM A,LCKINT ;STORE ELSEWHERE + MOVEI A,DOINTE ;CAUSE DISMISS TO HANDLER + HRRM A,TSINTR ;STORE IN INT RETURN + PUSH P,INTFLG ;SAVE INT FLAG + SETOM INTFLG ;AND DISABLE + + +INTDON: MOVE A,TSAVA ;RESTORE ACS + MOVE B,TSAVB + .DISMISS TSINTR ;AND DISMISS THE INTERRUPT + +; HERE IF INTERRUPTED IN OTHER THAN GC + +DOINT: PUSH P,INTFLG +DOINTE: PUSH P,LCKINT ;SAVE RETURN + SETZM INTFLG ;DISABLE + AOS -1(P) ;INCR SAVED FLAG + +;NOW SAVE WORKING ACS + +IRP A,,[0,A,B,C,D,E] + PUSH TP,A!STO(PVP) + SETZM A!STO(PVP) ;NOW ZERO TYPE + PUSH TP,A + TERMIN + PUSH P,INTNUM+1(TVP) ;PUSH CURRENT VALUE + +DIRQ: MOVE A,PIRQ ;NOW SATRT PROCESSING + JFFO A,FIRQ ;COUNT BITS AND GO + MOVE A,PIRQ2 ;1ST DONE, LOOK AT 2ND + JFFO A,FIRQ2 + +INTDN1: + POP P,INTNUM+1(TVP) ;RESTORE CURRENT +IRP A,,[E,D,C,B,A,0] + POP TP,A + POP TP,A!STO(PVP) + TERMIN + + POP P,LCKINT + POP P,INTFLG + JRST @LCKINT ;AND RETURN + +FIRQ: PUSHJ P,GETBIT ;SET UP THE BIT TO CLOBBER IN PIRQ + ANDCAM A,PIRQ ;CLOBBER IT + ADDI B,36. ;OFSET INTO TABLE + JRST XIRQ ;GO EXECUTE + +FIRQ2: PUSHJ P,GETBIT ;PREPARE TO CLOBBER BIT + ANDCAM A,PIRQ2 ;CLOBBER IT + ADDI B,71. ;AGAIN OFFSET INTO TABLE +XIRQ: + CAIN B,21 ;PDL OVERFLOW? + JRST PDL2 ;YES, HACK APPROPRIATELY + MOVEM B,INTNUM+1(TVP) ;AND SAVE + LSH B,1 ;TIMES 2 + ADD B,INTVEC+1(TVP) ;POINT TO LIST OF TASKS + SKIPN A,(B) ;ANY TASKS? + JRST DIRQ ;NO, PUNT + + PUSH TP,$TLIST ;SAVE LIST + PUSH TP,A +DOINTS: HLRZ C,(A) ;GET TYPE + CAIE C,TLIST ;LIST? + JRST IWTYP + HRRZ A,1(A) + JUMPE A,IWTYP ;LIST IS NIL, LOSE + HLRZ C,(A) ;CHECK FOR A PROCESS + CAIE C,TPVP + JRST IWTYP + HRRZ D,(A) ;POINT TO 2D PART OF PAIR + PUSH TP,(D) ;SETUP CALL TO EVAL + PUSH TP,1(D) + MOVE D,TB ;GET CURRENT FRAME POINTER + MOVE C,1(A) ;GET PROCESS WHO WANTS THIS INTERRUPT + CAME C,PVP ;SKIP IF CURRENT PROCESS + MOVE D,TBSTO+1(C) ;GET SAVED FRAME + HLRE A,C ;COMPUTE DOPE WORD POINTER + SUBI C,-1(A) ;HAVE POINTER + HRLI C,TFRAME ;BUILD A FRAME HACK + HLL D,OTBSAV(D) ;GET A WINNING TIME + PUSH TP,C ;AND PUSH IT + PUSH TP,D + MCALL 2,EVAL +INTCDR: HRRZ A,@(TP) ;CDR THE LIST OF TASKS + JUMPE A,TPPOP + MOVEM A,(TP) ;SAVE THE CDR'D LIST + JRST DOINTS + +TPPOP: SUB TP,[2,,2] ;REMOVE LIST + JRST DIRQ + +IWTYP: PUSH TP,(A) ;SAVE TASK + PUSH TP,1(A) + PUSH TP,$TATOM + PUSH TP,MQUOTE BAD-INTERRUPT-HANDLER-TASK-IGNORED + MCALL 1,PRINT + MCALL 1,PRINT + JRST INTCDR + +PDL2: MOVEI B,PDLGRO_-6 ;GET GROWTH SPEC + SKIPE A,PGROW ;SKIP IF A P IS NOT GROWING + DPB B,[111100,,-1(A)] ;STORE GROWTH SPEC +TRYTPG: SKIPE A,TPGROW ;IS TP BLOWN + DPB B,[111100,,-1(A)] ;YES, SET GROWTH SPEC + SKIPE A,PPGROW ;POINT TO BLOWN PP + DPB B,[111100,,-1(A)] + PUSHJ P,AGC ;COLLECT GARBAGE + SETZM PPGROW + SETZM PGROW + SETZM TPGROW + JRST INTDN1 + + + +;SUBROUTINE TO SET AN INTERRUPT HANDLER + +MFUNCTION SETINT,SUBR + ENTRY 2 + + HLRZ A,(AB) ;FIRST IS FIXED + CAIE A,TFIX + JRST WTYP1 + HLRZ A,2(AB) + CAIE A,TLIST + JRST WTYP2 + SKIPGE B,1(AB) ;GET NUMBER + JRST NEGINT ;INTERRUPT NEGATIVE + HRRZ C,3(AB) ;PICKUP LIST +ISENT1: PUSH P,CFINIS ;FALL INTO INTERNAL SET TO POP TO FINIS + +ISETNT: MOVEI D,(B) ;COPY + LSH B,1 + HRLI B,(B) ;TO 2 HALVES + ADD B,INTVEC+1(TVP) ;POINT TO HANDLER + JUMPGE B,INTOBG ;OUT OF RANGE + HRRZ E,(B) ;AND OLD POINTER + HRRM E,(C) ;SPLICE + HRRM C,(B) + CAILE D,35. ;WHICH MASK? + JRST SETW2 + + SUBI D,36. ;FIND BIT POSITION + MOVSI A,400000 + LSH A,(D) ;POSTITION + IORM A,MASK1 + .SUSET [.SMASK,,MASK1] +SETIN1: MOVE A,(AB) + MOVE B,1(AB) +CFINIS: POPJ P,FINIS ;USED BY SETINT TO SETUP RETURN + +SETW2: SUBI D,71. + MOVSI A,400000 + LSH A,(D) + IORM A,MASK2 + .SUSET [.SMSK2,,MASK2] + JRST SETIN1 +WTYP1: PUSH TP,$TATOM + PUSH TP,MQUOTE FIRST-ARG-WRONG-TYPE + JRST CALER1 + + +WTYP2: PUSH TP,$TATOM + PUSH TP,MQUOTE SECOND-ARG-WRONG-TYPE + JRST CALER1 + +NEGINT: PUSH TP,$TATOM + PUSH TP,MQUOTE NEGATIVE-INTERRUPT-NUMBER + JRST CALER1 +INTOBG: PUSH TP,$TATOM + PUSH TP,MQUOTE INT-NUMBER-TOO-LARGE + JRST CALER1 + +BADCHN: PUSH TP,$TATOM + PUSH TP,MQUOTE CHANNEL-NOT-PHYSICAL + JRST CALER1 + +LWTYP: PUSH TP,$TATOM + PUSH TP,MQUOTE LAST-ARG-WRONG-TYPE + JRST CALER1 + +; SET A CHANNEL INTERRUPT + +MFUNCTION ONCHAR,SUBR + + ENTRY + + SKIPL B,AB ;COPY ARG POINTER + JRST TFA + ADD B,[2,,2] ;POINT TO EXPRESSION ARG + PUSHJ P,CHKRGS ;CHECK OUT THE ARGS AND MAKE THE LIST + GETYP A,(AB) ;CHECK FOR A CHANNEL + CAIE A,TCHAN + JRST WTYP1 + MOVE C,1(AB) ;GET CHANNEL + SKIPN C,CHANNO(C) ;GET CHANNEL + JRST BADCHN + ADDI C,36. ;POINT INTO INT VECTOR + EXCH B,C + PUSHJ P,ISETNT ;SET THE INTERRUPT + MOVE A,2(AB) ;RETURN ARG + MOVE B,3(AB) + JRST FINIS + +; SET A CLOCK INTERRUPT + +MFUNCTION ONCLOCK,SUBR + + ENTRY + + MOVE B,AB + PUSHJ P,CHKRGS ;CHECK ARGS AND MAKE LIST + MOVE C,B ;COPY LIST POINTER + MOVEI B,13. ;CLOCK INT NUMBER + JRST ISENT1 ;SET UP THE INT + +CHKRGS: JUMPGE B,TFA + MOVE C,PVP ;GET CURRENT PROCESS + CAML B,[-2,,0] ;CHECK FOR PROCESS ARG + JRST GOTPVP + CAMGE B,[-4,,0] ;SKIP IF RIGHT NO. OF ARGS + JRST TMA ;TOO MANY + GETYP A,2(B) ;CHECK TYPE + CAIE A,TPVP + JRST LWTYP ;WRONG TYPE + MOVE C,3(B) ;GET PROCESS +GOTPVP: PUSH TP,$TPVP + PUSH TP,C + PUSH TP,(B) ;PUSH EXPRESSION + PUSH TP,1(B) + MCALL 2,LIST ;MAKE THE LIST + PUSH TP,A + PUSH TP,B + MCALL 1,LIST ;MAKE A LIST OF A LIST + POPJ P, + + +;ROUTINE TO GET CURRENT INT NUMBER + +MFUNCTION GETINT,SUBR + + ENTRY 0 + MOVSI A,TFIX + MOVE B,INTNUM+1(TVP) + JRST FINIS + +MFUNCTION INTCHAR,SUBR + + ENTRY + PUSH P,CFINIS ;CAUSE RETURN TO FINIS +INTCH1: MOVE B,INTNUM+1(TVP) + JUMPGE AB,GOTNUM + HLRZ A,(AB) + CAIE A,TFIX + JRST WTYP1 + MOVE B,1(AB) + +GOTNUM: SUBI B,36. ;CONVERT TO CHANNEL + MOVEI C,(B) ;SAVE A COPY OF CHANNEL + .ITYIC B, + JRST NOCHRS + + LSH B,29. + MOVSI A,TCHRS + MOVEI D,(C) ;COPY CHANNEL AGAIN + LSH D,1 ;TIMES 2 + ADDI D,CHANL0+1(TVP) ;POINT TO INFO + HRRZ E,(D) ;POINT TO CHANNEL + HRRZ E,BUFRIN(E) ;POINT TO ADDL INFO + AOS SYSCHR(E) + +REINT: MOVEI E,1 ;PREPARE TO RENABLE + LSH E,(C) + IORM E,MASK2 + .SUSET [.SMSK2,,MASK2] + POPJ P, + + +NOCHRS: MOVEI B,0 + MOVSI A,TFALSE + JRST REINT + +MFUNCTION QUITTER,SUBR + + ENTRY 0 + +REQT: PUSHJ P,INTCH1 ;CHECK FOR A CHAR + CAMN A,$TFALSE ;ANY LEFT? + JRST FINIS ;NO + CAME B,[7_29.] ;CNTL G? + JRST REQT + PUSH TP,$TCHAN ;QUIT HERE + PUSH TP,(D) ;PUSH CHANNEL + MCALL 1,RRRES + PUSH TP,$TATOM + PUSH TP,MQUOTE CONTROL-G + MCALL 1,ERROR + JRST FINIS + +MFUNCTION INTRCH,SUBR,INTCHAN + + ENTRY 0 + + MOVE B,INTNUM+1(TVP) ;GET INT NUMBER + SUBI B,36. + JUMPL B,IFALSE ;NOT A CHANNEL + CAILE B,17 + JRST IFALSE ;NOT A CHANNEL + LSH B,1 ;TIMES 2 + ADDI B,CHANL0(TVP) ;GET POINTER TO CHANNEL + MOVE A,(B) + MOVE B,1(B) + JRST FINIS + +MFUNCTION GASCII,SUBR,ASCII + ENTRY 1 + + HLRZ A,(AB) + CAIE A,TCHRS + JRST TRYNUM + + MOVE B,1(AB) + TDNN B,[3777,,-1] + LSH B,-29. + MOVSI A,TFIX + JRST FINIS + +TRYNUM: CAIE A,TFIX + JRST WTYP1 + SKIPGE B,1(AB) ;GET NUMBER + JRST TOOBIG + CAILE B,177 ;CHECK RANGE + JRST TOOBIG + LSH B,29. + MOVSI A,TCHRS + JRST FINIS + +TOOBIG: PUSH TP,$TATOM + PUSH TP,MQUOTE OUT-OF-RANGE + JRST CALER1 + +;SUBROUTINE TO GET BIT FOR CLOBBERAGE + +GETBIT: MOVNS B ;NEGATE + MOVSI A,400000 ;GET THE BIT + LSH A,(B) ;SHIFT TO POSITION + POPJ P, ;AND RETURN + +;HERE TO HANDLE PDL OVERFLOW. ASK FOR A GC + +IPDLOV: SKIPE FLFLG ;DURING FAILURE, + JRST IMPCH ;LET FAIL HANDLE BLOWN PDLS + MOVEM A,TSINT ;SAVE INT WORD + MOVEI A,200000 ;GET BIT TO CLOBBER + IORM A,PIRQ ;LEAVE A MESSAGE FOR HIGHER LEVEL + + SKIPE GCFLG ;IS GC RUNNING? + JRST GCPLOV ;YES, COMPLAIN GROSSLY + + EXCH P,GCPDL ;GET A WINNING PDL + HRRZ B,TSINTR ;GET POINTER TO LOSING INSTRUCTION + LDB B,[270400,,-1(B)] ;GET AC FIELD + MOVEI A,(B) ;COPY IT + LSH A,1 ;TIMES 2 + ADDI A,0STO(PVP) ;POINT TO THIS ACS CURRENT TYPE + HLRZ A,(A) ;GET THAT TYPE INTO A + CAIN B,P ;IS IT P + MOVEI B,GCPDL ;POINT TO SAVED P + + CAIN B,B ;OR IS IT B ITSELF + MOVEI B,TSAVB + CAIN B,A ;OR A + MOVEI B,TSAVA + + CAIN B,C ;OR C + MOVEI B,1(P) ;C WILL BE ON THE STACK + + PUSH P,C + PUSH P,A + + MOVE A,(B) ;GET THE LOSING POINTER + MOVEI C,(A) ;AND ISOLATE RH + + CAMG C,VECTOP ;CHECK IF IN GC SPACE + CAMG C,VECBOT + JRST NOGROW ;NO, COMPLAIN + + HLRZ C,A ;GET -LENGTH + SUBI A,-1(C) ;POINT TO A DOPE WORD + POP P,C ;RESTORE TYPE INTO C + CAIE C,TPDL ;IS IT A P STACK? + JRST TRYTP ;NO + SKIPE PGROW ;YES, ALREADY GROWN? + JRST PDLOSS ;YES, LOSE + ADDI A,PDLBUF ;POINT TO REAL DOPE WORD + HRRM A,PGROW ;STORE + JRST PNTRHK ;FIX UP THE PDL POINTER + +TRYTP: CAIE C,TTP ;TP STACK + JRST TRYPP + SKIPE TPGROW ;ALREADY GROWN? + JRST PDLOSS + ADDI A,PDLBUF ;POINT TO REAL DOPE WORD + HRRM A,TPGROW + JRST PNTRHK ;GO MUNG POINTER + +TRYPP: CAIE C,TPP ;PLANNER PDL? + JRST BADPDL + SKIPE PPGROW + JRST PDLOSS ;LOSER + ADDI A,PDLBUF + HRRM A,PPGROW + + +PNTRHK: MOVE C,(B) ;RESTORE PDL POINTER + SUB C,[PDLBUF,,0] ;FUDGE THE POINTER + MOVEM C,(B) ;AND STORE IT + + POP P,C ;RESTORE THE WORLD + MOVE A,TSINT ;RESTORE INT WORD + + EXCH P,GCPDL ;GET BACK ORIG PDL + JRST IMPCH ;LOOK FOR MORE INTERRUPTS + +TPOVFL: SETOM INTFLG ;SIMULATE PDL OVFL + PUSH P,A + MOVEI A,200000 ;TURN ON THE BIT + IORM A,PIRQ + SUB TP,[PDLBUF,,0] ;HACK STACK POINTER + HLRE A,TP ;FIND DOPEW + SUBM TP,A ;POINT TO DOPE WORD + ADDI A,1 + HRRZM A,TPGROW + POP P,A + POPJ P, + + +;HERE TO HANDLE LOW-LEVEL CHANNELS + + +CHNACT: SKIPN GCFLG ;GET A WINNING PDL + EXCH P,GCPDL + ANDI A,177777 ;ISOLATE CHANNEL BITS + PUSH P,0 ;SAVE + +CHNA1: MOVEI B,0 ;BIT COUNTER + JFFO A,.+2 ;COUNT + JRST CHNA2 + SUBI B,35. ;NOW HAVE CHANNEL + MOVMS B ;PLUS IT + MOVEI 0,1 + LSH 0,(B) ;SET TO CLOBBER BIT + ANDCM A,0 + LSH B,23. ;POSITION FOR A .STATUS + IOR B,[.STATUS B] + XCT B ;DO IT + ANDI B,77 ;ISOLATE DEVICE + CAILE B,2 + JRST CHNA1 + ANDCAM 0,MASK2 ;TURN OFF BIT + .SUSET [.SMSK2,,MASK2] + JRST CHNA1 + +CHNA2: POP P,0 + SKIPN GCFLG + EXCH P,GCPDL + JRST GCQUIT + +;HERE IF PDL OVERFLOW DURING GARBAGE COLLECTION + +BADPDL: SKIPA B,[[ASCIZ /NON-PDL OVERFLOW +/]] +GCPLOV: MOVEI B,[ASCIZ /PDL OVERFLOW DURING GARBAGE COLLECTION +/] +GFATER: MOVE P,GCPDL ;GET ORIGINAL PDL FOR TYPE OUT + JRST FATERR ;GO TO FATAL ERROR ROUTINE + +NOGROW: MOVEI B,[ASCIZ /PDL OVERFLOW ON NON-EXPANDABLE PDL +/] + JRST GFATER + +PDLOSS: MOVEI B,[ASCIZ /PDL OVERFLOW BUFFER EXHAUSTED +/] + JRST GFATER + +FATERR: PUSHJ P,MSGTYP ;TYPE THE MESSAGE + MOVEI B,[ASCIZ /FATAL ERROR, PLEASE DUMP SO THAT MUDDLE SYSTEM PROGRAMMERS +MAY DEBUG./] + PUSHJ P,MSGTYP ;TYPE THE LOSER MESSAGE + PUSHJ P,OCLOS ;CLOSE THE TTY + .VALUE + JRST .-1 + + +;MEMORY PROTECTION INTERRUPT + +IMPV: MOVEI B,[ASCIZ /MPV -- /] + +IMPV1: PUSHJ P,MSGTYP ;TYPE + SKIPE GCFLG ;THESE ERRORS FATAL IN GARBAGE COLLECTOR + JRST GCERR + + MOVE P,GCPDL ;MAKE SURE OF A WINNING PDL +ERLP: MOVEI B,[ASCIZ /TYPE "S" TO GO TO SUPERIOR, "R" TO RESTART PROCESS./] + PUSHJ P,IFLUSH ;FLUSH AWAITING INPUT + PUSHJ P,MSGTYP + + PUSHJ P,TYI ;READ THE CHARACTER + + PUSHJ P,UPLO ;CONVERT TO UPPER CASE + CAIN A,"S + .VALUE + + CAIE A,"R ;DOES HE WANT TO RESTART + JRST ERLP ;NO, TELL HIM AGAIN + + MCALL 0,INTABR ;ABORT THE PROCESS + +INTABR: MOVEI A,ERRET ;REAALY GO TO ERRET + HRRM A,TSINTR + .DISMISS TSINTR + + +GCERR: MOVEI B,[ASCIZ /IN GARBAGE COLLECTOR +/] + JRST FATERR + +ILOPR: MOVEI B,[ASCIZ /ILLEGAL OPERATION -- /] + JRST IMPV1 + +; SUBROUTINE TO CONVERT LOWER CASE LETTERS TO UPPER + +UPLO: CAIG A,172 ;GEATER THAN Z? + CAIG A,140 ;NO, LESS THAN A + POPJ P, ;YES, LOSE + SUBI A,40 ;MAKE UPPER CASE + POPJ P, + +;SUBROUTINE TO BE CALLED AT INITIALIZE TIME TO FUDGE INT PC + +INTINT: PUSHJ P,PCHACK ;FUDGE PC LOSSAGE + MOVE A,MASK1 ;SET MASKS + MOVE B,MASK2 + .SETM2 A, ;SET BOTH MASKS + POPJ P, + +PCHACK: .SUSET [.SMASK,,[200000]] ;SET FOR ONLY PDL OVERFLOW + MOVE D,TSINT+2 ;SAVE CONTENTS OF ITERRUPT HANDLER + MOVEI A,FUNINT ;POINT TO DUMMY THEREOF + HRRM A,TSINT+2 ;AND STORE IT + HRROI A,0 ;MAKE A VERY SHORT PDL +CHPUSH: PUSH A,0 ;PUSH SOMETHING AND OVERFLOW + .VALUE [ASCIZ /?/] ;SHOULD NEVER GET HERE + +FUNINT: HRRM D,TSINT+2 ;RESTORE STANDARD HANDLER + HRRZ D,TSINTR ;GET THE LOCATION STORED + SUBI D,CHPUSH ;FIND THE DIFFERENCE + MOVEM D,PCOFF ;AND SAVE + POP P,TSINTR ; POP INTO DISMISS WORD + .DISMISS TSINTR ;AND DISMISS + + + +INTLOS: .VALUE [ASCIZ /INT/] +CHARCH: .VALUE [ASCIZ /CHAR?/] +;RANDOM IMPURE CRUFT NEEDED + +TSAVA: 0 +TSAVB: 0 +PIRQ: 0 ;HOLDS REQUEST BITS FOR 1ST WORD +PIRQ2: 0 ;SAME FOR WORD 2 +PCOFF: 0 +MASK1: 220040 ;FIRST MASK +MASK2: 0 ;SECOND THEREOF + + +END +  \ No newline at end of file diff --git a/MUDDLE/nmain.14 b/MUDDLE/nmain.14 new file mode 100644 index 0000000..4da7b6c --- /dev/null +++ b/MUDDLE/nmain.14 @@ -0,0 +1,791 @@ +TITLE MAIN LOOP AND GLOBALLY REFERENCED SUBROUTINES +RELOCA +MAIN==1 ;THIS INCLUDES ONCE ONLY CODE + +NINT==72. ;NUMBER OF POSSIBLE ITS INTERRUPTS +NASOCS==159. ;LENGTH OF ASSOCIATION VECTOR + + +.GLOBAL PATCH,TBINIT,LERR,LPROG,PIDSTO,PROCID,PTIME,GCPDL,INTFLG,WTYP1,WTYP2 +.GLOBAL PAT,PDLBUF,INTINT,PARNEW,GCPVP,START,SWAP,ICR,SPBASE,TPBASE,GLOBAS,GLOBSP,TPBAS +.GLOBAL TOPLEVEL,INTNUM,INTVEC,INTOBL,ASOVEC,ERROBL,MAINPR,RESFUN,.BLOCK,ASOLNT,NODES +.GLOBAL WRONGT,TTYOPE,OPEN,CLOSE,IOT,ILVAL,MESS,FACTI + +.INSRT MUDDLE > + +VECTGO +TVBASE": BLOCK TVLNT + GENERAL + TVLNT+2,,0 +TVLOC=TVBASE + + + +;INITIAL TYPE TABLE + +TYPVLC": BLOCK 2*NUMPRI+2 + GENERAL + 2*NUMPRI+2+2,,0 + +TYPTP==.-2 ; POINT TO TOP OF TYPES + +INTVCL: BLOCK 2*NINT + TLIST,,0 + 2*NINT+2,,0 + +NODLST: TTP,,0 + 0 + TASOC,,0 + BLOCK ASOLNT-3 + GENERAL+ + 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 +  \ No newline at end of file diff --git a/MUDDLE/nmatch.1 b/MUDDLE/nmatch.1 new file mode 100644 index 0000000..3661531 --- /dev/null +++ b/MUDDLE/nmatch.1 @@ -0,0 +1,216 @@ + + T >> + + + T> + ("STACK") + <> >>> + + + + T >> + + + T> + ("STACK") + <> >>> + + + .EXP> + ("STACK") + >>> ) (BOUND ) + (OBLIGATORY T) (PBOUND ) + "AUX" PURE ENDP K BETA ENDE) + FORM> + <.S >) + ( + > + .BOUND) + ( + <.S >>) + ( + >) > + + + > + <.R >) + (<==? > SEGMENT> + .EXP .ENDE .OBLIGATORY>>>) + (<==? .EXP .ENDE> ) + (T <1 .EXP>> + >) > + > > + + <.S .EXP>) + (T <1 .EXP>>) > + > + > > >> ) (ENV2 <>) + (BOUND1 ) (BOUND2 ) + (OBL T)) + FORM> + FORM> + > >>> + <.MATCHER >>) > + <.MATCHER >>) + (<==? FORM> + <.MATCHER >>) + ( > + <.MATCHER >>) + ( > + ) + ( > + <.MATCHER .PAT2>) > + ALPHA1 SEG1> + ALPHA2 SEG2> + + + ) + (>>) >) + ( + > + ) + (>>) >) > + <.R <>>) + (T <1 .PAT2> .ENV1 .ENV2>) > + > + > > + END1 K1 BETA1 S1> + END2 K2 BETA2 S2> + + > + >>> + > + ) + ( + >>> + > + ) + (T > + >) >) > + <0? .K1>> + <0? .K2>> + FORM>> + .FORM1 .FORM1 T .ENV1 .ENV2 <>>) + (T .SEG2 .END2 T .ENV1 .ENV2 <>>) >) + ( <0? .K2>> + .SEG1 .END1 T .ENV1 .ENV2 <>>) + (<0? .S2> + ) + (T >) >) + (<0? .S1> + ) + () >) + (T <#FUNCTION ("STACK" (UV1 UV2) + > + ) + + >) > + ) > + <1 .END2> .ENV1 .ENV2> + > + > > > >> ) + (BOUND2 ) (OBL T) + "AUX" FORM1) + + <.SMATCHER .PAT2>) + (<==? > SEGMENT> + .PAT2 .BOUND2 .BOUND1> .OBL> .ENV1 .ENV2 <>>>) + (<==? .PAT2 .BOUND2> ) + (T <1 .PAT2> .ENV1 .ENV2> + >) > + > > >> + + >) + (<==? > SEGMENT> + > + + >) + (T >)> + > > >> + + +)) + .KOUNT> + > + > >> + + + + .K) + (T > + > + )> >> + + + + + > + .EXP >> + <==? > SEGMENT>> + <.SOFTENER [.ALPHA .PAT]>) > + > + > > >> + + + + + <.HACKER [.END .K .BETA .S]>) + (<==? >> SEGMENT> + > + + >>>> + >) > + > + + >) + (T >) > + > > >> +  \ No newline at end of file diff --git a/MUDDLE/nprint.8 b/MUDDLE/nprint.8 new file mode 100644 index 0000000..e719984 --- /dev/null +++ b/MUDDLE/nprint.8 @@ -0,0 +1,799 @@ +TITLE PRINTER ROUTINE FOR MUDDLE +RELOCATABLE +.INSRT DSK:MUDDLE > +.GLOBAL IPNAME,TYO,FIXB,FLOATB +.GLOBAL BYTPNT,OPNCHN,CHRWRD,IDVAL,CHARGS,CHFRM,NONSPC + +FLAGS==0 ;REGISTER USED TO STORE FLAGS +CARRET==15 ;CARRIAGE RETURN CHARACTER +ESCHAR=="\ ;ESCAPE CHARACTER +SPACE==40 ;SPACE CHARACTER +ATMBIT=200000 ;BIT SWITCH FOR ATOM-NAME PRINT +NOQBIT=020000 ;SWITCH FOR NO ESCAPING OF OUTPUT (PRINC) +SEGBIT=010000 ;SWITCH TO INDICATE PRINTING A SEGMENT +SPCBIT=004000 ;SWITCH TO INDICATE "PRINT" CALL (PUT A SPACE AFTER) +FLTBIT=002000 ;SWITCH TO INDICATE "FLATSIZE" CALL +HSHBIT=001000 ;SWITCH TO INDICATE "PHASH" CALL +TERBIT=000400 ;SWITCH TO INDICATE "TERPRI" CALL + +P.STUF: 0 + +PSYM: + EXCH A,P.STUFF + .VALUE [ASCIZ .=P.STUF!QîP.STUF/Q!:VP ] + PUSH TP, (A) + PUSH TP, 1(A) + MCALL 1,PRINT + EXCH A,P.STUFF + POPJ P, + +P.=PUSHJ P, PSYM + + MFUNCTION 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 + + MFUNCTION 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 + + PRIN01: 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 + 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 + IPRINT: 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]] + + + + ;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 + + ;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 + + RETIF1: 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 + + ;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*" + + ;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 + + ;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 + + + ;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 + + ;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 + + + ;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, + + + ;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 + ;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 + + ;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 PSEG: 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 + + +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 + PLMNT5: 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 + + LSTPRT: 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 +  \ No newline at end of file diff --git a/MUDDLE/nptest.4 b/MUDDLE/nptest.4 new file mode 100644 index 0000000..a4b7faf --- /dev/null +++ b/MUDDLE/nptest.4 @@ -0,0 +1,35 @@ + >> + + + + (.FINISH)) + ( <>) + (T (.START + !)) + >) + ( .FINISH (.START !.AVOID)>> + ) + (T >) >>)) >>> + + + + + + + + + + + +  + + + + + + +  \ No newline at end of file diff --git a/MUDDLE/nread.14 b/MUDDLE/nread.14 new file mode 100644 index 0000000..2d8e75a Binary files /dev/null and b/MUDDLE/nread.14 differ diff --git a/MUDDLE/nuprm.8 b/MUDDLE/nuprm.8 new file mode 100644 index 0000000..f99afc4 --- /dev/null +++ b/MUDDLE/nuprm.8 @@ -0,0 +1,532 @@ + +TITLE PRIMITIVE FUNCTIONS FOR THE MUDDLE SYSTEM + +RELOCATABLE + +.INSRT MUDDLE > + +.GLOBAL CALER,CALER1,NWORDT,CHARGS,CHFRM,CHLOCI,TFA,TMA,IFALSE,IPUTP,IGETP,WTYP1 +.GLOBAL ITRUTH + + +; BUILD DISPATCH TABLE FOR PRIMITIVE FUNCTIONS USAGE + +PRMTYP: + +REPEAT NUMSAT,[0] ;INITIALIZE TABLE TO ZEROES + +IRP A,,[2WORD,2NWORD,NWORD,ARGS,CHSTR,BYTE] + +LOC PRMTYP+S!A +P!A==.IRPCN+1 +P!A + +TERMIN + +LOC PRMTYP+NUMSAT + +PNUM==PBYTE+1 + +; MACRO TO BUILD PRIMITIVE DISPATCH TABLES + +DEFINE PRDISP NAME,DEFAULT,LIST + TBLDIS NAME,DEFAULT,[LIST]PNUM + TERMIN + + +; SUBROUTINE TO RETURN PRIMITIVE TYPE AND PRINT ERROR IF ILLEGAL + +PTYPE: GETYP A,(B) ;CALLE D WITH B POINTING TO PAIR + CAIN A,TILLEG ;LOSE IF ILLEGAL + JRST ILLCHOS + + PUSHJ P,SAT ;GET STORAGE ALLOC TYPE + CAIN A,SARGS ;SPECIAL HAIR FOR ARGS + PUSHJ P,CHARGS + CAIN A,SFRAME + PUSHJ P,CHFRM +PTYP1: MOVE A,PRMTYP(A) ;GET PRIM TYPE, + POPJ P, + + +; 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 + + + +; 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 + + + + +; 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 + + + +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 + + + +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 + + +; 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, + + + +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, + + + +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 + + + +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: y0C+@y/õ`±õ`7'(ô õ`‡@@,j÷¤‡õ`‡7 y/î.0:. ô­ë \y0)öè<°Wõ`«!<øW<°Qô<°O.\rô<°Sõ×åöw€®½õ`©ö‹€—ös€®½+76|y/ü?+N7 y/+7ô|¯/(@ö‹€3|%zõ` y/õ öH€¥õ+7 y/(@ \%zô€¥õô€+7ô<°Oõç<°S?  <.\u+I4^7þök»ïxYô<°QöÈ<°Wa|õ`»ô<°O.\rô<°Sõ×å+7`|+7ô<°Oõç<°S?  <.\s+77@y/+7ô<°Q`|+7ô<°Oõç<°S.\s+7ô€ÕöèKïö €,z föπË2>-g+k6@y/öÈ<°Q,!4>!"øð¼°Q Ffô€Ë y.y`|õ`ã6@y/õ`õ†€G,z:"l"@ö€øð¼°Q h÷PÍ+ y/%òé§Q y/&ùðÑ(ï{<')õ1<Xü1ÿÿ+ Q2D@Q&D@ Fgô€ÏòâÏg÷@E Dh4H÷pÑöÐ<¯ö2ÿÿ+aB+ø(€ÿûBTw=Hô€Ëõ†€í+ô€Õ1& ?`i,z hô€Ë`D‡÷¡ùmd+ ùðË!$øñ<°Q+fò逧Q/&4f ûô¼¯Kô¼¯M+w!< ø÷<°Qõ`ã÷PKïõb#ô€§S Bnõ†€N§ø+ùðKï nõ`öè<°Q,z/'ùðKï+@@iùðËþ—½‰Õïx,zöÈKï,zûg€ûX,LI"`Bõ`=ùðß,zø(€ÿôI€õ†€í,zõ`;ùðÍôO€"<õÇ­ë 2Xô €22-gõ`m7@I/7@I/õ`kô$°QöÐ$°O`dõ`kô €`dõ`W2X!"BB9ô€Ýòû€§Yú2÷PKï,z:#þ¿ nûa„Twö±€9!&ïzòëŒ]eNõ`ø+€ÿ1N+õY€!&GFR)þ¿ '-.nòë€õŽ€O@oõ†€N§@)õ–€òû€ô €òû€§[þ¿ n!$BDR)ôÀÝ7 oaf@õ`; .òû€§[:e,P{+(ùðKï+ `1"xö(€-õb=ûAÝô1Twô „Twô€×ô€×XF8÷@Õ:eûaˆú1„S‡õƒÿñö €+%ô ÷d'ô òù§?õ†€!ùðKïõ` ¿1~lõbSõŽ€3^võ`a y.y`|õ`a7@y/õ`_!< ø÷<°Qõ`aõ†€G+G y/%dN@ô¼¯Kõ ƒÿÿ.&8Q&$@öèQ&@òë€4N'.aN+:ÿR‡ô¿ÿþm(Nïx0n@@o1Nô €òû€÷@<°Sõ–€,zþ¿ôJô€½öè—7õ`}6@9õ`‡ôK€ô*ƒÿýöè—7õ`…öj—+ûC€öj—+ô—+õZ€ö‹€§]ZNmöš Ÿ *P6@9 *dô€Ûõ`ù/'/ n!.BNR)ùðKï,zô,ÿý76@_+Oô ÁQ@b@lôá,FôáO@@_õ\•,zôáö”§_ô Ç4*'0GJY/ ",zô€øá Y0( Y/% Y/& *(Dï{<')õ1<Zü1ÿÿõ`ËQ&D@Q(D@òà€`Bõ`Éö”€Éö4ƒÿÿõ`ÉõŽ€õŽ€,:,:Q6@l,F,Z,Zõ–€õ–€ö€ Ÿ÷@=d[0j@õ` ¥ Y0(/$ö™ ¥ *@ô¬¯Kô,¯Mõ`­öð<¯#3^.5,z:h2^-i3^-p,z2^-s3^W,z2^-l3^-m,z3^-k,z y.y`|:h,zô§E6@y/øç<¯ô<°[ø„§EDþìQþ½ÿþíø'4\;-<fõ†€Gõ`ô<°[ù¤<¯Aø €§E6@y/4Bm!<ø÷<¯ôöＯ!õ`úGG\y/ûX02x+9+77 A/î+7ô °]`|+ õ†€ # < . \y.y!<øW<¯ø|¯/õ` < ø÷¦+7öÐçõ`Qöï€õ`6@y/õ`9*%{ö€#3^%{õ`+ ô<¯  \y/ ô ó \y0'7>%{õ`Cô<¯ \ y/ \ y0'ô óú¯øW<¯=,< y.y \p!y/õO€+p!< üW<°Q+ !<PøW<°Q@@y/õ`õ†€G+ õ`þ€§a!<Z \îTú¯øW¯=@@&OD/+'1:.^! X@ô€*>ô€§cõ`€7>tõ`ôG<°S.-uõ箛õÇÕ/jõçå.u.s1<õ`!<øW<°WO@tøé:'÷ðç+; >ôM!<2>-g+9öè<°W7@y/+8öo<°Oú¡.ÿŸÿÿm+8ôô<°O.>lõ`g Tt7  <ôéö‹€Yõ`ô<¯IôãõŽ€,:õŽ€4^LûA€at+C`T+SZ`t õ`§ /%`t+U ".zb'2 Dy/ô<¯Katõ`•ôžY`Tõ`•ô(¯Kat Q/%`tô(¯Kô<¯?Dy/ò耧eö€õb›p y/îô@€&"l!$(Dpõ–€,Zõ–€,zöážYô(¯K "V+E "/+EùÚ®Ûïx^7@y/+.>l2>-g,z7@y/+<'55\ô<¯ø!GDy/+üä€ ô€§kô¼¯ISbDU8ïxþ,!õ` ³üä€ ô€§kô¼¯IBy/,:,<,Z,z÷@C4~'6 <l&^$<löw7@y/+' y/î`| õbQöÐ<¯õ` ¥öß<¯#+3 y/ öW§mõ`i y.ya|õ`a@@y/!<PøW<°Q:h,z6@y/+: '7 \y/ ,zø<¯#ø8¯#++7@y/,zöW§Iõ`o!<G\y/ y.y`|õbqô§m \y/ y.y \y/!>y/ \y.yø<¯I@@y/!<pøW<°Q6\y/+ ( @&Fõ`¯õ–€,zô¸ p+[ >2>-gõ`Ó7@y/+o.>lõ`Í7 ',z >l.-g,: 0(ö?<®Á+u,Zùð<­C*-g,x B^pFõ–€õÏ­íô<¯/ø<°Q@@y0)ø<°Sø<°Oùð<°YO@y0-@@y0( sCSwQLW@Y> @øÿÿÿÿÿð %{ô€ ]ô€ © y0/ $,T %{!< &X%{õb ï \y0C \y/ ,Zy.y $':òê§u6@.ûX0(õb +iõp +õ` +ƒ*\ 0 p`b~õ` ¥$':òê§uö‘ +uõÁ./0(+ ;+@ =,z÷' +m6 7 ,Z,Zõ–€/'8+põ†€ +‡, G[4B .õ†€ = B:@,z*õ†€ ++õb +‹*õ` ¥þ¿7 + `!$GDþ¿*,: , , t,Z+ F,: ,@õ` +á hú/7ÿÿ,: ,@, t,Zõ` ¥,: , õ` +á,: ,`õ` +á,: ,`õ` +á hú/7ÿÿ,: ,@, t,Zõ` ¥,: ,õ†€ +¹,Zõ` ¥õŽ€,:ô <°‘sDlXïx ^öð + d.0öð + d.0öð + d.0öð + dõb +Ç oï~þ,:p,Z@ PpQ\@ @üÿÿQPpþõ` +ù,: ,@õ` +á,: , õ` +á,: ,, t,Z,z,: ,@õ` +á* hôwÿÿ =* h, t,Zõ` ¥õŽ€ %{,:ô <°‘öð + |.0öð + |.0öð + |.0öð + |õb +÷ \@ô&<l %{Qy/Gô7 ZPy/õ` Ã,:7\y/+ Wõ†€ + :hõŽ€ %{l>7\y/õb , + V,:ô8Z\y/, ,Zö®Áø8,zõŽ€ <';`b5> ab+ O5> Oõ–€+p + + + #+ õ` ;õ` Cõ` +õ` 3ô7ÿÿO@p,zôwÿÿO@p,zôwÿÿõŽ€!"BBp+ OôwÿÿõŽ€ô(ƒÿÿ.Bp+ Oôwÿÿ>p,zùð¦e~f/ïx ô'wÿÿY\p!`üÿÿP\pø¦e,zôwÿÿ:p,zô7ÿÿ p5> %+pZ\y.yüÿÿû7<¯l~+ ',zõŽ€,:ô8Z\y/, ,ZXhö®Áø86\y/õ` Q/'8e~+?öئ@@y/#õ`c,:õŽ€,: %{7^y/+ 3ûDwÿýô3^+ 7ûG¼ö—€§w÷' i,Zõ–€õ†€ ÷@7ÿÿ+ WõŽ€ %{,:7\y/õb w, =õ` «,:ûD8ZPy/ö®Áø8,Z,zõ†€ ‡, ,zõ†€ ‡, =,zõŽ€ %{l>,: ô<¯3\|O"~ðùæ`-ÏùæUoÏðòÙKÛÿÿþ ;ùæX]O@Pðùæ[/;O(x^ð O0';ùæ^jÉð O)JO3Jð ùæ^9ÏO6,oðùæX+O0ðO@[] O@GðO:mO ùæX~‹ðùæTF# ùæL´íðùæ^k O@U}ðO(W-îO-ðùæTo•ùæLŸ•ðùæTr]ùæL¢]ðO*|DO4^Dð!O:gO/ð#O\ùæXm‹ð%O(8Ohð'ùæT8ùæLhð)O`(O`<ð+'U@}U@ }V@1Y\ññåC'ÿ@.,ññæPµ5@ñæPµññãæl×ññ术…@@<|ñ *l|@ñäÓÁuñ '@A@ñ䟅ñ (qA@ñæ(ªñQ&4@lññ杗_@ ñä{ö+ñ(oH@ ñä{õ ññæPµ @ ñä +§IññåsæE@ ÷„`ž“ÿþ »ñä{Ы@îñåH¸GñR.'@ñæúyÏññæ©OW@S[ñ<d@9d@ñãŸ:Iñ#ñä¾I@ñæ8gñ%ñæ(5@=vTñ'n@@ñäÓÙ ñ)ñæ7q[@ñæ`=ñ+ñåڊ@ñãž=ñ-73+@'>cñ/ñäØÙÅ@ñåbgÿñ1'@ñåcEñ3f@S1 ñ5ñä +Pƒ@'*?ñ7<\@'$ñ9)x@{xñ;R?t@[ñ=ñæ­SÏ@E ñ?yMJ@ ``gñAñæ(5ƒ@!NgñCM5D@"zMñECRh@#7x`ñä +¦ëbñ愋fñæÁÌghZlhjRk,lGn(o*pñäS?r(qˆt@M[vPxx&%zñååJ|X$8 ñãÄ÷ ñæ^å @ñã5µ `R% G@÷W²ßïxîðî`71 ðñæ§(gñäùxgðDfDYHðñåßaE%]0ð L*8A/4ð ñäԏ;ñãœ;ð 2,>fðD^\ñåbað\U Eðr X gE\ðuJ 8EðA;t Zoðñäͦ#îñã•&#ðñäÑo]ñã˜ï]ðñäÑދñã™^‹ðvu }E ð!p  NZ@ð#lf b\ð%@( @(ð'@< @<ð) @`ð+&k 'O ('<@0E^h@1~l+îL y0/d'=ô ©a|õb ò€§{4\îwú/¸ú/ ©d'>û7€ ©ò€§}b'?ò€§õa@ ©+ þŸ/p€õb «d'@7>%{+îWò§ <d'Aöè<¯Eõ` ë7<+îvöO§ƒ+îw2<'BöO§…÷A€ïxî]õ` —ö·€ ¿ 0*/ô§ \y/#õÿå y0/Z4'Cô<°U,p+îd÷@ © %{öÐ<¯Iõ†€93^&Höø¦+îhöȦ“+îq6@y/õb Ñö·€ Û <õG§ \/þ€õb × >ò€§‡õ` §7@y0I6@y0Jõb Ý7@y0K6@y0L+îp+îk7@y/#+îhùð¦“ø¦‘@@&I+îhõ†€Ù<'Dõ` Áö秉!<Tõ` »ô ©a|+îx!<Põ` »p€õb õd'@7>%{+î|ò§ <d'Aöè<¯Eõ` ë d'Eô€ óô€ ©azõbõÿåö7Gõ` ò€§‹õ` ŸBy/!:y/XûG€ d'F+îRþ %{ö×<¯#õ` %{þ6@y/+ h0"õ`Ùõȼ®Á[Zö”€Eû! H0ah@õ` ¥ô–Û!( øò• õ` ¥ ø-2'Jò꧕+PEð•Nô• N0N@N@I@Iö4€õ`)+Nl.b'K.'8üƒÿÿ:hò§—û€6&I#'+RõöÈõ`)ò€,zõ` ¥öè$£Íõ`)õ`¡ ô€ô €ô +W,t .f'Lò€§™[0`Põ`í`X õ`ÏdPl`N`Xÿ’Çȟÿþ¹aX+"`X (ö -õ`Óòê÷Š)÷ŠÅòéb'M+& õÁ€§›b'NaNô@`Nô@aNò§,z0P,z "@õ`Ý`Nõ`)/0 öŒ)00+rdPõ`ßõÌ®Á @d'O,zôõÍ ®Áô€ ZP+T00õ`ÿõÌ®±+nZõÍ<®Á[PZP,z`Pý›€õ`)ò€§Ÿd'P,:õŽ€õŽ€õŽ€ ,Wõ–€õ–€õ–€,Zò€§Ÿõ\ñ,z1p 10 õ`)õ†€ +ðKïõŽ€ 2 "Gàõ†€H—õ†€ ø)ÿòù€§¡l$ (Hïvl$ Gõ–€ õ`Ýø‚ ø ô ó‚ ôŽ ð õ=21(@9õgôaõc)v|2)z5.!t$-õ@[Q|õ>&(+õ?"€[õ?"€[õ>Ž€eõ>ƀ_ú=OÏWõ@qõUQv01v@6(@/õ@]õYõWø>‡õ?&€]õ?&€])|%.)|%.)|=/)|=/õ=‚€yQv3kMAÿþ9(@<õAQ|wOiQ}P){EM){EMõ>þ›õ>þ›){=Mõ>ú›(AN5H$öð°O,zõ`IôJõ†€ƒh'Qõ`¥õ†€ƒl(üŠ +öè¯1l( H .yõ`¥  /d(ï|ò§£,zþ3B%{B /d(ï|l( H /3B%{@ /õ` ³XH /,zúB¯;õû¯;õ`U&"lõ`ÝþBy/òê§O(H‡õ¯-þõ`Uö’)õ†€ƒ,;õ`ô¯%þõ`¥  / *þ2D)/õ`}ör¯%,z.*l3*-gõ`yõ` ¥õ†€¥öP€õ`)õ` ³('Rõ`Uh'R,zöw€õ`õ†€ƒ!$@øñ¯õ†€¥õÊÿ(Hï{ õŽ€õ†€ +PõG€,H>+ õ†€ s/'8õG€öw€,z!,@øS¯,zõ–€ %{õ`›6@ H /,zd Cô¯ô '`Hh`hh@XD /îü€p /î,zõÿÝ H /6@ü3€,zõ`'ö䧥ø,ÿ5›“Ëÿþ¹ô °[+@A'S6@ /+Z,zö䧥ø, $ 0.+]úB¯!õ`Ud C+0."‡õȀ."‡ø,+@@f,zGh /Bh /õ@€('Hõ@€õ`Uõ@€h'Hõ@€,z[y/(\û<¯1,zûB¯1õ`Uô€ ©b'Uò逧«ö€ö1€1õ`ö€+}&'V1Flõ`õ`bpõ`)ôõ†€­ Ty0Fh4\at~+öЦõ†€¤Óõ`ó,, v,z!"øð¼°Q+ , võbù$'V1DWõ`éö1­õ`õûa€ü€?0Fpõ`)õ`éõ†€ò€§­+o$'Wò€§¯d"pl"`õ`éDy/ y0Fn'X+ "$.Dy/ @@y/õ` ¥f,zõ` ¥,:ô §3\'7,PM,Z,zZø<°Uò€§± 6v'Y+ZõÍ<®ÁõŽ€,\õ–€ò€§±6'Y1V+p ,y0Dú+ ô ò€§³b'Zò€§µ y/ûb€S"1V7@y0D+)5D)ûEˏÿþ9ôbL'[õ`ÙõË<®Á 0[@0`Põ` aPõ` ¥[0*õAaPõ`M &]ZI'òû€§·,:'\õ`Oô ‚LëõŽ€§¹Q&(ô +€õ`mõ†€á+hô<¯'ûxQ"(õŽ€,:õŽ€ô)ÿÝûAˆ‹0FõY[5d>&']1V5F=!&ü€ \ No newline at end of file diff --git a/MUDDLE/nutil.1 b/MUDDLE/nutil.1 new file mode 100644 index 0000000..5b9bf7f --- /dev/null +++ b/MUDDLE/nutil.1 @@ -0,0 +1,230 @@ + + >> + + + ) + (T >>)>>> + + + + + >> + + + ("STACK" M A) + > >> + + + +)) + > + ("STACK" M A) + > + > >> + + + .L) + (<==? .ELT <1 .L>> + >) + (T ) >>> + + +> .L) + (<==? <2 .L> .ELT> >) + (T >) > >> + + +)) + + ("STACK" M A) + + >>> + + +)) + + ) + (T ) > + ("STACK" M A) + ) + () > + >>> + + +)) + > + ("STACK" M A) + > + >>> FALSE> >> + + + FORM> >> + + UNASSIGNED> >> + + SEGMENT> >> + + >> + + + + + + + + + + + + ) + ()> >> + + ("STACK") + ) + ( + >>>>) >> >> + + +>>>> + + + + > >> + + +> )) <> ("STACK") + > + > >> + + >> + + + >> > + '(LIST FORM VECTOR SEGMENT VECTOR)>> >> + +>) + "AUX" (RESULT ())) + <.CFUNC !.RESULT>) + (T !.RESULT)> + > + ) > >> + + + ()) + (T >>) >>> + + +> <1 .LSTUPL>) + (T >) >>> + + + ) + (T .LREST>>) >>> > + >>> >> + + + >> + + >) + (T >) > + >> + + +>> >> + + +>> + + ) + (T ) > + > + >> + + + ()) + (>> <.MAPPER .RESULT>) + (( + >> + !>)) > >> + + + ()) + (> .EXP) + (T > + ) >>> .THING) + (<==? LIST> ()) + (T >)> >> + + + + + >>  \ No newline at end of file diff --git a/MUDDLE/nuuoh.12 b/MUDDLE/nuuoh.12 new file mode 100644 index 0000000..687fba2 --- /dev/null +++ b/MUDDLE/nuuoh.12 @@ -0,0 +1,158 @@ +TITLE UUO HANDLER FOR MUDDLE +RELOCATABLE +.INSRT MUDDLE > + +;GLOBALS FOR THIS PROGRAM + +.GLOBAL BACKTR,PRINT,PDLBUF,TPGROW,SPECSTO,TIMOUT,AGC +.GLOBAL BCKTRK,SPCSTE,CNTIN2 + +;SETUP UUO DISPATCH TABLE HERE + +UUOTBL: ILLUUO + +IRP UUOS,,[[DP,DODP],[.MCALL,DMCALL],[.ACALL,DACALL]] +UUFOO==.IRPCNT+1 +IRP UUO,DISP,[UUOS] +.GLOBAL UUO +UUO=UUFOO_33 +DISP +.ISTOP +TERMIN +TERMIN + +REPEAT 100-.IRPCNT,ILLUUO + + +UUOH: +LOC 41 + JSR UUOH +LOC UUOH + 0 + JRST UUOPUR ;GO TO PURE CODE FOR THIS + +;SEPARATION OF PURE FROM IMPURE CODE HERE + +UUOPUR: PUSH P,C + LDB C,[330900,,40] + JRST @UUOTBL(C) ;DISPATCH BASED ON THE UUO + +;HANDLER FOR DEBUGGING CALL TO PRINT + +DODP: + POP P,C + PUSH TP, @40 + AOS 40 + PUSH TP,@40 + PUSH P,0 + PUSH P,1 + PUSH P,2 + PUSH P,3 + PUSH P,4 + PUSH P,5 + PUSH P,40 + MCALL 1,PRINT + POP P,40 + POP P,5 + POP P,4 + POP P,3 + POP P,2 + POP P,1 + POP P,0 + JRST 2,@UUOH + +;CALL HANDLER + +DMCALL: MOVEM SP,SPSAV(TB) ;STORE VITALS INTO CURRENT FRAME + MOVE C,UUOH ;PICK UP PCWORD + MOVEM C,PCSAV(TB) ;SAVE IN CURRENT FRAME + LDB C,[270400,,40] ;GET AC FIELD OF UUO +COMCAL: LSH C,1 ;TIMES 2 + MOVEM C,(P) ;SAVE + HRLI C,(C) ;TO BOTH SIDES + SUBM TP,C ;NOW HAVE TP TO SAVE + MOVEM C,TPSAV(TB) ;SAVE IT + MOVEI AB,1(C) ;BUILD THE AB POINTER + MOVN C,(P) ;NEGATE NUMBER OF ARGS + HRLI AB,(C) ;HAVE A REAL AB POINTER + MOVSI C,TENTRY ;SET UP ENTRY WORD + HRR C,40 ;POINT TO CALLED SR + PUSH TP,C ;START HACKING FRAME + PUSH TP,TB + PUSH TP,AB + PUSH TP,SP + PUSH TP,P + PUSH TP,TP + PUSH TP,PP + PUSH TP,[0] +CALDON: SUB P,[1,,1] ;POP STACK + MOVEM P,PSAV(TB) + MOVEM PP,PPSAV(TB) ;SAVE PLANNER PDL + HRRI TB,(TP) ;SETUP NEW TB + AOBJP TB,CALLIT ;GO TO CALLED SR + TLNE TB,-1 ;TIME OVERFLOW? + JRST CALLIT ;NO, GOT TO CALLED GOODIE + +;TIME OVERFLOW, CALL THE GARBAGE COLLECTOR + + MOVEM TP,TIMOUT ;POINT TO UNHAPPY PDL + PUSHJ P,AGC ;AND COLLECT GARBAGE + HRLI TB,TIMOUT ;CONTAINS CURRENT TIME + SETZM TIMOUT +CALLIT: INTGO ;CHECK FOR INTERRUPTS + JRST (C) + + +;HANDLER FOR CALL WHERE SPECIFIES NUMBER OF ARGS + +DACALL: MOVEM SP,SPSAV(TB) ;SETUP THE OLD FRAME + MOVE C,UUOH ;GET PC WORD + MOVEM C,PCSAV(TB) ;AND SAVE + LDB C,[270400,,40] ;GOBBLE THE AC LOCN INTO C + IOR C,[MOVE C,0] ;SETUP INS + EXCH C,(P) ;PUT INS ON STACK AND RESTORE C + XCT (P) ;C NOW HAS NO. OF ARGS + JRST COMCAL ;JOIN MCALL + +;HANDLE OVERFLOW IN THE TP + +TPLOSE: ADD TP,[-PDLBUF,,0] ;USE BUFFER + HLRE C,TP ;GET -LENGTH + MOVEI D,1(TP) ;COPY TP + SUB D,C ;D POINTS TO DOPE WORD + MOVEM D,TPGROW ;SAVE FOR NEXT GARBAGE COLLECTION + SETOM INTFLG ;CAUSE AN INTERRUPT NEXT TIME + JRST CALDON + +;SUBROUTINE TERMINATION CODE (NOT A UUO BUT HERE FOR COMPLETENENSS) + +FINIS: MOVE C,OTBSAV(TB) + MOVE E,SPSAV(C) ;RESTORE BINDINGS + CAIE E,(SP) + PUSHJ P,SPCSTE ;IF NECESSARY + HRR C,OTBSAV(TB) ;CHECK PP GROWTH + CAME PP,PPSAV(C) + JRST BCKTR1 ;SAVE TP FRAME +CNTIN1: HRR TB,OTBSAV(TB) ;RESTORE BASE +CNTIN2: MOVE TP,TPSAV(TB) ;START HERE FOR FUNNY RESTART + MOVE P,PSAV(TB) + MOVE AB,ABSAV(TB) ;AND GET OLD ARG POINTER + JRST 2,@PCSAV(TB) ;AND RETURN +BCKTR1: PUSH TP,A ;SAVE VALUE TO BE RETURNED + PUSH TP,B ;SAVE FRAME ON PP + PUSHJ P,BCKTRK + POP TP,B + POP TP,A + JRST CNTIN1 +CONTIN: CAME SP,SPSAV(TB) + PUSHJ P,SPECST + JRST CNTIN2 + + +ILLUUO: .VALUE + +OPC: 0 +JPC: 0 + +END +  \ No newline at end of file diff --git a/MUDDLE/omatch.1 b/MUDDLE/omatch.1 new file mode 100644 index 0000000..1e052a0 --- /dev/null +++ b/MUDDLE/omatch.1 @@ -0,0 +1,456 @@ + ) + (T >>)>>> + + + + + >> + + + (M A) + > >> + + + +)) + > + (M A) + > + > >> + + +) + "AUX" (TP ) VAL EXP1) + + + > + FORM>>) + ( + > GIVEN> + > + >> + .EXP>) + (<==? .EXP1 ALTER> + ?()> + ) .TP>) + (<==? .EXP1 VEL> + ) P1) + () + > + > + > + >>) + (<==? .EXP1 BE> + > > + .EXP) + (<==? .EXP1 ET> + > .EXP> + ) (PATS )) + + >> + > + > >>) + (T .EXP)>) + ( .EXP) + (<==? > > SEGMENT> + (!> + !>)) + (<==? SACTORFORM> + > + '(ACTORFORM SACTORFORM)> + ( + !>)> + (!.VAL !>)>) + (T ( !>))> >> FALSE> >> + + + FORM> >> + + UNASSIGNED> >> + + SEGMENT> >> + + >> + + >> + +) (OBLIGATORY T) (ENV <>) + "AUX" ACTOR) + + > + >>) + (>>)> + ACTOR-FUNCTION> + + '.OBJECT + '.BOUNDARY + .OBLIGATORY + !>>) + (<==? ACTOR> + ) + ()> >> + + + ) + ()> >> + + + >> + '(ACTOR ACTOR-FUNCTION)> >> ) (TP ) + (A2 > <2 .AFORM>>)) + + + + ) + (T > + .AFORM)>) + (<==? .A1 ALTER> + + > + ) + (<==? .A1 VEL> + .PURESWITCH>)) + FORM>>> + .PAT) + ()>>) + (<==? .A1 BE> + > + .TP>) + (<==? .A1 ET> + > + .TP>>> + ) (SPATS ()) + (BEG ()) (P <>)) + >> + > + >) + (>> + + > + >> + > + > > + >> + > + > >) + (T !.SPATS)>)> >) + (.AFORM)> >> )) + > + .VAL1) + (<==? FORM> + > + ) + ( + >) >) + (T .VAL1) > >> + + + )> + >> >> ) + "AUX" (VAL ..VAR) VAL1) + + >> + <==? .BEG .VAL>> + <==? .VAL .ENDVAR>> + > + )> + > + >>> + .VAL) + (<==? FORM> + + (> + ) + ( + >) >)) + (<==? SEGMENT> + + > + > + SEGMENT>>> + .VAL1> + (.VAL1)>) + ( + >) >> + + + >> + ) + (T .VAL1)>) + (T .VAL)>) + (.BEG)> >> + +)) <> () + > + > >> + + >> ) + "AUX" (PURE <>) TP EXP1) + > + + >> + > + > + + FORM>>> + > + !.EXP1 + !.>>>>) + (T >) > + <> .EXP1 !.>> >> + + +> + '(LIST FORM VECTOR SEGMENT VECTOR)>> >> + + + '(FORM SEGMENT)> + > + >> >> + + +)) + > UNASSIGNED> + LIST>)) + >> + > .OBJECT .BOUNDARY .OBLIGATORY <2 <1 .V>>>> + + > >> + + .OBLIGATORY> + >) + (T + >)>) + (T .OBLIGATORY> + .BOUNDARY) + (T >)>>>)> + .BOUNDARY >> + + + +> + )> >> + + + +)) + <==? .N > > + .BOUNDARY) + (.N + > + ) + (T )>) + (T )> >> + + + + .OBLIGATORY> + .BOUNDARY) + (T >)>>> + .BOUNDARY >> + + + >> > + >>> >> + + + + + + >) + (<==? > SEGMENT> + > + + >) + (T >)> + > > >> + + +)) + .KOUNT> + > + > >> + + + + .K) + (T > + > + )> >> + + <==? .L1 .TERM1>> + ) + (<==? .L2 .TERM2> )> + <1 .L2>> > + > > + >> + + + >> + + + + + + + ) (OBLIGATORY T) (ENV <>) + "AUX" (BEG ()) PURE ENDP BETA ENDE K ENDP1) + >>) + ( + >>) + ( + >)> + + > + >> + >) + (.PURE + > + ) + (<==? > SEGMENT> + >) + (T <1 .EXP>> + >)> > + + > + > + ) + (<==? > SEGMENT> + + .EXP + .ENDE + .OBLIGATORY>>>) + (<==? .EXP .ENDE> ) + (T <1 .EXP>> + >)> + >> + >>)> > + + >> + ) + (.PURE + <1 .ENDE>> >) + (T <1 .ENDE>>) > + > > >> + + > + .EXP >> + + +) (OBLIGATORY T) (ENV <>)) + FORM> + ) + () > >> + + + + .EXP1) + (<==? .EXP1 .EXP2> + ()) + ((<1 .EXP1> ! .EXP2>))> >> + + +)) + + > + >> + > + () <>>) + (T > + () <>>)> >> + + + <>) + (<==? LIST> ()) + (T >)> >>  \ No newline at end of file diff --git a/MUDDLE/pfunct.12 b/MUDDLE/pfunct.12 new file mode 100644 index 0000000..273feed --- /dev/null +++ b/MUDDLE/pfunct.12 @@ -0,0 +1,26 @@ + + > + +L2 > +L1 )> + + >> + >> + <=? .E FSUBR>> + + + + >> ) + (ELSE + > + ) + ()>)>)>)> + > + +FOO > + > )> + +>>> +  \ No newline at end of file diff --git a/MUDDLE/pprint.1 b/MUDDLE/pprint.1 new file mode 100644 index 0000000..b408a23 --- /dev/null +++ b/MUDDLE/pprint.1 @@ -0,0 +1,401 @@ + "MUDDLE PRETTY-PRINT, FRAME-SCANNER, AND OTHER ROUTINES" + +)> + +"These atoms are placed in the ROOT oblist to allow general + access to their functions" +M +> > >>)> +PPRINF +SPECBEF +SPECAFT +FORMS +PPRINT +EPRINT +FRAMES +FRATM +FRM +INDENT-TO +LINPOS +LINLNT +PAGPOS +PAGLNT +QUICKPRINT +PP ;"OBLIST" + + + + )> + + + + + ;"To make compatible with MEDDLE." + ) M (COMELE ,COMPONENTS)) + ) + (<==? TOPLEVEL> )> + >> FSUBR> + <==? > EVAL> + <==? >>> FORM> + <==? <1 <1 >>>> + > + + > + + + > + SKIPIT > + > + > + >>> + +) (DEPTH!-FR 1) AF) + ) + (<==? TOPLEVEL> )> + EVAL> + <1? >> + <==? >>> FORM> + <==? > ATOM> + <==? > ,<1 .AF>> + .F> .F>>>> + FUNCTION> + + + >> + > + > >> + +)) + ) + (<==? TOPLEVEL> + + + )> + > + >>>> + + + + + + + + + + + + + + + + + + +)) + ;"Print tabs and spaces to get to column -n-" + + -1> ,TABS>> + -1> ,SPACES>>)>>> + ) (STOP 0)) + ) (M 0)) + > > + > + + >>)> + > + + >>> + +) (STOP 0)) + ) + (.QUICKPRINT + > + >> <==? .L .STOP>> > + >) + (ELSE + ) COM) + > + > + >> <==? .L .STOP>> )> + )> + >)>>> + + + + ) ;"If its a MONAD, just print it." + (ELSE + .M>>> + )> ;"If it fits, use ELEMENTS, else COMPONENTS." + < PPRINT ;"Snarfed from BKD." + '#FUNCTION (() + + > + >>)>>)>>> + + + ) + ( .M>>> + ) + (ELSE < PPRINT + '#FUNCTION ( () + + > + >>)>>)>>> + + COMMENT>> + > .M) (0)>> + + + .MARG + 2>>> + )> + + + .MARG>> + 2>> + + )>>> + + + > + >>> + "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." + + <.COMELE .L > >> + + <.COMELE .L > :L>> + + + > + >> + + +> + <.COMELE .L <+ .M 2>> + >>> + + >>> + +>> + +> + +> + + >>> + + + > + <> + ">>> + ) (TEM %<>)) + ) + (ELSE + > ATOM> + -1> > + > + >> >)> + > LIST> .P>> >)> + ) + ( ) + (ELSE )>)>> + + .M .FUDGE>>>> + + %<>) + (ELSE + > -1> > + + > + ) (N <+ .M 1>)) + > + STRING> + )> + + ) + ( ) + (ELSE )> + + + >> + + + )>> + + %<>) + (<==? > STRING> + > + > + .T) + (ELSE + %<>) + (<==? > STRING> %<>) + (ELSE > >)>>)>> + "How to print FORM and its special cases." +"Special cases for FORM are PUT on the appropriate function." + + SPECFORM ',NORMFORM>>>> + +>)) + + > + ) + ( + <- + + .M 3>> + >) + (T >)>) + (T )> + ">> + + +)) + )> + >) + ( <.COMELE >)> >> + + + .M>)) + > FORM> + >> + >>> + T) + (ELSE + 2> ) + (> FORM>> ) + (> + <- 99999999>>> + 3>> + >) + (ELSE )>>)>> + + +>> + +>> + +>> + +> + ;"No fucking comments printed on . , or ' " + >) + (<.COMELE >)>) + (ELSE )>> + + + <- 2>> + ">>> + + + > + >>) + (ELSE + > + + .POS>)> + ">>> + + 3>)) + + > + + + <.COMELE > + ">>> + ATOM>> ) + ( + FUNCTION> + >) + (<==? RSUBR> + >>>>) + (ELSE >>)>) + ( > + FUNCTION> + ) + (<==? RSUBR> + >) + (ELSE )>>>) + (ELSE #FALSE ("NAKED ATOM?"))>>> + + + + + + ,NULL ;"Null atom returned" >> + +) + OUTCH NULLO) + > + > 13 100> + > 13 100> + )) + Q) + .INCH>> + >> + 58> .BOTH>> + > + + + + "DONE"> + + + + + + + +> )> +> )> +> )> +> )> +  ð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒð`Áƒ \ No newline at end of file diff --git a/MUDDLE/ptest.13 b/MUDDLE/ptest.13 new file mode 100644 index 0000000..f566d4a --- /dev/null +++ b/MUDDLE/ptest.13 @@ -0,0 +1,49 @@ + ) + (T >>)>>> + + + + () + > >)) + + >>> + + + + (.FINISH)) + ( + ) + (T (.START + !)) + () + ) + (> + > + )> > + .FINISH + (.START !.AVOID)>))>> > + + + + + + + + + + +  + + + + + + +  \ No newline at end of file diff --git a/MUDDLE/ptrace.7 b/MUDDLE/ptrace.7 new file mode 100644 index 0000000..3ffdc60 --- /dev/null +++ b/MUDDLE/ptrace.7 @@ -0,0 +1,114 @@ + >> + + +> + >>>> + + >) > + .PROCN) + .PROCNS> >> + EX ')>) > + > + > '(SUBR FSUBR FUNCTION ACTOR-FUNCTION)> + <.TR1 >> + > + "AUX" ! '(FUNCTION ACTOR-FUNCTION)> + ((*ARGS )))> + *VAL + (*OFUNC ACTOR-FUNCTION> + ) + (.PROC) >)) + !> + ( + !>))> + !> + ( + '(*MES *ACT) + + !> + ' >)) > + '> + !> + ( + '(*MES *ACT) + + !> + ' >)) > + !> + ( + !>)) > + ) + ACTOR-FUNCTION> ACTOR-FUNCTION) + (FUNCTION) >>> + .PROCN >> ) DECLS R) + + '("REST" *ARGS)) + (<==? .TP FSUBR> + '("REST" '*ARGS)) + (T > >> + > + > + >> + ) + (.DECLS) >) > >> + + +)) + ()) + (( .DECL) + (<==? .TP FORM> + ) + (<==? .TP LIST> + 2> + > + > + .DECL) + (<==? .TP FORM> + ) + (T )>) >>)) >) + .ARGL> >> + + + 2> + <==? <1 .DECL> QUOTE> + >> + <2 .DECL>) + () > >> + + + + <.TR1 (.PROCN *NOT TRACED*)> >> >> ()) + ((<1 .L> !>)) >>> + + + + ?FRONT) .EXP>>) >>> + + + ?END)> >>  \ No newline at end of file diff --git a/MUDDLE/sptest.6 b/MUDDLE/sptest.6 new file mode 100644 index 0000000..e5dd328 --- /dev/null +++ b/MUDDLE/sptest.6 @@ -0,0 +1 @@ +>  \ No newline at end of file diff --git a/MUDDLE/stctst.2 b/MUDDLE/stctst.2 new file mode 100644 index 0000000..5b39cb9 --- /dev/null +++ b/MUDDLE/stctst.2 @@ -0,0 +1,43 @@ + + ("STACK") + > >)) + + >>> + + + + (.FINISH)) + ( + ) + (T (.START + !)) + ("STACK") + ) + (> + > + )> > + .FINISH + (.START !.AVOID)>))>> > + + + + + + + + + + +  + + + + + + +  \ No newline at end of file diff --git a/MUDDLE/tentab.1 b/MUDDLE/tentab.1 new file mode 100644 index 0000000..da346e9 --- /dev/null +++ b/MUDDLE/tentab.1 @@ -0,0 +1,193 @@ + ; TABLE OF POWERS OF TEN + TITLE TENTAB + 1PASS + .LIBRA TENTAB,ITENTB + .GLOBA TENTAB,ITENTB + +TENTAB: REPEAT 39. 10.0^<.RPCNT-1> + +MUM=1 +ITENTB: REPEAT 11. 10.^<.RPCNT-1> + +END +  MENTED 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 + ;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) + ;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 + ;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 + TITLE 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 + + ;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 + TITLE GETITM +; THIS PROGRAM READS ITEMS FROM THE INPUT STREAM +; RETURNING THEM ONE AT A TIME TO THE USER WITH +; A TYPE CODE + + + + .GLOBA READCH,TENTAB,ITENTB,FLUSHI,GETERR + + +;THIS DEFINED FOR ACTUAL TTY ROUTINE + + + +; CODES FOR CHARACTER TYPES + +OCDIG=1 +DECDIG=2 diff --git a/MUDDLE/tester.putget b/MUDDLE/tester.putget new file mode 100644 index 0000000..de720cf --- /dev/null +++ b/MUDDLE/tester.putget @@ -0,0 +1,93 @@ +;"TESTER FOR PUT-GET ASSOCIATIONS" +;"MAKES RANDOM ASSOCIATIONS THEN CHECKS LATER TO SEE IF MISSING" + +) (OUTCHAN .OUTCHAN) + "EXTRA" (X ()) (Y ()) (Z ())) + .COUNT>>> + > + + ;"CALL GARBAGE COLLECTOR" + + )>> + FINAL>>> + + !.X)> + !.Y)> + !.Z)> + <1 .Y> <1 .Z>> ;"DO THE ASSOCIATION" + + > )>>>> + + 19>)) + 10> >) + (<1? .N> 10> >) + ( 10> >) + ( 10> !"A>) + ( <<+ 1 >> .X>) + ( <<+ 1 >> .Y>) + ( <<+ 1 >> .Z>) + ( 10> + 127>>>>) + ( FLOAT>) + ( 127>>)>>> + + + <1 .Y>> + <1 .Z>>> + + + + + + + )> + + + + > )>>>> + + + + + + + + <+ .K 10>> + + + <+ .K 10>> + + + <+ .K 10>>>> + + + +> + ) + (ELSE + + > + + + + <+ .K 10>>)> + > + + + )> + > + + + )> + > + + + )>>> +  \ No newline at end of file diff --git a/MUDDLE/testsp.4 b/MUDDLE/testsp.4 new file mode 100644 index 0000000..df6a2a0 --- /dev/null +++ b/MUDDLE/testsp.4 @@ -0,0 +1,18 @@ +> + + +> + +> + + > + + + .E1> + > + > + >  \ No newline at end of file diff --git a/MUDDLE/ts.midas b/MUDDLE/ts.midas new file mode 100644 index 0000000..e25d8ac Binary files /dev/null and b/MUDDLE/ts.midas differ diff --git a/MUDDLE/ts.muddle b/MUDDLE/ts.muddle new file mode 100644 index 0000000..95b2b6f Binary files /dev/null and b/MUDDLE/ts.muddle differ diff --git a/MUDDLE/ts.nplnnr b/MUDDLE/ts.nplnnr new file mode 100644 index 0000000..6334183 Binary files /dev/null and b/MUDDLE/ts.nplnnr differ diff --git a/MUDDLE/ts.omuddl b/MUDDLE/ts.omuddl new file mode 100644 index 0000000..d896dbe Binary files /dev/null and b/MUDDLE/ts.omuddl differ diff --git a/MUDDLE/ts.plannr b/MUDDLE/ts.plannr new file mode 100644 index 0000000..a825c96 Binary files /dev/null and b/MUDDLE/ts.plannr differ diff --git a/MUDDLE/ts.stink b/MUDDLE/ts.stink new file mode 100644 index 0000000..968ef3a Binary files /dev/null and b/MUDDLE/ts.stink differ diff --git a/MUDDLE/util.21 b/MUDDLE/util.21 new file mode 100644 index 0000000..859d2c3 --- /dev/null +++ b/MUDDLE/util.21 @@ -0,0 +1,230 @@ + + >> + + + ) + (T >>)>>> + + + + + >> + + + (M A) + > >> + + + +)) + > + (M A) + > + > >> + + + .L) + (<==? .ELT <1 .L>> + >) + (T ) >>> + + +> .L) + (<==? <2 .L> .ELT> >) + (T >) > >> + + +)) + + (M A) + + >>> + + +)) + + ) + (T ) > + (M A) + ) + () > + >>> + + +)) + > + (M A) + > + >>> FALSE> >> + + + FORM> >> + + UNASSIGNED> >> + + SEGMENT> >> + + >> + + + + + + + + + + + + ) + ()> >> + + () + ) + ( + >>>>) >> >> + + +>>>> + + + + > >> + + +> )) <> () + > + > >> + + >> + + + >> > + '(LIST FORM VECTOR SEGMENT VECTOR)>> >> + +>) + "AUX" (RESULT ())) + <.CFUNC !.RESULT>) + (T !.RESULT)> + > + ) > >> + + + ()) + (T >>) >>> + + +> <1 .LSTUPL>) + (T >) >>> + + + ) + (T .LREST>>) >>> > + >>> >> + + + >> + + >) + (T >) > + >> + + +>> >> + + +>> + + ) + (T ) > + > + >> + + + ()) + (>> <.MAPPER .RESULT>) + (( + >> + !>)) > >> + + + ()) + (> .EXP) + (T > + ) >>> .THING) + (<==? LIST> ()) + (T >)> >> + + + + + >>  \ No newline at end of file diff --git a/MUDDLE/vers.2 b/MUDDLE/vers.2 new file mode 100644 index 0000000..dd1c8d1 --- /dev/null +++ b/MUDDLE/vers.2 @@ -0,0 +1,17 @@ + +"> + + +) SUB) + )> + > +L2 )> + > + + > + + > +L1 >>> + +  \ No newline at end of file diff --git a/MUDDLE/}msgs}.muddle b/MUDDLE/}msgs}.muddle new file mode 100644 index 0000000..e69de29 diff --git a/README.md b/README.md index ed8917b..e09a978 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,6 @@ -MIDAS Muddle for TOPS-20. +## PDP-10 Muddle written in MIDAS assembly language +`` 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.