2274 lines
37 KiB
Plaintext
Executable File
2274 lines
37 KiB
Plaintext
Executable File
;-*-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 |