;-*-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