;		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