2 TITLE ATOMHACKER FOR MUDDLE
7 .GLOBAL RLOOKU,CHMAK,WRONGT,ERRTMA,OBLNT,ROOT,INTOBL,ERROBL
8 .GLOBAL .BLOCK,CALER1,IDVAL,NXTDCL,CHRWRD
11 ; FUNCTION TO GENERATE AN EMPTY OBLIST
13 MFUNCTION MOBLIST,SUBR
16 CAMGE AB,[-3,,0] ;CHECK NUMBER OF ARGS
18 MOVE A,OBLNT ;GET DEFAULT LENGTH
19 CAML AB,[-1,,0] ;IS LENGTH SUPPLIED
20 JRST MOBL1 ;NO, USE STANDARD LENGTH
21 HLRZ C,(AB) ;GET ARG TYPE
24 MOVE A,1(AB) ;GET LENGTH
27 MCALL 1,UVECTOR ;GET A UNIFORM VECTOR
28 MOVSI C,TLIST ;IT IS OF TYPE LIST
29 HLRE D,B ;-LENGTH TO D
30 SUBM B,D ;D POINTS TO DOPE WORD
31 MOVEM C,(D) ;CLOBBER TYPE IN
36 MFUNCTION GROOT,SUBR,ROOT
39 HRRZ B,(B) ;CDR THE LIST
41 MOVE B,1(B) ;RETURN ROOT OBLIST
44 MFUNCTION GINTS,SUBR,INTERRUPTS
50 MFUNCTION GERRS,SUBR,ERRORS
57 ; FUNCTION TO FIND AN ATOM ON A GIVEN OBLIST WITH A GIVEN PNAME
63 PUSHJ P,ILOOKU ;CAL INTERNAL ROUTINE
66 ILOOKU: PUSHJ P,ARGCHK ;CHECK ARGS
67 PUSHJ P,CSTACK ;PUT CHARACTERS ON THE STACK
69 CALLIT: MOVE B,3(AB) ;GET OBLIST
70 PUSHJ P,ILOOK ;LOOK IT UP
71 POP P,D ;RESTORE COUNT
72 HRLI D,(D) ;TO BOTH SIDES
76 ;THIS ROUTINE CHECKS ARG TYPES
78 ARGCHK: HLRZ A,(AB) ;GET TYPES
80 CAIE A,TCHRS ;IS IT EITHER CHAR STRING
82 CAIE C,TOBLS ;IS 2ND AN OBLIST
83 JRST WRONGT ;TYPES ARE WRONG
86 ;THIS SUBROUTINE PUTS CHARACTERS ON THE STACK (P WILL BE CHANGED)
89 CSTACK: POP P,D ;RETURN ADDRESS TO D
90 CAIE A,TCHRS ;IMMEDIATE?
93 PUSH P,[1] ;WITH NUMBER
94 JRST (D) ;GO CALL SEARCHER
96 NOTIMM: SETZB A,E ;INITIALIZE WORD COUNT AND CHAR WORD
97 HRRZ C,(AB) ;POINT TO DOPE WORD
99 MOVE B,1(AB) ;GET BYTE POINTER
103 CLOOP1: PUSH P,[440700,,E] ;SETUP A BYTE POINTER FOR STORING
104 JUMPN 0,.+2 ;DON'T READ FOR 1ST
105 CLOOP: ILDB 0,B ;GET A CHARACTER
106 CAIN C,(B) ;AT END OF INPUT
107 JRST CDONE ;YES, QUIT
108 JUMPE 0,CDONE ;FINISHED?
110 TRNN E,377 ;WORD FULL
111 JRST CLOOP ;NO CONTINUE
112 MOVEM E,(P) ;STORE CHARS
113 SETZB E,0 ;RESET CHAR WORD
114 AOJA A,CLOOP1 ;AND CONTINUE
116 CDONE: SUB P,[1,,1] ;REMOVE BYTE POINTER
119 PUSH P,E ;PUSH LAST WORD
120 CDONE1: PUSH P,A ;AND NUMBER OF WORDS
123 ; THIS FUNCTION LOOKS FOR ATOMS. CALLED BY PUSHJ P,ILOOK
125 ; -1(P)/ LENGTH IN WORDS OF CHARACTER BLOCK
126 ; CHAR STRING IS ON THE STACK
128 ILOOK: MOVN A,-1(P) ;GET -LENGTH
129 HRLI A,-1(A) ;<-LENGTH-1>,,-LENGTH
132 ADDI A,-1(P) ;HAVE AOBJN POINTER TO CHARS
135 AOBJN A,.-1 ;XOR THEM ALL TOGETHER
136 HLRE A,B ;GET LENGTH OF OBLIST
138 MOVMS D ;MAKE SURE OF + HASH CODE
140 HRLI E,(E) ;TO BOTH HALVES
141 ADD B,E ;POINT TO BUCKET
143 MOVEI 0,(B) ;IN CASE REMOVING 1ST
144 SKIPN C,(B) ;BUCKET EMPTY?
145 JRST NOTFND ;YES, GIVE UP
146 LOOK2: SKIPN A,1(C) ;NIL CAR ON LIST?
147 JRST NEXT ;YES TRY NEXT
148 ADD A,[2,,2] ;POINT TO ATOMS PNAME
149 MOVE D,(TP) ;GET PSEUDO AOBJN POINTER TO CHARS
150 ADDI D,-1(P) ;NOW ITS A REAL AOBJN POINTER
151 LOOK1: MOVE E,(D) ;GET A WORD
153 JRST NEXT ;THIS ONE DOESN'T MATCH
154 AOBJP D,CHECK ;ONE RAN OUT
155 AOBJN A,LOOK1 ;JUMP IF STILL MIGHT WIN
157 NEXT: MOVEI 0,(C) ;POINT TO PREVIOUS ELEMENT
158 HRRZ C,(C) ;STEP THROUGH
161 NOTFND: EXCH C,B ;RETURN BUCKET IN B
163 CPOPJT: SUB TP,[2,,2] ;REMOVE RANDOM TP STUFF
166 CHECK: AOBJN A,NEXT ;JUMP IF NO MATCH
167 MOVE B,1(C) ;GET ATOM
173 ; FUNCTION TO INSERT AN ATOM ON AN OBLIST
175 MFUNCTION INSERT,SUBR
178 PUSH TP,$TFIX ;FLAG CALL
181 PUSHJ P,ARGCHK ;CHECK ARGS
182 PUSHJ P,CSTACK ;COPY ONTO STACK
183 MOVE B,3(AB) ;GET OBLIST
184 PUSHJ P,ILOOK ;LOOK IT UP (BUCKET RETURNS IN C)
185 JUMPN B,RETFLS ;EXISTS, RETURN FALSE
186 INSRT1: PUSH TP,$TOBLS ;SAVE BUCKET POINTER
188 PUSHJ P,IATOM ;MAKE AN ATOM
191 PUSH TP,$TLIST ;AND LIST NOW IN BUCKET
192 MOVE C,-3(TP) ;GET BUCKET BACK
193 PUSH TP,(C) ;PUSH ITS LIST
195 MOVE C,(TP) ;BUCKET AGAIN
196 HRRM B,(C) ;INTO NEW BUCKET
198 MOVE B,1(B) ;GET ATOM BACK
199 MOVE C,-2(TP) ;GET FLAG
200 SUB TP,[4,,4] ;POP STACK
202 JRST (C) ;RETURN INTERNAL
204 RETFLS: PUSH P,CFINIS ;FOR POPJ TO WORK
208 ; FUNCTION TO REMOVE AN ATOM FROM AN OBLIST
210 MFUNCTION REMOVE,SUBR
214 PUSHJ P,ILOOKU ;LOOK IT UP
215 CFINIS: JUMPE B,FINIS ;NOT THERE
216 HRRZ D,0 ;PREPARE TO SPLICE (0 POINTS PRIOR TO LOSING PAIR)
217 HRRZ C,(C) ;GET NEXT OF LOSING PAIR
218 HRRM C,(D) ;AND SPLICE
221 ;INTERNAL CALL FROM THE READER
223 RLOOKU: PUSH TP,$TFIX ;PUSH A FLAG
224 POP P,C ;POP OFF RET ADR
225 PUSH TP,C ;AND USE AS A FLAG FOR INTERNAL
227 CAMN A,$TOBLS ;IS IT ONE OBLIST?
229 CAME A,$TLIST ;IS IT A LIST
234 PUSH TP,B ;TWO COPIES OF ARG
239 HLRZ A,(B) ;CHECK THIS IS AN OBLIST
242 MOVE B,1(B) ;LOOK FOR IT
243 PUSHJ P,ILOOK ;LOOK IT UP
245 HRRZ B,@(TP) ;CDR THE LIST
248 MOVE B,-2(TP) ;FAILED USE FIRST
250 SUB TP,[4,,4] ;POP TP
252 RLOOK1: PUSHJ P,ILOOK ;LOOK IT UP THERE
253 JUMPE B,INSRT1 ;GO INSET IT
257 RLOOK3: SUB TP,[4,,4] ;POP OFF LOSSAGE
258 PUSH P,(TP) ;GET BACK RET ADR
259 SUB TP,[2,,2] ;POP TP
260 JRST IATM1 ;AND RETURN
262 ;SUBROUTINE TO MAKE AN ATOM
268 HLRZ A,(AB) ;CHECK ARG TYPE
271 JRST .+2 ;JUMP IF WINNERS
274 PUSHJ P,CSTACK ;COPY ONTO STACK
275 PUSHJ P,IATOM ;NOW MAKE THE ATOM
276 JRST FINIS ;AND LEAVE
280 IATOM: MOVE A,-1(P) ;GET WORDS IN PNAME
281 ADDI A,2 ;FOR VALUE CELL
283 PUSH TP,A ;LENGTH IS ARG
284 MCALL 1,UVECTOR ;GET STORAGE
285 MOVSI C,<(GENERAL)>+SATOM ;FOR TYPE FIELD
286 MOVE D,-1(P) ;RE-GOBBLE LENGTH
287 ADDI D,2(B) ;POINT TO DOPE WORD
289 MOVE E,B ;COPY ATOM POINTER
290 ADD E,[2,,2] ;POINT TO PNAME AREA
292 SUB C,-1(P) ;POINT TO STRING ON STACK
293 MOVE D,(C) ;GET SOME CHARS
294 MOVEM D,(E) ;AND COPY THEM
297 MOVSI A,TATOM ;TYPE TO ATOM
298 IATM1: POP P,D ;RETURN ADR
299 POP P,C ;WORDA OF CHARS
305 ; BLOCK STRUCTURE SUBROUTINES FOR MUDDLE
307 MFUNCTION BLK,SUBR,BLOCK
311 HLRZ A,(AB) ;CHECK TYPE OF ARG
312 CAIE A,TOBLS ;IS IT AN OBLIST
313 CAIN A,TLIST ;OR A LIAT
316 MOVSI A,TATOM ;LOOK UP OBLIST
318 PUSHJ P,IDVAL ;GET VALUE
321 PUSH TP,.BLOCK(PVP) ;HACK THE LIST
322 PUSH TP,.BLOCK+1(PVP)
323 MCALL 2,CONS ;CONS THE LIST
324 MOVEM A,.BLOCK(PVP) ;STORE IT BACK
325 MOVEM B,.BLOCK+1(PVP)
327 PUSH TP,MQUOTE OBLIST
330 MCALL 2,SET ;SET OBLIST TO ARG
333 MFUNCTION ENDBLOCK,SUBR
337 SKIPN B,.BLOCK+1(PVP) ;IS THE LIST NIL?
338 JRST BLKERR ;YES,
\0 LOSE
339 HRRZ C,(B) ;CDR THE LIST
340 HRRZM C,.BLOCK+1(PVP)
341 PUSH TP,$TATOM ;NOW RESET OBLIST
342 PUSH TP,MQUOTE OBLIST
343 HLLZ A,(B) ;PUSH THE TYPE OF THE CAR
345 PUSH TP,1(B) ;AND VALUE OF CAR
349 BLKERR: PUSH TP,$TATOM
350 PUSH TP,MQUOTE UNMATCHED
353 BADLST: PUSH TP,$TATOM
354 PUSH TP,MQUOTE NIL-LIST-OF-OBLISTS
357 ;SUBROUTINE TO CREATE CHARACTER STRING GOODIE
359 CHMAK: PUSH TP,$TFIX ;SET UP CALL TO UVECTOR
362 MOVEI C,-1(P) ;FIND START OF CHARS
363 SUB C,-1(P) ;C POINTS TO START
364 MOVE D,B ;COPY VECTOR RESULT
365 JUMPGE D,NULLST ;JUMP IF EMPTY
368 ADDI C,1 ;BUMP POINTER
370 NULLST: MOVSI C,TCHRS ;GET TYPE
371 MOVEM C,(D) ;CLOBBER IT IN
372 MOVSI A,TCHSTR ;SETUP TYPE
373 HRRI A,1(D) ;POINT TO DOPE
374 HRLI B,350700 ;MAKE A BYTE POINTER
377 ; SUBROUTINE TO READ FIVE CHARS FROM STRING. TWO CALLS, ONE WITH A POINTING TO LIST ELEMENT, THE OTHER WITH B POINTING TO PAIR. SKIPS IF WINNER, ELSE DOESNT
379 NXTDCL: GETYP B,(A) ;CHECK TYPE
380 CAIE B,TDEFER ;LOSE IF NOT DEFERRED
383 MOVE B,1(A) ;GET REAL BYTE POINTER
385 GETYP C,(B) ;CHECK IT IS CHSTR
387 JRST CPOPJC ;NO, QUIT
391 MOVEI E,0 ;INITIALIZE DESTINATION
392 HRRZ C,(B) ;POINT TO DOPE WORD
393 MOVE B,1(B) ;GET BYTE POINTER
394 CAIN C,1(B) ;CHECK FULLNESS
395 JRST GOTDCL ;RETURN NIL WORD
396 MOVE D,[440700,,E] ;BYTE POINT TO E
398 CHLOOP: JUMPE 0,GOTDCL ;FINISHED, WIN
399 TRNE E,377 ;WORD FULL?
400 JRST CHREXT ;YES, LOSE
401 IDPB 0,D ;CLOBBER AWAY
402 ILDB 0,B ;AND GET NEXT
403 CAILE C,1(B) ;FULL NOW?
404 JRST CHLOOP ;NO, CONTINUE
406 GOTDCL: MOVE B,E ;RESULT TO B
407 AOS -4(P) ;SKIP RETURN
414 CHREXT: TRO E,1 ;MAKE IT LOOK FUNNY