Google
 

Trailing-Edge - PDP-10 Archives - decuslib10-04 - 43,50361/forth.mac
There is 1 other file named forth.mac in the archive. Click here to see a list.
;		FORTH PROGRAMMING SYSTEM

;Martin S. Ewing, California Institute of Technology,
;Pasadena, CA 91125	213-795-6811

;12/17/77 - REG 16 FREED FOR FORTRAN.
;12/17/77 - RP/IC REG ASSIGNMENTS SWITCHED.
;12/16/77 - ADD SIN,COS,... EXTERNALS TO FORTRAN LIBRARY.
;		(MUST NOW USE DUMMY FORTRAN RTN OR MACRO RTN TO LOAD!)
;08/28/77 - ADD "INTERPRET" FOR IN-CORE INTERPRETING.
;03/27/77 - ADD "FORSYS" "NOFORSYS" TO ALLOW SYSTEMS WITHOUT FORSYS.DAT.
;02/21/77 - WORDS "WOPEN", "WCLOSE" ENABLE OPENING BLOCK I/O FOR OUTPUT.
;12/31/76 - MAKE FORSYS.DAT READ ONLY UNTIL FLUSH TIME.
;12/12/76 - FIX UP 'CORE' WORD: TAKE # OF KWDS ON STACK.

	RADIX 8
	TITLE FORTH PROGRAMMING SYSTEM
	SUBTTL ASSEMBLY PARAMETERS

	.DIRECTIVE	FLBLST	;FIRST LINE BINARY LIST ONLY
SALL
..FORT==0	;IF DEFINED, INCLUDES FORTRAN LIBRARY RTNS

IFDEF ..FORT <
EXTERN SIN.,COS.,SQRT.,ATAN.,ATAN2.,EXP.
EXTERN IFX.2,ASIN.,CEXP.,FLT.2,ALG10.,ALOG.
>
EXTERN	.JBDDT,.JBSA,.JBREN,.JBREL

;Word header format:	word 0:	LINK ADR, 0
;			Word 1: CNT, C0, C1, C2, C3
;(Last bit of word 1 is the precedence.)

;ASSEMBLY PARAMETERS

;TWSEG==	0	;SIGNAL TWO SEGMENT ASSEMBLY, IF PRESENT
IFDEF	TWSEG,<TWOSEG>

PWR==	4	;LOG BASE 2 OF NUMBER OF DICT. THREADS
NWAY==	1_PWR	;NUMBER OF DICT. THREADS
MSK==	NWAY-1	;CORRESPONDING BIT MASK

KORE=2		;2K EXTRA CORE
RPSIZ=100	;RETURN STACK SIZE
DCH=0		;DISK'S SOFTWARE CHANNEL
CHPWD=4		;MAXIMUM NUMBER OF CHARACTERS PER FORTH 'WORD'
WDLIM=^D72	;MAX NUMBER OF CHARACTERS CONVERTIBLE BY "WORD"

;REGISTERS = LOW CORE
R0=	0
R1=	1
R2=	2
R3=	3
R4=	4
R5=	5
R6=	6
R7=	7
V=	10

DP=	11
T=	12
TT=	13	;NOTE TT MUST = T+1!
SP=	14
IC=	15
;R16 == FORTRAN PARAMETER BLOCK REG.
RP=	17
	SUBTTL	MACROS
;MACROS TO ASSEMBLE DICTIONARY ENTRIES

DEFINE CODE.(X,NAME< >) <

	LK.NEW==.
	XWD	LK.OLD,0		;;LINK ADR, 0
	LK.T==	LK.OLD			;;(TEMPORARY)
	LK.OLD==LK.NEW
	N==0
	IRPC X,<N==N+1>			;;COUNT CHARACTERS IN X
	M==N
	IFG M-CHPWD,<M==CHPWD>		;;CLIP AT MAX LIMIT
	I==0
	ZZ==N				;;TOTAL CHARACTER COUNT
	IRPC X, <				;;CHARACTER LOOP
		I==I+1
		IFLE I-4, <
			IFLE I-M,<Q.=="X">
			IFG   I-M,<Q.==" ">
			ZZ==ZZ_7+Q.
			>
		>
	REPEAT 4-I,<ZZ==ZZ_7+" ">	;;IF LESS THAN 4 CHARS IN NAME
	ZZ==ZZ_1			;;FINAL ALIGNMENT
ANAME==.				;;REMEMBER PLACE
	EXP ZZ
	IFNB	<NAME>,<NAME:>		;;LABEL IF REQUESTED
	>				;;END CODE.

DEFINE	IMMED	<
	QQQQ==.
	RELOC	ANAME
	EXP	ZZ!1			;;SET PRECEDENCE BIT
	RELOC	QQQQ
	>

DEFINE DEF(X,NAME< >) <

	CODE.(<X>,<NAME>)
	PUSHJ	RP,COLON
	>				;;END DEF

DEFINE CONST(X,VALUE) <

	CODE.(<X>)
	HRREI	T,VALUE		;;18-BITS ONLY
	JRST	PUSH1
	>				;;END CONST

DEFINE USE(LIST) <IRP LIST,<
	EXP LIST>>

DEFINE NEXT <AOJA IC,@0(IC)>	;NOTE IC UPDATED AFTER ADR CALC!
	SUBTTL	CONSTANTS, INTEGERS, BUFFERS
HEAD:	BLOCK NWAY			;FILLED AT ENTRY
STATE:	0
LAST:	0
OPX:	0
DP00:	XWD	0,DP0
SP00:	XWD	-1,SP0
RP00:	XWD	0,RP0-1
MSGPTR:	POINT	7,MSG
SPLIM:	XWD	SP0-DP0-40,0		;-40 FOR SAFETY
OUT:	POINT	7,MSG
BASE0:	12				;DECIMAL ******** NOTE!
DELIM:	" "
PREV:	BUFF1
ALT:	BUFF2
EMPTY:	0
D:	0
L:	0
F:	0
IN:	0
SCR:	0
OKFLG:	0
LWD=400
BUFF1:	BLOCK	LWD+1			;LAST WD IS BLOCK NUMBER
	0				;UPDATE FLAG
BUFF2:	BLOCK	LWD+1
	0
OUTMSG:	BLOCK	33			;132 CHARACTERS OUTPUT
MSG:	BLOCK	21			;72 CHARACTERS INPUT
MSGTOP:	ASCII/
 /
GUARD:	0				;FOR "WORD" TO INSERT DELIM
DSK:	016				;.IODPR MODE: DUMP RECORDS, NON-BUFFERED
	SIXBIT/DSK/
	XWD	0,0
DIN:	XWD	0,5			;EXTENDED FORM FOR LOOKUP
	0
	SIXBIT/FORSYS/
	SIXBIT/DAT/
	0
RBSIZ:	0				;WILL BE LENGTH OF FILE IN WORDS
DOUT:	SIXBIT/FORSYS/
	SIXBIT/DAT/
	0
	0
PROGR:	IOWD	200,1		;I/O PROGRAM (DUMMY ADR)
	IOWD	200,1		;TWO '10 BLOCKS PER FORTH BLOCK
	0
IOENBL:	-1			;PERMIT OPENING OF FORSYS.DAT


	IFDEF	TWSEG,<
	LOWLIM==	.
	RELOC	400000>		;SWITCH TO HIGH SEGMENT

OKMSG:	ASCIZ/ok/
CRMSG:	ASCIZ/
/

FTBL:	IFX.2		;TABLE OF FORTRAN ENTRIES
	ALG10.
	ALOG.
	ASIN.
	ATAN2.
	ATAN.
	CEXP.
	COS.
	FLT.2
	SIN.
	SQRT.
	EXP.
	SUBTTL	ABORT, ETC.
LK.OLD==	0			;ORIGIN OF DICTIONARY
	CODE.(QUESTN,QUESTN)		;******** QUESTN
ABORT:	HRRZ	T,DP
	ADD	T,[POINT 7,1]
	MOVE	SP,SP00
	MOVE	RP,RP00
	SETOM	EMPTY
	SETZM	SCR
	SETZM	STATE
	MOVEI	TT," "
	MOVEM	TT,DELIM
	MOVEI	IC,ABORT2
	JRST	PUSH1

ABORT2:	USE<COUNT,TYPE,LIT.>
	POINT	7,[BYTE (7)2,077,040]		;QUESTION MARK
	USE<COUNT,TYPE,QUERY>

	CODE.(FORSYS)			;******** FORSYS
	SETOM	IOENBL		;ENABLE OPENING OF FORSYS.DAT
	RELEASE	DCH,		;IN CASE ALREADY OPEN
	JSP	R2,OPNR		;OPEN FORSYS.DAT
	NEXT			;(DEFAULT)

	CODE.(NOFORSYS)			;******** NOFORSYS
	SETZM	IOENBL		;DISABLE FORSYS.DAT
	RELEASE	DCH,		;RELEASE CHANNEL
	NEXT

	SUBTTL	OPENING
OPNR:	RESET				;FOR START OR RESTART
	MOVE	TT,IOENBL		;CHECK IF FORSYS
	JUMPE	TT,(R2)			;IS ENABLED
	SETZM	DOUT+2
	SETZM	DOUT+3
	MOVE	1,[POINT 7,MSG]
	MOVEM	1,OUT			;RE-INITIALIZE OUTPUT PTR
	OPEN	DCH,DSK			;OPEN DISK FILE (TTY ALWAYS OPEN)
	JRST	ERR
	LOOKUP	DCH,DIN
	JRST	ERR
	JRST	(R2)			; NOTE USE OF R2

ERR:	OUTSTR	[ASCIZ /'FORSYS.DAT' cannot be opened for input./]
	JRST	EOF

	CODE.(REOPEN)			;******** REOPEN
	JSP	R2,OPNR
	NEXT	

	CODE.(WOPEN)			;******** WOPEN
	MOVEI	R0,0
	HRRM	R0,DOUT+1
	SETZM	DOUT+2
	SETZM	DOUT+3
	MOVEI	R0,4		;NUMBER OF RETRIES ALLOWED
WOPL:	ENTER	DCH,DOUT	;TRY TO OPEN FORSYS FOR OUTPUT
	JRST	WOPERR		;NO, TRY TO RECOVER
	NEXT			;NORMAL OPEN

WOPERR:	OUTSTR	[ASCIZ/'FORSYS.DAT' unavailable for output.  /]
	SOSGE	R0
	JRST	ABORT		;CAN'T RECOVER
	MOVEI	R1,5		;WAIT 5 SEC.
	SLEEP	R1,
	OUTSTR	[ASCIZ/Will try again.
/]
	JRST	WOPL

	CODE.(WCLOSE)			;******** WCLOSE
	CLOSE	DCH,2		;CLOSE OUTPUT ON FORSYS
	NEXT
	SUBTTL	TTY ROUTINES

BASE==	R0
Q==	R1
PTR==	R2
OP==	R3
CODE.(CONVERT,CONVERT)			;******** CONVERT
	JUMPGE	SP,ABORT		;UNDERFLOW?
	MOVE	BASE,BASE0
	MOVE	Q,T			;SIGNED VALUE
	MOVM	T,T			;MAGNITUDE
	HRRZ	PTR,DP
	ADDI	PTR,^D19		;ALLOWS ABOUT 64 CHARACTERS
CNV1:	IDIV	T,BASE
	ADDI	T+1,"0"
	PUSH	PTR,T+1
	SKIPE	T
	JRST	CNV1
	MOVEI	T,"-"
	SKIPGE	Q
	PUSH	PTR,T			;PUT MINUS IF NEGATIVE
	HLRE	T,PTR			;??
	SUB	T,F			;COMPARE AGAINST FIELD LENGTH
	JUMPGE	T,CNV2
	MOVEI	Q," "
	PUSH	PTR,Q
	AOJL	T,.-1			;PAD WITH BLANKS
CNV2:	HRRZ	OP,DP			;REMEMBER DP IS XWD COUNT,ADR
	ADD	OP,[POINT 7,4]		;(WILL PACK BYTES IN FORWARD ORDER)
	MOVEM	OP,OPX			;IF NEEDED LATER
	HLRZ	T,PTR			;COUNT
	IDPB	T,OP			;GOES IN FIRST BYTE
	CAIG	PTR,777777
	JRST	.+4
	POP	PTR,T			;GET A CHAR
	IDPB	T,OP			;PACK IT
	JRST	.-4
	MOVE	T,OPX			;RETURN A BYTE POINTER
	JRST	PUT			;PUT STARTING ADDRESS
	CODE.(COUNT,COUNT)		;******** COUNT (ILDB)
	ILDB	T,0(SP)			;LOAD CHAR COUNT,LEAVE BYTE POINTER
					;INCREMENTED FOR TYPE.
	JRST	PUSH1

	CODE.(TYPE,TYPE)		;******** TYPE
OP==	R1
IP==	R0
	CAILE	T,^D132			; OVER SIZE?
	MOVEI	T,^D132			; YES, CLIP
	MOVE	OP,[POINT 7,OUTMSG]
	MOVE	IP,1(SP)		;BYTE PTR TO 1ST CHAR OF MSG
TYPE2:	ILDB	TT,IP			;TRANSFER BYTES
	IDPB	TT,OP
	SOJG	T,TYPE2
	MOVEI	TT,0
	IDPB	TT,OP			;END OF MSG
	OUTSTR	OUTMSG			;OUTSTR IS FASTER THAN OUTCHR
	SETZM	OKFLG			;INHIBIT OK
	JRST	POP2

	;DEF( CR LF) ------- MANUALLY CODED TO SUIT MACRO-10
	LK.NEW==	.
	XWD	LK.OLD,0		;LINK ADR, 0
	LK.OLD==	LK.NEW
	BYTE	(7)2,015,012,040,040(1)1 ;CR,LF,BLANK,BLANK,  PRECEDENCE
	SKIPE	OKFLG			;TYPE OK?
	OUTSTR	OKMSG
	SETOM	OKFLG
	SETOM	EMPTY
	JRST	CRSND

	CODE.(CR)			;******** CR
CRSND:	OUTSTR	CRMSG			;SEND CR,LF
	NEXT	
	CODE.(QUERY,QUERY)		;******** QUERY
	MOVEI	IC,GO
	MOVE	TT,SCR
	SKIPGE	TT
	NEXT				;LOADING FROM CORE (SCR<0)
	CAILE	TT,2
	NEXT				;WE ARE LOAD'ING
	SKIPN	EMPTY			;NEED NEW MSG BUFFER?
	NEXT				;NO
	JSP	R2,RECEIV
	SETZM	EMPTY
	SETOM	OKFLG
	NEXT	
IP==	R0
Q==	R1
RECEIV:	MOVE	IP,MSGPTR
	MOVEM	IP,IN
	MOVEI	Q,WDLIM			;CHARACTER LIMIT
INCH:	INCHWL	TT
	CAIN	TT,015			;CAR RETN
	JRST	RCLF
	IDPB	TT,IP
	SOJG	Q,INCH
	JRST	ABORT			;RUN OUT

RCLF:	MOVEI	TT," "			;SPECIAL BLANK INSERTED
	IDPB	TT,IP
	MOVEI	TT,015			;CR
	IDPB	TT,IP
	INCHRW	TT			;PRESUMABLY LF
	IDPB	TT,IP
	MOVEI	TT," "			;BLANK FOR SAFETY
	IDPB	TT,IP
	JRST	(R2)

	CODE.(LOAD)			;******** LOAD
	MOVE	TT,[POINT 7,0]
	JRST	INT0

	CODE.(INTERPRET)		;******** INTERPRET
	MOVE	TT,T			;WORD ADDRESS FROM STACK
	IOR	TT,[POINT 7,0]		;MADE INTO BYTE PTR
	MOVEI	T,0
INT0:	PUSH	RP,IN			;SAVE INFO ON CURRENT INPUT STREAM
	PUSH	RP,SCR
	PUSH	RP,IC
	MOVEM	TT,IN			;USUALLY POINT 7,0
	MOVEM	T,SCR			;SET NEW BLOCK NUMBER
					;OR TTY(0) OR INTRPT ADR(<0)
	MOVEI	IC,GO			;SET UP INTERPRETER
	JRST	POP1

	CODE.(<;S>)			;******** ;S
	POP	RP,IC			;RESTORE INPUT STREAM, ETC
	POP	RP,SCR
	POP	RP,IN
	JUMPL	RP,ABORT
	NEXT	
	SUBTTL	STACKS & ARITHMETIC
	CODE.(OCTAL)			;******** OCTAL
	IMMED
	MOVEI	R0,10
PBASE:	MOVEM	R0,BASE0
	NEXT	

	CODE.(DECIMAL)			;******** DECIMAL
	IMMED
	MOVEI	R0,12
	JRST	PBASE

	CODE.(DROP)			;******** DROP
	JRST	POP1
POP2:	AOBJP	SP,SUFLO		;POP 2 WORDS
POP1:	AOBJP	SP,SUFLO		;POP A WORD
	MOVE	T,(SP)			;UPDATE T WITH TOP OF STACK
	NEXT	

	CODE.(SWAP)			;******** SWAP
	EXCH	T,1(SP)
PUT:	MOVEM	T,0(SP)
	NEXT	

	CODE.(<+>)			;******** +
	ADDB	T,1(SP)			;RESULT IN T AND 1(SP)
	AOBJP	SP,SUFLO
	NEXT	

BINARY:	AOBJP	SP,SUFLO
	MOVEM	T,0(SP)
	NEXT	

	CODE.(DUP)			;******** DUP
PUSH1:	POP	SP,V			;DECR SP, IGNORE DATA!
	MOVEM	T,0(SP)
	NEXT				;OK

SUFLO:	OUTSTR	[ASCIZ/Stack underflow! /]
	JRST	ABORT
	SUBTTL	COMPILATION WORDS
	DEF(WORD,WORD)			;******** WORD
	USE<SCR1,BLOCK.,WORD1,SEMI>

SCR1:	MOVE	T,SCR			;CHECK INPUT SOURCE
	JUMPGE	T,SCRX
	MOVEI	T,0			;INTERPRET FROM CORE
	AOJA	IC,PUSH1		;I.E. SCR<0
SCRX:	JUMPN	T,PUSH1			;YES, HAVE TO DO BLOCK
	AOJA	IC,PUSH1		;NO, SKIP&PUSH

IP==	R1
OP==	R2
CT==	R3
CH==	R4

WORD1:	MOVE	IP,IN			;BYTE PTR TO FAST CORE
	ADD	IP,T			;ZERO IF BLOCK 0, BUFF ADDR OTHERWISE
	MOVE	OP,[POINT 7,0]		;BYTE PTR SKELETON
	HRR	OP,DP			;ADDR FOR OUTPUT=NEXT DICT ENTRY
	ADDI	OP,1			;PLUS 1
	SETZM	(OP)			;MAKE SURE LAST BIT IS ZERO
					;(WORKS ON 1ST WORD ONLY!
	MOVEM	OP,OPX			;SAVE INITIAL POINTER
	MOVE	TT,DELIM
	DPB	TT,[POINT 7,GUARD,6]	;INSURE EXISTENCE OF A DELIM
	MOVEI	CT,WDLIM		;MAXIMUM NUMBER OF CHARACTERS ALLOWED
	IDPB	CT,OP			;VALUE IS FIRST BYTE
	ILDB	CH,IP			;GET CHAR
	CAMN	CH,DELIM		;THROW OUT EXTRA DELIMITERS
	JRST	.-2
	IDPB	CH,OP
	ILDB	CH,IP
	CAME	CH,DELIM
	SOJG	CT,.-3
	MOVEI	TT,7			;GUARANTEE LAST WD PADDED WITH BLANKS
	MOVEI	CH," "
	IDPB	CH,OP
	SOJG	TT,.-1
	MOVN	CT,CT
	ADDI	CT,WDLIM+1		;WHAT IS TRUE COUNT?
	MOVE	OP,OPX			;RESET TO FIRST OUTPUT CHAR
	IDPB	CT,OP			;TRUE COUNT TO FIRST CHARACTER
	SUB	IP,T			;UNDO THE DAMAGE FROM ABOVE
	MOVEM	IP,IN			;SAVE INPUT PTR
	MOVEI	0," "
	MOVEM	0,DELIM			;FORCE DELIM=BLANK AFTER WORD
	JRST	POP1
	CODE.(FIND,FIND)		;******** FIND
	HRLZI	TT,FF1		;PHASE IN LOOP
	BLT	TT,6
	MOVE	TT,1(DP)
	MOVE	R7,TT
	LSH	R7,-^D22
	ANDI	R7,MSK		;SELECT PROPER HEAD
	MOVE	T,HEAD(R7)	;MUST RESTORE LATER
	JRST	F1

FF1:	PHASE	0		;TO BE RELOCATED IN LOW MEMORY
F1:	JUMPE	T,SKIPX
	MOVE	R7,1(T)
	ANDCMI	R7,1		;RESET LSB (PRECEDENCE)
	CAMN	TT,R7
	JRST	F3
	HLRZ	T,0(T)
	JRST	F1
	DEPHASE			;END OF RELOCATED SEGMENT

F3:	MOVEM	T,L		;L(IN CORE) POINTS TO LK,CA FIELD
	MOVE	T,0(SP)
	NEXT	

SKIPX:	MOVE	T,0(SP)
SKIP:	ADDI	IC,2		;SKIP USED ELSEWHERE
	NEXT	

EXECUT:	MOVE	V,L
DO:	MOVE	TT,1(V)		;NAME  & PRECEDENCE
	ANDI	TT,1		;PREC. ONLY
	CAML	TT,STATE	;STATE=0 OR 1
EX1:	JRST	2(V)		;EXECUTE
	ADDI	V,2		;POINT TO 1ST PARM WD
COMPIL:	HRRZM	V,0(DP)		;COMPILE ADDR OF 1ST PARM WD
	AOBJN	DP,.+1
	NEXT	
	CODE.(LITERAL,LITERAL)		;******** LITERAL
RETN:	MOVE	TT,STATE
	JUMPG	TT,LITC			;COMPILING?
	MOVE	T,L			;NO, PUSH THE NUMBER ON STACK
	JRST	PUSH1
LITC:	MOVEI	V,LIT.			;WE WILL COMPILE IT
	MOVEM	V,0(DP)			;CALL TO LIT
	MOVE	TT,L
	MOVEM	TT,1(DP)		;NUMBER IS PARAMETER
	ADD	DP,[XWD	2,2]
	NEXT	

LIT.:	MOVE	T,0(IC)			;GET PARAM
	AOJA	IC,PUSH1		;SKIP LITERAL PARM

SEMIC:	PUSHJ	RP,EXCOL		;LEAVE COMPILE MODE
	JRST	COMPIL			;COMPILE SEMI OR SCODE

	CODE.(<;>)			;******** ;
	IMMED
	JSP	V,SEMIC
SEMI:	POP	RP,IC			;NOTE RP POINTS TO LAST USED WORD
	NEXT

ENCOL:	MOVE	TT,LAST			;ENTER COMPILE MODE
	AOS	-1(TT)
	AOS	-1(TT)			;FLIP LAST WD NAME
	MOVEI	TT,1
	MOVEM	TT,STATE		;SET COMP STATE
	AOBJN	DP,.+1			;LEAVE ROOM FOR JSP OR PUSHJ
	POPJ	RP,

EXCOL:	MOVE	TT,LAST			;EXIT COMPILE MODE
	SOS	-1(TT)
	SOS	-1(TT)			;UNFLIP LAST WD NAME
	SETZM	STATE			;RESET STATE
	POPJ	RP,
	CODE.(<;CODE>)			;********** ;CODE
	IMMED
	JSP	V,SEMIC
SCODE:	HRRZ	TT,IC		;NOTE IC HAS FLAGS IN LEFT HALF
	ADD	TT,[JSP V,0]
SCODEC:	MOVEM	TT,@LAST	;LAST POINTS TO 1ST PARM WD, PUSHJ,
	JRST	SEMI		;OR JSP.

	CODE.(<;:>)			;********** ;:
	IMMED
	MOVEI	TT,SCODE
	MOVEM	TT,0(DP)
	MOVE	TT,[PUSHJ RP,COLON]
	MOVEM	TT,1(DP)
	ADD	DP,[XWD 2,2]
	NEXT

;	CODE.(:<)			;******** :<
LK.NEW==.
	XWD	LK.OLD,0
LK.OLD==LK.NEW
	BYTE	(7)2,072,074,040,040(1)1
	PUSHJ	RP,EXCOL		;LEAVE COMPILE MODE
	MOVEI	TT,COLBRK
	MOVEM	TT,0(DP)
	AOBJN	DP,.+1
	SETZM	0,STATE
	NEXT

COLBRK:	MOVE	V,IC
	POP	RP,IC
	JRST	(V)

;	CODE.(>:)			;******** >:
LK.NEW==.
	XWD	LK.OLD,0
LK.OLD==LK.NEW
	BYTE	(7)2,076,072,040,040(1)0
	PUSHJ	RP,ENCOL		;ENTER COMPILE MODE
	MOVE	TT,[PUSHJ RP,COLON]
	MOVEM	TT,-1(DP)
	NEXT
	DEF(CODE,CODE)			;******** CODE 	
	USE<WORD,ENTER,SEMI>

ENTER:	MOVE	TT,1(DP)
	LSH	TT,-^D22
	ANDI	TT,MSK
	HRRZ	R0,DP
	EXCH	R0,HEAD(TT)
	HRLM	R0,0(DP)
	ADD	DP,[XWD	2,2]
	HRRZM	DP,LAST		;LAST POINTS TO [LINK,0]
	NEXT	

	DEF(<:>)			;******** : (COLON)
	USE<CODE,COLONS>

COLONS:	PUSHJ	RP,ENCOL	;ENTER COMPILE MODE
	MOVE	TT,[PUSHJ RP,COLON]	;INSTALL PUSHJ FOR COLON ONLY
	JRST	SCODEC

COLON:	EXCH	IC,(RP)
	NEXT	
	CODE.(<,>)			;******** ,
COMMA:	MOVEM	T,0(DP)
	AOBJN	DP,.+1
	JRST	POP1

CONS:	MOVE	TT,[JSP V,CON]
	MOVEM	TT,@LAST
	AOBJN	DP,.+1
	JRST	COMMA

CON:	MOVE	T,0(V)			;CON PUSHES A NUMBER FROM PARM LIST
	JRST	PUSH1

	DEF(FORGET)			;******** FORGET
	USE<WORD,FIND,PARE,SEMI,QUESTN>
PARE:	MOVE	R0,L
	CAIGE	R0,DP0
	MOVEI	R0,DP0		;DON'T TRIM OBJECT
	MOVEI	R1,NWAY-1	;THREAD INDEX
THLP:	MOVE	R2,HEAD(R1)
THLP2:	CAMGE	R2,R0
	JRST	THTRNC
	HLRZ	R2,0(R2)
	JRST	THLP2

THTRNC:	MOVEM	R2,HEAD(R1)
	SOJGE	R1,THLP
	MOVE	DP,R0		;RECLAIM SPACE
	NEXT	



LOC.:	AOS	L
	AOS	L
	JRST	RETN			;WHERE IT IS PUSHED OR COMPILED

	DEF(<'>)			;******** '
	IMMED
	USE<WORD,FIND,LOC.,SEMI,QUESTN>	;FIND MAY SKIP
	SUBTTL "GO" (TEXT) INTERPRETER
;INTERPRETER LOOP FOR DICTIONARY REFERENCES BY NAME

GO:	USE<WORD,FIND,EXECUT,QUERY>
	USE<NUMBER,LITERAL,QUERY>
	USE<QUESTN>
	SUBTTL	BLOCK I/O
CORE:	MOVE	TT,PREV			;A BUFFER ADDR (THE LAST READ OR WRITTEN)
	CAMN	T,LWD(TT)		;IS IT OUR BLOCK?
	JRST	GOT			;YES
	MOVE	Q,ALT			;ANOTHER ADDR
	CAME	T,LWD(Q)		;WILL IT BE ALT?
	NEXT				;NO, HAVE TO READ
	MOVEM	TT,ALT			;YES, SWITCH BUFFERS
	MOVEM	Q,PREV
	MOVE	TT,Q
GOT:	MOVE	T,TT
	ADDI	IC,2			;SKIP OVER 2
	JRST	PUT			;PUT THE GOOD BUFFER ADDR

	CODE.(FLUSH,FLUSH)		;******** FLUSH
	MOVE	Q,PREV			;SWITCH
	MOVE	TT,ALT
	MOVEM	Q,ALT
	MOVEM	TT,PREV
	SKIPN	LWD+1(TT)		;THE UPDTE FLAG
	NEXT
	PUSH	RP,TT
	MOVE	TT,LWD(TT)		;INFORMALLY PASSING THE BLOCK NUMBER
	PUSHJ	RP,WDISK		;WRITE BACK TO DISK
	POP	RP,TT
	SETZM	LWD+1(TT)
	NEXT	

READ:	MOVE	TT,T			;BLOCK NUMBER
	MOVE	T,PREV			;BUFFER ADDRESS
	MOVEM	TT,LWD(T)
	PUSHJ	RP,RDISK
	JRST	PUT
	DEF(BLOCK,BLOCK.)		;******** BLOCK
	USE<CORE,FLUSH,READ,SEMI>

	CODE.(UPDATE)			;******** UPDATE
	MOVE	TT,PREV
	SETOM	LWD+1(TT)		;SET UPDATE FLAG -1
	NEXT	

	CODE.(<ERASE-CORE>)		;******** ERASE-CORE
	SETZM	BUFF1+LWD
	SETZM	BUFF2+LWD
	NEXT	
RDISK:	CAIG	TT,0			;******** (RDISK)  (BLOCK IN TT)
	MOVEI	TT,1
	IMULI	TT,2			;DOUBLE BLOCKS
	SUBI	TT,1			;NO. 1 IS FIRST AVAILABLE TO US
	PUSHJ	RP,CHKBLK		;IN BOUNDS?
	USETI	DCH,(TT)		;SET UP FOR INPUT OF CORRECT BLOCK
RRD:	MOVE	TT,PREV
	SUBI	TT,1
	HRRM	TT,PROGR		;CORE ADDRESS (-1)
	ADDI	TT,200			;SECOND PDP-10 BLOCK
	HRRM	TT,PROGR+1
	IN	DCH,PROGR
	POPJ	RP,			;OK
	OUTSTR	[ASCIZ/Block input error. /]
	JRST	ABORT

WDISK:	CAIG	TT,0			;******** (WDISK) (BLOCK IN TT)
	MOVE	TT,1
	IMULI	TT,2
	SUBI	TT,1
	PUSHJ	RP,CHKBLK		;IN BOUNDS?
	USETO	DCH,(TT)
	MOVE	TT,PREV
	SUBI	TT,1
	HRRM	TT,PROGR
	ADDI	TT,200
	HRRM	TT,PROGR+1
	OUT	DCH,PROGR
	POPJ	RP,
	OUTSTR	[ASCIZ/Block output error. /]
	JRST	ABORT

CHKBLK:	MOVE	R0,RBSIZ		;WORD LENGTH OF FILE
	IDIVI	R0,200			;IN BLOCKS (PDP-10)
	CAML	R0,TT
	POPJ	RP,0			;OK RETURN
	OUTSTR	[ASCIZ/Block number too high! /]
	JRST	ABORT
	SUBTTL	CONSTANT WORDS
	DEF(CONSTANT,CONSTA)			;******** CONSTANT
	USE<CODE,CONS,SEMI>

	CONST(PUSH,PUSH1)
	CONST(PUT,PUT)
	CONST(BINARY,BINARY)
	CONST(POP,POP1)
	CONST(COMMA,COMMA)
	CONST(ABORT,ABORT)
	CONST(BASE,BASE0)
	CONST(FORTH,1)			;YOU CAN SAY "FORTH LOAD"
IFDEF ..FORT <
	CONST(FORTRAN,FTBL)		;FORTRAN ENTRY TABLE
>
	SUBTTL	ASSEMBLER
	DEF(CPU)			;******** CPU
	USE<CONSTA,SCODE>
	MOVE	TT,0(V)			;OP CODE DEPOSITED EARLIER
	LSH	TT,4
	IOR	T,TT			;OR IN AC FROM STACK HEAD
	ROT	T,-^D13			;MOVE TO HIGH ORDER 13 BITS
	IOR	T,1(SP)			;SECOND STACK IS I,X,Y (ADDRESS)
	AOBJP	SP,SUFLO		;POP 1, SECOND POPPED BY COMMA
	JRST	COMMA
	SUBTTL	MISCELLANY
	DEF(<(>)			;***** ( ***** ALLOW COMMENTS
	IMMED
	USE<LPAR1,WORD,SEMI>
LPAR1:	MOVEI	0,")"
	MOVEM	0,DELIM
	NEXT	

	CODE.(DDT)			;******** DDT
	HRRZ	TT,.JBDDT		;FROM JOB DATA AREA (PDP-10)
	JUMPE	TT,ABORT		;DDT NOT LOADED
	JRST	(TT)			;GO TO DDT

	CODE.(SAVE)			;******** SAVE
	SETZM	BUFF1+LWD	;DO 'ERASE-CORE'
	SETZM	BUFF2+LWD
	MOVEI	0,REST			;RESTORE ADDRESS
	HRRM	0,.JBSA			;DEFINED FOR NEXT START
	MOVEM	DP,STATE		;CONVENIENT PLACE TO KEEP DP
	JRST	EOF
REST:	JSP	R2,OPNR			;NOTE USE OF R2
	MOVE	DP,STATE		;RESTORE DP
	JRST	ABORT
	CODE.(NUMBER,NUMBER)		;******** NUMBER
IP==	R1
LL==	R2
BASE==	R3
PLACES==R4
SIGN==	R5
CH==	R6
	MOVE	IP,[POINT 7,0,6]	;BYTE POINTER SKELETON
	HRR	IP,DP
	ADDI	IP,1			;PT TO CH STRING FROM WORD
	MOVEI	LL,0
	MOVE	BASE,BASE0
	MOVNI	PLACES,1000		;LARGE NEGATIVE NUMBER
	ILDB	CH,IP			;FETCH CHARACTER
	MOVE	SIGN,CH
	CAIN	CH,"-"			;GET ANOTHER IF WE GOT A MINUS
	ILDB	CH,IP
	CAIN	CH,"+"			;ALLOW + SIGN
	ILDB	CH,IP
	JRST	NATURL+2
NATURL:	MOVE	BASE,BASE0		;RESET BASE FROM POSSBILE ":"
	ILDB	CH,IP
	SUBI	CH,"0"
	JUMPL	CH,NONDIG
	CAML	CH,BASE			;TOO HIGH?
	JRST	NONDIG			;WE'D BEST REJECT IT

DIGIT:	JOV	.+1			;BE CAREFUL OF OVFL
	IMUL	LL,BASE
	JOV	.+2
	JRST	.+2
	IOR	LL,[XWD 400000,0]
	ADD	LL,CH
	ADDI	PLACES,1
	JRST	NATURL
NONDIG:	ADDI	CH,"0"
	CAIE	CH,":"			;FOR SEXIGESIMAL
	JRST	.+3
	MOVEI	BASE,6
	JRST	NATURL+1
	CAIE	CH,"."
	JRST	.+3
	MOVEI	PLACES,0
	JRST	NATURL
	MOVEM	PLACES,D		;STORE NUMBER OF DIGITS TO RT OFDECIMAL
	CAIN	SIGN,"-"
	MOVN	LL,LL			;NEGATE
	MOVEM	LL,L
	CAMN	CH,DELIM		;DELIM USUALLY " "
	NEXT				;DONE OK
	JRST	SKIP			;NOT CONVERTIBLE AS NUMBER

	CODE.(<CORE?>)			;******** CORE?
	HRRZ	T,SP00		;CALCULATE REMAINING
	HRRZ	R0,DP		;DICT+STACK SPACE
	SUB	T,R0
	JRST	PUSH1		;RETURN # WORDS LEFT.

	CODE.(CORE)			;******** CORE
	IMULI	T,2000		;INPUT IN KILOWORDS,NOW WORDS
	SUBI	T,1		;SO 6 --> 6K WORDS, ETC.
	HRRZ	R0,DP		;CHECK THAT WE
	ADDI	R0,RPSIZ+100	;DON'T CUT OFF CURRENT
	CAMGE	T,R0		;DICT AND STACK
	MOVE	T,R0		;CLIP
	MOVE	R0,T		;SAVE
	CAMG	T,.JBREL	;CHECK FOR SENSE OF CHANGE
	JRST	CLWR		;WE WANT TO SHRINK
	CALLI	T,11		;CORE CALL
	JRST	ABORT		;ERROR
CLWR:	SUBI	R0,RPSIZ+1
	HRRZ	R2,SP00		;MOVE STACK DATA
	HRRZ	R1,SP
	SUB	R1,R2
	ADD	R1,R0		;TO=R0+SP-SP00
	HRL	R1,SP		;FROM=SP
	MOVE	R3,R0
	HRRZ	R4,SP00
	SUB	R3,R4		;R0-SP00
	HRRZ	R2,RP		
	ADD	R2,R3		;END=RP+OFFSET
	BLT	R1,@R2		;DO IT
	ADD	SP,R3		;SP=SP+OFFSET
	ADD	RP,R3		;RP=RP+OFFSET
	MOVE	T,R0		;RESTORE IF NEEDED
	CAML	T,.JBREL	;SHRINKING?
	JRST	CBIGR		;NO
	CALLI	T,11		;SHRINK
	JRST	ABORT
CBIGR:	MOVEM	R0,RP00		;RESET STACKS
	HRROM	R0,SP00
	HRRZ	R0,.JBREL	;GET HIGH ADR
	HRLM	R0,.JBSA	;FOR RUN AFTER SAVE
	JRST	POP1		;GET RID OF INPUT
HEAD0:	CODE.(GOODBY)			;******** GOODBY
EOF:	RELEASE DCH,0			;RELEASE DISK
	EXIT

LIT
	IFDEF	TWSEG,<RELOC	LOWLIM>	;GO BACK TO LOW SEGMENT
	VAR

DP0:	Z
	BYTE	(7)8,7,110,105,114	;BELL HEL
	BYTE	(7)114,117,15,12	;LO <CRLF>

ENTRY:	JSP	R2,OPNR			;REENTRANT CALL USING R2
	OUTSTR	[ASCIZ/Forth 12-19-77! /]
	MOVEI	R0,ABORT
	MOVEM	R0,.JBREN		;SET REENTER ADDRESS
	MOVE	DP,DP00
	MOVEI	R1,HEAD0		;TRUNCATE DICTIONARY
	MOVEM	R1,HEAD
	IFG	NWAY-1,<
	MOVE	R1,[XWD	HEAD,HEAD+1]
	BLT	R1,HEAD+NWAY-1>
	JRST	ABORT
LIT
	BLOCK	KORE*2000		;CAN BE CHANGED BY "CORE"
SP0:	Z
RP0:	BLOCK	RPSIZ
	END	ENTRY