;-*-Midas-*-

	Title FORTH - The FORTH Language

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	Caution:  This FORTH is NOT totally standard.
;;;
;;;	When FORTH is started up, the file AUTO-LOAD.4TH is searched
;;;	for.  If it exists, it is loaded automatically.  If not, a
;;;	standard header is printed.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

.DECSAV

A=1	;Used by JSYSs mostly
B=2
C=3

D=4	;Used exclusively by colon-compiler (Addr is last word built)
E=5	;  "	   "      "  EVAL (Addr of last word evaluated)

U=6	;# things in FORTH stack
V=7	;Args for FORTH stack pushing/popping
L=10	;Args for EVAL

K=11	;Kharacter from GETCHR and such

T1=12	;Trashy temporaries - No special purpose
T2=13
T3=14
T4=15

S=16	;FORTH stack pointer
P=17	;100% Pure Porpoise stack pointer


Call=PUSHJ P,
Return=POPJ P,


.PRIIN==100	;TTY input JFN
.PRIOU==101	;TTY output JFN


;;;
;;;	Macros
;;;


Define TYPE &string
	Hrroi A,[Asciz string]
	PSOUT
Termin


Define DBP ac
	Add ac,[70000,,0]
	Skipge ac
	  Sub ac,[430000,,1]
Termin


;;;
;;;	Storage
;;;


	Loc 140


Popj1:	Aos (P)
CPopj:	Return

PDLen==200		;Porpoise stack
PDList:	-PDLen,,.
	Block PDLen

Deep==100.		;FORTH stack
Stack:	-Deep,,.
	Block Deep

LogNcs:	1.0 ? 3.0 ? 5.0 ? 7.0 ? 9.0 ? 11.0 ? 13.0 ? 15.0


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	Start of execute-time stuff for structures.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


DOn==10.		;Maximum depth of DO loop nesting.
DOc:	-1		;Loop # we're in.  -1 means not in.
DOs:	Block DOn
DOtop:	Block DOn	;Upper limit of DO
DOind:	Block DOn	;Loop counter, what you get with I, J, etc

IFc:	-1

UNTILn==10.
UNTILc:	-1
UNTILs:	Block UNTILn

WHILEn==10.
WHILEc:	-1
WHILEs:	Block WHILEn
WHILEe:	Block WHILEn
BEGINp:	0


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	Random flags, variables, constants, etc
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


Level:	-1		;Level of recursion
Trace:	0
Base:	10.		;I/O number base
Echo:	-1		;True if we echo input

Width:	0		;Terminal width
Term:	0		;Terminal-type #

FName:	Block 7		;Filename (asciz) you're screwing with
Delim:	0		;Delimiter for text input stuff
lsText:	0		;Length of text read by sText
Loadp:	0		;True when input is from a file
StoNmp:	0		;Flag returned by StoN: Valid number?

Making:	0	;True when we're in the middle of building a Dictionary entry
Did:	0	;True when a DOES> was found after <BUILDS during execution.
BStart:	0	;For run-time DOES>... the address it returns.

JCall:	JSYS


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	<# and #> formatting controls
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


FBufl==6	;Room for 30. characters
Format:	0
FLeft:	0
FMinus:	0
FBuffr:	Block FBufl
FBufBP:	0


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	Instructions that are executed in the body of the two
;;;	testing routines, via XCT
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


2Tests:	Camn V,(S)	; =
	Came V,(S)	; =_
	Camle V,(S)	; <
	Caml V,(S)	; <=
	Camge V,(S)	; >
	Camg V,(S)	; >=

1Tests:	Skipn (S)	; 0=
	Skipe (S)	; 0=_
	Skipge (S)	; 0<
	Skipg (S)	; 0<=
	Skiple (S)	; 0>
	Skipl (S)	; 0>=


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	The ASCII strings needed to clear screen and home cursor
;;;	on assorted terminals.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


Clears:	0 ? 0 ? 0 ? 0 ? 0
	Asciz //			;#5 - DM2500
	Asciz //			;#6 - I400
	Asciz //			;#7 - DM1520
	0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0
	Asciz /HJ/			;#15 - VT52
	0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0
	Asciz /v/			;#24 - V200
	0
	Asciz /E/			;#26 - H19

Homes:	0 ? 0 ? 0 ? 0 ? 0
	Asciz //
	Asciz //
	Asciz //
	0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0
	Asciz /H/
	0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0 ? 0
	Asciz //
	0
	Asciz //


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	Control needed to keep track of nested LOADs and iJFNs
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


MaxLLs:	10
LLoad:	-1
LiJFNs:	Block MaxLLs
iJFN:	.PRIIN


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	All the rubbish used by the input processor
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


IBufln==40		;Allowing for 160. character input lines
pInBuf:	0
InBuf:	Block IBufln
nIchar:	0

IStrin:	Block 3
IAddr:	0
INump:	0
Inmpos:	0
NotNum:	0
IVal:	0

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	The Primitive FORTH Dictionary
;;;
;;;	Entries are like:
;;;
;;;	+0: NAME 01-05
;;;	+1: NAME 06-10
;;;	+2: NAME 11-15
;;;	+3: LENGTH,,CODE
;;;	+4: STUFF1
;;;	 .    .
;;;	+n: STUFFi
;;;
;;;	Where NAME's are ASCII words, LENGTH is the total length
;;;	of this entry, CODE is a pointer to a list of STUFFs that
;;;	will be executed when this word is mentioned, and a STUFF
;;;	is one of:
;;;
;;;		-1 ? CONSTANT
;;;		-1,,SUBROUTINE
;;;		 0,,DICTIONARY
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

DPage==10		;Page to load Dictionary into

Foo:	Loc DPage*2000

Dict:	Ascii /DUP/ ? 0 ? 0 ?		5,,0 ? -1,,Dup
	Ascii /SWAP/ ? 0 ? 0 ?		5,,0 ? -1,,Swap
	Ascii /ROLL/ ? 0 ? 0 ?		5,,0 ? -1,,Roll
	Ascii /PICK/ ? 0 ? 0 ?		5,,0 ? -1,,Pick
	Ascii /DROP/ ? 0 ? 0 ?		5,,0 ? -1,,Drop
	Ascii /OVER/ ? 0 ? 0 ?		5,,0 ? -1,,Over
	Ascii /ROT/ ? 0 ? 0 ?		5,,0 ? -1,,Rotate
	Ascii /-DUP/ ? 0 ? 0 ?		5,,0 ? -1,,NZDup
	Ascii /?DUP/ ? 0 ? 0 ?		5,,0 ? -1,,NZDup
	Ascii /LEVEL/ ? 0 ? 0 ?		5,,0 ? -1,,PLevel
	Ascii /DEPTH/ ? 0 ? 0 ?		5,,0 ? -1,,Depth
	Ascii /FLOAT/ ? 0 ? 0 ?		5,,0 ? -1,,ItoF
	Ascii /+/ ? 0 ? 0 ?		5,,0 ? -1,,Plus
	Ascii /-/ ? 0 ? 0 ?		5,,0 ? -1,,Minus
	Ascii /*/ ? 0 ? 0 ?		5,,0 ? -1,,Times
	Ascii "/" ? 0 ? 0 ?		5,,0 ? -1,,Divide
	Ascii /^/ ? 0 ? 0 ?		5,,0 ? -1,,Power
	Ascii /F+/ ? 0 ? 0 ?		5,,0 ? -1,,FPlus
	Ascii /F-/ ? 0 ? 0 ?		5,,0 ? -1,,FMin
	Ascii /F*/ ? 0 ? 0 ?		5,,0 ? -1,,FTimes
	Ascii "F/" ? 0 ? 0 ?		5,,0 ? -1,,FDiv
	Ascii /FIX/ ? 0 ? 0 ?		5,,0 ? -1,,FtoI
	Ascii /MOD/ ? 0 ? 0 ?		5,,0 ? -1,,Mod
	Ascii "/MOD" ? 0 ? 0 ?		5,,0 ? -1,,DivMod
	Ascii /0=/ ? 0 ? 0 ?		5,,0 ? -1,,EqualZ
	Ascii /0=_/ ? 0 ? 0 ?		5,,0 ? -1,,NotEq0
	Ascii /0</ ? 0 ? 0 ?		5,,0 ? -1,,LessZ
	Ascii /0<=/ ? 0 ? 0 ?	 	5,,0 ? -1,,LesEq0
	Ascii /0>/ ? 0 ? 0 ?		5,,0 ? -1,,GreatZ
	Ascii /0>=/ ? 0 ? 0 ?		5,,0 ? -1,,GrEq0
	Ascii /EXCHANGE/ ? 0 ?		5,,0 ? -1,,XChanj
	Ascii /JSYS/ ? 0 ? 0 ?		5,,0 ? -1,,JSys0
	Ascii /=/ ? 0 ? 0 ?		5,,0 ? -1,,Equal
	Ascii /=_/ ? 0 ? 0 ?		5,,0 ? -1,,NotEqu
	Ascii /</ ? 0 ? 0 ?		5,,0 ? -1,,Less
	Ascii /<=/ ? 0 ? 0 ?		5,,0 ? -1,,LessEq
	Ascii />/ ? 0 ? 0 ?		5,,0 ? -1,,Greatr
	Ascii />=/ ? 0 ? 0 ?		5,,0 ? -1,,GretEq
	Ascii /FLUSH/ ? 0 ? 0 ?		5,,0 ? -1,,Flush
	Ascii /TRACE/ ? 0 ? 0 ?		5,,0 ? -1,,CTrace
	Ascii /@/ ? 0 ? 0 ?		5,,0 ? -1,,Fetch
	Ascii /!/ ? 0 ? 0 ?		5,,0 ? -1,,Store
	Ascii /+!/ ? 0 ? 0 ?		5,,0 ? -1,,Storep
	Ascii /-!/ ? 0 ? 0 ?		5,,0 ? -1,,Storem
	Ascii /FILL/ ? 0 ? 0 ?		5,,0 ? -1,,Fill
	Ascii /'/ ? 0 ? 0 ?		5,,0 ? -1,,Tic
	Ascii /'#/ ? 0 ? 0 ?		5,,0 ? -1,,Ticnum
	Ascii "]" ? 0 ? 0 ?		5,,0 ? -1,,Ticome
	Ascii /QUIT/ ? 0 ? 0 ?		5,,0 ? -1,,Exit
	Ascii "<#" ? 0 ? 0 ?		5,,0 ? -1,,SOutF
	Ascii "#" ? 0 ? 0 ?		5,,0 ? -1,,FDigit
	Ascii /HOLD/ ? 0 ? 0 ?		5,,0 ? -1,,FHold
	Ascii "#N" ? 0 ? 0 ?		5,,0 ? -1,,FNDigs
	Ascii /SIGN/ ? 0 ? 0 ?		5,,0 ? -1,,FSign
	Ascii "#S" ? 0 ? 0 ?		5,,0 ? -1,,FDigs
	Ascii "#>" ? 0 ? 0 ?		5,,0 ? -1,,EOutF
	Ascii /HOME/ ? 0 ? 0 ?		5,,0 ? -1,,Home
	Ascii /CR/ ? 0 ? 0 ?		5,,0 ? -1,,Terpri
	Ascii /CLEAR/ ? 0 ? 0 ?		5,,0 ? -1,,CLS
	Ascii /SPACE/ ? 0 ? 0 ?		5,,0 ? -1,,Space
	Ascii /SPACES/ ? 0 ?		5,,0 ? -1,,Spaces
	Ascii /EMIT/ ? 0 ? 0 ?		5,,0 ? -1,,Emit
	Ascii /TYPE/ ? 0 ? 0 ?		5,,0 ? -1,,7TypeN
	Ascii "[TYPE]" ? 0 ?		5,,0 ? -1,,7Type
	Ascii /KEY/ ? 0 ? 0 ?		5,,0 ? -1,,Key
	Ascii /?TERMINAL/ ? 0 ?		5,,0 ? -1,,Inputp
	Ascii /EXPECT/ ? 0 ?		5,,0 ? -1,,ExpecN
	Ascii "[EXPECT]" ? 0 ?		5,,0 ? -1,,Expect
	Ascii /C@/ ? 0 ? 0 ?		5,,0 ? -1,,CFetch
	Ascii /C!/ ? 0 ? 0 ?		5,,0 ? -1,,CStore
	Ascii /C>/ ? 0 ? 0 ?		5,,0 ? -1,,CPlus
	Ascii /C</ ? 0 ? 0 ?		5,,0 ? -1,,CMinus
	Ascii /./ ? 0 ? 0 ?		5,,0 ? -1,,Dot
	Ascii /.R/ ? 0 ? 0 ?		5,,0 ? -1,,DotR
	Ascii /F./ ? 0 ? 0 ?		5,,0 ? -1,,FDot
DOTQa=.
	Ascii /."/ ? 0 ? 0 ?		5,,0 ? -1,,Dotext
	Ascii /:"/ ? 0 ? 0 ?		5,,0 ? -1,,ColTex
	Ascii /(")/ ? 0 ? 0 ?		5,,0 ? -1,,SaveTd
	Ascii /["]/ ? 0 ? 0 ?		5,,0 ? -1,,SaveTs
	Ascii /VLIST/ ? 0 ? 0 ?		5,,0 ? -1,,Vlist
PARENa=.
	Ascii "(" ? 0 ? 0 ?		5,,0 ? -1,,Remark
	Ascii /ABS/ ? 0 ? 0 ?		5,,0 ? -1,,Abs
	Ascii /MINUS/ ? 0 ? 0 ?		5,,0 ? -1,,Negate
	Ascii /+-/ ? 0 ? 0 ?		5,,0 ? -1,,ApSign
	Ascii /1+/ ? 0 ? 0 ?		5,,0 ? -1,,Plus1
	Ascii /1-/ ? 0 ? 0 ?		5,,0 ? -1,,Minus1
	Ascii /MAX/ ? 0 ? 0 ?		5,,0 ? -1,,Max
	Ascii /MIN/ ? 0 ? 0 ?		5,,0 ? -1,,Min
	Ascii /SINE/ ? 0 ? 0 ?		5,,0 ? -1,,Sine
	Ascii /COSINE/ ? 0 ?		5,,0 ? -1,,Cosine
	Ascii /ROOT/ ? 0 ? 0 ?		5,,0 ? -1,,Root
	Ascii /LN/ ? 0 ? 0 ?		5,,0 ? -1,,LogN
	Ascii /<-,,/ ? 0 ? 0 ?		5,,0 ? -1,,LHalf
	Ascii /SW,,AP/ ? 0 ?		5,,0 ? -1,,SHalfs
	Ascii /,,->/ ? 0 ? 0 ?		5,,0 ? -1,,RHalf
	Ascii /AND/ ? 0 ? 0 ?		5,,0 ? -1,,LogAND
	Ascii /OR/ ? 0 ? 0 ?		5,,0 ? -1,,LogOR
	Ascii /NOT/ ? 0 ? 0 ?		5,,0 ? -1,,LogNOT
	Ascii /XOR/ ? 0 ? 0 ?		5,,0 ? -1,,LogXOR
	Ascii /EXECUTE/ ? 0 ?		5,,0 ? -1,,Execut
	Ascii /FORGET/ ? 0 ?		5,,0 ? -1,,Forget
	Ascii /:/ ? 0 ? 0 ?		5,,0 ? -1,,Colon
SEMIa=.
	Ascii /;/ ? 0 ? 0 ?		5,,0 ? -1,,Buierr
	Ascii /<BUILDS/ ? 0 ?		5,,0 ? -1,,Builds
DOESa=.
	Ascii /DOES>/ ? 0 ? 0 ?		5,,0 ? -1,,Does
	Ascii /,/ ? 0 ? 0 ?		5,,0 ? -1,,Comma
	Ascii /ALLOT/ ? 0 ? 0 ?		5,,0 ? -1,,Allot
LOADa=.
	Ascii /LOAD/ ? 0 ? 0 ?		5,,0 ? -1,,Load
	Ascii "[LOAD]" ? 0 ?		5,,0 ? -1,,Loads
	Ascii /UNLOAD/ ? 0 ?		5,,0 ? -1,,Unload
	Ascii /DECIMAL/ ? 0 ?		5,,0 ? -1,,Base10
	Ascii /OCTAL/ ? 0 ? 0 ?		5,,0 ? -1,,Base8
	Ascii /BINARY/ ? 0 ?		5,,0 ? -1,,Base2

IFa=.
	Ascii /IF/ ? 0 ? 0 ?		5,,-1 ? -1,,If
ELSEa=.
	Ascii /ELSE/ ? 0 ? 0 ?		5,,-1 ? -1,,Else
THENa=.
	Ascii /THEN/ ? 0 ? 0 ?		5,,-1 ? -1,,Then

DOa=.
	Ascii /DO/ ? 0 ? 0 ?		5,,-1 ? -1,,DoLoop
LOOPa=.
	Ascii /LOOP/ ? 0 ? 0 ?		5,,-1 ? -1,,Loop
LOOPPa=.
	Ascii /+LOOP/ ? 0 ? 0 ?		5,,-1 ? -1,,Loopp

	Ascii /I/ ? 0 ? 0 ?		5,,0 ? -1,,Aye
	Ascii /J/ ? 0 ? 0 ?		5,,0 ? -1,,Jay
	Ascii /IJ..N/ ? 0 ? 0 ?		5,,0 ? -1,,En
	Ascii /RUNT/ ? 0 ? 0 ?		5,,0 ? -1,,Runt

REPTa=.
	Ascii /REPEAT/ ? 0 ?		5,,-1 ? -1,,Rept
UNTILa=.
	Ascii /UNTIL/ ? 0 ? 0 ?		5,,-1 ? -1,,Until

	Ascii /CMOVE/ ? 0 ? 0 ?		5,,0 ? -1,,CMoveN
	Ascii "[CMOVE]" ? 0 ?		5,,0 ? -1,,CMoves
	Ascii /HERE/ ? 0 ? 0 ?		5,,0 ? -1,,Here
	Ascii /LEAVE/ ? 0 ? 0 ?		5,,0 ? -1,,Leave
	Ascii /ERROR/ ? 0 ? 0 ?		5,,0 ? -1,,Erret
	Ascii "[NUMBER]" ? 0 ?		5,,0 ? -1,,Number

WHILEa=.
	Ascii /WHILE/ ? 0 ? 0 ?		5,,-1 ? -1,,While
BEGINa=.
	Ascii /BEGIN/ ? 0 ? 0 ?		5,,-1 ? -1,,Begin
ENDa=.
	Ascii /END/ ? 0 ? 0 ?		5,,-1 ? -1,,FEnd

Bottom:	0

	Loc Foo

Dicte:	D,,Bottom

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;               Start of Executable Part of FORTH		   ;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

Start: 	Move P,PDList
	Move S,Stack
	Movei A,.PRIOU
	GTTYP
	Movem B,Term
	Movei A,.PRIIN
	RFMOD
	Trz B,TT%DAM
	Tlz B,TT%ECO
	SFMOD
	Movei B,.MORLW
	MTOPR
	Movem C,Width

Initp:	Movsi A,(GJ%SHT\GJ%OLD)
	Hrroi B,[Asciz /AUTO-LOAD.4TH/]
	GTJFN
	  Jrst Greet
	Move B,[070000,,OF%RD]
	OPENF
	  Jrst Greet
	Call LSave
	Jrst PRun

Greet:	Type "FORTH-10   Type QUIT to exit."
	Call Terpri

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;                       Top Level of FORTH			   ;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

PPPRun:	Skipn Echo
	  Jrst PRun
	Type " Ok"
PPRun:	Call Terpri
PRun:	Call FillIB
Run:	Call Getwrd
	  Jrst PPPRun
	Skipe INump
	  Jrst [Move V,IVal	;Constants are pushed,
		Call 4SAVE
		Jrst Run]
	Skipn IAddr
	  Jrst NamErr
	Move L,IAddr
	Hrre A,3(L)
	Skipg A			;Subroutines executed,
	  Move L,4(L)
	Call Eval		;Words evaluated.
	Jrst Run

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;                           Primitives			   ;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;
;;;	Stack operations
;;;

Dup:	Jumpe U,UFlow			; DUP
	Move V,(S)
	Call 4SAVE
	Return

Drop:	Call 4REST			; DROP
	Return

Over:	Caige U,2			; OVER
	  Jrst UFlow
	Move V,-1(S)
	Call 4SAVE
	Return

Rotate:	Caige U,3			; ROT
	  Jrst UFlow
	Move T1,(S)
	Exch T1,-1(S)
	Exch T1,-2(S)
	Movem T1,(S)
	Return

Swap:	Caige U,2			; SWAP
	  Jrst UFlow
	Move T1,(S)
	Exch T1,-1(S)
	Movem T1,(S)
	Return

Roll:	Call 4REST			; ROLL
	Camle V,U
	  Jrst UFlow
	Hrrz T1,S
	Sub T1,V
	Move T2,1(T1)
	Movei T3,1(T1)
	Hrli T3,2(T1)
	BLT T3,-1(S)
	Movem T2,(S)
	Return

Pick:	Call 4REST			; PICK
	Camle V,U
	  Jrst UFlow
	Hrrz T1,S
	Sub T1,V
	Move V,1(T1)
	Call 4SAVE
	Return

NZDup:	Jumpe U,UFlow			; -DUP and ?DUP
	Skipn (S)
	  Return
	Move V,(S)
	Call 4SAVE
	Return

;;;
;;;	Numeric changes
;;;

Negate:	Jumpe U,UFlow			; MINUS
	Movns (S)
	Return

RHalf:	Jumpe U,UFlow			; ,,->
	Hrre A,(S)
	Movem A,(S)
	Return

LHalf:	Jumpe U,UFlow			; <-,,
	Hlre A,(S)
	Movem A,(S)
	Return

SHalfs:	Jumpe U,UFlow			; SW,,AP
	Movss (S)
	Return

ApSign:	Call 4REST			; +-
	Jumpe U,UFlow
	Skipge V
	  Movns (S)
	Return

Min:	Caige U,2			; MIN
	  Jrst UFlow
	Call 4REST
	Camge V,(S)
	  Movem V,(S)
	Return

Max:	Caige U,2			; MAX
	  Jrst UFlow
	Call 4REST
	Camle V,(S)
	  Movem V,(S)
	Return

Abs:	Jumpe U,UFlow			; ABS
	Movms (S)
	Return

Plus1:	Jumpe U,UFlow			; 1+
	Aos (S)
	Return

Minus1:	Jumpe U,UFlow			; 1-
	Sos (S)
	Return

;;;
;;;	Floating-point functions
;;;

Cosine:	Call 4REST			; COSINE
	FADR V,[1.57079632679]
	Skipa
Sine:	Call 4REST			; SINE
	Move A,V
	Call SorC
	Move V,A
	Call 4SAVE
	Return

SorC:	Movm B,A
	Camg B,[.0001761]
	  Return
	FDVRI A,(+9.0)
	Call SorC
	Call .+1
	FMPR B,B
	FSC B,2
	FADRI B,(-3.0)
	FMPRB A,B
	Return

Root:	Call 4REST			; ROOT
	Jumple V,[Setz V,
		  Call 4SAVE
		  Return]
	Move T1,V
	FADRI T1,(+1.0)
	FDVRI T1,(+2.0)
Root1:	Move T2,V
	FDVR T2,T1
	FADR T2,T1
	FDVRI T2,(+2.0)
	Move T3,T2
	FSBR T3,T1
	Movms T3
	Camg T3,[.0000001]
	  Jrst Root2
	Move T1,T2
	Jrst Root1
Root2:	Move V,T1
	Call 4SAVE
	Return

LogN:	Call 4REST			; LN
	Jumple V,[Setz V,
		  Call 4SAVE
		  Return]
	Move T1,V
	FSBRI T1,(+1.0)
	Move T2,V
	FADRI T2,(+1.0)
	FDVR T1,T2
	Move T2,T1
	Move A,T1
	Setzb C,B

LogN1:	FMPR T2,T1
	FMPR T2,T1
	Move T3,T2
	FDVR T3,LogNcs(C)
	FADR A,T3
	FSBR B,A
	Movms B
	Camg B,[.0000001]
	  Jrst LogN2
	Move B,A
	Aoja C,LogN1
LogN2:	FMPRI A,(+2.0)
	Move V,A
	Call 4SAVE
	Return

;;;
;;;	System constants and toggles and stuff
;;;

Depth:	Move V,U			; DEPTH
	Call 4SAVE
	Return

CTrace:	Setcmm Trace			; TRACE
	Return

Inputp:	Setz V,				; ?TERMINAL
	Movei A,.PRIIN
	SIBE
	  Seto V,
	Call 4SAVE
	Return

PLevel:	Move V,Level			; LEVEL
	Call 4SAVE
	Return

Runt:	Movei A,.FHSLF			; RUNT
	RUNTM
	Move V,A
	Call 4SAVE
	Return

Base10:	Movei A,10.			; DECIMAL
	Movem A,Base
	Return

Base8:	Movei A,8.			; OCTAL
	Movem A,Base
	Return

Base2:	Movei A,2			; BINARY
	Movem A,Base
	Return

Aye:	Skipge DOc			; I
	  Jrst DOerr
	Move T1,DOc
	Move V,DOind(T1)
	Call 4SAVE
	Return

Jay:	Skipg DOc			; J
	  Jrst DOerr
	Move T1,DOc
	Soj T1,
	Move V,DOind(T1)
	Call 4SAVE
	Return

En:	Call 4REST			; IJ..N
	Jumple V,[Type " ?Loop # <1"
		  Jrst Erret]
	Soj V,
	Camle V,DOc
	  Jrst DOerr
	Move T1,DOc
	Sub T1,V
	Move V,DOind(T1)
	Call 4SAVE
	Return

VLIST:	Movei T1,Dict
	Setz T2,
	Call Terpri
VL2:	Skipn (T1)
	  Return
	Move T3,[440700,,(T1)]
	Setz T4,
VL3:	Ildb A,T3
	Skipe A
	Aoja T4,VL3
	Add T2,T4
	Addi T2,2
	Caml T2,Width
	  Jrst [Call Terpri
		Move T2,T4
		Addi T2,2
		Jrst .+1]
	Movei A,40
	PBOUT
	PBOUT
	Move T3,[440700,,(T1)]
VL4:	Ildb A,T3
	PBOUT
	Sojn T4,VL4

VL5:	Hlrz T3,3(T1)
	Add T1,T3
	Jrst VL2

;;;
;;;	Formatted number output stuff
;;;

SOutF:	Skipe Format				; <#
	  Jrst [Type " ?Already formatting"
		Jrst Erret]
	Jumpe U,UFlow
	Move V,(S)
	Setom Format
	Jumpge V,SOutFs
	Movns V
	Setom FMinus
SOutFs:	Movem V,(S)
	Move A,[010700,,FBufBP-1]
	Movem A,FBufBP
	Movei B,5*FBufl-1
	Movem B,FLeft
	Return

FSign:	Skipn Format				; SIGN
	  Jrst NForm
	Skipn FMinus
	  Return
	Movei K,"-
	Call FSave
	Return

FDigit:	Skipn Format				; #
	  Jrst NForm
	Jumpe U,Unform
	Move T1,(S)
	Idiv T1,Base
	Move K,T2
	Addi K,60
	Call FSave
	Movem T1,(S)
	Return

FNDigs:	Skipn Format				; #N
	  Jrst NForm
	Call 4REST
	Skipg V
	  Return
	Jumpe U,Unform
	Move T1,(S)
FNDlop:	Idiv T1,Base
	Move K,T2
	Addi K,60
	Call FSave
	Sojn V,FNDlop
	Movem T1,(S)
	Return

FHold:	Skipn Format				; HOLD
	  Jrst NForm
	Call 4REST
	Move K,V
	Call FSave
	Return

FDigs:	Skipn Format				; #S
	  Jrst NForm
	Jumpe U,Unform
	Move T1,(S)
FDigsl:	Jumpe T1,FDigse
	Idiv T1,Base
	Move K,T2
	Addi K,60
	Call FSave
	Jrst FDigsl
FDigse:	Setzm (S)
	Return

EOutF:	Skipn Format				; #>
	  Jrst NForm
	Call 4REST
	Move V,FBufBP
	Call 4SAVE
	Movei V,5*FBufl-1
	Sub V,FLeft
	Call 4SAVE
	Setzm Format
	Return

FSave:	Skipn FLeft
	  Jrst [Type " ?Formatting buffer full"
		Jrst Erret]
	Move A,FBufBP
	DBP A
	Movem A,FBufBP
	Dpb K,FBufBP
	Sos FLeft
	Return

;;;
;;;	Display hacking
;;;

Home:	Skipn Term			; HOME
	  Return
	Move T1,Term
	Move A,[440700,,Homes(T1)]
	PSOUT
	Return

CLS:	Skipn Term			; CLEAR
	  Return
	Move T1,Term
	Move A,[440700,,Clears(T1)]
	PSOUT
	Return

;;;
;;;	Outputting words
;;;

Space:	Movei A,40			; SPACE
	PBOUT
	Return

Spaces:	Call 4REST			; SPACES
	Skipg V
	  Return
	Movei A,40
	PBOUT
	Sojn V,.-1
	Return

Terpri:	Movei A,^M			; CR
	PBOUT
	Movei A,^J
	PBOUT
	Return

Emit:	Call 4REST				; EMIT
	Move A,V
	PBOUT
	Return

7TypeN:	Call 4REST	;# Characters		  TYPE
	Move T1,V
	Call 4REST	;BP
7TNlop:	Ldb A,V
	PBOUT
	Ibp V
	Sojn T1,7TNlop
	Return

7Type:	Call 4REST	;BP			  [TYPE]
7TLoop:	Ldb A,V
	Skipn A
	  Return
	PBOUT
	Ibp V
	Jrst 7TLoop

Dotext:	Skiple Level			; ."
	  Jrst Dotsav
Dotxt2:	Call Getchr
	  Call Refill
	Movem K,Delim
Dotxt3:	Call Getchr
	  Call Refill
	Camn K,Delim
	  Return
	Move A,K
	PBOUT
	Caie A,^M
	  Jrst Dotxt3
	Movei A,^J
	PBOUT
	Jrst Dotxt3

Dotsav:	Move T1,E
	Hrli T1,440700
	Aoj T1,
	Setz T2,

Dots2:	Ildb A,T1
	Jumpe A,Dots3
	PBOUT
	Caie A,^M
	  Aoja T2,Dots2
	Movei A,^J
	PBOUT
	Aoja T2,Dots2

Dots3:	Idivi T2,5	;Return # of text words to skip
	Aoj T2,
	Add E,T2
	Return

;;;
;;;	Character operations
;;;

CFetch:	Jumpe U,UFlow			; C@
	Ldb A,(S)
	Movem A,(S)
	Return

CStore:	Call 4REST	;BP		  C!
	Move T1,V
	Call 4REST	;Byte
	Dpb V,(T1)
	Return

CPlus:	Call 4REST	;Number		  C+
	Move T1,V
	Call 4REST	;BP
	Idivi T1,5
	Add V,T1
	Jumpe T2,CPlusb
	Ibp V
	Sojn T2,.-1
CPlusb:	Call 4SAVE
	Return

CMinus:	Call 4REST	;Number		  C-
	Move T1,V
	Call 4REST	;BP
	IDivi T1,5
	Sub V,T1
	Jumpe T2,CMin2
CMin1:	Dbp V
	Sojn T2,CMin1
CMin2:	Call 4SAVE
	Return

CMoveN:	Call 4REST	;Number			CMOVE
	Move T1,V
	Call 4REST	;BP-to
	Move T2,V
	Call 4REST	;BP-from
CMNlop:	Ldb A,V
	Dpb A,T2
	Ibp V
	Ibp T2
	Sojn T1,CMNlop
	Return

CMoves:	Call 4REST	;BP-to		[CMOVE]		Returns #chars
	Move T1,V
	Call 4REST	;BP-from
	Setz T2,
CMSlop:	Ldb A,V
	Jumpe A,CMSdun
	Dpb A,T1
	Ibp V
	Ibp T1
	Aoja T2,CMSlop
CMSdun:	Call 4SAVE
	Return

;;;
;;;	Inputting words
;;;

Key:	PBIN				; KEY
	Andi A,177
	Move V,A
	Call 4SAVE
	Return

Number:	Jumpe U,UFlow			; caddr [NUMBER] --> caddr n -1
	Move T1,(S)	;BP-from	;		 --> caddr 0
	Call StoN
	  Jrst [Movem T1,(S)
		Setz V,
		Call 4SAVE
		Return]
	Movem T1,(S)
	Move V,T2
	Call 4SAVE
	Seto V,
	Call 4SAVE
	Return

ExpecN:	Call 4REST	;Number			EXPECT
	Move T1,V
	Call 4REST	;BP-to
ENLoop:	PBIN
	Dpb A,V
	Skipe Echo
	  PBOUT
	Ibp V
	Sojn T1,ENLoop
	Return

Expect:	Call 4REST	;BP		[EXPECT]
	Setz T3,
ELoop:	PBIN
	Cain A,^M
	  Jrst ESave
	Dpb A,V
	Skipe Echo
	  PBOUT
	Ibp V
	Aoja T3,ELoop
ESave:	Dpb V		;Make it asciz
	Move V,T3
	Call 4SAVE
	Return

;;;
;;;	Numberic output
;;;

DotR:	Call 4REST			; .R
	Move T4,V
	Skipa
Dot:	Call 4REST			; .
Dota:	Setz T4,
	Movm T1,V
	Setz T3,
Dot1:	IDiv T1,Base
	Push P,T2
	Aoj T3,
	Jumpn T1,Dot1
Dot2:	Move T1,T3
	Skipge V
	  Aoj T1,
	Camg T4,T1
	  Jrst DotS
	Sub T4,T1
DotF:	Movei A,40
	PBOUT
	Sojn T4,DotF
DotS:	Jumpge V,Dot3
	Movei A,"-
	PBOUT
Dot3:	Pop P,A
	Addi A,60
	PBOUT
	Sojn T3,Dot3
Dot4:	Movei A,40
	PBOUT
	Return

FDot:	Call 4REST			; F.
	Movei A,.PRIOU
	Move B,V
	Movei C,FL%ONE\FL%PNT
	FLOUT
	  Jfcl
	Return

;;;
;;;	Text building (Dictionary)
;;;

SaveTs:	Call 4REST			; ["]
	Move T1,V
	Movei A,^M
	Movem A,Delim
	Call sTextd
	Move V,T2
	Call 4SAVE
	Return

SaveTd:	Call 4REST			; (")
	Move T1,V
	Call sText
	Move V,T2
	Call 4SAVE
	Return

ColTex:	Call BText
	Move V,lsText
	Call 4SAVE
	Return

;;;
;;;	Miscellaneous
;;;

Exit:	Call Terpri
	Type "Exiting FORTH"
	Call Terpri
	Jrst Die

Remark:	Call Getchr			; (
	  Call Refill
	Caie K,")
	  Jrst Remark
	Return

Here:	Skipn Making			; HERE
	  Jrst Buierr
	Move V,Dicte
	Add V,D
	Call 4SAVE
	Return

Execut:	Call 4REST			; EXECUTE
	Move L,V
	Call Eval
	Return

Leave:	Skipge DOc
	  Jrst DOerr
	Move T1,DOc
	Move T2,DOtop(T1)
	Movem T2,DOind(T1)
	Return

Jsys0:	Call 4REST	;JSys#		  JSYS
	Hrr V,JCall
	Xct JCall
	Return

Flush:	Move S,Stack			; FLUSH
	Setz U,
	Return

;;;
;;;	Stack/Memory operations
;;;

Store:	Call 4REST			; !
	Move T1,V
	Call 4REST
	Movem V,(T1)
	Return

Storep:	Call 4REST			; +!
	Move T1,V
	Call 4REST
	Addm V,(T1)
	Return

Storem:	Call 4REST			; -!
	Move T1,V
	Call 4REST
	Exch V,(T1)
	Subm V,(T1)
	Return

Fill:	Call 4REST	;Value			FILL
	Move T1,V
	Call 4REST	;Number
	Move T2,V
	Call 4REST	;Address
	Add T2,V
	Movem T1,V
	Hrl V,V
	Aoj V,
	BLT V,-1(T2)
	Return

XChanj:	Call 4REST				; EXCHANGE
	Move T1,V
	Call 4REST
	Move T2,(V)
	Exch T2,(T1)
	Movem T2,(V)
	Return

Fetch:	Jumpe U,UFlow				; @
	Move T1,(S)
	Move T2,(T1)
	Movem T2,(S)
	Return

;;;
;;;	Random Dictionary stuff
;;;

Tic:	Call Getwrd				; '
	  Call Refill
	Skipn IAddr
	  Jrst NamErr
	Move V,IAddr
	Call 4SAVE
	Return

Ticnum:	Call Getwrd				; '#
	  Call Refill
	Skipn INump
	  Jrst NamErr
	Move V,IVal
	Call 4SAVE
	Return

Forget:	Call Getwrd				; FORGET
	  Call Refill
	Skipn IAddr
	  Jrst NamErr
	Move T1,IAddr
	Setzm (T1)
	Hrl T1,T1
	Aoj T1,
	BLT T1,Dicte
	Move A,IAddr
	Hrrm A,Dicte
	Return

;;;
;;;	Logical operations
;;;

LogAND:	Caige U,2			; AND
	  Jrst UFlow
	Call 4REST
	Andm V,(S)
	Return

LogOR:	Caige U,2			; OR
	  Jrst UFlow
	Call 4REST
	IOrm V,(S)
	Return

LogNOT:	Jumpe U,UFlow			; NOT
	Setcmm (S)
	Return

LogXOR:	Caige U,2			; XOR
	  Jrst UFlow
	Call 4REST
	XOrm V,(S)
	Return

;;;
;;;	Arithmetic operations
;;;

Plus:	Caige U,2			; +
	  Jrst UFlow
	Call 4REST
	Addm V,(S)
	Return

FPlus:	Caige U,2			; F+
	  Jrst UFlow
	Call 4REST
	FADM V,(S)
	Return

Minus:	Call 4REST			; -
	Jumpe U,UFlow
	Exch V,(S)
	Subm V,(S)
	Return

FMin:	Call 4REST			; F-
	Jumpe U,UFlow
	Exch V,(S)
	FSBM V,(S)
	Return

Times:	Caige U,2			; *
	  Jrst UFlow
	Call 4REST
	IMulm V,(S)
	Return

FTimes:	Caige U,2			; F*
	  Jrst UFlow
	Call 4REST
	FMPM V,(S)
	Return

Divide:	Call 4REST			; /
	Jumpe U,UFlow
	Exch V,(S)
	IDivm V,(S)
	Return

FDiv:	Call 4REST			; F/
	Jumpe U,UFlow
	Exch V,(S)
	FDVM V,(S)
	Return

Power:	Call 4REST			; ^
	Move T1,V
	Call 4REST
	Movei T2,1
P2:	Jumple T1,P3
	Imul T2,V
	Soja T1,P2
P3:	Move V,T2
	Call 4SAVE
	Return

Mod:	Call 4REST			; MOD
	Move T1,V
	Call 4REST
	Move T2,V
	IDiv T2,T1
	Move V,T3
	Call 4SAVE
	Return

DivMod:	Call 4REST			; /MOD
	Move T1,V
	Call 4REST
	Move T2,V
	IDiv T2,T1
	Move V,T3
	Call 4SAVE
	Move V,T2
	Call 4SAVE
	Return

;;;
;;;	Conversions
;;;

ItoF:	Jumpe U,UFlow			; FLOAT
	FLTR T1,(S)
	Movem T1,(S)
	Return

FtoI:	Jumpe U,UFlow			; FIX
	FIXR T1,(S)
	Movem T1,(S)
	Return

;;;
;;;	Single operator tests
;;;

EqualZ:	Setz A,			; 0=
	Jrst 1Test
NotEq0:	Movei A,1		; 0=_
	Jrst 1Test
LessZ:	Movei A,2		; 0<
	Jrst 1Test
LesEq0:	Movei A,3		; 0<=
	Jrst 1Test
GreatZ:	Movei A,4		; 0>
	Jrst 1Test
GrEq0:	Movei A,5		; 0>=

1Test:	Jumpe U,UFlow
	Setz T1,
	Xct 1Tests(A)
	  Seto T1,
	Movem T1,(S)
	Return

;;;
;;;	Two operator tests
;;;

Equal:	Setz A,			; =
	Jrst 2Test
NotEqu:	Movei A,1		; =_
	Jrst 2Test
Less:	Movei A,2		; <
	Jrst 2Test
LessEq:	Movei A,3		; <=
	Jrst 2Test
Greatr:	Movei A,4		; >
	Jrst 2Test
GretEq:	Movei A,5		; >=

2Test:	Call 4REST
	Jumpe U,UFlow
	Setz T1,
	Xct 2Tests(A)
	  Seto T1,
	Movem T1,(S)
	Return

;;;
;;;	File-loading things
;;;

Load:	Move T3,LLoad				; LOAD
	Cail T3,MaxLLs
	  Jrst [Type " ?Can't load deeper"
		Jrst Erret]
	Skipg Level
	  Jrst L2
	Movsi A,(GJ%SHT\GJ%OLD)
	Hrro B,E
	Aoj B,
	GTJFN
	  Jrst NoFile
	Hrrz T1,B
	Sub T1,E
	Move B,[070000,,OF%RD]
	OPENF
	  Jrst NoFile
	Add E,T1
	Jrst LSave

L2:	Call Getchr
	  Call Refill
	Movem K,Delim
	Move T1,[440700,,FName]
L3:	Call Getchr
	  Call Refill
	Camn K,Delim
	  Jrst L4
	Idpb K,T1
	Jrst L3
L4:	Idpb T1		;Make asciz
	Hrroi B,FName
L5:	Movsi A,(GJ%SHT\GJ%OLD)
	GTJFN
	  Jrst NoFile
	Move B,[070000,,OF%RD]
	OPENF
	  Jrst NoFile

LSave:	Move T1,iJFN
	Aos T2,LLoad
	Movem T1,LiJFNs(T2)
	Movem A,iJFN
	Setom Loadp
	Setzm Echo
	Return

Loads:	Call 4REST				; [LOAD]
	Hrro B,V
	Jrst L5

Unload:	Skipge LLoad			; UNLOAD
	  Jrst [Type " ?Not loading"
		Jrst Erret]
	Move A,iJFN
	CLOSF
	  Jrst [Type " %Can't close file"
		Jrst .+1]
	Move T1,LLoad
	Move A,LiJFNs(T1)
	Movem A,iJFN
	Sos LLoad
	Skipl LLoad
	  Return
	Setom Echo
	Setzm Loadp
	Return

;;;
;;;	The infamous IF/ELSE/THEN structure
;;;

IF:	Call 4REST
	Skipe V
	  Return
IFskip:	Aoj E,
	Move T1,(E)
	Came T1,[-1,,Then]
	  Camn T1,[-1,,Else]
	    Return
	Jrst IFskip

Else:	Aoj E,
	Move T1,(E)
	Came T1,[-1,,Then]
	  Jrst Else
	Return

Then:	Return

;;;
;;;	The REPEAT/UNTIL loop
;;;

Rept:	Aos T1,UNTILc
	Movem E,UNTILs(T1)	;Start of REPEAT code
	Return

Until:	Call 4REST
	Jumpe V,[Move T1,UNTILc
		 Move E,UNTILs(T1)
		 Return]
	Sos UNTILc
	Return

;;;
;;;	The leading test WHILE/BEGIN/END loop
;;;

While:	Aos T1,WHILEc
	Movem E,WHILEs(T1)
	Setzm WHILEe(T1)
	Return

Begin:	Call 4REST
	Skipe V
	  Return
	Move T1,WHILEc
	Skipe WHILEe(T1)
	  Jrst [Move E,WHILEe(T1)
		Return]
Begin2:	Aoj E,
	Move T1,(E)
	Came T1,[-1,,FEnd]
	  Aoja E,Begin2
	Sos WHILEc
	Return

FEnd:	Move T1,WHILEc
	Movem E,WHILEe(T1)
	Move E,WHILEs(T1)
	Return

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;	The obligatory DO/LOOP[+] structure.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

DoLoop:	Aos T1,DOc
	Movem E,DOs(T1)
	Call 4REST
	Movem V,DOind(T1)	;Initial value
	Call 4REST
	Movem V,DOtop(T1)	;Upper limit
	Return

Loop:	Move T1,DOc
	Aos V,DOind(T1)
	Jrst Loopt

Loopp:	Move T1,DOc
	Call 4REST
	Jumpl V,Looppm
	Addb V,DOind(T1)

Loopt:	Camge V,DOtop(T1)
	  Move E,DOs(T1)
	Caml V,DOtop(T1)
	  Sos DOc
	Return

Looppm:	Addb V,DOtop(T1)
	Camle V,DOtop(T1)
	  Move E,DOs(T1)
	Camg V,DOtop(t1)
	  Sos DOc
	Return

;;;
;;;	The Colon (:) Compiler (Quite Hirsute)
;;;

Colon:	Skipe Making
	  Jrst [Type " ?Can't compile :'s"
		Jrst Erret]
	Setom Making
	Call MHead

Colon1:	Call Getwrd
	  Call Refill
	Skipe INump
	  Jrst [Aoj D,
		Setom @Dicte
		Aoj D,
		Move T1,IVal
		Movem T1,@Dicte
		Jrst Colon1]
	Skipn IAddr
	  Jrst [Type " ?Undefined"
		Jrst Erret]
	Move T1,IAddr
	Cain T1,SEMIa
	  Jrst Coldun
	Caie T1,PARENa	;Don't compile comments
	  Jrst Colon2
Colsr:	Call Getchr
	  Call Refill
	Caie K,")
	  Jrst Colsr

Colon2:	Hrre A,3(T1)
	Jumpg A,[Aoj D,
		 Movem T1,@Dicte
		 Jrst Colon1]
	Caie T1,ELSEa
	  Jrst Colon3
	Skipge IFc
	  Jrst [Type " ?ELSE without IF"
		Jrst Erret]
	Jrst Colis

Colon3:	Caie T1,THENa
	  Jrst Colon4
	Skipge IFc
	  Jrst [Type " ?THEN without IF"
		Jrst Erret]
	Sos IFc
	Jrst Colis

Colon4:	Caie T1,BEGINa
	  Jrst Colon5
	Skipge WHILEc
	  Jrst [Type " ?BEGIN without WHILE"
		Jrst Erret]
	Setom BEGINp
	Jrst Colis

Colon5:	Caie T1,ENDa
	  Jrst Colis
	Skipge WHILEc
	  Jrst [Type " ?END without WHILE"
		Jrst Erret]
	Skipn BEGINp
	  Jrst [Type " ?END without BEGIN"
		Jrst Erret]
	Pop P,BEGINp
	Sos WHILEc

Colis:	Move T4,4(T1)
	Aoj D,
	Movem T4,@Dicte

CLoad:	Caie T1,DOTQa
	  Cain T1,LOADa
	    Jrst [Call BText
		  Jrst Colon1]

Colis1:	Caie T1,UNTILa
	  Jrst Colis2
	Skipge UNTILc
	  Jrst [Type " ?UNTIL without REPEAT"
		Jrst Erret]
	Sos UNTILc
	Jrst Colon1

Colis2:	Caie T1,LOOPa
	  Cain T1,LOOPPa
	    Skipa
	Jrst Colis3
	Skipge DOc
	  Jrst [Type " ?LOOP without DO"
		Jrst Erret]
	Sos DOc
	Jrst Colon1

Colis3:	Caie T1,IFa
	  Jrst Colis4
	Aos IFc
	Jrst Colon1

Colis4:	Caie T1,DOa
	  Jrst Colis5
	Move A,DOc
	Cail A,DOn-1
	  Jrst [Type " ?DOs nested too deeply"
		Jrst Erret]
	Aos DOc
	Jrst Colon1

Colis5:	Caie T1,REPTa
	  Jrst Colis6
	Move A,UNTILc
	Cail A,UNTILn-1
	  Jrst [Type " ?REPEATs nested too deeply"
		Jrst Erret]
	Aos UNTILc
	Jrst Colon1

Colis6:	Caie T1,WHILEa
	  Jrst Colon1
	Move A,WHILEc
	Cail A,WHILEn-1
	  Jrst [Type " ?WHILEs nested too deeply"
		Jrst Erret]
	Aos WHILEc
	Push P,BEGINp
	Setzm BEGINp
	Jrst Colon1

Coldun:	Skipl IFc
	  Jrst [Type " ?Unfinished IF"
		Jrst Erret]
	Skipl DOc
	  Jrst [Type " ?Unfinished DO"
		Jrst Erret]
	Skipl UNTILc
	  Jrst [Type " ?Unfinished REPEAT"
		Jrst Erret]
	Skipl WHILEc
	  Jrst [Type " ?Unfinished WHILE"
		Jrst Erret]
	Hrrz T1,Dicte
	Addi T1,4	;Address of executable part
	Addi D,2
	Hrl T1,D
	Movem T1,-1(T1)	;Length,,Address
	Addm D,Dicte
	Setzm Making
	Return

;;;
;;;	Dictionary building words
;;;

Builds:	Skipe Making				; <BUILDS
	  Jrst [Type " ?Already building"
		Jrst Erret]
	Call MHead
	Setom Making
	Return

Does:	Skipn Making				; DOES>
	  Jrst [Move V,BStart
		Call 4SAVE
		Return]
	Move T1,Dicte
	Move T2,E
	Aoj D,
	Hrl T2,D
	Movem T2,3(T1)
	Addm D,Dicte
	Setzm Making
	Setom Did
	Return

Comma:	Skipn Making			; ,
	  Jrst Buierr
	Call 4REST
	Aoj D,
	Movem V,@Dicte
	Return

Allot:	Skipn Making			; ALLOT
	  Jrst Buierr
	Call 4REST
	Skiple V
	  Add D,V
	Return

Ticome:	Skipn Making			; ] --> n
	  Jrst Buierr
	Setz V,
Ticom2:	Call Getwrd
	  Call Refill
	Skipe INump
	  Jrst Numer
	Skipn IAddr
	  Jrst UDef
	Move A,IAddr
	Cain A,SEMIa
	  Jrst [Call 4SAVE
		Return]
	Aoj D,
	Movem A,@Dicte
	Aoja V,Ticom2

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;                  Error Messages and Handling		   ;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

NoFile:	Type " ?Can't access file"
	Jrst Rerun

UFlow:	Type " ?Stack underflow"
	Jrst Erret

OFlow:	Type " ?Stack overflow"
	Jrst Erret

Buierr:	Type " ?Not building"
	Jrst Erret

DOerr:	Type " ?Loops too shallow"
	Jrst Erret

NForm:	Type " ?Not formatting"
	Jrst Erret

Unform:	Type " ?Formatting # gone"
	Setzm Format
	Jrst Erret

UDef:	Type " ?Undefined word"
	Jrst Erret

Numer:	Type " ?Numeric word"
	Jrst Erret

WMode:	Type " ?Immediate use disallowed"

Erret:	Call Terpri
	Move T1,[440700,,InBuf]
	Move T2,nIchar
	Soj T2,
Erret2:	Ildb A,T1
	PBOUT
	Sojg T2,Erret2
Erret3:	Type "<--"

UnMake:	Skipn Making
	  Jrst ReRun
	Call Terpri
	Type "%Unbuilding"
	Setzm @Dicte
	Sojge D,.-1
	Setzm Making

ReRun:	Setzm nIchar
	Setom Level
	Setom DOc
	Setom IFc
	Setom WHILEc
	Setom UNTILc
	Move P,PDList
	Skipn Loadp
	  Jrst PPRun
	Call Terpri
	Type "%Aborting load"
	Call Unload
	Jrst PPRun

NamErr:	Movei A,40
	PBOUT
	Hrroi A,IStrin
	PSOUT
	Movei A,"?
	PBOUT
	Movei A,40
	PBOUT
	Jrst ReRun

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;                          Subroutines			   ;;;
;;;								   ;;;
;;;								   ;;;
;;;								   ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

4SAVE:	Cail U,Deep
	  Jrst OFlow
	Aoj U,
	Push S,V
	Return

4REST:	Jumpe U,UFlow
	Soj U,
	Pop S,V
	Return

Getchr:	Ildb K,pInBuf		;Returns one character in K.  Skips
	Skipn K			;if there's something to get.
	  Return
	Aos nIchar
	Jrst Popj1

Refill:	Skipe Echo		;Does a fill-input-buffer and returns
	  Call Terpri		;to the instruction BEFORE the call.
	Call FillIB
	Sos (P)
	Sos (P)
	Return

FillIB:	Setzb T2,nIchar		;Gets a line of input from the input
	Move T4,[440700,,InBuf]	;source, with rubout handling, and
GL2:	Move A,iJFN		;stores it in InBuf - Appropriate BPs
GL2a:	BIN			;and character counts are reset.
	Erjmp [Call Unload
	       Jrst GLF]
	Andi B,177
	Cain B,^M
	  Jrst GL4
	Cain B,^E
	  Jrst [Setcmm Echo
		Jrst GL2a]
	Caige B,40
	  Jrst GL2
	Cain B,177
	  Jrst [Jumpe T2,GL2
		DBP T4
		Movei A,^H
		PBOUT
		Movei A,40
		PBOUT
		Movei A,^H
		PBOUT
		Soja T2,GL2]
GL3:	Move A,B
	Skipe Echo
	  PBOUT
GL4:	Cail T2,IBufln*5
	  Jrst GL2
	Idpb B,T4
	Aoj T2,
	Caie B,^M
	  Jrst GL2

GLnulp:	Caie T2,1	;Ignore blank lines.
	  Jrst GLF
	Skipe Echo
	  Call Terpri
	Jrst FillIB

GLF:	Idpb T4		;Store the final 0 to make string ASCIZ
	Move B,[440700,,InBuf]
	Movem B,pInbuf
	Return

Getwrd:	Setzm IStrin			;Reads one word (terminated by
	Move A,[IStrin,,IStrin+1]	;a blank, tab, or CR), parses
	BLT A,IVal			;it, and sets flags.  If INUMp
	Setz T2,			;is true, it's a number, whose
	Move T4,[440700,,IStrin]	;value is in IVAL.  If IADDR is
GWskip:	Call Getchr			;nonzero, then it is the address
	  Return			;in the Dictionary of the word.
	Caie K,40
	  Cain K,^I
	    Jrst GWskip
	Jrst GW3
GW2:	Call Getchr
	  Jrst Check
GW3:	Caie K,40
	  Cain K,^I
	    Jrst Check
	Cain K,^M
	  Jrst Check
	Cail T3,5*3	;Only 15 characters are significant
	  Jrst GW2
	Cail K,140
	  Trz K,40
	Cail K,"0	;if 0-9, or - in 1st place, or a ".", then ok.
	  Caile K,"9
	    Skipa
	Jrst GW4
	Cain K,"-
	  Skipe T2
	    Skipa
	Jrst GW4
	Caie K,".
	  Setom NotNum
GW4:	Idpb K,T4	;Store UPPERCASE
	Aoja T2,GW2

Check:	Skipn T2
	  Return
	Move T1,[350700,,IStrin]
	Call StoN
	  Jrst FCheck
	Movem T2,IVal
	Setom INump
	Jrst Popj1

FCheck:	Skipe NotNum
	  Jrst Search
	Move A,[440700,,IStrin]
	FLIN
	  Jrst Search
	Movem B,IVal
	Setom INump
	Jrst Popj1

Search:	Movei T1,Dict
S1:	Move T4,IStrin
	Came T4,(T1)
	  Jrst NFound
	Move T4,IStrin+1
	Came T4,1(T1)
	  Jrst NFound
	Move T4,IStrin+2
	Came T4,2(T1)
	  Jrst NFound
	Hrrzm T1,IAddr
	Jrst Popj1

NFound:	Hlrz T2,3(T1)
	Skipn T2
	  Jrst Popj1
	Add T1,T2
	Jrst S1

Eval:	Aos Level	;The heart of FORTH.  EVAL is the creature that
	Skipn Trace	;evaluates *things* - It either pushes constants,
	  Jrst Eval1	;calls subroutines (FORTH primitives), or EVALs
	Call Terpri	;the body of a FORTH word.  Note than that EVAL
	Move C,Level	;is, by nature, recursive.
	Jumpe C,ET1
	IMuli C,2
	Movei A,"=
	PBOUT
	Sojn C,.-1
ET1:	Movei A,">
	PBOUT

Eval1:	Came L,[-1]
	  Jrst Eval2
	Move V,1(E)
	Call 4SAVE
	Skipn Trace
	  Aoja E,EExit
	Type " Constant"
	Call SDump
	Aoja E,EExit

Eval2:	Skipl L
	  Jrst Eval3
	Skipe Trace
	  Jrst [Movei A,40
		PBOUT
		Call PFind
		Hrli V,350700
		Call 7TLoop
		Jrst .+1]
	Call (L)		; -1,,Subroutine
	Skipe Trace
	  Call SDump
	Jrst EExit

Eval3:	Hrrz T1,L	;T1 = Dict Addr
	Push P,E
	Hrrz E,3(T1)	;Code field
	Movei B,4(T1)
	Movem B,BStart
	Skipn Trace
	  Jrst Eval5
	Movei A,40
	PBOUT
	Move V,T1
	Hrli V,350700
	Call 7TLoop
	Call SDump

Eval5:	Skipe Did
	  Jrst EExitd
	Move L,(E)
	Jumpe L,EExit1
	Call Eval		;Recurse!
	Aoja E,Eval5

EExitd:	Setzm Did
EExit1:	Pop P,E
EExit:	Sos Level
	Return


MHead:	Call Getwrd		;This starts a Dictionary entry by filling
	  Call Refill		;in the name field, and reserving 1 more.
	Skipe INump
	  Jrst [Type " ?Numeric name field"
		Jrst Erret]
	Skipe IAddr
	  Jrst [Type " ?Already defined"
		Jrst Erret]
	Movei D,2
MH2:	Move T2,IStrin(D)
	Movem T2,@Dicte
	Sojge D,MH2
	Movei D,3
	Movei A,1
	Movem A,@Dicte
	Return

sText:	Call Getchr		;This reads text from the input buffer
	  Call Refill		;(delimited by 1st character) and stores
	Movem K,Delim		;them using T1 as the BP.  It saves the
sTextd:	Hrli T1,440700		;# of chars read in LSTEXT
	Setzm lsText
BTLoop:	Call Getchr
	  Call Refill
	Camn K,Delim
	  Jrst BTdone
	Idpb K,T1
	Aos lsText
	Jrst BTLoop
BTdone:	Idpb T1		;Make asciz
	Return

BText:	Skipn Making		;Used for ." and so on while building
	  Jrst Buierr		;to save the text in the Dictionary entry.
	Move T1,Dicte
	Aoj D,
	Add T1,D
	Call sText
	Move T2,lsText
	Idivi T2,5
	Add D,T2
	Return

PFind:	Movei V,Dict+3		;This finds the address of the primitive
PFind1:	Hrre A,(V)		;whose machine address we know (L)
	Jumpg A,[Setz V,
		 Return]
	Came L,1(V)
	  Jrst [Hlrz B,(V)
		Add V,B
		Jrst PFind1]
	Subi V,3
	Return

SDump:	Call Terpri			;This dumps the top 10. numbers
	Type "[ "			;on the stack for TRACEing.  TOS
	Jumpe U,[Type "Nil ] "		;is to the right.
		Return]
	Move C,U
	Soj C,
	Caig C,10.
	  Jrst SDump1
	Type "... "
	Movei C,10.
SDump1:	Move V,S
	Sub V,C
	Move V,(V)
	Call Dota
	Sojge C,SDump1
	Type "] "
	Return

StoN:	Setzb A,B		;This is the String-to-Number routine.  It
	Setzb T3,StoNmp		;expects a BP to the text in T1, and returns
SN1:	Ldb K,T1		;(skipping) with T2 as the number, and T3
	Caie K,40		;the number of character read.
	  Cain K,^I
	    Aoja T3,SN1
	Skipa
SN2:	Ldb K,T1
	Aoj A,
	Caie K,40	;String ends on "," or <space> or <cr>
	  Cain K,^M	;or a 0-byte
	    Jrst SNtest
	Caie K,",
	  Skipn K
	    Jrst SNtest
	Cain K,"-
	  Caie A,1
	    Jrst SN3
	Setom StoNmp
	Ibp T1
	Jrst SN2
SN3:	Subi K,60
	Skipge K
	  Jrst SNbad
	Caml K,Base
	  Jrst SNbad
	Push P,K
	Ibp T1
	Aoja B,SN2

SNtest:	Jumpe B,SNbad
	Setz T2,
	Movei T4,1
SNgood:	Pop P,K
	Imul K,T4
	Imul T4,Base
	Add T2,K
	Sojn B,SNgood
SNg2:	Skipe StoNmp
	  Movns T2
	Add T3,A
	Jrst Popj1

SNbad:	Skipn B
	  Return
	Pop P,K
	Soja B,SNbad

Lose:	Type "--Severe lossage--Dying--"
Die:	HALTF
	Jrst .-1

;;;
;;;	The End
;;;

Variables
Constants

	END Start