2190 lines
No EOL
45 KiB
Text
2190 lines
No EOL
45 KiB
Text
.STITL SYSTEM PRIMITIVES
|
||
|
||
VERN==VERN+%FNAM2
|
||
|
||
|
||
SENTENCE:
|
||
MOV (SP),D ;NUMBER OF ARGS (DON'T CHANGE THE REGISTER FROM D WITHOUT CHANGING SNAP, TOO)
|
||
|
||
MOV #SENT,(SP) ;WHAT TYPE THIS LIST IS
|
||
SNPSEN: CLR C
|
||
TST D
|
||
SENT.1: BLE SENT.R ;RETURN
|
||
MOV @S,B ;ARGUMENT. LEAVE ON S-PDL FOR GARBGE COLLECTOR
|
||
MOV B,A
|
||
BIC #7777,A ;LEAVE ONLY DATA TYPE
|
||
CMP #SENT,A
|
||
BEQ SENT.S ;ARG IS SENTENCE
|
||
CMP #ATOM,A
|
||
BNE SENT.2
|
||
|
||
;ARG IS AN ATOM
|
||
SENT.A: JSR PC,.LOAD ;CONVERT ATOM TO LSTR
|
||
MOV #LSTR,A
|
||
|
||
SENT.2: BIS C,A ;C POINTS TO PREVIOUS STUFF OF SENTENCE
|
||
JSR PC,GRBAD
|
||
|
||
SENT.3: MOV C,GCPREV ;POINTER TO PREVIOUS STUFF OF SENTENCE
|
||
SENT.4: JSR PC,SPOPT ;POP S
|
||
DEC D ;COUNTER
|
||
BR SENT.1
|
||
|
||
SENT.S: BIT #7777,B ;ARGUMENT IS A SENTENCE
|
||
BEQ SENT.4 ;EMPTY
|
||
TST C ;0 IF FIRST TIME CALLED
|
||
BEQ SENS.1
|
||
;SECOND OR LATER TIME THROUGH
|
||
SENS.2: JSR PC,COPYL ;COPY LIST. RETURN POINTER IN B
|
||
BIS GCPREV,A ;POINTER TO PREVIOUS STUFF
|
||
JSR PC,.STP1 ;C STILL POINTS TO LAST NODE COPIED
|
||
SENS.1: BIC #170000,B ;LEAVE POINTER ONLY
|
||
MOV B,C
|
||
BR SENT.3
|
||
|
||
;RETURN. POINTER TO SENTENCE IN C
|
||
SENT.R: BIS (SP)+,C ;THE TYPE
|
||
S.ORT: CLR GCPREV
|
||
JMP ORTC
|
||
|
||
|
||
LIST.P:
|
||
MOV (SP),D ;COUNT
|
||
MOV #ORTC,(SP) ;RETURN ADDRESS
|
||
LIST1: CLR C
|
||
LIST.1: DEC D ;COUNT
|
||
BLT LIST.9 ;DONE
|
||
MOV @S,B
|
||
MOV B,A
|
||
BIC #7777,A ;LEAVE DATA TYPE ONLY
|
||
LIST.2: BIS C,A ;POINTER TO REST OF LIST
|
||
JSR PC,GRBAD
|
||
MOV C,GCPREV ;PROTECT FROM GARBAGE COLLECTOR
|
||
JSR PC,SPOPT
|
||
BR LIST.1 ;GET NEXT ARG
|
||
|
||
LIST.9: CLR GCPREV
|
||
BIS #LIST,C
|
||
RTS PC
|
||
|
||
|
||
FPUT:
|
||
CLR F
|
||
BR .+6
|
||
LPUT:
|
||
MOV #<LPUT1-FPUT1>,F
|
||
MOV (SP),D ;NUMBER OF ARGS
|
||
MOV #ORTC,(SP) ;RETURN ADDRESS
|
||
DEC D
|
||
BGT .+4
|
||
ERROR+UEL ;NEED AT LEAST 2 ARGS
|
||
JSR PC,GLWARG
|
||
BR .+4 ;LIST
|
||
ERROR+WTA ;FIRST ARG MUST BE LIST
|
||
ADD F,PC ;CHOOSE BETWEEN LPUT AND FPUT
|
||
|
||
FPUT1: MOV B,A ;POINTS TO ARG
|
||
BIC #170000,A ;CLEAR DATA TYPE
|
||
JSR PC,SPOPT
|
||
MOV @S,B ;FIRST ELEMENT TO BE PUT
|
||
MOV B,C
|
||
BIC #7777,C ;THIS DATA TYPE WILL BE SET INTO A
|
||
DEC D
|
||
BR LIST.2
|
||
|
||
LPUT1: JSR PC,COPYL ;COPY LIST. RETURN PTR IN B
|
||
MOV B,GCP1
|
||
JSR PC,SPOPT ;POP 1ST ARG
|
||
JSR PC,LIST1 ;LIST REST OF ARGS
|
||
BIC #170000,C ;POINTER TO THAT LIST
|
||
MOV C,D ;SAVE IT
|
||
MOV F,C ;POINTER TO LAST NODE OF COPIED LIST
|
||
JSR PC,.LDP1
|
||
BIS D,A ;JOIN COPIED LIST TO LIST OF ARGS
|
||
JSR PC,.STP1
|
||
MOV GCP1,C
|
||
CLR GCP1
|
||
RTS PC
|
||
|
||
|
||
WORD:
|
||
CLR C
|
||
MOV (SP)+,D ;NUMBER OF ARGS
|
||
WORD.1: BLE WORDR
|
||
MOV @S,B ;GET ARG, BUT LEAVE ON STACK
|
||
CMP B,#LNUM ;IS ARG NUMBER?
|
||
BLO WORD.2
|
||
CMP B,#<LNUM+10000>
|
||
BLO WORD.N ;NUMBER
|
||
WORD.2: MOV #LSTR,A
|
||
JSR PC,CONVERT
|
||
ERROR+WTAB
|
||
BIT #7777,B ;IS ARG THE EMPTY WORD
|
||
BEQ WORD.4 ;YES
|
||
|
||
TST GCPREV ;IS 0 FIRST TIME THROUGH
|
||
BEQ WORD.3
|
||
|
||
;SECOND OR LATER ARG
|
||
WORD.5: JSR PC,CPYSTR ;COPY STRING
|
||
WORD.6: JSR PC,.LDP1 ;LAST NODE OF COPIED STRING
|
||
BIS GCPREV,A ;BIS POINTER TO PREVIOUS STUFF
|
||
JSR PC,.STP1 ;STORE BACK
|
||
|
||
WORD.3: MOV B,GCPREV ;POINTER TO PREVIOUS STUFF
|
||
WORD.4: JSR PC,SPOPT ;POP S
|
||
DEC D
|
||
BR WORD.1
|
||
|
||
;ARGUMENT IS NUMBER. CONVERT TO STRING
|
||
WORD.N: JSR PC,.CLNLS
|
||
ERROR+WTAB ;PROBABLY MORE THAN 16 BITS
|
||
TST GCPREV ;IS 0 FIRST TIME THROUGH
|
||
BEQ WORD.3 ;IS FIRST ARG
|
||
BR WORD.6 ;SECOND OR LATER, BUT DON'T RECOPY!!
|
||
|
||
;RETURN
|
||
WORDR: MOV GCPREV,C
|
||
BIS #LSTR,C
|
||
BR S.ORT
|
||
|
||
|
||
FIRST:
|
||
JSR PC,GLWANE
|
||
BR F.SENT ;ARG IS SENTENCE
|
||
|
||
;ARG IS WORD
|
||
JSR PC,INSTR ;RETURN ONE CHAR IN D
|
||
BNE .+4 ;FOUND A CHAR
|
||
F.WTA: ERROR+WTA ;NO CHARS IN STRING
|
||
TST (SP)+ ;POP OFF CO-ROUTINE LINK
|
||
MOV D,B
|
||
F.STOR: CLR F
|
||
JSR PC,ACTSTO ;STORE THE CHAR.
|
||
BIS #LSTR,C ;POINTER TO THE NODE OF THE CHAR
|
||
JMP ORTNC
|
||
|
||
F.SENT: MOV B,C
|
||
JSR PC,.LDP2
|
||
JMP ORTNA
|
||
|
||
|
||
BUTFIRST:
|
||
JSR PC,GLWANE
|
||
BR BF.SEN
|
||
|
||
;ARG IS WORD
|
||
BF.W: JSR PC,INSTR ;RETURN ONE CHAR
|
||
BEQ F.WTA ;NO CHARS IN STRING
|
||
TST (SP)+
|
||
;A CONTAINS FIRST 2 CHARS OF THE STRING
|
||
;BUT IT MAY ONLY HAVE ONE.
|
||
CMP A,#177 ;IS TOP CHAR OF A 0?
|
||
BLOS BF.W1 ;YES. ONLY ONE CHAR IN A
|
||
CLRB A ;KILL THE FIRST CHAR
|
||
MOV A,B
|
||
MOV C,A ;POINTER TO REST
|
||
JSR PC,GRBAD
|
||
BF.W1: BIC #170000,C
|
||
BIS #LSTR,C
|
||
JMP ORTNC
|
||
|
||
;ARG IS SENTENCE
|
||
BF.SEN: MOV B,C
|
||
JSR PC,.LDP1 ;POINTER TO REST OF SENTENCE
|
||
BIC #170000,A ;LEAVE ONLY POINTER
|
||
BIS #SENT,A
|
||
JMP ORTNA
|
||
|
||
|
||
LAST:
|
||
JSR PC,GLWANE
|
||
BR L.SENT ;ARG IS SENTENCE
|
||
|
||
;ARG IS WORD
|
||
MOV B,C
|
||
SPUSH #INSTR1 ;ADDRESS OF CO-ROUTINE
|
||
CLR D
|
||
L.W1: MOV D,B ;SAVE LAST CHAR
|
||
JSR PC,@(SP)+ ;RETURNS CHAR IN D
|
||
BNE L.W1 ;FOUND ONE
|
||
TST B ;STRING DONE
|
||
BNE F.STOR ;STORE THE CHAR AND RETURN
|
||
ERROR+WTA ;NO CHARS FOUND
|
||
|
||
L.SEN1: MOV A,B
|
||
;ARG IS SENTENCE
|
||
L.SENT: JSR PC,.LOAD
|
||
BIT #7777,A ;LAST NODE OF SENTENCE YET?
|
||
BNE L.SEN1
|
||
|
||
L.SRET: JMP ORTNB
|
||
|
||
|
||
BUTLAST:
|
||
JSR PC,GLWANE
|
||
BR BL.SEN ;ARG IS A SENTENCE
|
||
|
||
;ARG IS A WORD
|
||
JSR PC,CPYSTR ;COPY STRING.
|
||
JSR PC,.LDP2 ;LAST NODE OF NEW STRING
|
||
SWAB A
|
||
BNE BL.W2 ;THE LAST CHARACTER IS REALLY THERE
|
||
CLR A ;(WE KNOW THE FIST CHAR IS REALLY THERE)
|
||
CMP B,C ;IS THERE ONLY ONE NODE
|
||
BNE BL.W1 ;MORE TAN ONE NODE
|
||
CLR B ;ANSWER IS EMPTY WORD
|
||
BR BL.W3
|
||
|
||
BL.W2: CLRB A ;CLEAR LAST CHAR
|
||
BL.W1: JSR PC,.STP2 ;STORE NODE BACK
|
||
BL.W3: BIS #LSTR,B ;POINTER TO THE WORD
|
||
BL.ORT: JMP ORTNB
|
||
|
||
;ARG IS A SENTENCE
|
||
BL.SEN: JSR PC,COPYL ;COPY LIST
|
||
MOV E,C ;POINTS TO NEXT TO LAST NODE
|
||
BEQ BL.SR ;ANSWER IS EMPTY
|
||
JSR PC,.LDP1
|
||
BIC #7777,A
|
||
JSR PC,.STP1
|
||
MOV B,C
|
||
BL.SR: BIS #LIST,C
|
||
JMP ORTNC
|
||
|
||
|
||
COUNT:
|
||
JSR PC,GLWARG
|
||
BR CT.SEN
|
||
|
||
;ARG IS WORD
|
||
MOV B,C
|
||
CLR B
|
||
MOV #INSTR1,-(SP) ;ADDRESS OF A CO-ROUTINE
|
||
CT.W1: INC B ;INCREMENT COUNTER
|
||
JSR PC,@(SP)+ ;RETURNS CHAR IN B
|
||
BNE CT.W1
|
||
DEC B ;WHEN RETURNS HERE, NO MORE CHARS
|
||
CT.ORT: JSR PC,P1NARG
|
||
JMP ORTNB
|
||
|
||
;ARG WAS A SENTENCE
|
||
CT.SEN: MOV B,C
|
||
JSR PC,CLE ;RETURNS NUMBER OF LIST ELEMENTS IN B
|
||
BR CT.ORT
|
||
|
||
|
||
;COPY LIST.
|
||
; CALL WITH B POINTING TO LIST
|
||
; RETURNS B POIOTING TO NEW LIST, C POINTING TO LAST NODE
|
||
COPYL: CLR E ;WILL POINT TO 2ND NODE FROM LAST
|
||
CLR F
|
||
COPYL1: BIT #7777,B
|
||
BEQ COPYLR ;DONE
|
||
JSR PC,.LOAD
|
||
MOV F,E ;LISTB PLACES LAST NODE PTR INTO F
|
||
JSR PC,LISTB
|
||
MOV A,B
|
||
BR COPYL1
|
||
|
||
COPYLR: POPS B ;LISTB KEEPS POINTER TO NEW LIST ON S.
|
||
RTS PC
|
||
|
||
|
||
;COPY STRING
|
||
;CALL WITH B POINTING TO STRING TO BE COPIED,
|
||
;ASSUMES THAT INPUT STRING HAS BEEN GARBAGE COLLECT PROTECTED ALREAEDY
|
||
;B POINTS TO FIRST NODE OF NEW STRING, C POINTS TO LAST
|
||
;DOESN'T SKIP IF EXITS BECAUSE IT RAN OUT OF INPUT STRING
|
||
|
||
CPYSTR: MOV #INSTR,A
|
||
MAKSTR: MOV D,-(SP)
|
||
MOV E,-(SP)
|
||
MOV F,-(SP)
|
||
|
||
MOV A,-(SP) ;ADDRESS OF INPUT STRING ROUTINE
|
||
CLR F
|
||
|
||
OUTSTR: JSR PC,@(SP)+ ;CALL INPUT STRING CO-ROUTINE
|
||
BEQ OSTRE1 ;INPUT STRING DONE
|
||
|
||
OSTR1: MOV D,B ;SAVE CHARACTER
|
||
JSR PC,@(SP)+ ;CALL INPUT STRING CO-ROUTINE
|
||
BEQ OSTRE2 ;INPUT STRING DONE
|
||
|
||
OSTR2: SPUSH A ;SAVE REGISTERS USED BY INPUT STRING
|
||
SPUSH C
|
||
SWAB D
|
||
BIS D,B ;BIS SECOND CHARACTER
|
||
JSR PC,ACTSTO ;ACTUAL STORE
|
||
SPOP C
|
||
SPOP A
|
||
BR OUTSTR
|
||
|
||
;INPUT STRING HAS ENDED
|
||
OSTRE2: JSR PC,ACTSTO ;STORE CHAR IN B
|
||
OSTRE1: POPS B ;POINTER TO FIRST NODE OF STRING
|
||
MOV F,C ;POINTER TO LAST NODE
|
||
BIC #170000,B
|
||
BIC #170000,C
|
||
.RDEF: CLR GCP1
|
||
MOV (SP)+,F
|
||
MOV (SP)+,E
|
||
MOV (SP)+,D
|
||
OSTRR: RTS PC
|
||
|
||
|
||
;ACTUALLY STORE OUTPUT NODE
|
||
ACTSTO: MOV #SSTR,A
|
||
JMP LISTB
|
||
|
||
|
||
;INPUT STRING
|
||
;A CO-ROUTINE THAT HANDS BACK A CHARACTER IN BOTTOM BYTE OF D
|
||
;DOES RTS PC WHEN INPUT STRING FINISHED
|
||
|
||
INSTR: MOV B,C
|
||
INSTR1: BIT #7777,C
|
||
BEQ OSTRR ;RTS PC
|
||
JSR PC,.LDP2I
|
||
MOVB A,D
|
||
BEQ INSTR2 ;NULL CHAR
|
||
BIC #177400,D ;CLEAR TOP BYTE
|
||
JSR PC,@(SP)+ ;RETURN TO CO-ROUTINE
|
||
|
||
INSTR2: CLRB A
|
||
SWAB A
|
||
BEQ INSTR1 ;NULL CHAR
|
||
MOV A,D
|
||
JSR PC,@(SP)+ ;RETURN TO CO-ROUTINE
|
||
BR INSTR1
|
||
|
||
MAKE: BIC #MMF,FLAGS2
|
||
BR .+10
|
||
MMAKE: BIS #MMF,FLAGS2
|
||
POPS TOPS ;PUT VALUE INTO TOPS
|
||
MOV @S,B
|
||
MOV B,A
|
||
BIC #7777,A
|
||
CMP #ATOM,A ;IS TYPE ATOM?
|
||
BNE MAKE2
|
||
MAKE4: MOV #VBIND,A ;YES< SET VARIABLE BINDING?
|
||
JSR PC,.BIND
|
||
BIT #MMF,FLAGS2 ;IS IT MULTIPLE MAKE?
|
||
BEQ MAKE1
|
||
MOV TOPS,@S
|
||
CLR TOPS
|
||
JMP ORT
|
||
MAKE1: POPS A
|
||
CLR TOPS
|
||
JMP NORT
|
||
MAKE2: CMP #LSTR,A
|
||
BEQ MAKE3
|
||
MAKE5: ERROR+WTAB ;WRONG TYPE OF ARG
|
||
MAKE3: BIT #7777,B
|
||
BEQ MAKE5
|
||
MOV TOPS,@S
|
||
MOV B,TOPS ;FOR .INTRN
|
||
JSR PC,UINTRN ;.INTRN FOR STRINGS THAT MAY INCLUDE NULL CHARS
|
||
BR .+2
|
||
MOV @S,TOPS
|
||
BR MAKE4
|
||
DOTS: JSR PC,GUOEB ;GET UOE PTR FROM S INTO B
|
||
ERROR+HNV ;HAS NO VALUE
|
||
DOTS2: JSR PC,.BNDVS
|
||
ERROR+HNV ;HAS NO VALUE
|
||
PUSHS B
|
||
CLR TOPS
|
||
JMP ORT
|
||
GUOEB: POPS B ;GET UOE OR LSTR IN B FROM S
|
||
MOV B,A ; SKIP IF UOE
|
||
BIC #7777,A
|
||
CMP #ATOM,A
|
||
BEQ GUOE1
|
||
CMP #LSTR,A
|
||
BEQ GUOE2
|
||
ERROR+WTAB ;.(B). ISWRONG TYPE OF ARG
|
||
GUOE2: MOV B,TOPS
|
||
JSR PC,UOBSCH ;.OBSCH FOR STRINGS THAT HAVE NULL CHARS
|
||
RTS PC ;NOT THERE
|
||
GUOE1: JMP SRET
|
||
DO: MOV @S,A ;DO...
|
||
MOV A,B
|
||
BIC #7777,A
|
||
CMP #LSTR,A
|
||
BEQ DO1
|
||
CMP #LIST,A
|
||
BEQ DO1
|
||
ERROR+WTAB
|
||
DO1: JSR PC,BLSTI
|
||
MOV #BLST,PCHR
|
||
CLR NBKTS
|
||
JSR PC,PNODAB
|
||
JSR PC,BLSTF
|
||
BR DO3 ;EMPTY STRING
|
||
MOV TOPS,@S
|
||
MOV #TYO,PCHR
|
||
DO2: JSR PC,READ
|
||
JSR PC,EVLINE
|
||
JMP ORT
|
||
BR DO4
|
||
DO3: POPS A
|
||
DO4: JMP NORT
|
||
;PRINT TOP (C) THINGS ON S
|
||
PRINT: INC NBKTS ;PRINTS OUTER [,]'S
|
||
FPRINT: JSR PC,REVS ;DOESNT "
|
||
POP C
|
||
JSR PC,TYPE1
|
||
JSR PC,.CRLF
|
||
JMP NORT
|
||
|
||
TYPE: JSR PC,REVS
|
||
POP C
|
||
JSR PC,TYPE1 ;PRINT WITHOUT CRLF AT END
|
||
JMP NORT
|
||
|
||
TYPE1: BIS #DPQF,FLAGS2 ;DONT PRINT QUOTE BEFORE STRINGS
|
||
JSR PC,PRS1
|
||
POPS A
|
||
DEC C
|
||
BGT TYPE1
|
||
RTS PC
|
||
|
||
LPAR: JSR PC,GNT
|
||
CMP #$RPAR,CT+2
|
||
BEQ LPAR1
|
||
ERROR+TIP ;TOO MUCH INSIDE PARENS
|
||
LPAR1: JMP ORT
|
||
RPAR: ERROR+ERP ;EXTRA RIGHT PAREN
|
||
|
||
|
||
;SINGLE PRECISION ARITHMETIC ROUTINES
|
||
|
||
UPLUS: JMP ORT ;UNARY PLUS - NOTHING TO DO
|
||
UMINS: JSR PC,G1NARG ;UNARY MINUS
|
||
NEG B
|
||
JMP R1NARG
|
||
|
||
SUM:
|
||
CLR A
|
||
MOV (SP)+,D ;NUMBER OF ARGS
|
||
BLE SUM.2 ;DONE
|
||
SUM.1: JSR PC,G1NARG ;GET 1 NUMBER IN B
|
||
ADD B,A
|
||
BVS RTBE ;RESULT TOO BIG
|
||
DEC D ;COUNTER
|
||
BGT SUM.1
|
||
SUM.2: MOV A,B
|
||
BR DONEMP
|
||
|
||
DIFF:
|
||
JSR PC,G2NARG ;GET 2 NUMBERS
|
||
SUB A,B
|
||
BVS RTBE ;RESULT TOO BIG
|
||
DONEMP: JMP R1NARG
|
||
|
||
PROD:
|
||
MOV #MQ,F
|
||
MOV #EAESR,E
|
||
MOV #1,(F)+ ;INITIALIZE MULTIPLICAND TO 1
|
||
MOV #SIPRBT,C
|
||
MOV (SP)+,D ;NUMBER OF ARGS
|
||
PROD.1: DEC D
|
||
BLT PROD.2 ;DONE
|
||
JSR PC,G1NARG ;GET ONE ARG IN B
|
||
MOV B,(F) ;MULTIPLY
|
||
BITB C,(E)
|
||
BNE PROD.1
|
||
RTBE: ERROR+RTB ;RESULT TOO BIG
|
||
|
||
PROD.2: MOV -(F),B ;PICK ANSWER OUT OF EAE
|
||
BR DONEMP
|
||
|
||
MOD:
|
||
CLR D
|
||
BR DIV.1
|
||
DIVDE:
|
||
MOV #<DONEMP-DIV.8>,D
|
||
DIV.1: JSR PC,G2NARG
|
||
TST A
|
||
BEQ RTBE ;DIVISOR = 0
|
||
MOV #MQ,F
|
||
MOV B,(F) ;DIVIDEND
|
||
MOV A,DIVIDE
|
||
MOV (F),B ;PICK UP QUOTIENT
|
||
ADD D,PC ;IF DIVIDE DESIRED, BRANCHES TO DONEMP
|
||
DIV.8: MOV -(F),B ;IF MOD DESIRED, STAYS HERE
|
||
BR DONEMP ;AND PICKS UP REMAINDER
|
||
|
||
;PREDICATES
|
||
|
||
EQUAL: MOV S,F
|
||
MOV (F)+,B ;ARG1. LEAVE ON STACK FOR GC PROTECTION
|
||
MOV (F),C ;ARG2
|
||
MOV #7777,E ;AN OFT USED CONSTANT
|
||
JSR PC,EQUAL1
|
||
BR EQ.F ;RETURNS HERE IF FALSE
|
||
MOV #TRUE,B
|
||
BR EQ.RET
|
||
|
||
EQ.F: MOV #FALSE,B
|
||
EQ.RET: ADD #2,S
|
||
JMP ORTNB
|
||
|
||
|
||
;COMPARE THE DATA ITEM POINTED TO BY B WITH
|
||
;THE DATA ITEM POINTED TO BY C.
|
||
;SKIP IF THEY ARE EQUAL
|
||
|
||
EQUAL1: CMP B,C ;ARE THE POINTERS THE SAME
|
||
BEQ EQTRUE
|
||
MOV B,A
|
||
JSR PC,EQ.SUB ;IS ARG1 A WORD?
|
||
BNE EQ.W1 ;A WORD
|
||
JSR PC,EQ.SB1 ;IS ARG2 A WORD?
|
||
BNE EQFALS ;ARG1 ISN'T WORD, BUT ARG2 IS.
|
||
;BOTH ARGS ARE LISTS
|
||
EQ.LST: JSR PC,.LOAD ;FIRST NODE OF ARG1
|
||
PUSH A ;SAVE POINTER TO BF
|
||
JSR PC,.LDP2I ;FIRST NODE OF ARG2
|
||
SPUSH C ;SAVE POINTER TO BF
|
||
MOV A,C ;POINTER TO FIRST OF ARG1
|
||
;B POINTS TO FIRST ARG2. C POINTS TO FIRST ARG1.
|
||
JSR PC,EQUAL1 ;ARE THE FIRSTS EQUAL?
|
||
BR EQ.FF ;NO. RETURN FALSE
|
||
POP B ;POINTER TO BF
|
||
SPOP C ;POINTER TO BF OF OTHER ARG
|
||
BIC #170000,B
|
||
BIC #170000,C
|
||
CMP B,C
|
||
BEQ EQTRUE
|
||
JSR PC,EQ.LST ;ARE THE BF'S EQUAL?
|
||
EQFALS: RTS PC ;NO
|
||
EQTRUE: SKPRET ;YES
|
||
|
||
EQ.FF: CMP (SP)+,(SP)+ ;POP OFF THE POINTERS TO THE BF'S
|
||
JMP PPOPT ;DON'T OVERPOP!
|
||
|
||
EQ.SB1: MOV C,A ;IS ARG A WORD?
|
||
EQ.SUB: BIT E,A ;EMPTY?
|
||
BEQ EQFALS ;ONE ARG FINISHED
|
||
BIC E,A
|
||
CMP #SENT,A
|
||
RTS PC
|
||
|
||
;ARG1 IS A WORD
|
||
EQ.W1: JSR PC,EQ.SB1 ;IS ARG2 A WORD?
|
||
BEQ EQFALS ;NOT A WORD
|
||
;FALLS INTO WEQUAL
|
||
|
||
;COMPARE TWO WORDS
|
||
|
||
WEQUAL: MOV #SNUM,A
|
||
JSR PC,CONVERT ;TRY CONVERTING ARG TO SNUM
|
||
BR EQ.STR ;NOT NUMERIC
|
||
MOV #<EQFALS-EQ.FAL>,D ;ADD TO PC IN A WHILE
|
||
BR EQ.A2
|
||
|
||
;ARG NOT NUMERIC. TRY STRING COMPARE
|
||
EQ.STR: MOV #LSTR,A
|
||
JSR PC,CONVERT
|
||
ERROR+WTAB ;EQUAL NOT DEFINED FOR SNAPS, ETC
|
||
CLR D ;ADD TO PC IN A WHILE
|
||
EQ.A2: EXCH B,C
|
||
JSR PC,CONVERT ;TRY CONVERTING 2ND ARG, TOO
|
||
BR EQFALS ;NOT SAME TYPE AS FIRST ARG
|
||
CMP B,C
|
||
BEQ EQTRUE
|
||
ADD D,PC ;JUMP TO EQFALS IF NUMERIC.
|
||
EQ.FAL==.
|
||
|
||
;COMPARE TWO STRINGS. POINTERS IN B AND C.
|
||
MOV B,GCP1
|
||
MOV C,GCP2
|
||
SPUSH #INSTR1
|
||
MOV B,F
|
||
CMPST1: BIT E,F ;IS ARG 1 ENDED
|
||
BEQ CMPSTE ;YES
|
||
SPUSH A ;SAVE A
|
||
MOV F,B ;POINTER TO REST OF ARG1
|
||
JSR PC,.LOAD
|
||
MOV A,F ;POINTER TO REST OF ARG1
|
||
SPOP A ;RESTORE A
|
||
TSTB B ;IS CHAR REAL OR NULL?
|
||
BEQ CMPST2 ;NULL
|
||
JSR PC,@(SP)+ ;PUTS 1 CHAR OF ARG 2 INTO B
|
||
BEQ CSFAL1 ;ARG 2 ENDED
|
||
CMPB D,B ;COMPARE CHARS!!
|
||
BNE CSFALS
|
||
CMPST2: SWAB B
|
||
BEQ CMPST1 ;NULL CHAR
|
||
JSR PC,@(SP)+ ;1 CHAR OF ARG 2 IN B
|
||
BEQ CSFAL1
|
||
CMPB D,B ;COMPARE CHARS!!
|
||
BEQ CMPST1
|
||
CSFALS: TST (SP)+ ;POP CO-ROUTINE LINKAGE
|
||
CSFAL1: CLR GCP1
|
||
CLR GCP2
|
||
BR EQFALS
|
||
|
||
;ARG 1 HAS ENDED
|
||
CMPSTE: JSR PC,@(SP)+
|
||
BNE CSFALS ;BUT ARG 2 HASN'T ENDED
|
||
CLR GCP1
|
||
CLR GCP2
|
||
BR EQTRUE ;BOTH ENDED AT THE SAME TIME!!!!
|
||
|
||
;MORE PREDICATES
|
||
|
||
GREATR: JSR PC,G2NARG
|
||
CMP B,A
|
||
BGT RTTRUE
|
||
RTFALS: PUSHS #FALSE
|
||
RTNCMP: JMP ORT
|
||
|
||
LESS: JSR PC,G2NARG
|
||
CMP B,A
|
||
BGE RTFALS
|
||
RTTRUE: PUSHS #TRUE
|
||
BR RTNCMP
|
||
|
||
GREQ: JSR PC,G2NARG
|
||
CMP B,A
|
||
BGE RTTRUE
|
||
BR RTFALS
|
||
|
||
LSEQ: JSR PC,G2NARG
|
||
CMP B,A
|
||
BLE RTTRUE
|
||
BR RTFALS
|
||
|
||
NUMBP: POPS B
|
||
MOV #LNUM,A
|
||
JSR PC,CONVERT
|
||
BR RTFALS ;COULDN'T CONVERT IT
|
||
BR RTTRUE
|
||
|
||
EMPTYP: POPS B
|
||
BIT #7777,B
|
||
BEQ RTTRUE
|
||
BR RTFALS
|
||
|
||
LISTP: POPS B
|
||
BIC #7777,B
|
||
CMP #SENT,B
|
||
BEQ RTTRUE
|
||
BR RTFALS
|
||
|
||
WORDP: POPS B
|
||
BIC #7777,B
|
||
CMP #SENT,B
|
||
BEQ RTFALS
|
||
BR RTTRUE
|
||
IF: INC IFLEV
|
||
BIS #IFF,FLAGS
|
||
JSR PC,TSTST ;TEST S, SKIP IF "TRUE"
|
||
BR .+4
|
||
BR IFR
|
||
JSR PC,STNE
|
||
BR IFR
|
||
BIC #RTF,FLAGS
|
||
IFR: JMP NORT
|
||
THEN: BIT #IFF,FLAGS
|
||
BNE IFR
|
||
ERROR+OOP ;THEN OUT OF PLACE
|
||
BR IFR
|
||
ELSE: BIT #IFF,FLAGS
|
||
BNE .+4
|
||
ERROR+OOP ;ELSE OUT OF PLACE
|
||
JSR PC,STNE
|
||
BR IFR
|
||
DEC IFLEV
|
||
BGT IFR
|
||
BIC #IFF,FLAGS
|
||
BR IFR
|
||
STNE: JSR PC,GNT ;SCAN TOO NEXT ELSE
|
||
CMP #$ELSE,CT+2
|
||
BNE STNE1
|
||
BIS #RTF,FLAGS ;IF "ELSE", SET RTF AND SKIP RETURN
|
||
JMP SRET
|
||
STNE1: BIT #CRF,FLAGS
|
||
BEQ STNE2
|
||
STNE3: BIS #RTF,FLAGS ;IF "CR" SET RTF AND RETURN
|
||
BIC #CRF,FLAGS
|
||
RTS PC
|
||
STNE2: CMP #$IF,CT+2 ;IF "IF", LOOK FOR NEXT ELSE!
|
||
BNE STNE
|
||
JSR PC,STNE
|
||
BR STNE3
|
||
BIC #RTF,FLAGS
|
||
BR STNE
|
||
TSTST: PUSH A ;TEST S, SKIP IF TRUE
|
||
MOV @S,A ;ERROR IF NEITHER "TRUE" OR "FALSE"
|
||
PUSHS A
|
||
PUSHS #TRUE
|
||
JSR PC,CSEQ
|
||
BR TSTST1
|
||
POPS A ;"TRUE", SKIP
|
||
JMP SRETA
|
||
TSTST1: MOV @S,A
|
||
PUSHS A
|
||
PUSHS #FALSE
|
||
JSR PC,CSEQ
|
||
ERROR+NTF ;NOT "TRUE" OR "FALSE"
|
||
POPS A
|
||
JMP RETA
|
||
CSEQ: PUSH A ;COMPARE TWO STRINGS - POINTERS ON S
|
||
PUSH B ;SKIP IF EQUAL
|
||
PUSH C ;ASSUMES NO "NULL" (8-BIT ON) CHARACTERS
|
||
PUSH D
|
||
MOV S,C
|
||
MOV (C)+,D ;GET STR 1 POINTER IN D
|
||
MOV @C,C ;GET STR 2 POINTER INTO C
|
||
CSEQ1: MOV D,B
|
||
CMP C,D ;CHECK IF POINTERS EQUAL
|
||
BEQ CSEQ3
|
||
BIT #7777,B ;CHECK IF EITHER STRING DONE
|
||
BEQ CSEQ2
|
||
BIT #7777,A
|
||
BEQ CSEQ2
|
||
JSR PC,.LOAD ;GET NEXT NODE OF STR 1
|
||
MOV A,D ;SAVE POINTER IN D
|
||
JSR PC,.LDP2I ;GET NEXT NODE OF STR 2
|
||
CMP A,B
|
||
BEQ CSEQ1
|
||
CSEQ2: POPS A
|
||
SPOPS A
|
||
BR RETD ;STRINGS NOT EQUAL
|
||
RETF: POP F
|
||
RETE: POP E
|
||
RETD: POP D
|
||
RETC: POP C
|
||
RETB: POP B
|
||
RETA: POP A
|
||
RET: RTS PC
|
||
CSEQ3: ADD #2,8.(P) ;STRINGS EQUAL
|
||
BR CSEQ2
|
||
REVS: CMP #1,2(P)
|
||
BLT .+4
|
||
RTS PC
|
||
PUSH A ;REVERSES THE TOP ((P)+1) THINGS ON S
|
||
PUSH B
|
||
PUSH C
|
||
PUSH D
|
||
MOV 10.(P),C
|
||
MOV S,A
|
||
MOV C,B
|
||
ASL B
|
||
ADD A,B
|
||
ASR C
|
||
BEQ REVS1
|
||
REVS2: MOV @A,D
|
||
MOV -(B),(A)+
|
||
MOV D,@B
|
||
DEC C
|
||
BGT REVS2
|
||
REVS1: JMP RETD
|
||
.STITL CONVERSION ROUTINES
|
||
|
||
|
||
;CONVERT
|
||
;CALL WITH DESIRED DATA TYPE IN A
|
||
;CALL WITH POINTER TO DATA IN B
|
||
;IF CONVERSION SUCCEEDS, RETURN POINTER TO CONVERTED DATA IN B AND
|
||
;LEAVE A UNCHANGED.
|
||
;
|
||
;IF CONVERSION FAILS, LEAVE B UNCHANGED,BUT RETURN ITS DATA TYPE IN A
|
||
|
||
CONVERT:
|
||
MOV A,-(SP) ;SAVE A,B,C HERE
|
||
MOV B,-(SP)
|
||
MOV C,-(SP)
|
||
|
||
BIC #107777,A ;LEAVE DATA TYPE ONLY
|
||
MOV B,C
|
||
BIC #107777,C
|
||
ASR A ;SHIFT DESTINATION DATA TYPE 3 PLACES
|
||
ASR A
|
||
ASR A
|
||
BIS C,A ;SET SOURCE DATA TYPE IN THE 3 VACATED BITS
|
||
ASR A ;AND PLACE THE ENTIRE MESS IN BOTTOM 6 BITS
|
||
SWAB A
|
||
;(A IS NOW A 6 BIT DISPATCH ADDRESS)
|
||
MOVB CNVTBL(A),A ;PICK UP ENTRY FROM TABLE
|
||
BIC #177400,A ;CLEAR TOP BYTE
|
||
ASL A ;IT IS A BYTE ADDRESS
|
||
JSR PC,CNVTOP(A) ;RELATIVE TO CONVERT TOP
|
||
BR CONV.F ;THE CONVERSION FAILED
|
||
MOV (SP)+,C
|
||
TST (SP)+ ;DON'T RESTORE B
|
||
MOV (SP)+,A
|
||
JMP SRET ;SKIP RETURN
|
||
|
||
CONV.F: MOV (SP)+,C
|
||
MOV (SP)+,B
|
||
MOV B,A
|
||
BIC #7777,A ;DATA TYPE OF ARG LEFT IN A
|
||
TST (SP)+ ;DON'T RESTORE A
|
||
RTS PC
|
||
|
||
|
||
;CONVERT ROUTINE JUMPS TO THE PROGRAMS HERE
|
||
|
||
CNVTOP==. ;TOP OF CONVERT ROUTINES
|
||
|
||
;THE ARGUMENT CAN'T BE CONVERTED TO DESIRED DATA TYPE
|
||
.CERR: RTS PC
|
||
|
||
CNVNOP==<.-CNVTOP>/2
|
||
;THE ARGUMENT ALREADY HAS THE DESIRED TYPE
|
||
.CNOP: SKPRET
|
||
|
||
CA2LS==<.-CNVTOP>/2
|
||
;CONVERT ATOM TO LSTR
|
||
.CATLS: JSR PC,.LOAD
|
||
SKPRET
|
||
|
||
CSN2LN==<.-CNVTOP>/2
|
||
;CONVERT SNUM TO LNUM. ASSUME NUMBER IN B, RATHER THAN POINTER
|
||
.CSNLN: MOV #SNUM,A
|
||
JSR PC,GRBAD ;STORE THE NODE A,B IN A NEW NODE
|
||
BIS #LNUM,C ;CPOINTS TO NEW NODE
|
||
MOV C,B
|
||
SKPRET
|
||
|
||
;MORE CONVERSION ROUTINES
|
||
|
||
CSN2LS==<.-CNVTOP>/2
|
||
;CONVERT SNUM TO LSTR
|
||
.CSNLS: MOV D,-(SP)
|
||
MOV E,-(SP)
|
||
MOV F,-(SP)
|
||
MOV #MQ,A
|
||
MOV #<.CSNL4-.CSNL5>,E
|
||
CLR -(SP) ;MARK STACK
|
||
MOV B,(A)
|
||
BGT .CSNL0
|
||
BLT .CSNLL
|
||
SPUSH #'0 ;NUMBER IS 0
|
||
BR .CSNL2
|
||
|
||
.CSNLL: CLR E
|
||
NEG (A) ;SNUM WAS NEGATIVE
|
||
.CSNL0: MOV #10.,D
|
||
.CSNL1: JSR PC,.CNXTD ;GET NEXT DIGIT IN B
|
||
BR .CSNL2 ;NO MORE CHARS
|
||
SWAB B
|
||
MOV B,-(SP)
|
||
JSR PC,.CNXTD
|
||
BR .CSNL2
|
||
BISB B,(SP) ;SET NEW CHAR INTO PREVIOUS ONE
|
||
BR .CSNL1
|
||
|
||
.CSNL2: MOV #SSTR,A
|
||
CLR F
|
||
ADD E,PC
|
||
.CSNL5: MOV #'-,B ;STAYS HERE IF ARG WAS NEGATIVE
|
||
.CSNL3: JSR PC,LISTB ;PUT NEXT 2 CHARS ONTO LIST
|
||
.CSNL4: MOV (SP)+,B
|
||
BNE .CSNL3 ;0 MARKS END OF DIGITS
|
||
POPS B ;POINTER TO FIRST NODE OF ANSWER
|
||
BIC #170000,B ;CLEAR DATA TYPE
|
||
BIS #LSTR,B ;REPLACE BY LSTR
|
||
|
||
.SRDEF: CLR GCP1
|
||
MOV (SP)+,F
|
||
MOV (SP)+,E
|
||
MOV (SP)+,D
|
||
SKPRET
|
||
|
||
;GET NEXT CHARACTER IN B
|
||
;SKIP UNLESS NO MORE CHARS
|
||
.CNXTD: TST (A) ;IS THERE MORE NUMBER LEFT
|
||
BEQ .CLNR ;RTS PC
|
||
CLR -(A) ;CLEAR REMAINDER
|
||
MOV D,-(A) ;DIVIDE BY 10.
|
||
TST (A)+
|
||
MOV (A)+,B ;REMAINDER IS NEXT DIGIT
|
||
ADD #60,B ;CONVERT TO ASCII
|
||
SKPRET
|
||
|
||
;MORE CONVERSION ROUTINES
|
||
|
||
CLN2SN==<.-CNVTOP>/2
|
||
;CONVERT LNUM TO SNUM. RETURN NUMBER IN B
|
||
.CLNSN: JSR PC,.LOAD
|
||
CMP A,#SNUM
|
||
BEQ .CLNS1
|
||
.CLNR: RTS PC ;CAN'T CONVERT IF LNUM HAS MORE THAN ONE NODE
|
||
.CLNS1: SKPRET
|
||
|
||
CLN2LS==<.-CNVTOP>/2
|
||
;CONVERT LNUM TO LSTR
|
||
.CLNLS: ;CONVERT LNUM TO LSTR
|
||
JSR PC,.CLNSN ;FOR NOW, CAN ONLY CONVERT
|
||
RTS PC ;IF LNUM HAS ONE NODE
|
||
JMP .CSNLS ;(WHICH MUST BE CHANGED SOMEDAY)
|
||
|
||
CLS2SN==<.-CNVTOP>/2
|
||
;CONVERT LSTR TO SNUM
|
||
.CLSSN: BIT #7777,B ;IS B EMPTY
|
||
BEQ .CLNR ;CAN'T CONVERT EMPTY
|
||
MOV D,-(SP)
|
||
MOV E,-(SP)
|
||
MOV F,-(SP)
|
||
MOV B,GCP1 ;POINT TO INPUT. (GETS CLEARED AT .RDEF & .SRDEF)
|
||
|
||
MOV B,C
|
||
MOV #INSTR1,-(SP) ;ADD. OF CO-ROUTINE
|
||
CLR B
|
||
MOV #10.,E
|
||
MOV #MQ,F
|
||
CLR (F) ;ZERO AC AND MQ
|
||
|
||
.CLSS0: TST (F)+ ;POINT TO MULTIPLY
|
||
.CLSS1: JSR PC,@(SP)+ ;OUTPUTS CHAR IN D
|
||
BEQ .CLSS9
|
||
TST B ;IF NOT THE FIRST CHARACTER,
|
||
BNE .CNXN2 ;BRANCH.
|
||
INC B ;1
|
||
CMPB D,#55 ;IS CHARACTER MINUS?
|
||
BNE .CNXN1
|
||
NEG B ;-1 (MUST BE EXACTLY -1 FOR LATER USE)
|
||
BR .CLSS1
|
||
|
||
.CNXN1: CMPB D,#53 ;PLUS?
|
||
BEQ .CLSS1 ;(REMEMBER THAT D=1)
|
||
|
||
.CNXN2: SUB #60,D ;CONVERT ASCII TO BINARY
|
||
BLT .CNXN9
|
||
CMPB D,E ;COMPARE TO 10.
|
||
BGE .CNXN9
|
||
MOV E,(F) ;MULTIPLY MQ BY 10.
|
||
BITB #SIPRBT,EAESR ;TEST SINGLE PRECISION BIT
|
||
BEQ .CNXN9 ;ANSWER NO LONGER SINGLE PRECISION
|
||
ADD D,-(F) ;ADD NEW NUMBER TO MQ
|
||
BR .CLSS0
|
||
|
||
.CNXN9: TST (SP)+ ;POP OFF ADDRESS OF CO-ROUTINE
|
||
JMP .RDEF ;RESTORE D,E,F
|
||
|
||
.CLSS9: MOV B,(F) ;END OF STRING. MULTIPLY BY 1 OR -1
|
||
MOV -(F),B ;PICK NUMBER OUT OF EAE
|
||
JMP .SRDEF ;RESTORE D,E,F AND SKPRET
|
||
|
||
CLS2LN==<.-CNVTOP>/2
|
||
;CONVERT LSTR TO LNUM
|
||
;FOR NOW ONLY WORKS IF NUMBER LESS THAN 16 BITS
|
||
.CLSLN: JSR PC,.CLSSN ;CONVERT TO SNUM
|
||
RTS PC
|
||
JMP .CSNLN
|
||
|
||
|
||
;THE DISPATCH TABLE FOR CONVERT
|
||
|
||
CNVTBL:
|
||
.BYTE CNVNOP ;SNAP TO SNAP
|
||
REPT1 7,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
|
||
REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
.BYTE 0 ;ATOM TO SNUM
|
||
.BYTE 0 ;ATOM TO LNUM
|
||
.BYTE CA2LS ;ATOM TO LSTR
|
||
REPT1 3,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
|
||
REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
.BYTE CNVNOP ;SNUM TO SNUM
|
||
.BYTE CSN2LN ;SNUM TO LNUM
|
||
.BYTE CSN2LS ;SNUM TO LSTR
|
||
REPT1 3,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
|
||
REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
.BYTE CLN2SN ;LNUM TO SNUM
|
||
.BYTE CNVNOP ;LNUM TO LNUM
|
||
.BYTE CLN2LS ;LNUM TO LSTR
|
||
REPT1 3,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
|
||
REPT1 2,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
.BYTE CLS2SN ;LSTR TO SNUM
|
||
.BYTE CLS2LN ;LSTR TO LNUM
|
||
.BYTE CNVNOP ;LSTR TO LSTR
|
||
REPT1 3,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
|
||
REPT1 8.,^\.BYTE 0\ ;NOT USED AT THIS TIME (RNUM TO ANYTHING)
|
||
|
||
REPT1 6,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
.BYTE CNVNOP ;SENT TO SENT
|
||
REPT1 1,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
|
||
REPT1 7,^\.BYTE 0\ ;NOT USED AT THIS TIME
|
||
.BYTE CNVNOP ;LIST TO LIST
|
||
|
||
.EVEN
|
||
|
||
.STITL GET ARGUMENT ROUTINES
|
||
|
||
;GET 2 SNUM'S OFF OF S PDL
|
||
;RETURN TOP ONE IN A, BOTTOM ONE IN B
|
||
G2NARG: JSR PC,G1NARG ;NUMBER IN B
|
||
MOV B,A
|
||
|
||
;GET 1 SNUM OFF OF S PDL
|
||
;RETURN IT IN B
|
||
G1NARG: POPS B
|
||
G1NAR1: MOV A,-(SP) ;ENTER HERE WITH ARG IN B
|
||
MOV #SNUM,A
|
||
JSR PC,CONVERT
|
||
G1WTA: ERROR+WTAB ;WRONG TYPE OF ARG
|
||
MOV (SP)+,A
|
||
G1RET: RTS PC
|
||
|
||
;GET ONE LIST OR WORD ARG
|
||
;SKIP IF WORD
|
||
GLWARG: MOV @S,B ;DON'T POP ARG. LEAVE IT GC PROTECTED
|
||
GLWAR1: MOV #LSTR,A
|
||
JSR PC,CONVERT
|
||
BR GSW1 ;NOT WORD
|
||
SKPRET
|
||
GSW1: CMP A,#SENT
|
||
BNE G1WTA ;NOT SENTENCE EITHER
|
||
GSW2: RTS PC
|
||
|
||
;GET ONE LIST OR WORD. ERRROR IF EMPTY
|
||
GLWANE: MOV @S,B
|
||
BIT #7777,B
|
||
BEQ G1WTA
|
||
BR GLWAR1
|
||
|
||
;RETURN ONE NUMERIC ARGUMENT
|
||
;CALL WITH SNUM IN B
|
||
R1INT: JSR PC,GETINT
|
||
R1NARG: MOV #ORTB,-(SP) ;ENTER HERE FROM LOGO
|
||
P1NARG: JSR PC,.CSNLN ;CONVERT SNUM TO LNUM
|
||
NOP 1
|
||
RTS PC
|
||
|
||
PSHINT: JSR PC,GETINT
|
||
;PUSH A NUMBER ONTO THE S-PDL
|
||
PSHNUM: JSR PC,.CSNLN
|
||
NOP 1
|
||
SPUSHS B
|
||
RTS PC
|
||
|
||
|
||
;GET 1 SNAP
|
||
; RETURN POINTER TO SNAP IN D, DELTA X IN E, DELTA Y IN F
|
||
G1SNAP: MOV @S,C ;POINTER TO ARG
|
||
BIT #7777,C ;IS IT EMPTY?
|
||
BEQ G1RET ;YES. RETURN WITHOUT SKIPPING
|
||
JSR PC,LD3NUM ;LOAD D,E,F
|
||
SKPRET
|
||
|
||
|
||
;LOAD 3 NUMBERS
|
||
; GROVEL DOWN A LIST OF NUMBERS RETURNING 3 NUMBERS IN D,E,F
|
||
; CALL WITH C POINTING TO LIST
|
||
; IF LIST CONTAINS 1)NON-NUMBERS OR 2)MORE THAN 3 ELEMENTS,
|
||
; THEN ERROR+WTA
|
||
LD3NUM: PUSH A
|
||
SPUSH B
|
||
SPUSH C
|
||
MOV #7777,D ;AN OFT USED CONSTANT
|
||
MOV #3,F ;COUNTER
|
||
LDN.L: BIT D,C ;IS THERE MORE LIST?
|
||
BEQ LDN.E ;ERROR
|
||
JSR PC,.LDP2I ;LOAD A WITH NEXT ELEMENT
|
||
MOV A,B
|
||
MOV #SNUM,A
|
||
JSR PC,CONVERT
|
||
LDN.E: ERROR+WTA
|
||
SPUSH B ;PUSH THIS ELEMENT
|
||
DEC F
|
||
BGT LDN.L ;LOOP BACK
|
||
BIT D,C ;IS THE LIST FINISHED?
|
||
BNE LDN.E ;NO. ERROR
|
||
JMP RETF ;SKIP RETURN AND RESTORE ALL AC'S!
|
||
.STITL EVAL
|
||
EVBUG=HALT
|
||
|
||
EVAL: JSR PC,GNT
|
||
JSR PC,STRACE
|
||
BIC #7777,A
|
||
CMP A,#UFUN
|
||
BLOS EVFUN
|
||
CMP A,#UVAR
|
||
BEQ EVVAR
|
||
CMP A,#SSTR
|
||
BHIS .+4
|
||
EVBUG
|
||
CMP A,#ATOM
|
||
BEQ EVATM
|
||
CMP A,#RNUM
|
||
BNE EVCON
|
||
EVBUG
|
||
EVCON:
|
||
EVATM: PUSHS CT+2
|
||
BR EVI
|
||
EVVAR: BIC #7777,A
|
||
JSR PC,.BINDL
|
||
ERROR+HNV ;... HAS NO VALUE
|
||
PUSHS B
|
||
EVI: JSR PC,GNT ;ABOUT TO OUTPUT A VLAUE. BEFORE WE DO, CHECK TO SEE IF
|
||
;NEXT TOKEN IS INFIX WHICH SHOULD GOBBLE IT.
|
||
BIC #7777,A ;IS NEXT TOKEN INFIX?
|
||
CMP #INFIX,A
|
||
BEQ CKPRCD ;YES
|
||
EVI1: BIS #RTF,@#FLAGS ;SET REPEAT TOKEN FLAG
|
||
BIC #CRF,FLAGS
|
||
JMP SRET
|
||
CKPRCD: TST CO+2 ;COMPARE PRECEDENCE
|
||
BEQ EVI2
|
||
MOV @CT+2,A
|
||
BIC #7777,A
|
||
CMP A,COF
|
||
BLOS EVI1 ;PRECD OF CO IS >= PRECD OF NEXT OPR
|
||
;NEXT TOKEN SHOULD GOBBLE THIS OUTPUT
|
||
EVI2: JSR PC,STRACE
|
||
PUSH CO
|
||
SPUSH CO+2
|
||
SPUSH NOR
|
||
MOV CT,CO
|
||
MOV CT+2,CO+2
|
||
MOV @CO+2,COF ;GET FLAGS
|
||
JSR PC,CKTYP
|
||
ERROR+WTA ;WRONG TYPE OF ARG
|
||
MOV #1,NOR
|
||
JMP EVW
|
||
EVFUN: BIT #CRF,FLAGS ;CT IS A FUNCTION
|
||
BEQ .+4
|
||
ERROR+UEL ;UNEXPECTED END OF LINE
|
||
CMP #$LPAR,CT+2
|
||
BNE EVF1
|
||
TST CO+2
|
||
BEQ EVF11
|
||
CMP #$LLPAR,CO+2
|
||
BNE EVF1
|
||
EVF11: MOV #$LLPAR,CT+2
|
||
EVF1: PUSH CO
|
||
SPUSH CO+2
|
||
SPUSH NOR
|
||
MOV CT,CO
|
||
MOV CT+2,CO+2
|
||
CMP A,#UFUN ;IS IT A USER FUNCTION?
|
||
BLO MFUN ;NO, MACHINE
|
||
EVF2: MOV #40000,COF ;SET PRECD TO 2
|
||
JSR PC,GNASN ;GET NO. OF ARGS IN B
|
||
ERROR+HNM ;... HAS NO MEANING
|
||
MOVB B,B ;CLEAR ANY LEFT HALF FLAGS
|
||
MOV B,NOR
|
||
BNE EVL1
|
||
EVXP: JMP PEVAL ;SET TO EVALUATE THIS USER PROCEDURE
|
||
;PEVAL RETURNS TO "NORT" IF THERE WAS NO OUTPUT
|
||
;GOES TO "ORT:" IF THERE WAS
|
||
MFUN: MOV @CO+2,A ;GET FLAGS FOR THIS MACHINE PROCEDURE
|
||
MOV A,COF
|
||
SWAB A
|
||
BIC #177774,A
|
||
MOV A,NOR
|
||
BNE EVS ;IS NO. ARGS = 0?
|
||
EVXM: JMP MEVAL ;YES. EXECUTE THIS MACHINE PROCEDURE
|
||
NORT: MOV #EVDNO,A
|
||
NORT1: MOV CO+2,LO+2
|
||
MOV CO,LO
|
||
POP NOR
|
||
SPOP B
|
||
MOV B,CO+2
|
||
SPOP CO
|
||
CLR COF
|
||
TST B
|
||
BEQ NORT2
|
||
BIT #170000,B ;IS IT A UFUN
|
||
BNE NORT2
|
||
MOV @B,COF
|
||
NORT2: JMP @A
|
||
EVDNO: RTS PC
|
||
EVS: BIT COF,#INFIX ;IS CO INFIX OP
|
||
BEQ EVL ;NO
|
||
JSR PC,CKUI ;CHECK FOR VALID UNARY INFIX +,-
|
||
ERROR+INF1 ;INFIX IN WRONG PLACE
|
||
BR EVW
|
||
PROC: JSR PC,GUOEB ;PEVAL INVOKED VIA "#"
|
||
ERROR+HNM ;HAS NO MEANING
|
||
CLR TOPS
|
||
MOV #UFUN,CO
|
||
MOV B,CO+2
|
||
JMP EVF2
|
||
|
||
EVL: BIT #PTLPF,FLAGS ;WAS PREVIOUS TOKEN A LEFT PAREN
|
||
BEQ EVL1
|
||
BIT #VNAF,COF
|
||
BEQ EVL1
|
||
CLR NOR
|
||
EVL1: JSR PC,GNT
|
||
CMP #$OF,CT+2
|
||
BEQ EVW
|
||
EVW1: BIS #RTF,FLAGS ;SET RTF
|
||
BIC #CRF,FLAGS
|
||
EVW: JSR PC,EVAL
|
||
BR EVW2
|
||
JSR PC,CKTYP
|
||
ERROR+WTA ;WRONG TYPE
|
||
DEC NOR
|
||
BEQ EVX ;WHEN NOR = 0, WE'VE ENUF INPUTS
|
||
JSR PC,GNT
|
||
CMP #$AND,CT+2 ;SKIP NEXT TOKEN IF IT IS "AND"
|
||
BEQ EVW
|
||
TST NOR ;IF NOR < 0 AND NEXT TOKEN IS ")" THEN THE ")"
|
||
BGE EVW1 ;TERMINATES THE ARG SCAN FOR THE CO
|
||
CMP #$RPAR,CT+2
|
||
BNE EVW1
|
||
BIS #RTF,FLAGS
|
||
BIC #CRF,FLAGS
|
||
NEG NOR
|
||
JMP MEVALN
|
||
EVX: BIT #160000,CO ;IS IT A MACHINE PROCEDURE
|
||
BNE EVXP ;NO
|
||
BIT #VNAF,COF ;MACHINE PROC NOW HAS ITS "STD" NO. OF ARGS.
|
||
;IF IT CAN TAKE A VARIABLE NO., THEN THE "STD" NO. HAS TO
|
||
;BE PUSHED ON P
|
||
BEQ MEVAL
|
||
MOV COF,A
|
||
SWAB A
|
||
BIC #177774,A
|
||
MOV A,NOR
|
||
BR MEVALN
|
||
EVW2: CMP #$LLPAR,CO+2 ;EVAL SHOULD OUTPUT WHEN NOT AT TOP LEVEL
|
||
BEQ LLPAR ;EXCEPT WHEN CO IS LLPAR
|
||
ERROR+NOU ;WHAT, NO OUTPUT??!!
|
||
LLPAR: JSR PC,GNT
|
||
CMP #$RPAR,CT+2
|
||
BNE EVW1
|
||
JMP NORT
|
||
|
||
ORTNA: SPUSH A
|
||
BR ORTNP
|
||
ORTNB: SPUSH B
|
||
BR ORTNP
|
||
ORTNC: SPUSH C
|
||
BR ORTNP
|
||
ORTND: SPUSH D
|
||
BR ORTNP
|
||
ORTNE: SPUSH E
|
||
BR ORTNP
|
||
ORTNF: SPUSH F
|
||
ORTNP: MOV (SP)+,@S
|
||
BR ORT
|
||
|
||
|
||
ORTA: SPUSH A
|
||
BR ORTSP
|
||
ORTB: SPUSH B
|
||
BR ORTSP
|
||
ORTC: SPUSH C
|
||
BR ORTSP
|
||
ORTD: SPUSH D
|
||
BR ORTSP
|
||
ORTE: SPUSH E
|
||
BR ORTSP
|
||
ORTF: SPUSH F
|
||
ORTP==.
|
||
ORTSP: PUSHS (SP)+
|
||
ORT: MOV #EVI,A
|
||
JMP NORT1
|
||
SRETF: POP F
|
||
SRETE: POP E
|
||
SRETD: POP D
|
||
SRETC: POP C
|
||
SRETB: POP B
|
||
SRETA: POP A ;POP A THEN SKIP RETURN
|
||
CKTYP:
|
||
SRET:
|
||
CMP #200,@0(P) ;SKIP RETURN. IS NEXT INST A 'JMP' OR HALT
|
||
BLOS .+6
|
||
ADD #2,@P ;YES, SKIP 2 EXTRA
|
||
ADD #2,@P
|
||
RTS PC
|
||
CKUI: PUSH A
|
||
MOV CO+2,A
|
||
CMP A,#$PLUS ;+
|
||
BNE CKUI1
|
||
MOV #$UPLUS,CO+2
|
||
CKUI0: MOV @CO+2,COF
|
||
MOV #1,NOR
|
||
JMP SRETA
|
||
CKUI1: CMP A,#$MINUS ;-
|
||
BNE CKUI2
|
||
MOV #$UMINS,CO+2
|
||
BR CKUI0
|
||
CKUI2: POP A
|
||
RTS PC
|
||
MEVALN: PUSH NOR
|
||
MEVAL: MOV CO+2,A ;GET SOE POINTER
|
||
CLR NBKTS
|
||
JMP @2(A) ;JMP ADDR IS IN 2ND WORD
|
||
.STITL PROCEDURE EVALUATOR
|
||
PEVAL: MOV CO+2,B ;FIRST CHECK IF PROC IS THERE
|
||
JSR PC,.BINDF
|
||
ERROR+HNM ;PROCEDURE HAS NO MEANING
|
||
PUSH CPP ;PUSH THE WORLD!
|
||
SPUSH CPSN
|
||
SPUSH CLN
|
||
SPUSH CLP
|
||
SPUSH CLGN
|
||
SPUSH CTN
|
||
PUSH CTP
|
||
SPUSH FLAGS
|
||
SPUSH CO
|
||
SPUSH CO+2
|
||
SPUSH IFLEV
|
||
;GET ARG LIST - PUT UOE POINTERS AND VALUES FROM THERE ON S
|
||
MOV B,C ;SAVE PTR TO LLP
|
||
MOV CO+2,B
|
||
JSR PC,GNASN ;GET FLAGS,,#ARGS
|
||
HALT
|
||
HALT
|
||
MOV B,FLAGS
|
||
MOVB B,B
|
||
SPUSH B
|
||
BIC #-TPTF-1,FLAGS
|
||
BEQ PEV6
|
||
MOV CO+2,B
|
||
INC FUNLEV
|
||
JSR PC,TINDNT
|
||
DEC FUNLEV
|
||
JSR PC,PPNAME
|
||
PRTXT ^\'S INPUTS: \
|
||
MOV @P,B
|
||
PEV6: SPUSH C ;SAVE FOR BELOW
|
||
MOV B,D
|
||
BEQ PEV2
|
||
JSR PC,.LOADC
|
||
JSR PC,.LOAD
|
||
SPUSH A ;SAV PTR TO REST OF LLP
|
||
SPUSH B ;FOR REVS
|
||
JSR PC,REVS
|
||
JSR PC,PUSHSN ;PUSH S BY (B) WORDS
|
||
MOV S,D
|
||
SPOP B ;REVS DOESNT POP
|
||
MOV D,E
|
||
ASL B
|
||
ADD B,E ;E POINTS TO FIRST ARG
|
||
MOV @P,B ;GET SAVED LLP PTR
|
||
PEV1: BIT #TPTF,FLAGS
|
||
BEQ PEV5
|
||
MOV @E,B
|
||
MOV B,A
|
||
SPUSH D
|
||
JSR PC,PRTAB
|
||
SPACE
|
||
SPOP D
|
||
MOV @P,B
|
||
PEV5: JSR PC,.LOAD
|
||
MOV A,@P
|
||
MOV B,(D)+ ;SAVE UOE PTR
|
||
JSR PC,.BNDVN ;NOW GET VARIB. BINDING
|
||
BR PEV3 ;NOT THERE
|
||
PEV4: BIT #100000,A ;IF OLD VALUE SWAPPED OUT, CLEAR TYPE FIELD
|
||
BEQ .+6
|
||
BIC #170000,B
|
||
MOV (E)+,A ;GET NEW VALUE PTR
|
||
MOV B,(D)+ ;SAVE OLD VALUE PO[NTER
|
||
MOV A,B
|
||
JSR PC,.LDP1
|
||
BIC #100000,A ;MAKE SURE BINDING NODE SAYS "VBIND"
|
||
JSR PC,.STORE ;STORE NEW BINDING AWAY
|
||
MOV @P,B
|
||
BIT #7777,B
|
||
BNE PEV1 ;GO DO NEXT ARG
|
||
SPOP C ;USED LLP POINTER
|
||
PEV2: SPOP C ;PTR TO LLP THAT WAS SAVED WAY ABOVE
|
||
SPUSH CSPDLP
|
||
MOV S,CSPDLP
|
||
SUB SPRBAO,CSPDLP ;SPECIAL PDL RELATIVE BASE ADDR OFFSET
|
||
SPUSH CPDLP
|
||
MOV P,CPDLP
|
||
SUB PRBAO,CPDLP ;PDL RELATIVE BASE ADDR OFFSET
|
||
BIS #100000,CPDLP ;TO INDICATE PROC PUSH AS OPPOSED TO A LOCAL PUSH
|
||
MOV CO+2,CPP
|
||
CLR CLN
|
||
MOV C,CLP
|
||
MOV CPP,B ;GET CPSN IN A
|
||
JSR PC,GNASN
|
||
EVBUG
|
||
HALT
|
||
MOV A,CPSN
|
||
CLR CO
|
||
CLR CO+2
|
||
CLR IFLEV
|
||
INC FUNLEV
|
||
JMP MLOOP
|
||
PEV3: MOV #VBIND,A
|
||
CLR B
|
||
JSR PC,GRBAD1
|
||
BR PEV4
|
||
PUSHSN: TST B ;PUSH (B) EMPTY WORDS ONTO S
|
||
BGT .+4
|
||
RTS PC
|
||
PSN1: PUSHS #0
|
||
DEC B
|
||
BGT PSN1
|
||
RTS PC
|
||
PUSHN: TST B ;PUSH (B) EMPTY WORDS ON P
|
||
BGT .+4
|
||
RTS PC
|
||
MOV @P,TEMP
|
||
PN1: PUSH #0
|
||
DEC B
|
||
BGT PN1
|
||
JMP @TEMP
|
||
TINDNT: PUSH A ;TRACE INDENT
|
||
PRCR
|
||
MOV FUNLEV,A
|
||
TIND2: DEC A
|
||
BGT TIND1
|
||
JMP RETA
|
||
TIND1: SPACE
|
||
BR TIND2
|
||
.STITL PROC EVAL - "OUTPUT" "STOP"
|
||
PSTP30: ERROR+OIP ;ONLY IN PROCEDURE
|
||
PSTP35: JMP PSTP33
|
||
PSTP31: MOV #VBIND,A
|
||
POPS B
|
||
TST B ;IF OLD BINDING EMPTY, DONT BOTHER
|
||
BEQ PSTP35
|
||
JSR PC,GRBAD1
|
||
BR PSTP32
|
||
OUTPUT: TST FUNLEV
|
||
BLE PSTP30
|
||
MOV #ORT,PSTOPR ;"OUTPUT"
|
||
POPS TOPS1 ;SAVE THE OUTPUT
|
||
BR PSTP10
|
||
STOP:
|
||
PSTOP: TST FUNLEV
|
||
BLE PSTP30
|
||
MOV #NORT,PSTOPR ;"STOP" AND "END"
|
||
CLR TOPS1
|
||
PSTP10: BIT #TPTF,FLAGS
|
||
BEQ PSTP14
|
||
JSR PC,TINDNT
|
||
MOV CPP,B
|
||
JSR PC,PPNAME
|
||
MOV TOPS1,B
|
||
BEQ PSTP13
|
||
PRTXT ^\ OUTPUTS \
|
||
JSR PC,PNODAB ;USES A
|
||
SPACE
|
||
BR PSTP14
|
||
PSTP13: PRTXT ^\ STOPS.\
|
||
PSTP14: ADD #12,P ;TO GET BACK IN PHASE
|
||
MOV CPDLP,A
|
||
BIC #TF3,TFLAGS ;SAVE MODE OF PROC/LOCAL PUSH FLAG
|
||
BIT #100000,A
|
||
BEQ .+10
|
||
BIS #TF3,TFLAGS
|
||
BIC #100000,A
|
||
BEQ .+6
|
||
BIS #100000,A
|
||
ADD PRBAO,A
|
||
PSTP11: CMP A,P
|
||
BEQ PSTOP1
|
||
BGT .+4
|
||
HALT ;PDL SCREWED
|
||
POP B
|
||
BR PSTP11
|
||
PSTOP1: POP CPDLP ;RESTORE OLD CPDLP
|
||
MOV CSPDLP,A
|
||
ADD SPRBAO,A
|
||
PSTP21: CMP A,S
|
||
BEQ PSTOP2
|
||
BGT .+4
|
||
HALT ;SPECIAL PDL OUT OF PHASE
|
||
POPS B
|
||
BR PSTP21
|
||
PSTOP2: SPOP CSPDLP ;RESTORE OLD CSPDLP
|
||
SPOP D ;# ARGS SAVED
|
||
BEQ PSTOP4 ;NO ARGS
|
||
PSTOP3: POPS B ;GET NEXT UOE PTR
|
||
JSR PC,.BNDVN ;GET VARIB BINDING PTR
|
||
BR PSTP31 ;NONE THERE
|
||
BIT #100000,A ;IS IT SWAPPED OUT
|
||
BEQ .+6 ;NO
|
||
JSR PC,DSVB ;YES, DELETE SWAPPED VARIB
|
||
POPS B ;GET OLD VARIB BINDING
|
||
BIC #100000,A
|
||
PSTP32: TST B ;IF OLD PTR 0, SKIP SWAPPED TEST
|
||
BEQ PSTP34
|
||
BIT #170000,B ;IS OLD BINDING SWAPPED
|
||
BNE PSTP34
|
||
BIS #100000,A ;YES
|
||
PSTP34: JSR PC,.STORE ;RESTORE OLD BINDING
|
||
PSTP33: DEC D
|
||
BGT PSTOP3
|
||
PSTOP4: BIT #TF3,TFLAGS ;WAS IT A LOCAL PUSH OR PROC PUSH
|
||
BEQ PSTOP ;LOCAL
|
||
CMP #ORT,PSTOPR ;WAS IT "OUTPUT"
|
||
BNE PSTP42 ;NO
|
||
PUSHS TOPS1 ;PUT THE OUTPUT BACK ON S
|
||
CLR TOPS
|
||
PSTP42: POP IFLEV ;PROC, RESTORE REST OF WORLD
|
||
SPOP CO+2
|
||
SPOP CO
|
||
SPOP FLAGS
|
||
SPOP CTP
|
||
SPOP CTN
|
||
SPOP CLGN
|
||
POP CLP
|
||
SPOP CLN
|
||
SPOP CPSN
|
||
SPOP CPP
|
||
DEC FUNLEV ;IF AT TOP LEVEL, ALMOST DONE!
|
||
BLE PSTOP9
|
||
MOV CPP,B
|
||
JSR PC,.BINDF ;MAKE SURE PROC IS IN
|
||
ERROR+PNH ;PROCEDURE ... NOT HERE
|
||
MOV CPP,B ;SEE IF PROC'S CPSN AGREE
|
||
JSR PC,GNASN ;GET CPSN
|
||
EVBUG ;IMPOSSIBLE!!!
|
||
HALT
|
||
MOV CLP,C
|
||
BIS #TF3,TFLAGS
|
||
CMP A,CPSN
|
||
BEQ PSTP41 ;OK
|
||
BIC #TF3,TFLAGS
|
||
MOV CLN,B ;DON'T AGREE, GO RELOCATE LINE WE WERE IN
|
||
JSR PC,GTLINE
|
||
BR PSTOP5 ;LINE NOT THERE
|
||
PSTP41: MOV C,CLP
|
||
JSR PC,.LOADC ;GET LLP NODE
|
||
JSR PC,.LOAD ;GET LINE #
|
||
MOV A,C
|
||
JSR PC,.LOADC ;GET NEXT NODE-SEE IF SNUM (I.E. GEN NO.)
|
||
BIC #7777,A
|
||
CMP #SNUM,A
|
||
BEQ .+4
|
||
CLR B ;NOT SNUM, SO SET GEN NO. TO 0
|
||
CMP B,CLGN ;ARE GEN #'S =?
|
||
BEQ .+4
|
||
PSTOP5: ERROR+LCE ;NO, LINE CHANGED BY EDIT
|
||
BIT #TF3,TFLAGS ;IF PROC WASNT SWAPPED
|
||
BEQ PSTOP8 ;THEN CTP IS GOOD
|
||
PSTOP9: CLR D
|
||
MOV CTP,C
|
||
BR PSTOP6
|
||
PSTOP8: MOV CTN,D ;OK, NOW GET NODE NO.
|
||
TST B ;IF B > 0, WE WERE LOOKING GEN NO.
|
||
BEQ PSTOP6
|
||
JSR PC,.LDP1
|
||
PSTOP7: MOV A,C
|
||
PSTOP6: JSR PC,.LOADC
|
||
DEC D
|
||
BGT PSTOP7
|
||
MOV C,CTP
|
||
MOV A,CT
|
||
MOV B,CT+2
|
||
JMP @PSTOPR
|
||
.STITL "TO" ETC.
|
||
EDIT: BIS #EDITF,FLAGS
|
||
BR .+10
|
||
TO: BIC #EDITF,FLAGS
|
||
TST TOPRNM
|
||
BEQ TO8
|
||
ERROR+CTIT ;CANT "TO" IN TO
|
||
TO8: JSR PC,GNT
|
||
BIC #7777,A
|
||
CMP #UFUN,A
|
||
BEQ TO1
|
||
CMP #ATOM,A
|
||
BEQ TO1
|
||
MOV B,TOPS ;FOR .INTRN
|
||
CMP #LSTR,A
|
||
BNE TO2
|
||
JSR PC,.INTRN
|
||
BR TO1
|
||
TO1: MOV B,TOPRNM
|
||
CLR TOPS
|
||
JSR PC,.BINDF
|
||
BR TO6
|
||
MOV B,FNLLP
|
||
BIT #EDITF,FLAGS ;IS IT "EDIT"?
|
||
BNE TO5 ;YES
|
||
ERROR+PAE ;PROCEDURE ALREADY EXISTS
|
||
TO7: MOV CT,TOPS
|
||
TO3: JSR PC,GNT
|
||
BIT #CRF,FLAGS
|
||
BNE TO4 ;DONE
|
||
BIC #7777,A
|
||
CMP #UVAR,A
|
||
BEQ TO3
|
||
ERROR+WIT ;WRONG TYPE OF INPUT TO "TO"
|
||
TO4: MOV #UFUN,A
|
||
MOV A,B
|
||
JSR PC,GRBAD1 ;THE UFUN BINDING NODE
|
||
MOV #LIST,A
|
||
MOV A,B
|
||
JSR PC,GRBAD2 ;FIRST NODE IN LLP
|
||
MOV C,FNLLP
|
||
MOV TOPS,C ;PTR TO REST OF LINE
|
||
CLR TOPS
|
||
JSR PC,CLE ;COUNT 'EM
|
||
MOV C,A
|
||
BIC #170000,A
|
||
BIS #SNUM,A
|
||
MOV FNLLP,C
|
||
JSR PC,GRBAD2 ;FIRST NODE OF LINE 0 (ARG LINE)
|
||
MOV B,D
|
||
MOV TOPRNM,B
|
||
JSR PC,.BNDFS ;GET SWAPPED FUNC BINDING NODE FOR THIS PROC
|
||
BR END1 ;NOT THERE
|
||
MOV B,C ;PTR TO LIST OF GOODIES
|
||
JSR PC,.LDP2 ;ALL THIS TO PRESERVE "TRACED" FLAG
|
||
BIC #377,A
|
||
ADD D,A ;#ARGS FROM ABOVE
|
||
JSR PC,.STP2 ;STORE # ARGS IN FIRST NODE
|
||
JSR PC,.LOADC ;TO GET ADDR OF NEXT NODE
|
||
MOV A,C
|
||
JSR PC,.LDP2
|
||
INC A
|
||
JSR PC,.STP2 ;GET, INC AND STORE BACK CPSN
|
||
BR TO5
|
||
END1: MOV #LNUM,B ;CREATE S. F. B. NODE STUFF
|
||
JSR PC,GRBAD1
|
||
MOV #SNUM,A
|
||
MOV D,B ;# ARGS FROM ABOVE
|
||
JSR PC,GRBAD2 ; - # ARGS NODE
|
||
CLR B
|
||
JSR PC,GRBAD1 ; - CPSN NODE (START CPSN AT 0)
|
||
TO5: MOV #'>,PRMTCH
|
||
JMP NORT
|
||
TO2: ERROR+ILN ;INVALID LOGO NAME
|
||
TO6: BIT #EDITF,FLAGS ;IS IT "EDIT"
|
||
BEQ TO7 ;NO
|
||
ERROR+PNH ;YES, PROCEDUTE NOT HERE
|
||
GO: JSR PC,G1NARG
|
||
MOV B,CLN
|
||
CLR CLP
|
||
JMP NORT
|
||
TOLN: PUSH A ;TOKEN
|
||
SPUSH B ;LIST ON S
|
||
MOV @S,B
|
||
JSR PC,.LOAD
|
||
BIC #7777,A
|
||
CMP #SNUM,A ;IS FIRST THING A NUMBER
|
||
BNE TOLN1 ;NO
|
||
JSR PC,ADLN ;ADD LINE-LINE IS ON S
|
||
;FNLLP POINTS TO FIRST NODE OF LIST OF LINE POINTERS
|
||
TOLN2: POPS A ;FINISHED WITH LINE
|
||
JMP RETB
|
||
TOLN1: CMP #$END,B
|
||
BEQ END
|
||
PRTXT ^\NO DIRECT WITHIN TO DEF YET.\
|
||
BR TOLN2
|
||
END: MOV TOPRNM,B
|
||
BEQ END2
|
||
JSR PC,PPNAME
|
||
PRTXT ^\ DEFINED\
|
||
PRCR
|
||
CLR TOPRNM
|
||
MOV #'?,PRMTCH
|
||
END2: JMP NORT
|
||
.STITL UTILITY - COUNT LIST ELEMENTS
|
||
CLE: ;COUNT LIST ELEMENTS
|
||
;IN - LIST PTR IN C
|
||
;OUT - # OF ELEMENTS IN B
|
||
PUSH A
|
||
SPUSH C
|
||
CLR B
|
||
MOV C,A
|
||
CLE1: BIT #7777,A
|
||
BEQ CLE2
|
||
MOV A,C
|
||
JSR PC,.LDP1
|
||
INC B
|
||
BR CLE1
|
||
CLE2: POP C
|
||
SPOP A
|
||
RTS PC
|
||
ADLN: ;ON S IS A "NEW LINE" INSERT IN PROPER PLACE
|
||
;IN LLP POINTED TO BY FNLLP.
|
||
PUSH A
|
||
SPUSH B
|
||
SPUSH C
|
||
SPUSH D
|
||
SPUSH E
|
||
SPUSH F
|
||
MOV @S,C
|
||
JSR PC,.LOADC
|
||
MOV B,F
|
||
MOV FNLLP,C
|
||
MOV C,D
|
||
JSR PC,.LOADC
|
||
MOV A,C
|
||
;LOOK DOWN LLP FOR LINE #(@P)
|
||
ADLN1: MOV D,E ;SAVE PTR TO PREDECESSOR IN E
|
||
MOV C,D ;SAVE PTR TO CURRENT IN D
|
||
MOV #LIST,A
|
||
BIT #7777,C
|
||
BEQ ADLN2 ;AT END, ADD NEW NODE
|
||
JSR PC,.LOADC
|
||
MOV A,C ;SAVE PTR TO SUCCESSOR IN C
|
||
JSR PC,.LOAD
|
||
CMP B,F
|
||
BLT ADLN1 ;NOT THERE YET
|
||
BEQ ADLN3 ;FOUND LINE
|
||
MOV D,A ;PASSED IT, INSERT NEW LINE
|
||
ADLN2: MOV @S,B ;ADD NEW NODE TO END
|
||
MOV E,C
|
||
JSR PC,GRBAD1
|
||
ADLN5: JMP RETF
|
||
ADLN3: ;FOUND LINE #.REPLACE THEN CHECK GEN. NO.
|
||
MOV A,E ;SAVE A, POINT TO FIRST TOKEN IN OLD LINE
|
||
MOV @S,A
|
||
MOV D,C ;D POINTS TO RELEVENT LLP NODE
|
||
JSR PC,.STP2 ;STORE LINK TO NEW LINE
|
||
TST FUNLEV ;IF AT FUNLEV 0, DON'T BOTHER WITH GEN #
|
||
BEQ ADLN5
|
||
MOV E,C ;E POINTS TO OLD LINE
|
||
JSR PC,.LOAD ;GET NEXT NODE IN OLD LINE(1ST TOKEN OR GEN )
|
||
BIC #7777,A
|
||
CMP #SNUM,A
|
||
BEQ ADLN4
|
||
CLR B
|
||
ADLN4: INC B ;ALREADY HAS GEN NO.
|
||
MOV @S,C
|
||
JSR PC,.LDP1
|
||
BIC #170000,A
|
||
BIS #SNUM,A
|
||
JSR PC,GRBAD1
|
||
BR ADLN5
|
||
GTLINE: ;GET LLP POINTER OF LINE WHOSE NO. IS IN B
|
||
;FOR PROCEDURE PONTED TO BY "CPP"
|
||
;OUTPUT - LLP PTR WILL BE IN C AND WILL SKIP
|
||
BIS #TF1,TFLAGS
|
||
BR .+10
|
||
GNLINE: ;SAME EXCEPT LOOKING FOR LINE WHOSE # IS > # IN B
|
||
BIC #TF1,TFLAGS
|
||
PUSH A
|
||
SPUSH B
|
||
SPUSH C
|
||
SPUSH D
|
||
SPUSH E
|
||
MOV B,D
|
||
MOV CPP,B
|
||
JSR PC,.BINDF ;LOOK FOR PROC BINDING
|
||
EVBUG ;WHAT NO PROC BINDING??!!
|
||
HALT
|
||
MOV B,C
|
||
JSR PC,.LDP2I
|
||
MOV C,E
|
||
GNL1: BIT #7777,E
|
||
BEQ GNL4 ;NONE LEFT
|
||
MOV E,C
|
||
JSR PC,.LOADC ;GET NEXT NODE IN LLP
|
||
MOV A,E
|
||
JSR PC,.LOAD ;GET FIRST NODE OF THAT LINE
|
||
CMP B,D
|
||
BLT GNL1 ;NOT THERE YET
|
||
BEQ GNL2 ;FOUND IT
|
||
BIT #TF1,TFLAGS ;WENT PAST, WERE WE LOOKING FOR IT?
|
||
BEQ GNL3 ;NO, OK
|
||
GNL4: JMP RETE ;YES "NO SUCH LINE NO."
|
||
GNL2: BIT #TF1,TFLAGS ;FOUND IT, LOOKING FOR IT?
|
||
BEQ GNL1 ;NO, GET NEXT
|
||
GNL3: MOV C,4(P) ;OUTPUT (C) INTO C
|
||
JMP SRETE
|
||
GNASN: ;GET NO. OF ARGS AND CPSN OF USER PROC
|
||
;IN: PROC PTR IN B
|
||
;OUTPUT: CPSN IN A # IN B
|
||
;DONT SKIP IF NO PROC
|
||
PUSH A
|
||
SPUSH B
|
||
SPUSH C
|
||
JSR PC,.BNDFS
|
||
JMP RETC
|
||
JSR PC,.LOAD
|
||
MOV B,2(P) ;# IN OLD B
|
||
JSR PC,.LOAD
|
||
MOV B,4(P) ;CPSN IN OLD A
|
||
JMP SRETC
|
||
.STITL UTILITY - LOAD AND STORE
|
||
.LOADC: MOV C,B ;NODE ADDR IN C
|
||
;NODE RETURNED IN A,B
|
||
.LOAD: BIC #170000,B ;NODE ADDR IN B
|
||
ASL B ;NODE RETURNED IN A,B
|
||
ASL B
|
||
ADD UAB,B
|
||
MOV (B)+,A
|
||
MOV @B,B
|
||
RTS PC
|
||
.STORE: SPUSH C ;NODE ADDR IN C
|
||
BIC #170000,C
|
||
ASL C ;NODE IN A,B IS STORED AT C
|
||
ASL C
|
||
ADD UAB,C
|
||
MOV A,(C)+
|
||
MOV B,@C
|
||
SPOP C
|
||
RTS PC
|
||
|
||
.STP2: ;SAME AS .STP1 EXCEPT STORE IN 2ND WORD OF NODE
|
||
SEC ;THEN RESULT OF ROL'S WILL BE TWO GREATER THAN .STP1
|
||
BR .+4
|
||
.STP1: CLC ;STORE (A) IN FIRST WORD OF NODE AT C
|
||
SPUSH C ;NODE ADDR IN C
|
||
BIC #170000,C
|
||
ROL C
|
||
ROL C
|
||
ADD UAB,C
|
||
MOV A,@C
|
||
SPOP C
|
||
RTS PC
|
||
|
||
.LDP2: SEC ;NODE ADDR IN C (TYPE FIELD =0)
|
||
BR .+4 ;LOAD 2ND WORD OF NODE INTO A
|
||
.LDP1: CLC ;SAME AS .LDP2 EXCEPT 1ST WORD
|
||
MOV C,A
|
||
BIC #170000,A
|
||
ROL A
|
||
ROL A
|
||
ADD UAB,A
|
||
MOV @A,A
|
||
RTS PC
|
||
|
||
.LDP2I: MOV C,A ;SAME AS .LDP2 EXCEPT C WILL
|
||
BIC #170000,A ;CONTAIN ADDR OF NEXT NODE
|
||
ASL A
|
||
ASL A
|
||
ADD UAB,A
|
||
MOV (A)+,C
|
||
MOV @A,A
|
||
RTS PC
|
||
.STITL UTILITY - BINDING
|
||
;INPUT: A=TYPE B=UOE POINTER
|
||
; TOPS=0 OR TYPE+VALUE POINTER
|
||
;OUTPUT: A - UCHANGED
|
||
; B - EITHER UNCHANGED OR VALUE POINTER
|
||
; C - POINTS TO BINDING NODE, EITHER
|
||
; RELEVANT ONE OR LAST IN BINDING LIST
|
||
; IF TOPS = 0, SKIPS IF BINDING FOUND
|
||
; IF TOPS NOT = 0, TOPS WILL BE INSERTED
|
||
; AS THE NEW VALUE POINTER (A NEW BINDING
|
||
; NODE WILL BE ADDED IF NECESSARY) NEVER SKIPS.
|
||
.BINDL: TST TOPS
|
||
BEQ .BIND
|
||
PUSHS TOPS
|
||
CLR TOPS
|
||
.BIND: PUSH D
|
||
SPUSH B
|
||
SPUSH A
|
||
BINDF1: MOV B,C
|
||
JSR PC,.LOADC
|
||
MOV A,D
|
||
BIC #7777,D
|
||
CMP @P,D
|
||
BEQ BINDF4 ;FOUND IT
|
||
MOV A,B
|
||
BIT #7777,A
|
||
BNE BINDF1
|
||
TST TOPS ;DIDNT FIND IT
|
||
BEQ BINDF2 ;SHOULD ONE BE CREATED?
|
||
SPOP A
|
||
MOV TOPS,B
|
||
JSR PC,GRBAD1
|
||
BINDF5: POP D ;OLD B
|
||
BINDF3: SPOP D
|
||
RTS PC
|
||
BINDF2: POP A ;NO, DONT CREATE NODE
|
||
SPOP B
|
||
BR BINDF3
|
||
BINDF4: TST TOPS ;FOUND, CHANGE VALUE POINTER?
|
||
BEQ BINDF6
|
||
MOV TOPS,A ;YES + DONT SKIP
|
||
JSR PC,.STP2
|
||
POP A
|
||
BR BINDF5
|
||
BINDF6: POP A ;NO, LEAVE VALUE POINTER, BUT SKIP
|
||
POP D ;OLD B
|
||
POP D
|
||
JMP SRET
|
||
.BINDF: MOV #FBIND,A ;GET FUNCTION BINDING, SWAP IN IF NECESSARY
|
||
;PTR TO UOE IN B
|
||
;OUTPUT AS IN .BIND: EXCEPT A = #FBIND
|
||
JSR PC,.BINDL ;LOOK FOR FUNCTION BINDING
|
||
BR BIF1 ;NOT THERE
|
||
JMP SRET
|
||
BIF1: MOV #SFBIND,A ;OK, THEN, LOOK FOR SWAPPED FUNCTION BINDING
|
||
JSR PC,.BINDL
|
||
RTS PC ;PROC NOT DEFINED
|
||
JSR PC,PSWPIN ;GO GET IT
|
||
JMP SRET
|
||
.BNDVS: ;GET VARIABLE BINDING, SWAPIN IF NECESSARY
|
||
;INPUT AND OUTPUT SIMILAR TO .BINDF
|
||
BIS #TF2,TFLAGS
|
||
BR .+10
|
||
.BNDVN: ;SAME AS ABOVE EXCEPT DONT SWAP
|
||
BIC #TF2,TFLAGS
|
||
MOV #VBIND,A
|
||
JSR PC,.BINDL ;LOOK FOR BINDING
|
||
BR BIV1 ;NOPE
|
||
JMP SRET ;FOUND IT
|
||
BIV1: MOV #SVBIND,A ;LOOK FOR SWAPPED BINDING
|
||
JSR PC,.BINDL
|
||
RTS PC ;LOSE AGAIN - UNDEFINED
|
||
BIT #TF2,TFLAGS ;FOUND IT, SWAP IT IN?
|
||
BEQ .+6
|
||
JSR PC,VSWPIN ;YES
|
||
JMP SRET
|
||
.BNDFS: MOV #SFBIND,A ;LOOK FOR SWAPPED FUNCTION BINDING
|
||
JSR PC,.BINDL
|
||
RTS PC
|
||
JMP SRET
|
||
.STITL .INTRN!!
|
||
.OBSCH: ;SAME AS .INTRN EXCEPT WONT INSERT IF ENTRY ISNT FOUND
|
||
;(ALSO SEE UOBSCH ON NEXT PAGE)
|
||
BIC #TF5,TFLAGS
|
||
BR .+10
|
||
.INTRN: ;(ALSO SEE UINTRN ON NEXT PAGE)
|
||
;INPUT: TYPE IN A, LSTR IN "TOPS"
|
||
;OUTPUT: IF TYPE IS UFUN OR SFUN, SEARCH SYSTEM OBLIST FIRST.
|
||
; IF FOUND THERE, RETURN THAT PTR IN B, MAKING TYPE OF A
|
||
; TO "SFUN". IF NOT FOUND THERE, AND IF A=UFUN, OR IF TYPE
|
||
; IS > "UFUN", DO THE LOOKUP IN THE USER OBLIST.
|
||
; RETURN WITH THE UOE PTR IN B. DONT SKIP IF A NEW ONE
|
||
; HAD TO BE ADDED.
|
||
BIS #TF5,TFLAGS
|
||
PUSH A
|
||
SPUSH B
|
||
SPUSH C
|
||
MOV TOPS,C
|
||
CMP #UFUN,A ;IS TYPE SFUN OR UFUN
|
||
BLO INT2 ;NO
|
||
JSR PC,SSOL ;YES, SEARCH SYSTEM OBLIST
|
||
BR INT1 ;NOT THERE
|
||
CLR A ;SET A TO TYPE "SFUN" (=0)
|
||
MOV A,4(P)
|
||
BR INT5
|
||
INT1: TST A ;IS A = TYPE SFUN
|
||
BEQ INT0 ;YES, DONE, DONT SKIP
|
||
INT2: JSR PC,HSSL ;NO, HASH TO AND SEARCH SUBLIST
|
||
BR INT3
|
||
MOV @B,B
|
||
JSR PC,.LOAD ;GET UOE PTR
|
||
INT5: MOV B,2(P)
|
||
JMP SRETC ;FOUND IT
|
||
INT3: BIT #TF5,TFLAGS ;NOT THERE, SHOULD IT BE ADDED
|
||
BEQ INT0 ;NO, RETURN AND DONT SKIP
|
||
JSR PC,.GRAB ;YES
|
||
MOV @B,A
|
||
MOV C,@B ;UPDATE BUCKET POINTER
|
||
JSR PC,.GRAB
|
||
MOV C,2(P) ;NEW UOE PTR
|
||
MOV @B,C
|
||
MOV 2(P),B
|
||
JSR PC,.STORE
|
||
MOV B,C
|
||
MOV #ATOM,A
|
||
MOV TOPS,B
|
||
JSR PC,.STORE
|
||
INT0: JMP RETC
|
||
|
||
|
||
;"UNPURE" .INTRN AND .OBSCH
|
||
;BY "UNPURE" IT IS MEANT THAT THE INPUT STRING MAY INCLUDE
|
||
;NULL CHARACTERS
|
||
;SPECIFICATIONS ARE OTHERWISE IDENTICAL TO .INTRN AND .OBSCH
|
||
UOBSCH: MOV #<UOBCON-UINCON>,-(SP)
|
||
BR UINOB
|
||
|
||
UINTRN: CLR -(SP)
|
||
UINOB: PUSH A
|
||
PUSH B
|
||
PUSH C
|
||
MOV TOPS,B
|
||
JSR PC,CPYSTR ;OUTPUT POINTER IN B TO STRINWITH NO NULLS
|
||
MOV B,TOPS
|
||
POP C
|
||
POP B
|
||
POP A
|
||
|
||
ADD (SP)+,PC
|
||
UINCON: JSR PC,.INTRN ;CONTINUES HERE IF UINTRN
|
||
RTS PC ;THE PURE STRING WAS ADDED BY .INTRN
|
||
UOBSKP: JSR PC,FRELST ;PURE LIST NOT ADDED. FREE IT
|
||
SKPRET
|
||
|
||
UOBCON: JSR PC,.OBSCH ;CONTINUES HERE IF UOBSCH
|
||
JMP FRELST ;FREE PURE STRING AND DON'T SKIP RETURN
|
||
BR UOBSKP ;FREE IT AND SKIP
|
||
SSOL: ;SEARCH SYSTEM OBLIST
|
||
;INPUT: C POINTS TO STRING
|
||
;OUTPUT: SKIP = FOUND AND SOE PTR IN B
|
||
; NO SKIP = NOT FOUND AND NO CHANGE
|
||
;NULL MUST BE USED AS FILLER CHAR BUT NOT BE IMBEDDED
|
||
PUSH A
|
||
SPUSH B
|
||
SPUSH C
|
||
SPUSH D
|
||
SPUSH E
|
||
SPUSH F
|
||
JSR PC,.LOADC
|
||
MOV B,D
|
||
SPUSH A
|
||
MOV SOBP2,E
|
||
MOV #SOBLST,F
|
||
SSOL1: ASR E
|
||
BIT #177776,E
|
||
BEQ SSOL5
|
||
ADD E,F
|
||
CMP F,SOOMX
|
||
BHIS SSOL2
|
||
MOV @F,B
|
||
ADD #4,B
|
||
MOV @P,C
|
||
MOV D,A
|
||
BR SSOL6
|
||
SSOL4: JSR PC,.LDP2I
|
||
SSOL6: CMPB A,(B)+
|
||
BHI SSOL1
|
||
BLO SSOL2
|
||
SWAB A
|
||
CMPB A,(B)+
|
||
BHI SSOL1
|
||
BLO SSOL2
|
||
BIT #7777,C
|
||
BNE SSOL4
|
||
TSTB (B) ;AT END OF STRING, IS IT END OF SYS PNAME
|
||
BEQ SSOL3 ;YES
|
||
TSTB -1(B) ;NO, BUT CHECK IF PREV CHAR WAS TERMINATOR
|
||
BNE SSOL2
|
||
SSOL3: SPOP A
|
||
MOV @F,10(P) ;YES, SAVE F AS OUTPUT
|
||
JMP SRETF
|
||
SSOL5: SPOP A
|
||
JMP RETF
|
||
SSOL2: SUB E,F
|
||
BR SSOL1
|
||
HSSL: ;HASH, THEN SEARCH SUB-LIST
|
||
;INPUT: C POINTS TO LSTR
|
||
;OUTPUT: B POINTS TO SUBLIST PTR. RELEVANT ENTRY WILL
|
||
; WILL BE AT HEAD OF SUBLIST. SKIPS IF ONE FOUND.
|
||
PUSH A
|
||
SPUSH B
|
||
SPUSH C
|
||
SPUSH D
|
||
SPUSH E
|
||
SPUSH F
|
||
JSR PC,.LOADC ;GET FIRST CHARS INTO B
|
||
MOV B,D
|
||
MOV A,E ;PTR TO REST OF ARG
|
||
MOV #MQ,A
|
||
MOV B,(A)
|
||
CLR -(A) ;DIVIDEND IS 0,,(B)
|
||
MOV #HCC,-(A) ;DIVIDE BY HASH CODE CONSTANT
|
||
TST (A)+
|
||
MOV (A),B ;GET REMAINDER
|
||
ROL B
|
||
ADD SUHCT,B
|
||
MOV B,10(P) ;FOR OUTPUT
|
||
MOV @B,F
|
||
BEQ HSSL6 ;NO ENTRYS IN THIS BUCKET
|
||
MOV F,C
|
||
SPUSH C
|
||
HSSL1: JSR PC,.LOADC ;GET NEXT SUBLIST NODE
|
||
MOV A,@P
|
||
JSR PC,.LOAD ;GET UOE PNAME NODE
|
||
JSR PC,.LOAD ;GET FIRST NODE OF PNAME
|
||
CMP B,D ;ARE THE FIRST 2 CHAR =
|
||
BNE HSSL2 ;NO
|
||
PUSHS A ;YES, COMPARE REST OF STRING
|
||
SPUSHS E
|
||
JSR PC,CSEQ
|
||
BR HSSL2 ;NOT EQUAL
|
||
HSSL3: CMP F,C ;IF F = C, THEN LOCATED UOE WAS FIRST SO DONE
|
||
BNE HSSL4
|
||
SPOP A
|
||
HSSL5: JMP SRETF
|
||
HSSL2: MOV C,F ;NOPE, SAVE THIS PTR FOR PREDECESSOR
|
||
MOV @P,C ;GET SAVED PTR TO NEXT SUBLIST NODE
|
||
BIT #7777,C
|
||
BNE HSSL1
|
||
POP A
|
||
HSSL6: JMP RETF
|
||
HSSL4: MOV @12(P),A ;MOVE ENTRY TO HEAD OF BUCKET
|
||
JSR PC,.STP1 ;NEW TOP NOW PIONTS TO OLD TOP
|
||
MOV C,@12(P) ;UHCT ENTRY NOW POINTS TO NEW TOP
|
||
MOV F,C
|
||
SPOP A
|
||
JSR PC,.STP1 ;NEW TOP'S OLD PREDECESSOR NOW LINKED TO ITS SUC.
|
||
BR HSSL5
|
||
WIPOBS: RTS PC ;WIPE WIPERS FROM OBLIST
|
||
.STITL MINI SWAPPING
|
||
PSWPIN: HALT
|
||
PSWPOT: HALT
|
||
VSWPIN: HALT
|
||
VSWPOT: HALT
|
||
DSVB: HALT ;DELETE SWAPPED VARIABLE BINDING
|
||
.STITL UTILITY - GRAB NODE ROUTINES
|
||
.GRAB: PUSH A ;GRAB A FREE NODE - PTR IN C; CLEAR IT
|
||
SPUSH B
|
||
CLR A
|
||
CLR B
|
||
JSR PC,GRBAD
|
||
JMP RETB
|
||
GRBAD2: SEC ;GRAB A FREE NODE, FILL IT WITH A,,B
|
||
;IF C NOT =0, PUT PTR TO NEW NODE IN WORD 2 OF NODE(C)
|
||
BR .+6
|
||
GRBAD: CLR C ;SAME AS ABOVE EXCEPT NEW POINTER ALWAYS IN C
|
||
GRBAD1: CLC ;SAME AS ABOVE EXCEPT NEW PTR IN WORD 1
|
||
SPUSH A
|
||
BIC #170000,C
|
||
BEQ GRB2 ;C IS ZERO, FORGET STORING NEW NODE PTR
|
||
ROL C
|
||
ROL C
|
||
ADD UAB,C
|
||
GRB2: MOV UNGRAB,A
|
||
BNE GRB1
|
||
MOV FREE,A
|
||
BNE GRB1
|
||
JSR PC,.GCOLL
|
||
MOV FREE,A
|
||
BNE GRB1
|
||
ERROR+NSL ;NO STORAGE LEFT
|
||
GRB1: CLR UNGRAB
|
||
TST C
|
||
BEQ GRB3
|
||
BIC #170000,A
|
||
BIC #7777,@C
|
||
ADD A,@C
|
||
GRB3: MOV A,C
|
||
JSR PC,.LDP1
|
||
BIC #170000,A
|
||
MOV A,FREE
|
||
SPOP A
|
||
JSR PC,.STORE
|
||
RTS PC
|
||
;.STITL UTILITY - FREE NODE ROUTINES
|
||
.FREE: SPUSH A ;RETURN NODE IN C TO FREE STORAGE
|
||
MOV FREE,A
|
||
JSR PC,.STP1
|
||
BIC #170000,C
|
||
MOV C,FREE
|
||
SPOP A
|
||
RTS PC
|
||
FRELST: TST TOPS
|
||
BNE .+4
|
||
RTS PC
|
||
PUSH A ;RETURN LIST IN TOPS TO FREE STORAGE
|
||
SPUSH B
|
||
SPUSH C
|
||
MOV TOPS,C
|
||
FRL1: JSR PC,.LOADC
|
||
BIT #7777,A
|
||
BEQ FRL2
|
||
MOV A,C
|
||
BR FRL1
|
||
FRL2: ADD FREE,A
|
||
JSR PC,.STORE
|
||
MOV TOPS,FREE
|
||
BIC #170000,FREE
|
||
CLR TOPS
|
||
JMP RETC
|
||
|