GopherProxy

;-*-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 /[2J/ ;#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