/ ** FORTH-8 ** /FORTH COMPILER/INTERPRETER /FOR TSS/8.24 /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, / 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 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" (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 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, 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 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!