Code: Select all
/ ** FORTH-8 **
/FORTH COMPILER/INTERPRETER
/FOR TSS/8.24 PAL/D assembler
/STARTED 29-JUL-84
/BY JOHN WILSON.
/
*0
JMP START
/BETCHA DIDN'T KNOW YOU COULD JUMP-START A PROGRAM!
/
FIXTAB BSW= 7002
/
JUMP= JMS I .
JUMP0 /JUMP TO ADDRESS FOLLOWING JMS
CALL= JMS I .
CALL0 /CALL TO ADDR FOLLOWING JMS, USING STACK
RET= JMP I .
RET0 /POP VALUE OFF STACK, JUMP TO IT
RPUSH= JMS I .
RPUSH0 /PUSH AC TO RETURN STACK
RPOP= JMS I .
RPOP0 /POP RETURN STACK TO AC
PPUSH= JMS I .
PPUSH0 /PUSH AC TO PARAMETER STACK
PPOP= JMS I .
PPOP0 /POP PARAMETER STACK TO AC
*10
INDEX1, 0 /SCRATCH AUTO-INDEXING POINTER
INDEX2, 0
INDEX3, 0
/CONSTANTS:
C0007, 7
C0027, 27
C0077, 77
C0240, 240
C7540, 7540
*20
DP, USRDCT /DICTIONARY PTR
IMMDP, ICODE /DICT PTR INTO IMMEDIATE BUFFER
/
SP, 0 /RETURN STACK POINTER
PSP, 0 /PARAMETER STACK POINTER
NSP, 0 /NESTING STACK POINTER
/
/TEMPORARY VARIABLES:
TEMP1, 0
TEMP2, 0
TEMP3, 0
TEMP4, 0
TEMP5, 0
/
ERROR= JMS I .
ERROR0 /PRINT TRIMMED ASCII ERROR MESSAGE AFTER JMS, & ABORT
PPUSHC= JMS I .
PPC0 /PUSH CONSTANT AFTER JMS TO PARAMETER STACK
NPUSH= JMS I .
NPUSH0 /PUSH AC AND WORD AFTER JMS TO NESTING STACK
NPOP= JMS I .
NPOP0 /CHECK FOR MATCH WITH WORD AFTER JMS, POP AC FROM NSTACK
DCTVAL= JMS I .
DCTVA0 /PUT AC IN DICT (ONLY), AND ADVANCE DP
DCTCON= JMS I .
DCTCO0 /PUT WORD FOLLOWING JMS IN DICT, ADVANCE DP
PUTVAL= JMS I .
PUTVA0 /PUT AC IN CURRENT BUFFER, AND ADVANCE PTR
PUTCON= JMS I .
PUTCO0 /PUT WORD FOLLOWING JMS IN CURR BUFF, & ADVANCE PTR
TYPE= JMS I .
TYPE0 /TYPE .ASCIZ STRING FOLLOWING JMS
PRINT= JMS I .
PRINT0 /PRINT CHAR IN AC, UPDATE PRCOL
CRLF= JMS I .
CRLF0 /PRINT CR, LF
RTS= JMP I .
DOWORD /DO NEXT WORD (RETURN FROM TSTRU'S)
RUNIMM= JMS I .
RUNIM0 /RUN IMMEDIATE CODE, IF ANY
CURRDP= JMS I .
CURRD0 /RETURN DP FOR CURRENT BUFFER (SELON INWORD)
IF= JMS I .
WHILE= JMS I .
UNTIL= JMS I .
JUMPZ /PPOP, JUMP TO @PC IF ZERO
DO= JMS I .
DO0 /COPY TOP TWO ARGS ON PSTACK TO RSTACK
LOOP= JMS I .
LOOP0 /INC @RSP, LOOP IF NOT EQUAL TO @RSP+1, ELSE CLEAR RSTACK
/
/NESTING STACK TOKENS:
TIF= 1 /IF-ELSE-THEN
TBEGIN= 2 /BEGIN-UNTIL, BEGIN-WHILE-REPEAT, BEGIN-AGAIN
TWHILE= 3 /BEGIN-WHILE-REPEAT
TDO= 4 /DO-LOOP, DO-+LOOP, DO-/LOOP
/
PRCOL, 0 /CURRENT PRINTING COLUMN (FOR TABS)
KBFILE, 0 /<>0 -> REDIRECTING KB INPUT FROM CHANNEL 0 (LOAD)
INWORD, 0 /<>0 -> COMPILING A WORD (: ... ;)
NLEVEL, 0 /CURRENT NESTING LEVEL
CARETF, 0 /<>0 -> PRINT "^" UNDER LAST WORD READ ON ERROR
ERRCOL, 0 /ADDR OF BEGN OF LAST WORD READ FROM LINE (FOR "^" ON ERR)
PROMPT, 0 /<>0 -> PROMPT WITH "OK" (ONLY IF THINGS ARE OKAY!)
DELFLG, 0 /<>0 -> BETWEEN \'S (ON INPUT)
LINPTR, LINE /PTR TO NEXT WORD IN LINE
/
M0211, -211
WORDM1, WORD-1
CLINE, LINE
CWORD, WORD
LOOKUP, LOOKU0 /PTR TO LOOKUP ROUTINE
MAKEW, MAKEW0 /PTR TO ROUTINE TO BUILD A WORD HEADER
GETWRD, GETW /PTR TO ROUTINE TO READ A WORD FROM THE KB
SMUDGE, 0 /PTR TO LINK TO LAST CREATED WORD (ZEROED ON ERR)
/
/INITIALIZE POINTERS, SET ^C VECTOR
CTRLC /^C VECTOR
START, CLA+400 /=7600 (RSTACK/PSTACK BOUNDARY)
TAD .-2 /GET ^C VECTOR
SRA /SET IT
UND /TURN OFF ECHO
STA /SET KB BREAK
KSB /TO ANYTHING
TYPE /PRINT "FORTH-8 BY JOHN WILSON"
"F;"O+40;"R+40;"T+40;"H+40;"-;"8;240;240 /KINKY LOWER CASE
"B+40;"Y+40;240;"J;"O+40;"H+40;"N+40;240
"W;"I+40;"L+40;"S+40;"O+40;"N+40
215;212;0 /CR,LF,<NUL>
/
RESET, TAD START /LOAD 7600
DCA PSP /SET PSTACK PTR
CTRLC, CLA /JUMP HERE ON ^C
DCA I LINPTR /FORCE KB READ ON NEXT GETW
TAD ICODE0 /GET PTR TO IMM CODE
DCA IMMDP /POKE IT TO PTR
DCA NSP /SET NSTACK PTR
DCA SP /SET RSTACK PTR
IAC /SET BIT FOR CHAN 0 (KB REDIRECTION)
ISZ KBFILE /REDIRECTING INPUT?
SKP CLA /NO, DON'T WASTE FIP'S TIME
CLOS /YES, CLOSE THE FILE
DCA KBFILE /ANYWAY, WE'RE NOT NOW
TAD SMUDGE /KILL LAST WORD?
SNA CLA
JMP .+5 /NO, CONTINUE
TAD I SMUDGE /YES, GET LINK TO CONDEMNED WORD
DCA DP /BACK UP DP
DCA I SMUDGE /CLEAR OUT THE LINK
DCA SMUDGE /DON'T DO THIS AGAIN
DCA NLEVEL /CLEAR NESTING LEVEL
CMA /PRINT "^" UNDER ERRORS
DCA CARETF
DCA INWORD /NOT IN A WORD (: DEF'N)
/THAT SHOULD DO IT - NOW START THE INTERPRETER
JMP I .+1
C0200, DOWORD /JUMP INTO LOOP
ICODE0, ICODE /BEGN OF IMMEDIATE CODE
/
PAGE
/
DOWORD, /GET AND COMPILE A WORD
JMS GETW /GET A WORD
JMS I LOOKUP /LOOK UP THE WORD
SZL /SKIP IF FOUND
JMP DOWOR1 /NOT FOUND, MAYBE IT'S A #
TAD I TEMP1 /GET TYPE
DCA TEMP2 /SAVE
ISZ TEMP1 /INC PTR
JMP I TEMP2 /TYPE IS ALSO VECTOR
TCONS, /CONSTANT
TAD I TEMP1 /GET VALUE
DCA TEMP1 /SAVE AS ADDR (FAKE OUT TVARI)
TVARI, /VARIABLE
PUTCON /COMPILE A PPUSHC
PPUSHC /THAT'S WHAT I SAID
TAD TEMP1 /GET ADDR (VALUE IF TCONS)
PUTVAL /COMPILE IT IN-LINE
JMP DOWORD /LOOP
TSUBR, /SUBROUTINE (: ... ;)
PUTCON /COMPILE A CALL
CALL /YEP
TAD TEMP1 /GET ADDR
PUTVAL /LOOKS AN AWFUL LOT LIKE TVARI!
JMP DOWORD /LOOP
TSTRU, /CONTROL STRUCTURE (DO-LOOP, IF-ELSE-THEN, ETC.)
JMP I TEMP1 /JUMP TO COMPILATION ROUTINE
/CONTROL STRUC ROUTINES RETURN VIA "RTS" (JMP I (DOWORD))
DOWOR1, /WORD NOT DEFINED, CHECK FOR NUMBER
TAD CWORD /POINT AT WORD
DCA TEMP1 /SAVE PTR
JMS NUM /SEE IF NUMBER
SNL /NO, ERROR
JMP DOWOR2 /YES, VALUE IS IN TEMP2, GO PPUSHC IT
ERROR /UNDEFINED WORD
TEXT /WHAT?/ /I JUST LOVE VAGUE MESSAGES!
DOWOR2, PUTCON /PPUSHC
PPUSHC /...
TAD TEMP2 /GET VAL BACK
PUTVAL /COMPILE IN-LINE
JMP DOWORD /DO ANOTHER WORD
/
NUM, 0 /CONVERT .ASCIZ NUMBER AT @TEMP1 TO BINARY
/RESULT IN TEMP2, LINK SET IF NOT VALID NUMBER.
DCA TEMP2 /CLEAR ACCUMULATOR
DCA TEMP3 /CLEAR NEGATIVE FLAG
TAD I TEMP1 /GET FIRST CHAR
TAD MMINUS /"-" ?
SZA CLA /SKIP IF SO
JMP NUM1 /NO
ISZ TEMP3 /SET FLAG
ISZ TEMP1 /INC PTR
NUM1, TAD I TEMP1 /GET A CHAR
SNA /SKIP IF NOT DONE
JMP NUM2 /DONE, WHEE!
TAD NUM4 /MOVE TO RANGE [-10,-1]
CLL
TAD C0012 /FLIP LINK IF VALID DECIMAL
SNL /SKIP IF HOOPY
JMP NUM3 /INVALID DIGIT - NOT A NUMBER
DCA TEMP4 /SAVE
TAD TEMP2 /GET OLD NUMBER
CLL RTL /*4
TAD TEMP2 /+NUMBER
CLL RAL /*2 =(((N*4)+N)*2)=N*10.
TAD TEMP4 /ADD IN NEW DIGIT
DCA TEMP2 /REPLACE
ISZ TEMP1 /INC PTR
JMP NUM1 /LOOP
NUM2, TAD TEMP3 /NEGATE?
SNA CLA
JMP .+4 /NO, SKIP
TAD TEMP2 /GET NUMBER
CIA /NEGATE
DCA TEMP2 /REPLACE
CLL /CLEAR LINK - VALID NUMBER
JMP I NUM /RETURN WITH VALUE IN TEMP2
NUM3, STL /NOT A NUMBER
JMP I NUM /RETURN
NUM4, -12-"0
C0012, 12
MMINUS, -"-
/
GETW, 0
/READ A WORD FROM @LINPTR TO FIRST CTRL CHAR OR SPACE
/ENTER WITH AC CLEAR
/RETURN WITH .ASCIZ STRING IN WORD
TAD WORDM1 /PT AT WORD (AX)
DCA INDEX1 /OUTPUT PTR
GETW1, TAD LINPTR /SET ERRCOL TO POINT HERE
DCA ERRCOL /IN CASE THIS IS A NASTY WORD
TAD I LINPTR /GET CHAR
SNA /END OF LINE?
JMP I READLN /YES, GET ANOTHER ONE
TAD M0241 /SPACE OR CTRL CHAR?
SMA
JMP GETW2 /NO
IAC /SPACE?
SZA
TAD C0027 /TAB?
SZA CLA /YES, ONE OR THE OTHER
JMP .+3 /NO, ILLEGAL CHAR
ISZ LINPTR /INC PTR (IGNORE)
JMP GETW1 /LOOP
ERROR /ILLEGAL CHAR
TEXT /ILL CHAR/
GETW2, CLA
GETW3, TAD I LINPTR /GET CHAR
TAD M0241 /CTRL CHAR OR SPACE?
SPA CLA
JMP GETW4 /YES, GO RETURN
TAD I LINPTR /NO, RESTORE CHAR
TAD C7405 /CVT LOWER CASE TO [-26.,-1]
CLL
TAD C0032 /LOWER CASE?
SZL CLA /NO, SKIP
TAD M0040 /YES, SUBTRACT 32.
TAD I LINPTR /GET CHAR BACK
DCA I INDEX1 /SAVE
ISZ LINPTR /INC PTR
JMP GETW3 /LOOP
GETW4, DCA I INDEX1 /MARK END WITH <NUL>
JMP I GETW /RETURN
M0241, -241 /SPACE, CTRL CHARS -> [-32.,-1]
C0032, 32 /[-26.,-1] -> [0,25.] (FLIPPING LINK)
C7405, 7405 /LOWER CASE -> [-26.,-1]
M0040, -40 /LOWER CASE -> UPPER CASE
READLN, READL0 /PROMPT, GET A LINE
/
PAGE
/
READL0, /CALLS INPUT, AND RESETS LINPTR
RUNIMM /RUN IMMEDIATE CODE FIRST
TAD PROMPT /PROMPT?
SNA CLA
JMP READL1 /NO
TYPE /YES, PRINT PROMPT
"O+40;"K+40;215;212;0 /"OK<CR><LF>" (LOWER CASE)
READL1, CMA /REMEMBER TO PROMPT NEXT TIME, ANYWAY
DCA PROMPT
TAD CLINE /PT AT LINE BUFFER
DCA TEMP1 /PUT IN TEMP1
JMS INPUT /READ A LINE
TAD CLINE /GET PTR TO LINE
DCA LINPTR /PT AT LINE
JMP I .+1 /TRY AGAIN
GETW+1
/
INPUT, 0 /READ 80 CHARS FROM TTY TO @TEMP1
/ENTER WITH AC CLEAR
/0 MARKS END OF INPUT STRING
TAD TEMP1 /GET START OF BUFFER
CIA /NEGATE
DCA TEMP2 /USED TO CHECK BEG OF BUFF ON RUBOUT
TAD TEMP1 /GET PTR
DCA INDEX2 /SAVE IT
TAD TEMP1 /GET START OF BUFFER
TAD D0080 /PT AT LAST NON-CR CHAR IN BUFFER
CIA /NEGATE
DCA TEMP3 /USED TO CHECK END OF BUFF ON INSERT
DCA DELFLG /NOT BETWEEN \'S
INPUT1, KRB /GET A CHAR
DCA TEMP4 /SAVE IT
TAD NUMSPC /-(NUMBER OF SPECIALLY TREATED CHARS)
DCA TEMP5 /LOOP CTR
TAD CIDISP /PT AT IDISP (DISP. TABLE)
DCA INDEX1 /SAVE
TAD TEMP4 /GET CHAR BACK
INPUT2, TAD I INDEX1 /IS THIS THE CHAR?
SNA /SKIP IF THIS ISN'T IT
JMP INPUT5 /THIS IS IT, GO JUMP TO IT
ISZ INDEX1 /SKIP OVER ADDR
ISZ TEMP5 /DONE?
JMP INPUT2 /NO, TRY NEXT VALUE
CLA
INPUT3, /INSERT AND ECHO CHAR
JMS BACKSL /PRINT \ AND CLEAR DELFLG IF DELFLG
TAD TEMP1 /GET PTR
TAD TEMP3 /OUT OF SPACE?
SZA CLA /SKIP IF SO
JMP INPUT4 /OTHERWISE CONTINUE
TAD C0007 /RING BELL
PRINT
JMP INPUT1 /AND IGNORE
INPUT4, TAD TEMP4 /GET CHAR
DCA I TEMP1 /PUT IN BUFFER
ISZ TEMP1 /INC PTR
JMS I ECHOA /ECHO THE CHAR
JMP INPUT1 /LOOP
INPUT5, /JUMP TO DISPATCH TABLE ADDRESS
CLA /CLEAR AC
TAD I INDEX1 /GET DISPATCH VALUE
DCA BACKSL /SAVE
JMP I BACKSL /JUMP TO IT
BACKSL, 0 /IF DELFLG.NE.0, PRINT \ AND CLEAR DELFLG
TAD DELFLG /INSIDE \'S?
SNA CLA
JMP I BACKSL /NO, RETURN
DCA DELFLG /CLEAR FLAG
TAD .+3 /LOAD "\"
PRINT /PRINT IT
JMP I BACKSL /AND RETURN
"\ /DELIMITS DELETED CHAR'S
INPUT6, /MARK END OF STRING AND RETURN
JMS BACKSL /"\" IF NESSA
DCA I TEMP1 /ZERO AT END
CRLF /CR,LF
JMP I INPUT /RETURN
INPUT7, /^R - CR,LF AND REDRAW STRING
JMS BACKSL /"\" IF NESSA
JMS I ECHOA /PRINT "^R"
CRLF /CR,LF
DCA I TEMP1 /MARK END OF STRING, FOR NOW
CMA /LOAD -1
TAD INDEX2 /PT AT START OF STRING -1
DCA INDEX3 /SAVE
INPUT8, TAD I INDEX3 /GET A CHAR
SNA /SKIP IF NOT ZERO
JMP INPUT1 /GET ANOTHER CHAR
DCA TEMP4 /SAVE THE CHAR
JMS I ECHOA /ECHO IT
JMP INPUT8 /LOOP UNTIL 0
INPUT9, /^U - CR,LF AND CANCEL STRING
JMS I ECHOA /PRINT "^U"
CRLF /CR,LF
TAD INDEX2 /GET START OF BUFFER
DCA TEMP1 /RESET POINTER
JMP INPUT1 /GET ANOTHER CHAR
"$
INPU10, /ESCAPE - ECHO $ AND RETURN
JMS BACKSL /"\" IF NESSA
TAD .-2 /GET "$"
PRINT /PRINT IT
DCA I TEMP1 /MARK END OF STRING
JMP I INPUT /AND RETURN
/
RUBOUT, /RUBOUT - PRINT "\" (IF NESSA) AND ECHO LAST CHAR
TAD TEMP1 /GET PTR
TAD TEMP2 /GET -(START)
SZA CLA /BUFFER EMPTY?
JMP RUB1 /NO
JMS BACKSL /PRINT CLOSING \ IF NESSA
CRLF /YES, CR,LF
JMP INPUT1 /AND IGNORE
RUB1, TAD DELFLG /NEED A "\" ?
SZA CLA
JMP RUB2 /NO, ALREADY INSIDE \'S
TAD INPUT6-1 /GET \
PRINT /PRINT IT
ISZ DELFLG /SET DELFLG
RUB2, CMA /BACK UP PTR
TAD TEMP1
DCA TEMP1
TAD I TEMP1 /GET CHAR TO BE DELETED
DCA TEMP4 /PUT IN CHAR BUFF
JMS I ECHOA /ECHO IT
TAD TEMP1 /AT BEGN OF BUFF NOW?
TAD TEMP2
SZA CLA
JMP INPUT1 /NO, LOOP
JMS BACKSL /PRINT "\"
CRLF /CR,LF
JMP INPUT1 /AND DO ANOTHER CHAR
ECHOA, ECHO /PTR TO ECHO ROUTINE
D0080, 120 /80. (LENGTH OF BUFFER)
NUMSPC, -13 /-(NUMBER OF SPECIAL INPUT CHARS)
CIDISP, IDISP-1 /PTR TO INPUT DISPATCH TABLE
/
PAGE
/
ECHO, 0 /ECHO CHAR IN TEMP4
TAD TEMP4 /GET CHAR
AND C7540 /CLEAR AC4,AC7-AC11
SNA CLA /CTRL CHAR?
JMP ECHO2 /YES, SPECIAL TREATMENT
ECHO1, TAD TEMP4 /GET CHAR
PRINT /PRINT IT
JMP I ECHO /RETURN
ECHO2, TAD TEMP4 /GET CHAR
TAD M0211 /TAB?
SZA /SKIP IF SO
IAC /BACKSPACE?
SNA CLA /SKIP IF NOT
JMP ECHO1 /HT & BS ARE ECHOED AS-IS
TAD UPARR /PRINT "^"
PRINT
7203 /CLA IAC BSW (PAL-D BUG) LOAD 64.
TAD TEMP4 /LOAD CHAR+64.
PRINT /ECHO IT
JMP I ECHO /RETURN
UPARR, "^ /FOR CTRL CHARS
/
/DISPATCH TABLE FOR SPECIAL CHARACTERS:
IDISP, /INPUT DISPATCH TABLE (RO,ESC,^U,^R,^M,^L,^K,^J,^I,^H,NUL)
-377 /RUBOUT
RUBOUT
377-233 /ESCAPE
INPU10
233-225 /^U
INPUT9
225-222 /^R
INPUT7
222-215 /CR
INPUT6
215-214 /FF
INPUT6
214-213 /VT
INPUT6
213-212 /LF
INPUT6
212-211 /TAB
INPUT3
211-210 /BACKSPACE
INPUT3
210-200 /NUL
INPUT1
/DWEE!
/
0 /TEMP BUFFER FOR CHAR
PRINT0, 0 /PRINT CHAR IN AC, DEAL WITH TABS
DCA PRINT0-1 /SAVE
TAD PRINT0-1 /GET BACK
TAD M0211 /TAB?
SNA
JMP TAB /YES, DEAL WITH IT
IAC /BACKSPACE?
SNA /NO, SKIP
JMP BCKSPC /YES, SPECIAL TREATMENT
TAD C7773 /CR?
SNA CLA
JMP CARRET /YES
TAD PRINT0-1 /GET CHAR
AND C7540 /CTRL CHAR?
SZA CLA /SKIP IF SO
ISZ PRCOL /OTHERWISE INC PRCOL
PRINT1, TAD PRINT0-1 /GET CHAR
TLS /PRINT IT
CLA /CLEAR AC
JMP I PRINT0 /RETURN
/
BCKSPC, CLL CMA /DEC PRCOL
TAD PRCOL
SZL /UNLESS IT'S ALREADY 0 (DEC TERMINALS)
DCA PRCOL
CLA /IN CASE WE JUST SKIPPED
JMP PRINT1 /PRINT BS AND RETURN
TAB, TAD C0240 /PRINT A SPACE
TLS
CLA
ISZ PRCOL /MOVE OVER A COL
TAD PRCOL /GET PRCOL
AND C0007 /AT A TAB STOP?
SZA CLA /SKIP IF SO
JMP TAB /ELSE LOOP
JMP I PRINT0 /RETURN
CARRET, DCA PRCOL /CLEAR PRINT COLUMN
JMP PRINT1 /PRINT CR AND RETURN
/
C7773, 7773
/
CRLF0, 0 /PRINT CR,LF
TYPE /A LITTLE SLOW, BUT SO WHAT?
215;212;0 /CR,LF
JMP I CRLF0 /RETURN
/
TYPE0, 0 /PRINT .ASCIZ STRING FOLLOWING "TYPE"
TAD I TYPE0 /GET CHAR
ISZ TYPE0 /INC PTR
SNA /DONE YET?
JMP I TYPE0 /YES, RETURN
PRINT /NO, PRINT THE CHAR
JMP TYPE0+1 /LOOP UNTIL 0
/
RPUSH0, 0 /PUSH AC TO RETURN STACK (7600-7777)
DCA TYPE0 /SAVE AC
TAD SP /GET SP
TAD C0200 /STACK FULL?
SZA CLA
JMP RPUSH1 /NO, GO PUSH
ERROR /YES, PRINT MESSAGE
TEXT /RSTACK OVERFLOW/
RPUSH1, CMA /DEC SP
TAD SP
DCA SP
TAD TYPE0 /GET AC BACK
DCA I SP /PUSH IT
JMP I RPUSH0 /RETURN
/
PAGE
/
ERROR0, 0 /PRINT TRIMMED ASCII MESSAGE AFTER JMS & ABORT
TAD CARETF /PRINT "^"?
SNA CLA
JMP ERROR3 /NO
TAD ERRCOL /GET COLUMN OF ERROR
CIA /NEGATE
DCA TEMP1 /SAVE
TAD CLINE /PT AT LINE
DCA TEMP2 /SAVE
ERROR1, TAD TEMP1 /DONE?
TAD TEMP2
SNA CLA
JMP ERROR2 /YES, GO PRINT "^ "
TAD I TEMP2 /GET CHAR
TAD M0211 /TAB?
SZA CLA
TAD C0027 /NO, PRINT A SPACE
TAD C0211 /YES, PRINT A TAB
PRINT /HACK, HACK, HACK
ISZ TEMP2 /INC PTR
JMP ERROR1 /LOOP
ERROR2, TYPE /PRINT "^ "
"^;" ;0
ERROR3, STA CLL RAL /LOAD -2
DCA RPOP0 /SAVE LOOP CTR
TAD I ERROR0 /GET CHAR
BSW /GET HIGH CHAR
ERROR4, AND C0077 /MASK OUT HIGH BITS
SNA /DONE?
JMP ERROR6 /YES, CR/LF AND RESTART
DCA LOOKU0 /NO, SAVE THE CHAR
TAD LOOKU0 /GET BACK
CMA /FLIP EVERYTHING
AND C0040 /BIT 6 SET?
CLL RAL /HACK HACK HACK
TAD C0200 /ADD MISSING BITS
TAD LOOKU0 /GET CHAR BACK
PRINT /PRINT IT
ISZ RPOP0 /WAS THAT THE HIGH OR THE LOW CHAR?
JMP ERROR5 /HIGH
ISZ ERROR0 /LOW - PT TO NEXT CHAR
JMP ERROR3 /DO THE NEXT TWO CHARS
ERROR5, TAD I ERROR0 /GET LOW CHAR
JMP ERROR4 /PRINT IT
ERROR6, CRLF /CR,LF
DCA PROMPT /NOT "OK"
JMP RESET /GO RESTART
C0040, 40
C0211, 211 /TAB
/
LOOKU0, 0 /LOOK UP WORD IN WORD BUFFER
/RETURN WITH LINK CLEAR AND TEMP1 POINTING AT TYPE IF
/FOUND, OR WITH LINK SET IF NOT FOUND.
TAD CDICT /PT AT DICT
DCA TEMP1
DCA TEMP2 /PTR TO LAST LINK (FORGET)
LOOKU1, TAD WORDM1 /#WORD -1
DCA INDEX1 /SOURCE PTR (AX)
LOOKU2, CMA CLL RAL /LOAD -2 (2 CH'S/WORD)
DCA TEMP3 /LOOP CTR
TAD I TEMP1 /GET 2 CHARS
BSW /LOOK AT HIGH ORDER FIRST
LOOKU3, AND C0077 /REMOVE HIGH CHAR
SNA /END OF ENTRY?
JMP LOOKU5 /YES, SEE IF END OF WORD
TAD C0240 /CVT TO ASCII
CIA /NEGATE
TAD I INDEX1 /=?
SZA CLA
JMP LOOKU6 /NO, SKIP TO LINK
ISZ TEMP3 /FINISHED WORD?
JMP LOOKU4 /NO, CHECK LOW CHAR
ISZ TEMP1 /YES, PT AT NEXT PAIR OF CHARS
JMP LOOKU2 /LOOP
LOOKU4, TAD I TEMP1 /GET PAIR OF CHARS BACK
JMP LOOKU3 /CHECK LOW CHAR
LOOKU5, TAD I INDEX1 /END OF WORD?
SZA CLA
JMP LOOKU6 /NO, SKIP TO NEXT ENTRY
ISZ TEMP1 /YES, PT AT LINK
ISZ TEMP1 /PT AT TYPE
CLL /SIGNIFY FOUND
JMP I LOOKU0 /RETURN
LOOKU6, TAD I TEMP1 /GET CHAR
ISZ TEMP1 /PT AT NEXT CHAR OR LINK
AND C0077 /BOTTOM BYTE SHOULD BE 0, ANYWAY
SZA CLA /IS IT?
JMP LOOKU6 /NO, TRY NEXT WORD
TAD TEMP1 /YES, GET PTR TO LINK
DCA TEMP2 /SAVE IN CASE OF <FORGET>
TAD I TEMP1 /GET LINK
STL /IN CASE THIS IS THE END OF THE DICT
SNA /IS IT?
JMP I LOOKU0 /YES, RETURN, LINK SET
DCA TEMP1 /NO, PT TO NEXT NAME FIELD
JMP LOOKU1 /CHECK THIS ENTRY
CDICT, DICT /BEGINNING OF DICTIONARY
/
DCTVA0, 0 /PUT AC IN DICTIONARY, ADVANCE DP (CHECK PSTACK)
DCA I DP /THERE IS ALWAYS AT LEAST 1 FREE WORD
TAD DP /GET DP
CMA /NEGATE, SUBTRACT 1 (HACK HACK)
TAD PSP /PSTACK COLLISION?
SZA CLA
JMP DCTVA1 /NO
ERROR /YES, ERROR
TEXT /DICT FULL/
DCTVA1, ISZ DP /ALL OK, INC DP
JMP I DCTVA0 /RETURN, AC CLEAR
/
DCTCO0, 0 /PUT WORD AFTER JMS IN DICT, ADVANCE DP
CLA
TAD I DCTCO0 /GET WORD TO PUT
JMS DCTVA0 /PUT IT IN THE DICT
ISZ DCTCO0 /PT PAST ARG
JMP I DCTCO0 /RETURN, AC CLEAR
/
PAGE
/
MAKEW0, 0 /CREATE ENTRY FOR WORD IN WORD BUF IN DICT
/FIRST, CHECK TO MAKE SURE THE WORD DOESN'T ALREADY EXIST.
/USE TYPE IN WORD FOLLOWING JMS.
JMS I LOOKUP /TRY TO LOOK THE WORD UP
SZL /SKIP IF FOUND
JMP MAKEW1 /NOT THERE, MAKE IT
ERROR /ALREADY DEFINED
TEXT /ILL REDEF'N/
MAKEW1, TAD TEMP2 /GET PTR TO LINK IN LAST ENTRY
DCA SMUDGE /SAVE IN CASE OF COMPILATION ERROR
TAD WORDM1 /PT AT WORD
DCA INDEX1 /SOURCE PTR
MAKEW2, CMA CLL RAL /-2
DCA TEMP1 /LOOP CTR
MAKEW3, TAD I INDEX1 /GET A CHAR
SNA /END?
JMP MAKEW6 /YES, FINISH OFF
TAD M0240 /NO, CVT TO SIXBIT
DCA TEMP2 /SAVE
TAD TEMP2 /CHECK
AND C7700 /ANY EXTRA BITS?
SNA CLA
JMP MAKEW4 /OK, CONTINUE
ERROR /ILLEGAL NAME
TEXT /ILL NAME/
MAKEW4, TAD TEMP2 /GET CHAR
ISZ TEMP1 /CHAR 1, OR 2?
JMP MAKEW5 /1
TAD TEMP3 /2 - GET OLD CHAR
DCTVAL /COMPILE INTO DICTIONARY
JMP MAKEW2 /LOOP
MAKEW5, BSW /LEFT 6 BITS
DCA TEMP3 /SAVE
JMP MAKEW3 /LOOP
MAKEW6, /END OF WORD
ISZ TEMP1 /CHAR 1, OR 2?
SKP /1 - PUT 0,0
TAD TEMP3 /2 - PUT CHAR,0
DCTVAL /COMPILE LAST WORD OF NAME
DCTVAL /LINK IS 0
TAD I MAKEW0 /GET TYPE
DCTVAL /COMPILE IT
ISZ MAKEW0 /SKIP OVER TYPE
JMP I MAKEW0 /RETURN
C7700, 7700 /CLEAR OUT CHAR
M0240, -240 /CONVERT ASCII TO SIXBIT
/
PUTVA0, 0 /PUT AC IN DICT OR IMMBUF, DEPENDING ON INWORD
DCA MAKEW0 /SAVE AC
TAD INWORD /IN A : DEFN?
SNA CLA /SKIP IF SO
JMP PUTVA1 /ELSEWISE, GO PUT IN ICODE
TAD MAKEW0 /GET AC
DCTVAL /SAVE IN DICT
JMP I PUTVA0 /RETURN
PUTVA1, TAD IMMDP /GET IMMEDIATE PSEUDO-DICTIONARY PTR
TAD PUTVA3 /ICODE FULL?
SZA CLA /YES, ERROR
JMP PUTVA2 /NO, POKE THE VALUE
ERROR
TEXT /IMM BUFF FULL/
PUTVA2, TAD MAKEW0 /GET AC
DCA I IMMDP /PUT IN ICODE
ISZ IMMDP /INC PTR
JMP I PUTVA0 /RETURN
PUTVA3, -ICODE-176 /ALWAYS LEAVE ONE EXTRA WORD FOR "RET"
/
PUTCO0, 0 /PUT WORD AFTER JMS IN APPROPRIATE BUFFER
CLA
TAD I PUTCO0 /GET WORD
JMS PUTVA0 /POKE TO BUFFER
ISZ PUTCO0 /INC PTR
JMP I PUTCO0 /RETURN
/
JUMP0, 0 /JUMP TO ADDR AFTER JMS
CLA
TAD I JUMP0 /GET ADDR
DCA JUMP0 /SAVE
JMP I JUMP0 /JUMP TO IT
/
CALL0, 0 /CALL ADDR FOLLOWING "CALL," USING RSTACK
CLA IAC /LOAD 1
TAD CALL0 /RETURN ADDRESS
RPUSH /PUSH TO RSTACK
TAD I CALL0 /GET ADDR TO CALL
DCA CALL0 /SAVE
JMP I CALL0 /JUMP TO IT
/
RET0, /POP PC OFF OF RSTACK
RPOP /GET RETURN ADDRESS
DCA CALL0 /SAVE
JMP I CALL0 /JUMP TO IT
/
PPUSH0, 0 /PUSH AC TO PSTACK
DCA CALL0 /SAVE AC
CMA /DEC PSP
TAD PSP
DCA PSP
TAD DP /PSP-DP-1=0?
CMA
TAD PSP
SZA CLA
JMP PPUSH1 /NO, EVERYTHING'S HIP
ERROR
TEXT /PSTACK OVERFLOW/
PPUSH1, TAD CALL0 /RESTORE AC
DCA I PSP /PUSH IT
JMP I PPUSH0
/
PAGE
/
PPOP0, 0 /POP AC FROM PSTACK
CLA
TAD PSP /GET PSP
TAD C0200 /PSP=7600?
SZA CLA
JMP PPOP1 /NO
ERROR
TEXT /PSTACK UNDFL/
PPOP1, TAD I PSP /POP A VALUE
ISZ PSP /INC PSP
JMP I PPOP0 /RETURN
/
RPOP0, 0 /POP AC FROM RETURN STACK (7600-7777)
TAD SP /GET SP
SZA CLA
JMP RPOP1 /STACK OK, GO POP
ERROR /UNDERFLOW, PRINT ERROR
TEXT /RSTACK UNDFL/
RPOP1, TAD I SP /GET AC
ISZ SP /INC SP
NOP /THIS WILL SKIP ON THE LAST WORD
JMP I RPOP0 /RETURN
/
PPC0, 0 /PPUSH CONSTANT IN LOCN AFTER "PPUSHC"
CLA
TAD I PPC0 /GET CONSTANT
PPUSH /PPUSH IT
ISZ PPC0 /INC PAST ARG
JMP I PPC0 /RETURN
/
RUNIM0, 0 /RUN IMMEDIATE CODE
TAD INWORD /COMPILING A : DEFN?
SZA CLA
JMP IMM1 /YES, DON'T WORRY ABOUT NESTING
TAD NLEVEL /NLEVEL=NSP?
CIA
TAD NSP
SNA CLA
JMP IMM1 /YES, NO PROBLEM
ERROR /NO, GACK
TEXT /UNCLOSED STRUC/
IMM1, DCA CARETF /NO "^" ON RUN-TIME ERRORS
TAD CRET /"RET" AT END OF IMM CODE
DCA I IMMDP
CALL /CALL THE CODE
ICODE
TAD CICODE /PT AT ICODE
DCA IMMDP /RESET IMMDP
CMA /^ ON ERRORS
DCA CARETF
JMP I RUNIM0 /RETURN
CRET, RET
CICODE, ICODE
/
NPUSH0, 0 /PUSH AC, @PC TO NESTING STACK
DCA RPOP0 /SAVE AC
TAD NSP /GET NSTACK PTR
TAD NPUSH2 /STACK FULL?
SZA CLA
JMP NPUSH1 /NO
ERROR /YES, ERROR
TEXT /TOO MUCH NESTING/
NPUSH1, TAD NSP /GET OFFSET
TAD CNSTAK /ADD BASE
DCA PPC0 /SAVE PTR
TAD RPOP0 /GET ADDRESS BACK
DCA I PPC0 /PUSH IT
ISZ PPC0 /INC PTR
ISZ NSP /INC OFFSET
TAD I NPUSH0 /GET KEYWORD TOKEN
DCA I PPC0 /PUSH IT
ISZ NSP /INC OFFSET (NOT PTR)
ISZ NPUSH0 /SKIP OVER ARG
JMP I NPUSH0 /RETURN
NPUSH2, -40 /STACK BIG ENOUGH FOR 16 LEVELS OF NESTING
CNSTAK, NSTACK /PTR TO BASE OF NSTACK
/
PAGE
/
NPOP0, 0 /POP AC OFF OF NESTING STACK
/CHECK TO SEE IF TOKEN AGREES WITH ONE AFTER CALL (NEGATIVE)
CLA /JUST TO MAKE SURE
TAD NSP /GET NSTACK PTR
SZA /SKIP IF EMPTY
JMP NPOP1 /OTHERWISE START THE POP
ERROR /NO MATCHING NPUSH
TEXT /STRUC ERR/
NPOP1, TAD NSTAK1 /ADD BASE TO OFFSET
DCA TEMP5 /SAVE THIS PTR
TAD I TEMP5 /GET TOKEN
TAD I NPOP0 /GET -TOKEN TO MATCH
SNA CLA /DO THEY MATCH?
JMP NPOP2 /YES
ERROR /NO
TEXT /NEST ERR/
NPOP2, STA CLL RAL /-2
TAD NSP /DEC NSP BY 2
DCA NSP
STA /DEC PTR BY 1
TAD TEMP5
DCA TEMP5
TAD I TEMP5 /GET ADDRESS
ISZ NPOP0 /SKIP OVER TOKEN
JMP I NPOP0 /RETURN
NSTAK1, NSTACK-1
/
CURRD0, 0 /RETURN DP FOR CURRENT BUFFER
CLA /JUST MAKING SURE
TAD INWORD /IN A COLON DEFINITION?
SZA CLA
JMP .+3 /YES
TAD IMMDP /NO
JMP I CURRD0 /RETURN
TAD DP /GET DICTIONARY POINTER
JMP I CURRD0 /RETURN
/
/DATA AREAS
NSTACK= . /NESTING STACK
*.+40 /ALLOW 16. LEVELS OF NESTING
WORD= . /BUFFER FOR WORD
*.+40 /ALLOW 32. CHARS BEFORE HITTING LINE
LINE= . /BUFFER FOR INPUT LINE
*.+120 /ALLOW 80 CHARS
ICODE= . /BUFFER FOR IMMEDIATE MODE CODE
*.+200 /ALLOW A LOT OF THAT
DICT= . /START OF PREDEFINED DICTIONARY
/
0100 /!
PAREN
TSUBR
/( VAL ADDR -- ) POKES ADDR TO VAL
PPOP /GET ADDRESS
DCA TEMP1 /SAVE
PPOP /GET VALUE
DCA I TEMP1 /POKE
RET /RETURN
/
PAREN, 1000 /(
MULT
TSTRU
/( -- TEXT ')') IGNORES TEXT TO NEXT ")"
CLA
PAREN1, TAD I LINPTR /LOOK FOR ")"
ISZ LINPTR /PT AT NEXT CHAR
SNA /END OF LINE?
JMP PAREN2 /YES, GO READ ANOTHER ONE (BIG COMMENT)
TAD PAREN3 /")" ?
SZA CLA
JMP PAREN1 /NO, LOOP
RTS /YES, RETURN
PAREN2, TAD CLINE /PT AT LINE BUFF
DCA TEMP1 /SAVE PTR FOR INPUT
JMS I PAREN4 /CALL INPUT
TAD CLINE /PT AT LINE, AGAIN
DCA LINPTR /SET LINPTR TO POINT THERE
JMP PAREN1 /SEARCH LINE FOR ")"
PAREN3, -") /SEARCH CHARACTER
PAREN4, INPUT
/
MULT, 1200 /*
PLUS
TSUBR
PPOP /GET FIRST VALUE
DCA TEMP1 /SAVE IT
PPOP /GET SECOND VALUE
DCA TEMP2 /SAVE IT
JMS MULT0 /PERFORM THE MULTIPLY
TAD TEMP4 /GET THE PRODUCT
PPUSH /RETURN IT
RET
/
MULT0, 0 /MULTIPLY TEMP1 BY TEMP2, RESULT IN TEMP4
TAD M0014 /-12.
DCA TEMP3 /BIT COUNTER
DCA TEMP4 /ACCUMULATOR
MULT1, TAD TEMP1 /GET MULTIPLIER
RAR /AC11 INTO LINK
DCA TEMP1 /SAVE RESULT
SNL /SKIP IF 1
JMP MULT2 /0, DON'T ADD
TAD TEMP4 /GET ACCUMULATOR
TAD TEMP2 /ADD MULTIPLICAND
DCA TEMP4 /SAVE SUM
MULT2, TAD TEMP2 /ROTATE MULTIPLICAND LEFT ONE BIT
CLL RAL
DCA TEMP2
ISZ TEMP3 /DONE ALL 12. BITS?
JMP MULT1 /NO, LOOP
JMP I MULT0 /YES, RETURN (RESULT IN TEMP4)
M0014, -14 /-(NUMBER OF BITS IN A WORD)
/
PLUS, 1300 /+
COMMA
TSUBR
( VAL1 VAL2 -- VAL1+VAL2) RETURNS SUM OF TOP TWO VALUES
PPOP /GET FIRST VALUE
DCA TEMP1 /SAVE IT
PPOP /GET SECOND VALUE
TAD TEMP1 /ADD FIRST VALUE
PPUSH /PUSH SUM
RET
/
COMMA, 1400 /,
MINUS
TSUBR
( VALUE -- ) PUTS VALUE INTO DICTIONARY AND ADVANCES DP
PPOP /GET VALUE
DCTVAL /POKE INTO DICTIONARY
RET
/
MINUS, 1500 /-
DOT
TSUBR
( VAL1 VAL2 -- VAL1-VAL2) RETURNS DIFFERENCE BETWIXT TOP TWO VALUES
PPOP /GET VAL1
DCA TEMP1 /SAVE
PPOP /GET VAL2
CIA /NEGATE
TAD TEMP1 /ADD VAL1
PPUSH /PUSH RESULT
RET
/
DOT, 1600 /.
DOTQ
TSUBR
( VAL -- ) PRINTS VALUE ON TOP OF STACK, SIGNED
PPOP /GET VALUE
JMS .+2 /PRINT THE VALUE
RET /RETURN
/
PRNUM0, 0 /PRINT SPACE, AC (SIGNED)
SMA /NEGATIVE?
JMP PRNUM1 /NO
CIA /MAKE POSITIVE
DCA TEMP1 /SAVE
TYPE /PRINT " -"
" ;"-;0
JMP PRNUM2 /GO PRINT THE #
PRNUM1, DCA TEMP1 /SAVE NUMBER
TYPE /PRINT " "
" ;0
PRNUM2, TAD TEMP1 /GET NUMBER BACK
JMS I PRNUM3 /PRINT IT
RET /AND RETURN
PRNUM3, UPRNUM /ROUTINE TO PRINT A #, UNSIGNED
/
*. /TO AVOID "PE" ERRORS (PAL-D BUG)
DOTQ, 1602 /."
0000
DIVD
TSTRU /SPECIAL CASE COMPILATION
PUTCON /COMPILE "DOTQUO"
DOTQUO
JMS ASCIZ0 /COMPILE IN-LINE .ASCIZ CONSTANT
RTS
/
ASCIZ0, 0 /COMPILE IN-LINE STRING TERMINATED WITH "
TAD I LINPTR /END OF LINE HERE?
SNA CLA /NO
JMP ASCIZE /YES, ERROR (UNTERMINATED)
ASCIZ1, ISZ LINPTR /PT AT NEXT CHAR
TAD I LINPTR /GET A CHAR (LOWER CASE OK)
SNA /SHOULDN'T BE END OF LINE
JMP ASCIZE /ERROR IF SO
TAD ASCIZ3 /END OF STRING?
SNA CLA
JMP ASCIZ2 /YES, <NUL> AT END AND RETURN
TAD I LINPTR /NO, RESTORE CHAR
PUTVAL /PUT IN DICTIONARY
JMP ASCIZ1 /LOOP
ASCIZ2, ISZ LINPTR /SKIP OVER "
PUTVAL /COMPILE A <NUL>
RTS /AND RETURN
ASCIZ3, -242 /QUOTE
ASCIZE, ERROR /ERROR IF END OF LINE ENCOUNTERED
TEXT /NO CLOSING "/
/
DOTQU0, 0 /RUN-TIME ROUTINE TO PRINT .ASCIZ STRING FOLLOWING CALL
CLA /JUST TO MAKE SURE
DOTQU1, TAD I DOTQU0 /GET A CHAR
ISZ DOTQU0 /PT AT NEXT ONE
SNA /DONE?
JMP I DOTQU0 /YES, RETURN
PRINT /NO, PRINT THE CHAR
JMP DOTQU1 /LOOP UNTIL 0
/
DIVD, 1700 /"/"
/ADD THIS LATER
USRDCT= . /USER-DEFINED WORDS START HERE
$ THAT'S ALL, FOLKS!
FORTH COMPILER/INTERPRETER FOR TSS/8.24
