.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