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)-g+k6@y/!"Q Ff y.y`|`6@y/`G,z:"l"@Q hP+ y/%Q y/&({<')1<X1+ Q2D@Q&D@ Fgg@E Dh4Hp<2+aB+(BTw=H+1& ?`i,z h`Dmd+ !$X!"BB9Y2PK,z:# naTw9!&z]eN`+1N+Y!&GFR) '-.nO@oN@) [ n!$BDR)7 oaf@`; .[:e,P{+(K+ `1"x(-b=A1Tw TwXF8@:ea1S +% d' ?!K` 1~lbS3^v`a y.y`|`a7@y/`_!< %{`C< \ y/ \ y0' W<=,< y.y \p!y/O+p!< Wc`7>t`GM!<2>-g+9l`g Tt7  <Y`.>l2>-g,z7@y/+<'55\<!GDy/+ kISbDU8x,!` kIBy/,:,<,Z,z@C4~'6 <l&^$<lw7@y/+' y/`| bQ<` <#+3 y/ Wm`i y.ya|`a@@y/!<PWy/ \y.y@&F`,z p+[ >2>-g`7@y/+o.>l`7 ',z >l.-g,: 0(?<+u,ZB^pFsCSwQLW@Y> @ %{ ] y0/ $,T %{!< &X%{b \y0C \y/ ,Zy.y $':u6@.X0(b ip ` *\ 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` ,: 7\y/b , + V,:8Z\y/, ,Z8,z <';`b5> ab+ O5> O+p + + + #+ ` ;` C` +` 37O@p,zwO@p,zw!"BBp+ Ow(.Bp+ Ow>p,ze~f/x 'wY\p!`P\pe,zw:p,z7 p5> %+pZ\y.y7<l~+ ',z,:8Z\y/, ,ZXh86\y/` Q/'8e~+?@@y/#`c,:,: %{7^y/+ 3Dw3^+ 7Gw' i,Z @7+ W %{,:7\y/b w, =` ,:D8ZPy/8,Z,z , ,z , =,z %{l>,: <3\|O"~`-UoK ;X]O@P[/;O(x^ O0';^j O)JO3J ^9O6,oX+O0O@[] O@GO:mO X~TF# L^k O@U}O(W-O-ToLTr]L]O*|DO4^D!O:gO/#O\Xm%O(8Oh'T8Lh)O`(O`<+'U@}U@ }V@1Y\C'@.,P5@Pl术@@<| *l|@u '@A@ (qA@(Q&4@l杗_@ {+(oH@ { P @ IsE@ ` {Ы@HGR.'@yOW@S[<d@9d@:I#I@8g%(5@=vT'n@@ )7q[@`=+ڊ@=-73+@'>c/@bg1'@cE3f@S1 5 P@'*?7<\@'$9)x@{x;R?t@[=S@E ?yMJ@ ``gA(5@!NgCM5D@"zMECRh@#7x` bfghZlhjRk,lGn(o*pS?r(qt@M[vPxx&%zJ|X$8 ^ @5 `R% G@Wx`71 (gxgDfDYHaE%]0 L*8A/4 ԏ;; 2,>fD^\ba\U Er X gE\uJ 8EA;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@ + /pb d'@7>%{+W <d'A` 7@y0I6@y0Jb 7@y0K6@y0L+p+k7@y/#+h@@&I+h<'D` !<T`  a|+x!<P` pb d'@7>%{+| <d'Ah0"`ȼ[ZE! H0ah@` !(  ` -2'J+PEN N0N@N@I@I4`)+Nl.b'K.'8:h6&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 "GH )l$ (Hvl$ G `      =21(@9gac)v|2)z5.!t$-@[Q|>&(+?"[?"[>e>ƀ_=OW@qUQv01v@6(@/@]YW>?&]?&])|%.)|%.)|=/)|=/=yQv3kMA9(@<AQ|wOiQ}P){EM){EM>>){=M>(AN5H$O,z`IJh'Q`l( 1l( H .y`  /d(|,z3B%{B /d(|l( H /3B%{@ /` XH /,zB;;`U&"l`By/O(H-`U),;`%`  / *2D)/`}r%,z.*l3*-g`y` P`)` ('R`Uh'R,zw`!$@(H{  PG,H>+ s/'8Gw,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,zB1`U b'U逧11`+}&'V1Fl``bp`) Ty0Fh4\at~+`,, v,z!"Q+ , vb$'V1DW`1`a?0Fp`)`+o$'Wd"pl"``Dy/ y0Fn'X+ "$.Dy/ @@y/` f,z` ,: 3\'7,PM,Z,zZ&']1V5F=!&