* FIG FORTH FOR SERIES-16 MACHINES ****************************************************************** * * SERIES-16 FORTH INTRODUCTION SERIES-16 FORTH * ****************************************************************** * * AUGUST 2008 * * ORIGINALLY DEVELOPED BY THE * FORTH INTEREST GROUP / FORTH IMPLEMENTATION TEAM * P.O. BOX 1105 * SAN CARLOS, CA. 94070 * * * PDP-11 FIG-FORTH IMPLEMENTED BY * JOHN S. JAMES * P.O. BOX 348 * BERKELEY, CA. 94701 * JANUARY 1980 * * NOVA FIG-FORTH DEVELOPED BY * DR. C. H. TING * OFFETE ENTERPRISES * 1306 S. B ST. * SAN MATEO, CA. 94402 * MAY 1981 * * SERIES-16 FORTH WAS DEVELOPED BY * ADRIAN WISE * HTTP://WWW.SERIES16.ADRIANWISE.CO.UK * * THE CODE WAS LARGELY COPIED FROM THE PDP-11 IMPLEMENTAION * WITH SIGNIFICANT SECTIONS, PARTICULARLY THOSE RELATING TO * CHARACTER HANDLING ON A WORD-ADDRESSED MACHINE, TAKEN * FROM THE NOVA CODE * * * THIS SYSTEM IS IN THE PUBLIC DOMAIN AND CAN BE USED * WITHOUT RESTRICTION. PLEASE CREDIT THE FORTH INTEREST * GROUP IF YOU REPUBLISH SUBSTANTIAL PORTIONS. * * EJCT * THE FORTH INTEREST GROUP / FORTH IMPLEMENTATION TEAM * ALSO HAS DEVELOPED NEARLY IDENTICAL VERSIONS OF THIS * SYSTEM FOR THE * 8080 * 6800 * 6502 * 9900 * PACE * PDP-11 * NOVA * * * FOR MORE INFORMATION, WRITE: * * JOHN S. JAMES * P.O. BOX 348 * BERKELEY, CA. 94701 * * OR * * FORTH INTEREST GROUP * P.O. BOX 1105 * SAN CARLOS, CA. 94070 * * * THIS FORTH SYSTEM HAS * - FULL LENGTH NAMES * - EXTENSIVE COMPILE-TIME CHECKS AND ERROR MESSAGES * - DOUBLE INTEGER I/O * - LINKED VOCABULARIES * - HOOKS FOR MULTITASKING/MULTIUSER (CURRENTLY * SINGLE TASK) * - AND AS CURRENTLY CONFIGURED IT CALCULATES THE * EXTENT OF MEMORY AT START-UP AND WILL RUN, * WITHOUT DISKS, IN SYSTEMS WITH AS LITTLE AS 4K * WORDS OF RAM, USING ALL AVAILABLE MEMORY UP TO * 16K, OR 32K WHEN CONFIGURED TO USE EXTENDED * ADDRESSING. THE CODE IS CONFIGURED TO USE THE * HIGH SPEED ARITHMETIC OPTION, BUT MAY BE * ASSEMBLED TO RUN WITHOUT HSA SINCE SOFTWARE * MULTIPLY AND DIVIDE ROUTINES ARE SUPPLIED. * THE SYSTEM MAY BE EXTENDED TO USE DISK I/O, BUT * AT THIS TIME (AUGUST 2008) THIS IS NOT * IMPLEMENTED. * EJCT * AT A LATER DATE THE SYSTEM, WITH DISK (OR EQUIVALENT) MAY * WELL BE EXTENDED TO ALSO PROVIDE: * - A FORTH ASSEMBLER, PERMITTING STRUCTURED, * INTERACTIVE DEVELOPMENT OF DEVICE HANDLERS, * SPEED-CRITICAL ROUTINES, AND LINKAGE TO * OPERATING SYSTEMS OR TO SUBROUTINE PACKAGES * WRITTEN IN OTHER LANGUAGES. * - STRING-HANDLING ROUTINES * - A STRING-SEARCH EDITOR * * * IT IS ALIGNED WITH THE 1978 STANDARD OF THE FORTH * INTERNATIONAL STANDARDS TEAM. * * * * RECOMMENDED DOCUMENTATION: * - A FORTH LANGUAGE MANUAL. WE PARTICULARLY * RECOMMEND EITHER * (A) 'USING FORTH', BY FORTH, INC. * OR * (B) 'A FORTH PRIMER', * BY W. RICHARD STEVENS, KITT PEAK * NATIONAL OBSERVATORY. * EITHER IS AVAILABLE THROUGH * THE FORTH INTEREST GROUP, * P.O. BOX 1105, SAN CARLOS, CA. 94070. * - PDP-11 FORTH USER'S GUIDE, AVAILABLE FROM * JOHN S. JAMES, ADDRESS ABOVE. * - FORTH REFERENCE CARD FOR THE FORTH * IMPLEMENTATION TEAM COMMON MODEL, AVAILABLE * FROM FIG. * - 'FIG-FORTH INSTALLATION MANUAL', ALSO FROM FIG. * * * * ACKNOWLEDGMENTS: * THIS FORTH SYSTEM (IN 'FORTH.MAC') IS A GROUP * PRODUCT OF THE FORTH IMPLEMENTATION TEAM OF THE * FORTH INTEREST GROUP (P.O. BOX 1105, SAN CARLOS * CA. 94070). THE IMPLEMENTER IS RESPONSIBLE FOR * THIS SERIES-16 VERSION OF THE MODEL. EJCT ****************************************************************** * * VARIATIONS FROM F.I.G. MODEL * ****************************************************************** * * THESE DIFFERENCES WERE INHERITED FROM THE PDP-11 * IMPLEMENTATION: * * * 'FIRST' AND 'LIMIT' HAVE BEEN MADE USER VARIABLES, NOT * CONSTANTS. THEREFORE WHEN THEY ARE USED, 'FIRST @' AND * 'LIMIT @' ARE REQUIRED. * * ';CODE' AND 'FORTH' ARE NOT PURE CODE, SO THEY WERE MOVED TO * THE END OF THE DICTIONARY. THIS IS SO THE BULK OF THE * DICTIONARY COULD BE PUT IN PROM OR USED RE-ENTRANTLY. * * THE MACHINE-INDEPENDENT I/O SECTION WAS MOVED TO NEAR THE END * OF THE DICTIONARY, BECAUSE IT IS NOT ALWAYS PURE CODE, AND ALSO * TO ALLOW THE I/O TO BE REDEFINED WITHOUT REASSEMBLY. * * THIS SYSTEM MUST TEST FOR FIRST-TIME-THROUGH TERMINAL AND DISK * I/O, TO AVOID ERRONEOUS ATTEMPT TO OPEN FILES TWICE AT LATER * COLD STARTS. IT CLEARS DISK BUFFERS AT COLD START. * * ***** ***** ***** ***** ***** ***** ***** ***** ***** * * THESE DIFFERENCES WERE INHERITED FROM THE NOVA * IMPLEMENTATION: * * * ALL MEMORY REFERENCES ARE CELL ADDRESSING EXCEPT: * ENCOSE, CMOVE, C@, C!, -TRAILING, HOLD, (NUMBER), NUMBER * * TRAVERSE IS NOT NEEDED FOR NFA PROCESSING * * BRANCH, 0BRANCH, (LOOP), AND (+LOOP) USE THE ACTUAL * DESTINATION ADDRESS, NOT THE OFFSET FROM THE CURRENT * ADDRESS * * ?TERMINAL RETURNS TRUE AFTER ANY KEYSTROKE * * ADDED WORDS ARE: BYTE, CELL, U< * * ***** ***** ***** ***** ***** ***** ***** ***** ***** * * IN ADDITION THE FOLLOWING DIFFERENCES ARE PECULIAR TO THIS * SERIES-16 IMPLEMENTATION: * * * THE CODE FIELD IS HANDLED DIFFERENTLY, SEE EXPLANATION OF * THREADING BELOW. * * ;CODE (ASSEMBLER LABEL 'PSCD') WAS TRADITIONALLY IMMEDIATELY * FOLLOWED, WHERE IT IS REFERENCED IN A COLON DEFINITION, * BY THE ASSEMBLER CODE THAT WAS TO BE USED TO DEFINE THE * PRIMITIVE, SO THAT THE 'RETURN' ADDRESS ON THE RETURN STACK * WAS THE ADDRESS THAT WAS TO BE PLACED IN THE CFA. SINCE THE * USAGE OF CFA DIFFERS IN THIS IMPLEMENTATION (AS DISCUSSED * BELOW) 'DAC PSCD' SHOULD NOW BE FOLLOWED BY THE ONE WORD * INSTRUCTION REQUIRED TO REACH THE ASSEMBLER CODE, TYPICALLY * 'JST DOXX', AND THIS WORD IS COPIED INTO THE CFA. * EJCT ****************************************************************** * * USE OF REGISTERS * ****************************************************************** * * THE ONLY MACHINE REGISTER WITH A SPECIAL FORTH-RELATED USE * IS THE INDEX REGISTER. THIS IS USED TO REFER TO THE DATA STACK. * SINCE THE X REGISTER CANNOT DIRECTLY BE DECREMENTED WHEN VALUES * ARE PUSHED ONTO THE DATA STACK THE X REGISTER'S VALUE MUST * ITSELF BE MANIPULATED IN THE ACCUMULATOR. HOWEVER, THE VALUE IN * THE ACCUMULATOR (THE VALUE TO BE PUSHED) MUST BE SAVED FIRST. * SO, THE X REGISTER POINTS TO THE FIRST FREE LOCATION ON THE * STACK (AS OPPOSED TO THE LAST OCCUPIED LOCATION) SO THAT THE * ACCUMULATOR MAY BE SAVED BY 'STA 0,1' BEFORE THE X REGISTER * IS DECREMENTED. (IT IS NOT POSSIBLE TO CODE 'STA -1,1') * TOP-OF-STACK IS ADDRESSED AS '1,1', NEXT-ON-STACK AS '2,1'. * * OTHER TRADITIONAL FORTH REGISTERS: * * IP - INTERPRETER POINTER * RP - RETURN STACK POINTER * UP - USER AREA POINTER * * ARE MAINTAINED IN MEMORY WORDS IN SECTOR ZERO (SO THEY CAN * BE ACCESSED FROM ALL SECTORS). * * SINCE THERE IS NO AVAILABLE INDEX REGISTER FOR THE RETURN * STACK POINTER, THE POINTER ITSELF HAS TO BE MANIPULATED IN THE * ACCUMULATOR, AND IF A SIMPLE POINTER IS MAINTAINED IN MEMORY * THEN IT IS DIFFICULT TO PICK UP ANYTHING BUT THE TOP-OF-STACK * VALUE, WHEN IT IS COMMON (E.G. FOR LOOPING) TO NEED THE TOP TWO * VALUES. TO ADDRESS THIS, (RP) POINTS TO THE TOP-OF-STACK VALUE * AND A SECOND POINTER, RP1, IS MAINTAINED POINTING AT THE * NEXT-ON-STACK. * * THE TRADITIONAL FORTH REGISTER 'W', THE WORKING POINTER, DOES * NOT EXIST IN THIS IMPLEMENTATION. * EJCT ****************************************************************** * * THREADING METHODOLOGY * ****************************************************************** * * EARLIER DEVELOPMENT VERSIONS (NEVER RELEASED) OF THIS * IMPLEMENTATION USED A MORE TRADIONAL ORGANIZATION USING IP, * POINTING AT THE NEXT WORD TO INTERPRET, A 'W' POINTER, AND A * CODE FIELD (IN THE WORD'S HEADER) POINTING AT THE CODE TO * IMPLEMENT THE PRIMITIVE. HOWEVER, ON AN ACCUMULATOR MACHINE * WITH NO GENERAL PURPOSE REGISTERS THIS PROVED VERY CUMBERSOME * WITH 'NEXT' REQUIRING ABOUT EIGHT INSTRUCTIONS. * * IN ORDER TO BETTER TAKE ADVANTAGE OF THE FACILITIES OFFERED BY * THE SERIES-16 MACHINES SOME CHANGES WERE MADE. * * FIRSTLY, THE INTERPRETER POINTER, IP, IS MAINTAINED WITH THE * INDIRECT BIT SET. FURTHERMORE, SINCE THERE IS NO POST-INCREMENT * ADDRESSING MODE, IP IS MODIFIED TO POINTER TO THE WORD CURRENTLY * BEING INTERPRETED, SO THAT IT SHOULD BE INCREMENTED BEFORE * IT IS USED. THIS OFFSET-BY-ONE IS TAKEN ACCOUNT OF SO THAT WHEN * A RETURN ADDRESS IS PUSHED ONTO THE STACK, FOR EXAMPLE, IT IS * FIRST INCREMENTED (AND THE INDIRECT BIT ZEROED) SO THAT THE * VALUE WILL BE THE SAME AS IN OTHER FIG-FORTHS. * * 'NEXT' THERFORE BECOMES THE SEQUENCE: * * IRS IP * JMP* IP * * AND A TWO-WORD 'NEXT' IS POSSIBLE, WHICH IS REMARKABLE FOR SUCH * A SIMPLE MACHINE. * * THE NEXT ISSUE IS GETTING A POINTER TO THE PARAMETERS, WHICH * WOULD NORMALLY BE IN THE 'W' POINTER. THIS IS ADDRESSED BY * MODIFYING WHAT IS PLACED IN THE CODE FIELD OF THE HEADER. THE * 'W' POINTER IS ONLY REQUIRED FOR THOSE WORDS WHERE THE ASSEMBLER * ROUTINE IS RE-USED MANY TIMES, WITH DIFFERING PARAMETERS. FOR * EXAMPLE 'DOCOLON' ('DOCL' HERE, BECAUSE OF THE 4-CHARACTER LIMIT * ON LABELS IN THE DAP ASSEMBLER) WHICH EXECUTES A COLON * DEFINITION THIS REQUIRES 'W', WHICH POINTS TO THE LIST OF WORDS * TO EXECUTE I.E. THE NEW VALUE TO BE PLACED IN 'IP'. SIMILAR WORDS * ARE: * * DOCN - DEAL WITH A CONSTANT * DOVR - DEAL WITH A VARIABLE * DOUS - DEAL WITH A USER VARIABLE * DODS - IMPLEMENT 'DOES>' EJCT * IN CONTRAST 'W' IS NOT USED BY TRUE PRIMITIVES. FOR EXAMPLE * THE '+' WORD ADDS THE TOP TWO VALUES ON THE DATA STACK, AND * HAS NO NEED OF 'W'. * * THE CODE FIELD FOR WORDS REQURING 'W' IS FILLED WITH A 'JST' * INSTRUCTION (I.E. SUBROUTINE CALL) TO THE ACTUAL ASSEMBLER * ROUTINE (E.G. DOCL, DOCN,...). THIS MEANS THAT THE RETURN * ADDRESS (STORED IN THE ADDRESS REFERRED TO BY THE 'JST' * INSTRUCTION) HOLDS THE VALUE THAT WOULD HAVE BEEN IN 'W'; * IT POINTS TO THE PARAMETERS. * * CROSS-SECTOR REFERENCE ISSUES ARE AVOIDED BY THE SIMPLE * EXPEDIENT OF PLACING ALL OF THESE ROUTINES IN SECTOR ZERO. * * FOR TRUE PRIMITIVES THE CODE FIELD ISN'T REALLY IDENTIFIABLE * AS SUCH, SINCE IT IS JUST THE FIRST INSTRUCTION OF THE * ASSEMBLER DEFINING THE PRIMITIVE. THIS HAS THE ADDITIONAL * ADVANTAGE THAT ONE WORD IS SAVED IN EACH PRIMITIVE SINCE * TRADITIONALLY THE CODE FIELD WOULD HAVE HELD A POINTER TO * THE CODE WHICH WAS LOCATED IN THE FOLLOWING WORD. * * DIAGRAMATICALLY: * * +----------+ * LIST OF WORDS | NAME | NFA * CURRENTLY BEING | ... | * EXECUTED | NAME | * +----------+ +----------+ * IP | WORD N-1 | | LINK PTR | LFA * +----------+ +----------+ +----------+ * |*| | ---> | WORD N | ---> | JST DOXX | CFA * +----------+ +----------+ +----------+ * (INDIRECT | WORD N+1 | | PARM. 1 | PFA * BIT SET) +----------+ +----------+ * | ... | | PARM. 2 | * +----------+ * | ... | * * SO, WHEN 'NEXT' DOES 'JMP* IP' CONTROL PASSES TO THE * ADDRESS IN 'WORD N', I.E. THE 'JST DOXX' INSTRUCTION, * TRANSFERRING CONTROL TO THE 'DOXX' SUBROUTINE (AT * DOXX+1), AND PLACING THE PFA (THE ADDRESS OF 'PARM. 1') * IN THE 'DOXX' LOCATION. * EJCT ****************************************************************** * * MACROS * ****************************************************************** * * THE DAP ASSEMBLER IS VERY POOR AT DEALING WITH STRINGS, AND THE * MACRO PREPROCESSOR CAN ONLY HANDLE VERY SIMPLE CASES. SO THE * 'HEAD' MACRO COULD NOT BE EFFICIENTLY DEALT WITH USING THESE * TOOLS. FOR THIS REASON A SEPARATE DEDICATED MACRO PREPROCESSOR * WAS WRITTEN TO EXPAND THE 'HEAD' MACRO. THIS IS AVAILABLE * AS 'HEADMAC.C' AND NEEDS A MORE MODERN MACHINE THAN A * SERIES-16 - SO IT'S A BIT OF A CHEAT... * * 'HEAD' TAKES THREE OR FOUR ARGUMENTS: * * (1) A FLAG - NORMALLY 'FNUL', OR 'FIMD' WHICH INDICATES AN * IMMEDIATE OPERATION. * (2) THE NAME OF THE WORD, WHICH IS CONVERTED TO A STRING * (3) A LABEL USED FOR THE CODE FIELD * (4) OPTIONALLY A LABEL FOR THE 'DO' ROUTINE. IF NOT PASSED * THEN A PRIMITIVE IS BEING DEALT WITH AND NO CODE FIELD * IS PRODUCED - THE FOLLOWING ASSEMBLER STARTS AT CFA. * * THE HEAD MACRO PRODUCES A FORTH HEADER COMPRISING: * (1) THE NAME FIELD. ON SERIES-16 MACHINES ASCII CHARACTERS * USUALLY HAVE THE TOP BIT SET, SO USAGE IS REVERSED FROM * MOST FIG FORTHS - MOST CHARACTERS HAVE THE TOP BIT SET * WHILE THE LENGTH BYTE, AND THE LAST BYTE HAVE IT CLEAR. * THE IMMEDIATE FLAG IS PLACED IN THE 2^64 BIT OF THE LENGTH * BYTE. THE LOWER 6 BITS HOLD THE LENGTH, SINCE THE MAXIMUM * NAME LENGTH IS 31 CHARACTERS, THE 2^32 BIT IS NEVER SET * AND IS USED, IN THE TRADITIONAL WAY, AS THE SMUDGE BIT. * STRINGS ARE PACKED WITH THE EARLIER CHARACTER IN THE * MORE SIGNIFICANT BYTE, THE LENGTH BYTE BEING IN THE UPPER * BYTE OF THE FIRST WORD. * FOR STRINGS OF ODD LENGTH THAT, BECAUSE OF THE LENGTH * BYTE, FILL A 16-BIT WORD, THE TOP BIT OF THE LAST * CHARACTER IS CLEARED. * FOR STRINGS OF EVEN LENGTH THE TOP BIT OF THE LAST ACTUAL * CHARACTER (IN THE UPPER BYTE OF THE LAST WORD) IS SET IN * THE NORMAL WAY, THE LOWER BYTE IS ALL-ZEROS, AND SO THE * LAST WORD CAN BE LOCATED FOR BOTH ODD AND EVEN LENGTH * NAMES BY CHECKING THE TOP BIT OF THE LOWER BYTE. * SIMILARLY THE FIRST WORD CAN BE IDENTIFIED BY THE MOST * SIGNIFICANT BIT OF THE WORD BEING CLEARED. * (2) THE LINK WORD, POINTING AT THE NFA OF THE PREVIOUS * DICTIONARY ENTRY. * (3) WHERE THE OPTIONAL FOURTH ARGUMENT TO THE MACRO IS USED, * A 'JST' TO THE SUPPLIED LABEL. * * 'HEADMAC.C' ALSO IMPLEMENTS A SECOND MACRO - 'STRG' THAT * CONVERTS ITS SINGLE ARGUMENT TO A STRING WITH LENGTH BYTE. IT * IS USED WHERE STRINGS ARE EMBEDDED IN THE PRECOMPILED FORTH. * * BOTH 'STRG' AND 'HEAD' ALLOW CHARACTERS IN THEIR STRING * ARGUMENT TO BE ESCAPED BY PRECEDING THEM BY A BACK-SLASH. * BACK-SLASH-COMMA ALLOWS A COMMA TO BE INCLUDED IN THE NAME, * (IT IS NOT INTERPRETED AS A SEPARATOR FOR THE NEXT ARGUMENT) * BACK-SLASH-SPACE ALLOWS A SPACE (AT THE START OR END OF THE * ARGUMENT) TO BE INCLUDED IN THE STRING. * * THE SINGLE 'PROPER' MACRO IMPLEMENTED USING THE 'MAC' * PREPROCESSOR IS 'NEXT' WHICH SIMPLY ASSEMBLES TO: * * IRS IP * JMP* IP * ****************************************************************** * * 32-BIT ARITHMETIC * ****************************************************************** * * ONE FAIRLY SUBSTANTIAL ISSUE WAS HOW TO DEAL WITH 32-BIT * ARITHMETIC. THIS IS AN ISSUE BECAUSE THE SERIES-16 MACHINES * WERE NOT INTENDED TO PERFORM 32-BIT ARITHMETIC. INSTEAD THEIR * NATURAL DOUBLE-WORD FORMAT HOLDS 31-BITS: * * A REGISTER B REGISTER * +--------------+ +--------------+ * |S|M.S. 15 BITS| |0|L.S. 15 BITS| * +--------------+ +--------------+ * * THE SIGN BIT OF THE LOWER WORD (OFTEN IN THE B REGISTER) IS * ALWAYS ZERO. THIS ISN'T TOTALLY RIDICULOUS AS A FORMAT SINCE * WHEN TWO SIGNED 16-BIT NUMBERS ARE MULTIPLIED THEY WILL FIT * IN A SIGNED 31-BIT NUMBER (EXCEPT FOR THE SINGLE OVERFLOWING * CASE OF -2^15 * -2^15). * * SOME CONSIDERATION WAS GIVEN TO ONLY IMPLEMENTING 31-BIT DOUBLE * WORD ARITHMETIC, BUT IN THE END THIS WAS REJECTED IN FAVOUR OF * 32-BIT ARITHMETIC, LIKE OTHER FIG FORTHS - THOUGH INEVITABLY * THIS WILL LEAD TO LOSS OF PERFORMANCE IN MATH-DOMINATED * APPLICATIONS. * * ONE MAJOR HURDLE IS THAT THE 16-BIT ADDITION AND SUBTRACTION * ROUTINES DO NOT PRODUCE A CARRY BIT - INSTEAD THE SO-CALLED * 'C' BIT GETS THE TWO'S COMPLEMENT OVERFLOW. THIS DOES HANG * TOGETHER AS A SELF-CONSISTENT SET OF DESIGN DECISIONS BECAUSE * THE CARRY OUT OF THE 15-BIT ADDITION IS AVAILABLE IN THE TOP BIT * OF THE RESULT. HOWEVER, IT'S NOT DIRECTLY APPLICABLE TO * PERFORMING 32-BIT ADDITION AND SUBTRACTION. * * THE APPROACH TAKEN IS TO NOTE THAT: * * IF A, B ARE INPUTS TO THE TOP BIT OF ADDITION AND S IS THE TOP * BIT FROM THE SUM, THEN THE CARRY INTO THE TOP BIT CIN=(A^B^S) * SINCE OVERFLOW, V=CIN^COUT, IT FOLLOWS THAT COUT=V^CIN * SO CARRY CALCULATED AS (A^B^S^V) * * CIN A B | S V |COUT * 0 0 0 | 0 0 | 0 * 0 0 1 | 1 0 | 0 * 0 1 0 | 1 0 | 0 * 0 1 1 | 0 1 | 1 * 1 0 0 | 1 1 | 0 * 1 0 1 | 0 0 | 1 * 1 1 0 | 0 0 | 1 * 1 1 1 | 1 0 | 1 * * THE SAME PROCEDURE WILL ALSO YIELD BORROW FROM A 16-BIT * SUBTRACTION. * * WHERE THE HIGH SPEED ARITHMETIC (HSA) OPTION IS AVAILABLE * IT IS USED TO IMPROVE SPEED OF THE MULTIPLY AND DIVIDE * OPERATIONS. HOWEVER, THERE IS INEVITABLY SOME MUCKING * AROUND TO CONVERT BETWEEN FORTH'S 32-BIT FORMAT AND THE * NATURAL SERIES-16 31-BIT FORMAT, EVEN FOR NUMBERS THAT * FIT WITHIN THE 31-BIT RANGE. * THE HSA ONLY PROVIDES SIGNED OPERATIONS, BUT UNSIGNED * MULTIPLY CAN STILL BE ACCELERATED USING THE SIGNED MULTIPLY * OPERATION. NO SATISFACTORY WAY TO USE THE SIGNED DIVIDE * OPERATION COULD BE FOUND TO ACCELERATE THE UNSIGNED DIVIDE. * EJCT CF1 SHOULD WORK ON 116, 316, 516, 716 ABS SETB NXTZ SUBR GFORTH,ORGN GLOBAL LABEL - NORMALLY NOT USED ****************************************************************** * * SYSTEM PARAMETERS * ****************************************************************** HSA EQU 1 SET TO 1 TO USE HIGH-SPEED ARITHMETIC OPTION XTND EQU 0 SET TO 1 TO USE EXTENDED ADDRESSING OPTION DISK EQU 0 SET TO 1 IF HAVE DISK PTW EQU 1 SET TO 1 TO INCLUDE PAPERTAPE WORDS * DBGW EQU 0 SET TO 1 TO INCLUDE 'DEBUG' WORD * RSRV EQU 0 WORDS TO RESERVE AT MEMORY TOP * ECHO EQU 0 SET TO 1 IF ECHO TO TERMINAL REQUIRED ECLF EQU 1 SET TO 1 TO ECHO LF IN RESPONSE TO CR * * CHARACTER CONSTANTS * CEOT EQU '204 END OF TRANSMISSION (END OF PAPERTAPE) CCR EQU '215 CARRIAGE RETURN CLF EQU '212 LINE FEED CBS EQU '210 BACKSPACE CSPC EQU '240 =' ' SPACE CDQT EQU '242 ='"' DOUBLE QUOTE CRPR EQU '251 =')' RIGHT PARENTHESIS CMNS EQU '255 ='-' MINUS CDOT EQU '256 ='.' FULL STOP (PERIOD) CZRO EQU '260 ='0' (DIGIT ZERO) CDEL EQU '377 DELETE * * OTHER CONSTANTS * KPAD EQU 34 =68 BYTES ****************************************************************** * * VARIABLES * ****************************************************************** IFN XTND EXD ENDC ORG '100 IP BSS 1 INTERPRETER POINTER RP BSS 1 RETURN STACK POINTER RP1 BSS 1 RETURN STACK POINTER+1 UP BSS 1 USER AREA POINTER * * TEMPORARIES T1 BSS 1 T2 BSS 1 T3 BSS 1 T4 BSS 1 T5 BSS 1 * CADR BSS 1 USED BY CHARACTER ACCESS ROUTINES * ****************************************************************** * * MACRO DEFINITIONS * ****************************************************************** NEXT MAC* IRS IP JMP* IP ENDM * NEXT MAC* * IRS IP * JMP* IP * ENDM EJCT ****************************************************************** * * INNER INTERPRETER - CODE ENDINGS * ****************************************************************** * * POP AND POP2 DISCARD 1 AND 2 (RESPECTIVELY) OPERANDS FROM THE * STACK AND GO TO NEXT * POP2 IRS 0 POP IRS 0 NEXT * * PUSH PUSHES THE VALUE IN A REG. ONTO THE STACK AND GOES TO * NEXT, WHILE 'NEXT' IS AVAILABLE WHERE IT IS JUST USEFUL TO * JUMP TO A LOCATION THAT GOES TO NEXT (E.G. UNDER A SKIP * OR CAS INSTRUCTION). * PUSH STA 0,1 X POINTS TO NEXT FREE LOCATION LDA 0 NOW DECREMENT X SUB =1 STA 0 * FALL THROUGH NEXT EQU * NEXT * * BINA DISCARDS ONE VALUE FROM THE STACK AND REPLACES THE * VALUE NOW AT TOP-OF-STACK WITH THE VALUE IN A REG. * IT THUS DOES WHAT IS COMMONLY REQUIRED FOR BINARY * OPERATORS * * PUT JUST REPLACES TOS WITH A REG. STACK POINTER UNCHANGED * BINA IRS 0 PUT STA 1,1 NEXT EJCT * EXECUTE A COLON DEFINITION * SAVES CORRECTED IP TO THE RETURN STACK, THEN PICKS UP * THE PARAMETER ADDRESS, THAT WOULD COMMONLY BE IN THE * W REGISTER, FROM DOCL - WHERE IT WAS PLACED BY THE * JST INSTRUCTION AT THE CFA IN THE HEADER - AND * JUMPS TO THAT LOCATION * DOCL DAC* ** INDIRECT BIT SET LDA IP SSP AOA JST RPSH LDA DOCL NOTE INDIRECT BIT IS SET BY DAC* NXT1 STA IP JMP* IP EFFECTVELY NEXT * * EXECUTE A CONSTANT * SIMPLY PICKS UP THE VALUE AT THE PARAMETER ADDRESS * AND PUSHES IT ONTO THE STACK * DOCN DAC ** LDA* DOCN JMP PUSH * * EXECUTE A VARIABLE * PICKS UP THE ADDRESS OF THE PARAMETER ADDRESS AND * PUSHES IT ONTO THE STACK * DOVR DAC ** LDA DOVR JMP PUSH * * EXECUTE A USER VARIABLE * PICK UP THE VALUE IN THE PARAMETER ADDRESS, WHICH IS * AN OFFSET INTO THE USER AREA, ADD IT ONTO THE USER AREA * BASE POINTER AND PUSH THE RESULTING ADDRESS ONTO THE * STACK * DOUS DAC ** LDA* DOUS ADD UP JMP PUSH EJCT * EXECUTE A 'DOES>' * SAVES CORRECTED IP TO THE RETURN STACK, THEN PICKS UP * THE FIRST PARAMETER, WHICH WILL BE JUMPED TO, AND * THE SECOND PARAMETER, WHICH IS PUSHED ONTO THE STACK * DODS DAC ** NO INDIRECT BIT SET LDA IP SSP AOA JST RPSH LDA* DODS SUB =1 SSM SET THE INDIRECT BIT STA IP LDA DODS AOA JMP PUSH EJCT ****************************************************************** * * CHARACTER HANDLING * ****************************************************************** CHGT DAC ** GET CHARACTER AT ADDRESS LGR 1 LS BIT GOES TO CARRY STA CADR SAVE WORD ADDRESS LDA* CADR LOAD THROUGH IT SSC LGR 8 FIRST BYTE IN UPPER BYTE ANA ='377 LOSE UPPER BYTE JMP* CHGT * CHPT DAC ** PUT CHARACTER IN B TO CHARACTER ADDRESS LGR 1 LS BIT GOES TO CARRY STA CADR SAVE WORD ADDRESS SSC JMP CHPU * * PLACE IN LOWER BYTE IAB GET CHARACTER BACK ANA ='377 LOSE UPPER BYTE IF ANY IMA* CADR GET EXISTING WORD ANA ='177400 DISCARD LOWER BYTE CHP1 ERA* CADR STA* CADR JMP* CHPT * * PLACE IN UPPER BYTE CHPU IAB GET CHARACTER BACK ANA ='377 LOSE UPPER BYTE IF ANY LGL 8 GET INTO UPPER BYTE IMA* CADR GET EXISTING WORD ANA ='377 DISCARD UPPER BYTE JMP CHP1 EJCT ****************************************************************** * * RETURN STACK * ****************************************************************** * * PUSH A VALUE ONTO THE RETURN STACK * RPSH DAC ** IMA RP TEMP. SAVE VALUE STA RP1 NEXT-ON-STACK-POINTER SUB =1 DECREMENT POINTER IMA RP NEW POINTER, GET VALUE TO PUSH BACK STA* RP JMP* RPSH * * POP A VALUE FROM THE RETURN STACK * RPOP DAC ** LDA* RP GET VALUE IMA RP1 SAVE AND GET RP+1 STA RP WHICH IS NEW VALUE OF RP AOA INCREMENT TO NEW VALUE OF RP1 IMA RP1 UPDATE RP1, RETRIEVE VALUE JMP* RPOP NXTW EQU * EJCT ****************************************************************** * * START-UP TABLE * ****************************************************************** * * AT STARTUP, MOST OF THESE VALUES ARE MOVED INTO THE USER AREA * (STARTING AT 'XDP:'); THEY ARE NORMALLY ACCESSED THERE. THE * VALUES HERE ARE NOT USUALLY CHANGED, BUT THEY MAY BE CHANGED * E.G. TO CONTROL WHAT HAPPENS AT COLD START. THIS TABLE COULD * BE MOVED OUT OF LOW MEMORY IF NECESSARY FOR ROM SYSTEMS. * * LOCATED AT '1000 BECAUSE THAT'S THE TRADITIONAL STARTING * POINT FOR SERIES-16 PROGRAMS * ORG '1000 ORGN JMP CENT COLD START ENTRY POINT JMP WENT WARM START ENTRY ADDRESS * * NOTE - COLD START WIPES OUT ANY NEW DICTIONARY DEFINITIONS, AND * THEN DOES A WARM START. WARM START CLEANS UP STACKS, TERMINAL * BUFFER, ETC. * DEC 16 CPU DEC 0 REVISION OTSK DAC XTSK '00 - POINTER TO LATEST WORD DEFINED OCT 10 '01 - BACKSPACE CHARACTER OUP DAC XUP '02 - POINTER TO USER AREA * NOTE - THE USER AREA IS A HOOK IN THIS SYSTEM TO ALLOW * MULTITASKING TO BE ADDED LATER. OXS0 DAC XS0 '03 - POINTER TO BEGINNING OF THE STACK DAC XR0 '04 - POINTER TO BEGINNING OF RETURN STACK OXTB DAC XTIB '05 - POINTER TO TERMINAL INPUT BUFFER DEC 31 '06 - MAXIMUM NAME-FIELD WIDTH, NORMALLY 31 DEC 0 '07 - WARNING MODE; 0=ERROR, 1=DISK MESSAGE * NOTE - WARNING MODE INITIALIZED TO ZERO, IN CASE DISK ISN'T UP. DAC XDP '10 - FENCE TO PROTECT AGAINST ACCIDENTAL * 'FORGET' OF THE SYSTEM. DAC XDP '11 - POINTER TO NEXT AVAILABLE DICTIONARY * LOCATION (RETURNED BY 'HERE'). DAC XXVC '12 - POINTER TO INITIAL VOCABULARY LINK IFN DISK O1ST DAC DSKB '13 - INITIALIZE 'FIRST' OLMT DAC ENDB '14 - INITIALIZE 'LIMIT' ELSE O1ST DEC 0 '13 - INITIALIZE 'FIRST' OLMT DEC 0 '14 - INITIALIZE 'LIMIT' ENDC DEC 0 '15 - AVAILABLE DEC 0 '16 - AVAILABLE * XXS0 DAC OXS0 START OF AREA COPIED X4P4 DAC FRTH+4 * * ACTUAL COLD ENTRY POINT * * NOTE THAT THE DICTIONARY ENTRY FOR 'COLD' IS FURTHER * ON. THIS CODE IS MOVED HERE SO CROSS-SECTOR LINKS FROM * THE ENTRY POINT AT '1000, AND REFERENCES TO THE START-UP * TABLE ARE NOT REQUIRED. * CENT EQU * IFN XTND EXA ENDC JST MSZ ONCE ONLY - CALCULATE MEMORY SIZE LDA OTSK SET 'FORTH' VOCABULARY FROM STARTUP TABLE STA* X4P4 LDA OUP INITIALIZE USER POINTER STA UP STA 0 AND BORROW INDEX REGISTER FOR INITIALISATION * NOTE - FOR SMALLER STAND-ALONE BOOT, INITIALIZE AREAS IN * HIGH MEMORY WHICH MUST BE INITIALIZED. * CLEAR DISK BUFFERS ON FIRST TIME THROUGH LDA O1ST GET POINTER TO START OF BUFFERS SNZ ANY DISK BUFFERS? JMP CNT2 STA T2 SUB OLMT SUBTRACT END TO GET -VE WORDS STA T1 COUNTER CRA CNT1 STA* T2 IRS T2 STEP POINTER IRS T1 STEP COUNTER JMP CNT1 LOOP * NOW INITIALIZE 'OUT', 'OFFSET', 'USE' AND 'PREV' * NOTE INDEX REGISTER POINTING AT USER AREA (NOT STACK) CNT2 CRA STA '21,1 CLEAR 'OUT' STA '23,1 CLEAR 'OFFSET' LDA O1ST STA '35,1 TO 'USE' STA '36,1 TO 'PREV' * END OF SPECIAL HIGH-MEMORY INITIALIZE LDA =-12 ON COLD START, MOVE 12 WORDS JMP WNT1 STOP HLT 'BYE' COMES HERE * SO RESTART GOES TO WARM ENTRY WENT EQU * IFZ XTND DXA BECAUSE START-BUTTON INTERRUPT COME HERE * AND MAY HAVE FORCED EXTENDED MODE ELSE EXA IN CASE MANUALLY STARTED HERE ENDC LDA =-5 ON WARM START, MOVE 5 WORDS WNT1 STA T1 LDA XXS0 START WITH INITIAL STACK POINTER STA T2 LDA =3 TO AREA 3 WORDS BEYOND ADD OUP USER POINTER STA T3 WNT2 LDA* T2 STA* T3 COPY WORDS IRS T2 STEP POINTERS IRS T3 IRS T1 STEP COUNTER JMP WNT2 * * SET UP VECTOR SO THAT START-BUTTON INTERRUPT * GOES TO WARM ENTRY LDA XWNT STA '63 ENB ENABLE INTERRUPTS * * NOW SET FORTH'S INSTRUCTION COUNTER, AND GO LDA XGO JMP NXT1 * XWNT DAC WENT TO INITIALISE INTERRUPT VECTOR * * NOTE - NORMALLY THE ABOVE INSTRUCTION WOULD JUMP STRAIGHT * TO THE ABORT ROUTINE. IT HAS BEEN CHANGED HERE TO ALLOW USER * TO PATCH A DIFFERENT START-UP. BUT THE SYSTEM WON'T WORK * UNTIL SOME OF THE WORK OF 'ABORT' HAS BEEN DONE, SO THAT WORK * IS REPEATED. THE USER CAN PATCH OVER THE 'ABORT' AND THE * ZEROS. * XGO DAC* GO GO DAC RPST INITIALIZE RETURN STACK POINTER DAC SPST INITIALIZE DATA STACK POINTER DAC DEC SELECT DECIMAL DAC FRTH FORTH DAC DFNS DEFINITIONS DAC ABRT ABORT DAC 0 DAC 0 DAC 0 NXTX EQU * EJCT ****************************************************************** * * CODE DEFINITIONS * ****************************************************************** ORG NXTW LINK SET 0 FNUL EQU 0 FIMD EQU 1 * * **** LIT **** * USED ONLY BY THE COMPILER. PUSH FOLLOWING LITERAL ONTO THE STACK * HEAD FNUL,LIT,LIT TLNK SET * VFD 1,0,1,FNUL,6,3,8,'314 * =,'L' VFD 8,'311,8,'124 ='IT' DAC LINK LINK SET TLNK LIT EQU * IRS IP LDA IP SSP LOSE INDIRECT BIT STA T1 LDA* T1 JMP PUSH * * **** EXEC **** * USED ONLY BY THE COMPILER. EXECUTE FORTH WORD WHOSE ADDRESS IS * ON THE STACK * HEAD FNUL,EXECUTE,EXEC TLNK SET * VFD 1,0,1,FNUL,6,7,8,'305 * =,'E' BCI 2,XECU VFD 8,'324,8,'105 ='TE' DAC LINK LINK SET TLNK EXEC EQU * IRS 0 POP IFZ XTND JMP* 0,1 JMP TO CFA ELSE * EXTENDED ADDRESSING DELAYS INDEXING UNTIL AFTER ALL INDIR. LDA 0,1 STA T1 JMP* T1 ENDC EJCT * **** BRANCH **** * USED ONLY BY THE COMPILER. BRANCH TO THE ADDRESS WHICH FOLLOWS * HEAD FNUL,BRANCH,BRAN TLNK SET * VFD 1,0,1,FNUL,6,6,8,'302 * =,'B' BCI 2,RANC VFD 8,'110 ='H' DAC LINK LINK SET TLNK BRAN EQU * LDA IP SSP AOA STA T1 LDA* T1 SSM INDIRECT BIT JMP NXT1 * * **** 0BRANCH **** * USED ONLY BY THE COMPILER. BRANCH TO THE ADDRESS WHICH FOLLOWS * IF THE TOP OF STACK IS ZERO (FALSE) * HEAD FNUL,0BRANCH,ZBRA TLNK SET * VFD 1,0,1,FNUL,6,7,8,'260 * =,'0' BCI 2,BRAN VFD 8,'303,8,'110 ='CH' DAC LINK LINK SET TLNK ZBRA EQU * IRS 0 POP LDA 0,1 SZE JMP ZBR1 LDA IP SSP AOA STA T1 LDA* T1 SSM JMP NXT1 ZBR1 IRS IP NEXT EJCT * **** (LOOP) **** * USED ONLY BY THE COMPILER. INCREMENT LOOP INDEX BY 1 * BRANCH IF BELOW LIMIT * HEAD FNUL,(LOOP),XLOP TLNK SET * VFD 1,0,1,FNUL,6,6,8,'250 * =,'(' BCI 2,LOOP VFD 8,'051 =')' DAC LINK LINK SET TLNK XLOP EQU * LDA* RP AOA INCREMENT LOOP VARIABLE XLL1 CAS* RP1 JMP XLL3 [RP]+1 > [RP1] JMP XLL3 [RP]+1 = [RP1] XLL2 STA* RP [RP]+1 < [RP1] IRS IP LDA IP SSP STA T1 LDA* T1 GET JUMP ADDRESS SSM JMP NXT1 AND LOOP * XLL3 LDA RP1 POP 2 VALUES FROM RETURN STACK AOA STA RP AOA STA RP1 IRS IP AND SKIP THE BRANCH ADDRESS NEXT EXIT THE LOOP EJCT * **** (+LOOP) **** * USED ONLY BY THE COMPILER. INCREMENT LOOP INDEX BY TOP-OF-STACK * CONDITIONALLY BRANCH * HEAD FNUL,(+LOOP),XPLO TLNK SET * VFD 1,0,1,FNUL,6,7,8,'250 * =,'(' BCI 2,+LOO VFD 8,'320,8,'051 ='P)' DAC LINK LINK SET TLNK XPLO EQU * LDA 1,1 GET INCREMENT SPL +VE JMP XLL4 ADD* RP CURRENT LOOP COUNT JMP XLL1 SAME COMPARISON AS (LOOP) * XLL4 ADD* RP CURRENT LOOP COUNT CAS* RP1 JMP XLL2 [RP]-N > [RP1] JMP XLL2 [RP]-N = [RP1] JMP XLL3 [RP]-N < [RP1] * * **** (DO) **** * USED ONLY BY THE COMPILER. SET UP 'DO' LIMIT AND INDEX * HEAD FNUL,(DO),XDO TLNK SET * VFD 1,0,1,FNUL,6,4,8,'250 * =,'(' BCI 1,DO VFD 8,'051 =')' DAC LINK LINK SET TLNK XDO EQU * LDA 2,1 JST RPSH LDA 1,1 JST RPSH JMP POP2 EJCT * **** I **** * RETURN CURRENT LOOP COUNTER TO THE STACK * HEAD FNUL,I,I TLNK SET * VFD 1,0,1,FNUL,6,1,8,'111 * =,'I' DAC LINK LINK SET TLNK I EQU * LDA* RP JMP PUSH * * **** DIGIT **** * USED BY THE COMPILER * (ASCII-DIGIT BASE ==> DIGIT-VALUE TRUE(OR FALSE)) * HEAD FNUL,DIGIT,DIGT TLNK SET * VFD 1,0,1,FNUL,6,5,8,'304 * =,'D' BCI 1,IG VFD 8,'311,8,'124 ='IT' DAC LINK LINK SET TLNK DIGT EQU * LDA 2,1 GET ASCII VALUE SUB XZRO SPL JMP DIGX CAS =9 JMP DIGA A>9 NOP A=9 DIGY CAS 1,1 COMPARE BASE JMP DIGX A>BASE JMP DIGX A=BASE STA 2,1 SAVE DIGIT VALUE LDA =1 JMP PUT XZRO VFD 16,CZRO * DIGA SUB =7 SUBTRACT 'A'-'0' CAS =9 NOW EXPECT TO BE >9 JMP DIGY A>9 - OK NOP A=9 DIGX CRA A<9 - ERROR EXIT JMP BINA EJCT * **** (FIND) **** * USED BY THE COMPILER. FIND A WORD IN THE DICTIONARY * (STRING-ADDRESS NFA ==> PFA LENGTH TRUE (OR FALSE)) * STRING-ADDRESS IS (WORD) ADDRESS OF THE WORD CONTAINING * LENGTH BYTE, OF THE STRING BEING SOUGHT. NFA IS THE * NAME FIELD ADDRESS OF THE WORD IN THE DICTIONARY WHERE * THE SEARCH BEGINS. PFA IS THE PARAMETER FIELD ADDRESS * OF THE DICTIONARY ENTRY WHICH IS FOUND. IF WORD NOT * FOUND ONLY ONE RESULT (0, FALSE) IS RETURNED. * * HEAD FNUL,(FIND),PFND TLNK SET * VFD 1,0,1,FNUL,6,6,8,'250 * =,'(' BCI 2,FIND VFD 8,'051 =')' DAC LINK LINK SET TLNK PFND EQU * LDA 2,1 PICK UP STRING ADDRESS STA T1 STA T2 LDA 1,1 PICK UP NFA STA T3 * FNDL LDA* T3 STA T5 SAVE FIRST WORD OF NFA ERA* T2 ANA ='037577 LOSE FLAG IN LENGTH BYTE, MS BITS SNZ JMP FNDS * * WORDS DON'T MATCH - FIND END OF STRING FNDX LDA* T3 IRS T3 STEP POINTER ANA ='200 LOOK AT MS BIT OF LOWER BYTE SZE JMP FNDX LDA* T3 PICK UP LINK TO PREVIOUS NFA SNZ JMP FNDN STA T3 LDA T1 STA T2 GO BACK TO START OF DESIRED STRING JMP FNDL EJCT * FIRST WORD DOES MATCH - CHECK THE REST FNDS LDA* T2 GET LENGTH LGR 8 MOVE TO LOWER BYTE ANA ='077 LOSE FLAGS TCA WE COUNT -N TO -1 STA T4 JMP FNDZ * FNDT IRS T2 STEP POINTERS IRS T3 LDA* T2 PICK UP TWO BYTES FROM EACH STRING ERA* T3 IRS T4 FIRST OF TWO INCREMENTS IN LOOP SKP JMP FNDY ANA ='077577 LOSE MS BITS SZE JMP FNDX DON'T MATCH GO TO NEXT DIRECTORY ENTRY FNDZ IRS T4 JMP FNDT * * MATCH - RETURN REQUIRED VALUES FNDM LDA T3 POINTS AT LAST BYTES OF NAME ADD =3 SKIP OVER LINK AND CODE ADDRESS STA 2,1 LDA T5 GET SAVED (NFA) LGR 8 PUT LENGTH IN LOW BYTE STA 1,1 LDA =1 JMP PUSH * * FIRST IRS SKIPPED - SO ONLY THE TOP * BYTE SHOULD BE COMPARED, NOT BOTH FNDY ANA ='077400 LOSE MS BIT AND LOWER BYTE SZE MATCHED JMP FNDX JMP FNDM * * THE STRINGS DON'T MATCH FNDN CRA JMP BINA EJCT * **** ENCLOSE **** * USED BY THE COMPILER. BREAK NEXT WORD OUT OF THE INPUT BUFFER * ( CADDR DELIMITER ==> CADDR OFFSET END-OFFSET NEXT-OFFSET) * HEAD FNUL,ENCLOSE,ENCL TLNK SET * VFD 1,0,1,FNUL,6,7,8,'305 * =,'E' BCI 2,NCLO VFD 8,'323,8,'105 ='SE' DAC LINK LINK SET TLNK ENCL EQU * LDA 0 SUB =2 STA 0 CREATE SPACE FOR RESULTS CRA SET OFFSET TO ZERO STA T1 USE A TEMPORARY TO COUNT CHARACTERS IMA 3,1 CLEAR OFFSET, GET DELIMITER STA T2 BECAUSE STACK LOCATION WILL BE OVERWRITTEN ENC1 JST ENCC JMP ENC4 NULL JMP ENC1 LOOP ON DELIMITERS SUB =1 STA 3,1 OFFSET ENC2 JST ENCC JMP ENC4 NULL SKP DELIMITER JMP ENC2 LOOP UNTIL DELIMITER STA 1,1 NEXT-OFFSET SUB =1 ENC3 STA 2,1 END-OFFSET NEXT * ENC4 STA 1,1 NEXT-OFFSET CAS 3,1 CONTAINS THE START-OFFSET JMP ENC3 NOT EQUAL AOA EQUAL - STEP POINTER, FALL THROUGH JMP ENC3 NOT EQUAL EJCT * LOOK AT THE CHARACTER AT [CADDR+T1] * RETURN TO ONE OF THE FOLLOWING THREE LOCATIONS * IN PRIORITY ORDER: * +1 - CHARACTER IS NULL (T1 NOT INCREMENTED) * +2 - CHARACTER IS DELIMITER (T2) * +3 - OTHER CHARACTER * * T1 IS RETURNED IN THE A REGISTER ENCC DAC ** LDA T1 GET CHARACTER POINTER ADD 4,1 ADD BASE ADDRESS JST CHGT GET THE CHARACTER SNZ JMP ENCX NULL EXIT IRS T1 NON-NULL EXITS STEP T1 IRS ENCC CAS T2 SKP JMP ENCX DELIMITER EXIT IRS ENCC FALL THROUGH FOR NORMAL EXIT ENCX LDA T1 JMP* ENCC EJCT * * THE NEXT 4 HEADERS POINT TO INSTALLATION-DEPENDENT TERMINAL I/O * ROUTINES. * * HEAD FNUL,EMIT,EMIT **** EMIT TLNK SET * VFD 1,0,1,FNUL,6,4,8,'305 * =,'E' BCI 1,MI VFD 8,'124 ='T' DAC LINK LINK SET TLNK EMIT EQU * JMP PEMT * HEAD FNUL,KEY,KEY **** KEY TLNK SET * VFD 1,0,1,FNUL,6,3,8,'313 * =,'K' VFD 8,'305,8,'131 ='EY' DAC LINK LINK SET TLNK KEY EQU * JMP PKEY * HEAD FNUL,?TERMINAL,QTRM **** ?TERMINAL TLNK SET * VFD 1,0,1,FNUL,6,9,8,'277 * =,'?' BCI 3,TERMIN VFD 8,'301,8,'114 ='AL' DAC LINK LINK SET TLNK QTRM EQU * JMP PQTR * HEAD FNUL,CR,CR **** CR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'303 * =,'C' VFD 8,'122 ='R' DAC LINK LINK SET TLNK CR EQU * JMP PCR EJCT IFN PTW * HEAD FNUL,PTRC,PTRC **** PTRC - PAPERTAPE READER CHARACTER TLNK SET * VFD 1,0,1,FNUL,6,4,8,'320 * =,'P' BCI 1,TR VFD 8,'103 ='C' DAC LINK LINK SET TLNK PTRC EQU * JMP PPTC ENDC * * **** CMOVE **** * ( CADDR1 CADDR2 COUNT --- ) * ADDRESSES ARE BYTE ADDRESSES NOT CELL (WORD) ADDRESSES * * TODO - SHOULD PROBABLY OPTIMIZE TO MOVE WORDS WHERE POSSIBLE * HEAD FNUL,CMOVE,CMOV TLNK SET * VFD 1,0,1,FNUL,6,5,8,'303 * =,'C' BCI 1,MO VFD 8,'326,8,'105 ='VE' DAC LINK LINK SET TLNK CMOV EQU * LDA 1,1 GET COUNT SNZ JMP CMVX TCA STA T1 LDA 2,1 DESTINATION ADDRESS STA T2 LDA 3,1 SOURCE ADDRESS STA T3 * CMVL LDA T3 GET POINTER IRS T3 STEP JST CHGT GET CHARACTER IAB LDA T2 GET DEST POINTER IRS T2 JST CHPT PUT CHARACTER IRS T1 JMP CMVL * CMVX IRS 0 ALSO USED FOR MOVE EXIT JMP POP2 EJCT * **** MOVE **** * ( ADDR1 ADDR2 COUNT --- ) * ADDRESSES ARE CELL (WORD) ADDRESSES * * HEAD FNUL,MOVE,MOVE TLNK SET * VFD 1,0,1,FNUL,6,4,8,'315 * =,'M' BCI 1,OV VFD 8,'105 ='E' DAC LINK LINK SET TLNK MOVE EQU * LDA 1,1 GET COUNT SNZ JMP CMVX TCA STA T1 LDA 2,1 DESTINATION ADDRESS STA T2 LDA 3,1 SOURCE ADDRESS STA T3 * MOVL LDA* T3 IRS T3 STA* T2 IRS T2 IRS T1 JMP MOVL JMP CMVX * * FIRST SECTOR FULL - LEAVING SPACE FOR CONSTANT POOL * AND DESECTORIZING * NXTY EQU * EJCT ORG NXTX AFTER START-UP CODE * **** U* **** * ( N1 N2 --- D ). PRODUCT IS 32-BIT DOUBLE INTEGER, * HEAD FNUL,U*,USTR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'325 * =,'U' VFD 8,'052 ='*' DAC LINK LINK SET TLNK USTR EQU * IFZ HSA * SOFTWARE UNSIGNED MULTIPLY LDA =-16 COUNTER STA T1 CRA CLEAR ACCUMULATOR IAB CRA STA T3 MS WORD OF MULTIPLIER UST1 LLL 1 SHIFT ACCUMULATOR LEFT IMA 2,1 GET MULTIPLICAND LGL 1 TOP BIT TO CARRY IMA 2,1 GET ACCUMULATOR BACK SSC CARRY SET? JMP UST2 NO IAB YES - LS WORD TO A STA T2 SAVE VALUE ADD 1,1 ADD MULIPLIER IMA T2 SAVE SUM, GET FIRST INPUT SRC CARRY (OVERFLOW!) SET? CHS YES - XOR IT INTO MSB ERA 1,1 XOR IN SECOND ERA T2 XOR IN SUM, CARRY NOW IN MSB CSA PUT IN CBIT LDA T2 GET SUM BACK IAB GET MS BITS BACK ACA ADD IN ANY CARRY NEEDED ADD T3 ADD IN MS WORD (FOR SIGNED MULTIPLY) UST2 IRS T1 JMP UST1 STA 1,1 MS WORD IAB STA 2,1 LS WORD NEXT ELSE EJCT * HARDWARE UNSIGNED MULTIPLY * ONLY HAVE SIGNED MULTIPLY INSTRUCTION SO THIS CODE WORKS * BY BREAKING EACH 16-BIT UNSIGNED NUMBER INTO TWO FIELDS; * THE LOWER 15 BITS, WHICH (BEING A VALID SIGNED NUMBER) CAN * BE MULTIPLIED, AND THE TOP BIT, WHICH HAS SIGNIFICANCE * 2^15. SO WE HAVE: * (P1*2^15+P[2-16]) * (Q1*2^15+Q[2-16]) WHICH EQUALS... * P1.Q1*2^30 + P1*2^15*Q[2-16] + Q1*2^15*P[2-16] + P[2-16]*Q[2-16] LDA 1,1 ALL OF P SSP STA T1 BITS 2-16 OF P IAB LDA 2,1 ALL OF Q SSP STA T2 BITS 2-16 OF Q MPY T1 P[2-16]*Q[2-16] STA T3 SAVE UPPER BITS IAB GET LOWER 15 BITS (B1=0) STA T4 SAVE CRA CLEAR B REGISTER IAB * LDA 1,1 CHECK TOP BITS SMI JMP UST5 LDA 2,1 SMI JMP UST4 * * BOTH TOP BITS SET LDA T3 UPPER BITS OF P[2-16]*Q[2-16] ADD T1 2^15*P[2-16] (2^15 FREE, SINCE 15-BITS IN B) * CAN'T OVERFLOW TO THIS POINTS SINCE BOTH * INPUTS TO PREVIOUS ADD WERE 15-BITS, BUT NOW HAVE * A 16-BIT VALUE AND ADDING A THIRD 15-BIT VALUE MAY * OVERFLOW SPL JMP UST2 * TOP BIT CLEAR - CANNOT OVERFLOW ADD T2 2^15*Q[2-16] UST1 LRL 1 LS BIT OF A SHIFTS INTO B1, A1=0 JMP UST3 * TOP BIT WAS SET UST2 ADD T2 2^15*Q[2-16] SPL JMP UST1 IT STILL IS - NO OVERFLOW LRL 1 SSM SET A1, DUE TO CARRY FROM ADD UST3 ADD ='040000 2^30 JMP UST8 * * ONLY TOP BIT OF P SET UST4 LDA T3 UPPER BITS OF P[2-16]*Q[2-16] ADD T2 2^15*Q[2-16] JMP UST7 * UST5 LDA 2,1 SMI JMP UST6 * * ONLY TOP BIT OF Q SET LDA T3 UPPER BITS OF P[2-16]*Q[2-16] ADD T1 2^15*P[2-16] JMP UST7 * * NEITHER UPPER BIT SET UST6 LDA T3 UPPER BITS OF P[2-16]*Q[2-16] UST7 LRL 1 UST8 STA 1,1 MS WORD IAB GET BACK 2^15 SIGNIFICANCE BIT IN MS BIT ERA T4 OR IN THE LOWER 15 BITS STA 2,1 LS WORD NEXT ENDC EJCT * **** U/ **** * ( D N --- N1 N2 ) * UNSIGNED DIVIDE YIELDING REMAINDER AND QUOTIENT * HEAD FNUL,U/,USLA TLNK SET * VFD 1,0,1,FNUL,6,2,8,'325 * =,'U' VFD 8,'057 ='/' DAC LINK LINK SET TLNK USLA EQU * JST DIVU NEXT * * UNSIGNED DIVIDE - SUBROUTINE SINCE CALLED * BY SIGNED DIVIDE * DIVU DAC ** LDA =-16 STA T1 COUNT LDA 1,1 DIVISOR SNZ JMP DVU6 DIVIDE BY ZERO SUB 2,1 COMPARE TO DIVIDEND SNZ JMP DVU6 BAD DIVIDE * DON'T NEED SUM, WANT CARRY SRC CARRY (OVERFLOW!) SET? CHS YES - XOR IT INTO MSB ERA 1,1 XOR IN FIRST OPERAND ERA 2,1 XOR IN SECOND OPERAND, CARRY NOW IN MSB SPL JMP DVU6 BAD DIVIDE LDA 3,1 LS WORD IAB LDA 2,1 MS WORD DVU1 LLL 1 SHIFT ACCUMULATOR LEFT STA T2 SAVE IN CASE OF RESTORE SRC TOP BIT WAS SET? JMP DVU5 YES SUB 1,1 DIVISOR STA T3 SAVE SUM SRC CARRY (OVERFLOW!) SET? CHS YES - XOR IT INTO MSB ERA 1,1 XOR IN SECOND OPERAND ERA T2 XOR IN FIRST OPERAND, CARRY NOW IN MSB SPL JMP DVU4 CARRY SET DVU2 IAB AOA QUOTIENT BIT IS 1 IAB LDA T3 DVU3 IRS T1 JMP DVU1 RCB NO ERROR IRS 0 DISCARD DIVISOR STA 2,1 REMAINDER IAB STA 1,1 QUOTIENT JMP* DIVU * DVU4 LDA T2 RESTORE, QUOTIENT BIT ZERO JMP DVU3 * * HERE IF TOP BIT SHIFTED OUT WAS 1 SO * SUBTRACTION CANNOT GENERATE CARRY DVU5 SUB 1,1 DIVISOR STA T3 JMP DVU2 * DVU6 IRS 0 ERROR EXIT - DISCARD DIVISOR CRA RETURN ZEROS STA 2,1 REMAINDER STA 1,1 QUOTIENT SCB SET CARRY SO CALLER CAN DETECT OVERFLOW JMP* DIVU EJCT * **** AND **** * ( N1 N2 --- N3 ) BITWISE AND * HEAD FNUL,AND,AND TLNK SET * VFD 1,0,1,FNUL,6,3,8,'301 * =,'A' VFD 8,'316,8,'104 ='ND' DAC LINK LINK SET TLNK AND EQU * LDA 1,1 ANA 2,1 JMP BINA * * **** OR **** * ( N1 N2 --- N3 ) BITWISE INCLUSIVE OR * HEAD FNUL,OR,OR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'317 * =,'O' VFD 8,'122 ='R' DAC LINK LINK SET TLNK OR EQU * LDA 1,1 ERA ='177777 ANA 2,1 ERA 1,1 JMP BINA * * **** XOR **** * ( N1 N2 --- N3 ) BITWISE EXCLUSIVE OR * HEAD FNUL,XOR,XOR TLNK SET * VFD 1,0,1,FNUL,6,3,8,'330 * =,'X' VFD 8,'317,8,'122 ='OR' DAC LINK LINK SET TLNK XOR EQU * LDA 1,1 ERA 2,1 JMP BINA EJCT * **** SP@ **** * ( --- N ) CURRENT STACK POINTER * HEAD FNUL,SP@,SPAT TLNK SET * VFD 1,0,1,FNUL,6,3,8,'323 * =,'S' VFD 8,'320,8,'100 ='P@' DAC LINK LINK SET TLNK SPAT EQU * LDA 0 GET POINTER AOA INCREMENT BECAUSE POINTS TO FIRST FREE JMP PUSH * * **** SP! **** * ( --- ) INITIALISE STACK POINTER * HEAD FNUL,SP!,SPST TLNK SET * VFD 1,0,1,FNUL,6,3,8,'323 * =,'S' VFD 8,'320,8,'041 ='P!' DAC LINK LINK SET TLNK SPST EQU * LDA UP ADD ='3 OFFSET 3 IN USER AREA STA T1 POINT TO LOCATION IN TABLE LDA* T1 GET VALUE SUB =1 BECAUSE POINTS TO FIRST FREE STA 0 NEXT EJCT * **** RP! **** * ( --- ) INITIALISE RETURN STACK POINTER * HEAD FNUL,RP!,RPST TLNK SET * VFD 1,0,1,FNUL,6,3,8,'322 * =,'R' VFD 8,'320,8,'041 ='P!' DAC LINK LINK SET TLNK RPST EQU * LDA UP ADD ='4 OFFSET 4 IN USER AREA STA T1 POINT TO LOCATION IN TABLE LDA* T1 GET VALUE STA RP AOA STA RP1 NEXT * * **** ;S **** * ( --- N ) RETURN? * HEAD FNUL,;S,SMIS TLNK SET * VFD 1,0,1,FNUL,6,2,8,'273 * =,';' VFD 8,'123 ='S' DAC LINK LINK SET TLNK SMIS EQU * JST RPOP SUB =1 SSM STA IP NEXT EJCT * **** LEAVE **** * ( --- ) * HEAD FNUL,LEAVE,LEAV TLNK SET * VFD 1,0,1,FNUL,6,5,8,'314 * =,'L' BCI 1,EA VFD 8,'326,8,'105 ='VE' DAC LINK LINK SET TLNK LEAV EQU * LDA* RP STA* RP1 NEXT * * **** >R **** * ( N --- ) * HEAD FNUL,>R,TOR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'276 * =,'>' VFD 8,'122 ='R' DAC LINK LINK SET TLNK TOR EQU * LDA 1,1 IRS 0 JST RPSH NEXT EJCT * * **** R> **** * ( --- R ) * HEAD FNUL,R>,FRMR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'322 * =,'R' VFD 8,'076 ='>' DAC LINK LINK SET TLNK FRMR EQU * JST RPOP JMP PUSH * * **** R **** * ( --- N ) * HEAD FNUL,R,R TLNK SET * VFD 1,0,1,FNUL,6,1,8,'122 * =,'R' DAC LINK LINK SET TLNK R EQU * LDA* RP JMP PUSH * * **** 0= **** * ( N --- N ) * HEAD FNUL,0=,ZEQU TLNK SET * VFD 1,0,1,FNUL,6,2,8,'260 * =,'0' VFD 8,'075 ='=' DAC LINK LINK SET TLNK ZEQU EQU * LDA 1,1 SZE IS IT ZERO? JMP ZEQ0 ZEQ1 LDA =1 RETURN TRUE JMP PUT ZEQ0 CRA RETURN FALSE JMP PUT EJCT * **** 0< **** * ( N --- N ) * HEAD FNUL,0<,ZLES TLNK SET * VFD 1,0,1,FNUL,6,2,8,'260 * =,'0' VFD 8,'074 ='<' DAC LINK LINK SET TLNK ZLES EQU * LDA 1,1 SMI JMP ZEQ0 JMP ZEQ1 * * **** + **** * ( N N --- N ) * HEAD FNUL,+,PLUS TLNK SET * VFD 1,0,1,FNUL,6,1,8,'053 * =,'+' DAC LINK LINK SET TLNK PLUS EQU * LDA 1,1 ADD 2,1 JMP BINA * * **** D+ **** * ( D D --- D ) * HEAD FNUL,D+,DPLS TLNK SET * VFD 1,0,1,FNUL,6,2,8,'304 * =,'D' VFD 8,'053 ='+' DAC LINK LINK SET TLNK DPLS EQU * LDA 4,1 ADD LOWER WORDS ADD 2,1 IMA 4,1 GET BACK FIRST INPUT, SAVE SUM SRC CARRY (OVERFLOW!) SET? CHS YES - XOR IT INTO MSB ERA 2,1 XOR IN SECOND ERA 4,1 XOR IN SUM * TOP BIT IS NOW CARRY CSA PLACE IN CARRY LDA 3,1 ADD UPPER WORDS ACA CARRY FROM LOWER ADD 1,1 IRS 0 DISCARD A WORD JMP BINA * * **** MINUS **** * ( N --- N ) * HEAD FNUL,MINUS,MINS TLNK SET * VFD 1,0,1,FNUL,6,5,8,'315 * =,'M' BCI 1,IN VFD 8,'325,8,'123 ='US' DAC LINK LINK SET TLNK MINS EQU * LDA 1,1 TCA JMP PUT * **** DMINUS **** * ( D --- D ) * HEAD FNUL,DMINUS,DMNS TLNK SET * VFD 1,0,1,FNUL,6,6,8,'304 * =,'D' BCI 2,MINU VFD 8,'123 ='S' DAC LINK LINK SET TLNK DMNS EQU * LDA 2,1 TCA STA 2,1 RCB SNZ ZERO? SCB YES - SET CARRY LDA 1,1 MS WORD CMA ACA ADD ANY CARRY IN JMP PUT EJCT * **** OVER **** * ( N1 N2 --- N1 N2 N1 ) * HEAD FNUL,OVER,OVER TLNK SET * VFD 1,0,1,FNUL,6,4,8,'317 * =,'O' BCI 1,VE VFD 8,'122 ='R' DAC LINK LINK SET TLNK OVER EQU * LDA 2,1 JMP PUSH * **** DROP **** * ( N --- ) * HEAD FNUL,DROP,DROP TLNK SET * VFD 1,0,1,FNUL,6,4,8,'304 * =,'D' BCI 1,RO VFD 8,'120 ='P' DAC LINK LINK SET TLNK DROP EQU * JMP POP * **** SWAP **** * ( N1 N2 --- N2 N1 ) * HEAD FNUL,SWAP,SWAP TLNK SET * VFD 1,0,1,FNUL,6,4,8,'323 * =,'S' BCI 1,WA VFD 8,'120 ='P' DAC LINK LINK SET TLNK SWAP EQU * LDA 1,1 IMA 2,1 JMP PUT EJCT * **** DUP **** * ( N1 --- N1 N1 ) * HEAD FNUL,DUP,DUP TLNK SET * VFD 1,0,1,FNUL,6,3,8,'304 * =,'D' VFD 8,'325,8,'120 ='UP' DAC LINK LINK SET TLNK DUP EQU * LDA 1,1 JMP PUSH * * **** +! **** * ( N A --- ) * HEAD FNUL,+!,PSTR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'253 * =,'+' VFD 8,'041 ='!' DAC LINK LINK SET TLNK PSTR EQU * IFZ XTND LDA 2,1 ADD* 1,1 STA* 1,1 ELSE LDA 1,1 STA T1 LDA 2,1 ADD* T1 STA* T1 ENDC JMP POP2 * * **** TOGGLE **** * ( A N --- ) EXCLUSIVE OR INTO MEMORY WORD * HEAD FNUL,TOGGLE,TOGL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'324 * =,'T' BCI 2,OGGL VFD 8,'105 ='E' DAC LINK LINK SET TLNK TOGL EQU * IFZ XTND LDA 1,1 GET PATTERN ERA* 2,1 STA* 2,1 ELSE LDA 2,1 STA T1 LDA 1,1 GET PATTERN ERA* T1 STA* T1 ENDC JMP POP2 EJCT * **** @ **** * ( A --- N) * HEAD FNUL,@,AT TLNK SET * VFD 1,0,1,FNUL,6,1,8,'100 * =,'@' DAC LINK LINK SET TLNK AT EQU * IFZ XTND LDA* 1,1 ELSE LDA 1,1 STA T1 LDA* T1 ENDC JMP PUT * * **** C@ **** * ( CADDR --- N) * HEAD FNUL,C@,CAT TLNK SET * VFD 1,0,1,FNUL,6,2,8,'303 * =,'C' VFD 8,'100 ='@' DAC LINK LINK SET TLNK CAT EQU * LDA 1,1 JST CHGT JMP PUT * * **** ! **** * ( N A --- ) * HEAD FNUL,!,STOR TLNK SET * VFD 1,0,1,FNUL,6,1,8,'041 * =,'!' DAC LINK LINK SET TLNK STOR EQU * IFZ XTND LDA 2,1 STA* 1,1 ELSE LDA 1,1 STA T1 LDA 2,1 STA* T1 ENDC JMP POP2 EJCT * **** C! **** * ( N CADDR --- ) * HEAD FNUL,C!,CSTR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'303 * =,'C' VFD 8,'041 ='!' DAC LINK LINK SET TLNK CSTR EQU * LDA 2,1 IAB LDA 1,1 JST CHPT JMP POP2 * **** BYTE **** * ( A --- CADDR) GET BYTE ADDRESS FROM WORD ADDRESS * HEAD FNUL,BYTE,BYTE TLNK SET * VFD 1,0,1,FNUL,6,4,8,'302 * =,'B' BCI 1,YT VFD 8,'105 ='E' DAC LINK LINK SET TLNK BYTE EQU * LDA 1,1 LGL 1 JMP PUT * **** CELL **** * ( CADDR --- A) GET WORD ADDRESS FROM BYTE ADDRESS * HEAD FNUL,CELL,CELL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'303 * =,'C' BCI 1,EL VFD 8,'114 ='L' DAC LINK LINK SET TLNK CELL EQU * LDA 1,1 LGR 1 JMP PUT EJCT ****************************************************************** * * PRE-COMPILED FORTH SECTION * ****************************************************************** * * * * NOTE - A FEW OF THE FOLLOWING OPERATIONS HAVE BEEN * CONVERTED TO CODE FOR SPEED. HOWEVER, THE WORD ORDER * IN THE DICTIONARY HAS NOT BEEN CHANGED. * * **** : **** * HEAD FIMD,:,COLN,DOCL TLNK SET * VFD 1,0,1,FIMD,6,1,8,'072 * =,':' DAC LINK LINK SET TLNK COLN JST DOCL DAC QEXC DAC SCSP DAC CURR DAC AT DAC CONT DAC STOR DAC CRAT DAC RBRC DAC PSCD JST DOCL PICKED UP BY PSCD * * **** ; **** * HEAD FIMD,;,SEMI,DOCL TLNK SET * VFD 1,0,1,FIMD,6,1,8,'073 * =,';' DAC LINK LINK SET TLNK SEMI JST DOCL DAC QCSP DAC COMP DAC SMIS DAC SMDG DAC LBRC DAC SMIS * * **** CONSTANT **** * HEAD FNUL,CONSTANT,CON,DOCL TLNK SET * VFD 1,0,1,FNUL,6,8,8,'303 * =,'C' BCI 3,ONSTAN VFD 8,'124 ='T' DAC LINK LINK SET TLNK CON JST DOCL DAC CRAT DAC SMDG DAC COMA DAC PSCD JST DOCN PICKED UP BY PSCD * * **** VARIABLE **** * ( N --- ) * HEAD FNUL,VARIABLE,VAR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,8,8,'326 * =,'V' BCI 3,ARIABL VFD 8,'105 ='E' DAC LINK LINK SET TLNK VAR JST DOCL DAC CON DAC PSCD JST DOVR PICKED UP BY PSCD * * **** USER **** * HEAD FNUL,USER,USER,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'325 * =,'U' BCI 1,SE VFD 8,'122 ='R' DAC LINK LINK SET TLNK USER JST DOCL DAC CON DAC PSCD JST DOUS PICKED UP BY PSCD EJCT * * CONSTANTS * * **** 0 * HEAD FNUL,0,ZERO,DOCN TLNK SET * VFD 1,0,1,FNUL,6,1,8,'060 * =,'0' DAC LINK LINK SET TLNK ZERO JST DOCN DEC 0 * * **** 1 **** * HEAD FNUL,1,ONE,DOCN TLNK SET * VFD 1,0,1,FNUL,6,1,8,'061 * =,'1' DAC LINK LINK SET TLNK ONE JST DOCN DEC 1 * * **** 2 **** * HEAD FNUL,2,TWO,DOCN TLNK SET * VFD 1,0,1,FNUL,6,1,8,'062 * =,'2' DAC LINK LINK SET TLNK TWO JST DOCN DEC 2 * * **** 3 **** * HEAD FNUL,3,THRE,DOCN TLNK SET * VFD 1,0,1,FNUL,6,1,8,'063 * =,'3' DAC LINK LINK SET TLNK THRE JST DOCN DEC 3 * * **** BL **** * HEAD FNUL,BL,BL,DOCN TLNK SET * VFD 1,0,1,FNUL,6,2,8,'302 * =,'B' VFD 8,'114 ='L' DAC LINK LINK SET TLNK BL JST DOCN VFD 16,CSPC * * **** C/L **** # OF CHARACTERS PER LINE * HEAD FNUL,C/L,CL,DOCN TLNK SET * VFD 1,0,1,FNUL,6,3,8,'303 * =,'C' VFD 8,'257,8,'114 ='/L' DAC LINK LINK SET TLNK CL JST DOCN OCT 100 * * 'FIRST' AND 'LIMIT' MOVED TO USER AREA * * **** B/BUF **** BYTES PER DISK-BLOCK BUFFER. * HEAD FNUL,B/BUF,BBUF,DOCN TLNK SET * VFD 1,0,1,FNUL,6,5,8,'302 * =,'B' BCI 1,/B VFD 8,'325,8,'106 ='UF' DAC LINK LINK SET TLNK BBUF JST DOCN DEC 1024 * * **** B/SCR **** DISK BLOCKS PER FORTH SCREEN. * HEAD FNUL,B/SCR,BSCR,DOCN TLNK SET * VFD 1,0,1,FNUL,6,5,8,'302 * =,'B' BCI 1,/S VFD 8,'303,8,'122 ='CR' DAC LINK LINK SET TLNK BSCR JST DOCN DEC 1 * * **** +ORIGIN **** RETURNS ADDRESS, GIVEN OFFSET FROM ORIGIN. * HEAD FNUL,+ORIGIN,PORG,DOCL TLNK SET * VFD 1,0,1,FNUL,6,7,8,'253 * =,'+' BCI 2,ORIG VFD 8,'311,8,'116 ='IN' DAC LINK LINK SET TLNK PORG JST DOCL DAC LIT DAC ORGN DAC PLUS DAC SMIS * * USER VARIABLES * * **** S0 **** STACK ORIGIN. * HEAD FNUL,S0,SZRO,DOUS TLNK SET * VFD 1,0,1,FNUL,6,2,8,'323 * =,'S' VFD 8,'060 ='0' DAC LINK LINK SET TLNK SZRO JST DOUS OCT 3 * * **** R0 **** RETURN STACK ORIGIN. * HEAD FNUL,R0,RZRO,DOUS TLNK SET * VFD 1,0,1,FNUL,6,2,8,'322 * =,'R' VFD 8,'060 ='0' DAC LINK LINK SET TLNK RZRO JST DOUS OCT 4 * * **** TIB **** TERMINAL INPUT BUFFER. * HEAD FNUL,TIB,TIB,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'324 * =,'T' VFD 8,'311,8,'102 ='IB' DAC LINK LINK SET TLNK TIB JST DOUS OCT 5 * * **** WIDTH **** MAXIMUM NAME LENGTH (DEFAULT, 31 CHARACTERS). * HEAD FNUL,WIDTH,WDTH,DOUS TLNK SET * VFD 1,0,1,FNUL,6,5,8,'327 * =,'W' BCI 1,ID VFD 8,'324,8,'110 ='TH' DAC LINK LINK SET TLNK WDTH JST DOUS OCT 6 * * **** WARNING **** WARNING MODE * (DEFAULT, GIVE MESSAGE NUMBER AT ERROR OR WARNING CONDITION, * DON'T GO TO DISK FOR MESSAGE). * HEAD FNUL,WARNING,WARN,DOUS TLNK SET * VFD 1,0,1,FNUL,6,7,8,'327 * =,'W' BCI 2,ARNI VFD 8,'316,8,'107 ='NG' DAC LINK LINK SET TLNK WARN JST DOUS OCT 7 * * **** FENCE **** PREVENTS 'FORGET' BELOW THIS 'FENCE' SETTING. * HEAD FNUL,FENCE,FENC,DOUS TLNK SET * VFD 1,0,1,FNUL,6,5,8,'306 * =,'F' BCI 1,EN VFD 8,'303,8,'105 ='CE' DAC LINK LINK SET TLNK FENC JST DOUS OCT 10 * * **** DP **** DICTIONARY POINTER TO NEXT AVAILABLE SPACE. * HEAD FNUL,DP,DP,DOUS TLNK SET * VFD 1,0,1,FNUL,6,2,8,'304 * =,'D' VFD 8,'120 ='P' DAC LINK LINK SET TLNK DP JST DOUS OCT 11 * * **** VOC-LINK **** VOCABULARY LINK (MAINLY FOR FUTURE USE). * HEAD FNUL,VOC-LINK,VOCL,DOUS TLNK SET * VFD 1,0,1,FNUL,6,8,8,'326 * =,'V' BCI 3,OC-LIN VFD 8,'113 ='K' DAC LINK LINK SET TLNK VOCL JST DOUS OCT 12 * * **** FIRST **** ADDRESS OF BEGINNING OF DISK BUFFER. * HEAD FNUL,FIRST,FRST,DOUS TLNK SET * VFD 1,0,1,FNUL,6,5,8,'306 * =,'F' BCI 1,IR VFD 8,'323,8,'124 ='ST' DAC LINK LINK SET TLNK FRST JST DOUS OCT 13 * * **** LIMIT **** ADDRESS JUST BEYOND END OF DISK BUFFERS. * HEAD FNUL,LIMIT,LIMT,DOUS TLNK SET * VFD 1,0,1,FNUL,6,5,8,'314 * =,'L' BCI 1,IM VFD 8,'311,8,'124 ='IT' DAC LINK LINK SET TLNK LIMT JST DOUS OCT 14 * * POSITIONS '15 AND '16 ARE AVAILABLE FOR EXPANSION. * THEY ARE INITIALIZED FROM BOOT-UP TABLE, AT COLD START. * * **** BLK **** CURRENT DISK BLOCK BEING LOADED (0=TERMINAL) * HEAD FNUL,BLK,BLK,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'302 * =,'B' VFD 8,'314,8,'113 ='LK' DAC LINK LINK SET TLNK BLK JST DOUS OCT 17 * * **** IN **** OFFSET IN TERMINAL INPUT BUFFER. * HEAD FNUL,IN,IN,DOUS TLNK SET * VFD 1,0,1,FNUL,6,2,8,'311 * =,'I' VFD 8,'116 ='N' DAC LINK LINK SET TLNK IN JST DOUS OCT 20 * * **** OUT **** OFFSET IN OUTPUT LINE. * HEAD FNUL,OUT,OUT,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'317 * =,'O' VFD 8,'325,8,'124 ='UT' DAC LINK LINK SET TLNK OUT JST DOUS OCT 21 * * **** SCR **** CURRENT FORTH DISK SCREEN. * HEAD FNUL,SCR,SCR,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'323 * =,'S' VFD 8,'303,8,'122 ='CR' DAC LINK LINK SET TLNK SCR JST DOUS OCT 22 * * **** OFFSET **** * HEAD FNUL,OFFSET,OFST,DOUS TLNK SET * VFD 1,0,1,FNUL,6,6,8,'317 * =,'O' BCI 2,FFSE VFD 8,'124 ='T' DAC LINK LINK SET TLNK OFST JST DOUS OCT 23 * * **** CONTEXT **** * HEAD FNUL,CONTEXT,CONT,DOUS TLNK SET * VFD 1,0,1,FNUL,6,7,8,'303 * =,'C' BCI 2,ONTE VFD 8,'330,8,'124 ='XT' DAC LINK LINK SET TLNK CONT JST DOUS OCT 24 * * **** CURRENT **** * HEAD FNUL,CURRENT,CURR,DOUS TLNK SET * VFD 1,0,1,FNUL,6,7,8,'303 * =,'C' BCI 2,URRE VFD 8,'316,8,'124 ='NT' DAC LINK LINK SET TLNK CURR JST DOUS OCT 25 * * **** STATE **** * HEAD FNUL,STATE,STAT,DOUS TLNK SET * VFD 1,0,1,FNUL,6,5,8,'323 * =,'S' BCI 1,TA VFD 8,'324,8,'105 ='TE' DAC LINK LINK SET TLNK STAT JST DOUS OCT 26 * * **** BASE **** * HEAD FNUL,BASE,BASE,DOUS TLNK SET * VFD 1,0,1,FNUL,6,4,8,'302 * =,'B' BCI 1,AS VFD 8,'105 ='E' DAC LINK LINK SET TLNK BASE JST DOUS OCT 27 * * **** DPL **** OFFSET OF DECIMAL POINT AFTER DOUBLE-INTEGER INPUT. * HEAD FNUL,DPL,DPL,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'304 * =,'D' VFD 8,'320,8,'114 ='PL' DAC LINK LINK SET TLNK DPL JST DOUS OCT 30 * * **** FLD **** * HEAD FNUL,FLD,FLD,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'306 * =,'F' VFD 8,'314,8,'104 ='LD' DAC LINK LINK SET TLNK FLD JST DOUS OCT 31 * * **** CSP **** USED BY COMPILER TO HOLD CURRENT STACK POSITION, * FOR ERROR CHECKING. * HEAD FNUL,CSP,CSP,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'303 * =,'C' VFD 8,'323,8,'120 ='SP' DAC LINK LINK SET TLNK CSP JST DOUS OCT 32 * * **** R# **** CURSOR POSITION (FOR SOME EDITORS). * HEAD FNUL,R#,RNUM,DOUS TLNK SET * VFD 1,0,1,FNUL,6,2,8,'322 * =,'R' VFD 8,'043 ='#' DAC LINK LINK SET TLNK RNUM JST DOUS OCT 33 * * **** HLD **** POINTS TO LAST CHARACTER HELD IN 'PAD' * HEAD FNUL,HLD,HLD,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'310 * =,'H' VFD 8,'314,8,'104 ='LD' DAC LINK LINK SET TLNK HLD JST DOUS OCT 34 * * **** USE **** * HEAD FNUL,USE,USE,DOUS TLNK SET * VFD 1,0,1,FNUL,6,3,8,'325 * =,'U' VFD 8,'323,8,'105 ='SE' DAC LINK LINK SET TLNK USE JST DOUS OCT 35 * * **** PREV **** * HEAD FNUL,PREV,PREV,DOUS TLNK SET * VFD 1,0,1,FNUL,6,4,8,'320 * =,'P' BCI 1,RE VFD 8,'126 ='V' DAC LINK LINK SET TLNK PREV JST DOUS OCT 36 * *END OF USER AREA * EJCT * **** 1+ **** * HEAD FNUL,1+,ONEP TLNK SET * VFD 1,0,1,FNUL,6,2,8,'261 * =,'1' VFD 8,'053 ='+' DAC LINK LINK SET TLNK ONEP EQU * LDA 1,1 AOA JMP PUT * * **** 2+ **** * HEAD FNUL,2+,TWOP TLNK SET * VFD 1,0,1,FNUL,6,2,8,'262 * =,'2' VFD 8,'053 ='+' DAC LINK LINK SET TLNK TWOP EQU * LDA 1,1 ADD =2 JMP PUT * * **** HERE **** * HEAD FNUL,HERE,HERE,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'310 * =,'H' BCI 1,ER VFD 8,'105 ='E' DAC LINK LINK SET TLNK HERE JST DOCL DAC DP DAC AT DAC SMIS * * **** ALLOT **** * HEAD FNUL,ALLOT,ALOT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'301 * =,'A' BCI 1,LL VFD 8,'317,8,'124 ='OT' DAC LINK LINK SET TLNK ALOT JST DOCL DAC DP DAC PSTR DAC SMIS * * **** , **** * ( N --- ) L0 * STORE N INTO THE NEXT AVAILABLE DICTIONARY MEMORY CELL, ADVANCING * THE DICTIONARY POINTER. * HEAD FNUL,$,,COMA,DOCL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'054 * =,',' DAC LINK LINK SET TLNK COMA JST DOCL DAC HERE DAC STOR DAC ONE DAC ALOT DAC SMIS * * THIS SYSTEM DOES NOT USE 'C,' * * **** - **** * HEAD FNUL,-,SUB TLNK SET * VFD 1,0,1,FNUL,6,1,8,'055 * =,'-' DAC LINK LINK SET TLNK SUB EQU * LDA 2,1 SUB 1,1 JMP BINA * * **** = **** * HEAD FNUL,=,EQAL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'075 * =,'=' DAC LINK LINK SET TLNK EQAL EQU * LDA 2,1 ERA 1,1 SZE EQUAL? LDA =-1 NO: -1=>0 AOA YES: 0=>1 JMP BINA * * **** < **** * HEAD FNUL,<,LESS TLNK SET * VFD 1,0,1,FNUL,6,1,8,'074 * =,'<' DAC LINK LINK SET TLNK LESS EQU * LDA 2,1 CAS 1,1 JMP LES2 JMP LES2 LES1 LDA =1 JMP BINA LES2 CRA JMP BINA * * **** > **** * HEAD FNUL,>,GRTR TLNK SET * VFD 1,0,1,FNUL,6,1,8,'076 * =,'>' DAC LINK LINK SET TLNK GRTR EQU * LDA 2,1 CAS 1,1 JMP LES1 JMP LES2 JMP LES2 * * **** ROT **** ( N1 N2 N3 --- N2 N3 N1 ) * HEAD FNUL,ROT,ROT TLNK SET * VFD 1,0,1,FNUL,6,3,8,'322 * =,'R' VFD 8,'317,8,'124 ='OT' DAC LINK LINK SET TLNK ROT EQU * LDA 1,1 N3 IMA 2,1 STORE N3, GET N2 IMA 3,1 STORE N2, GET N1 JMP PUT * * **** SPACE **** TYPE ONE SPACE * HEAD FNUL,SPACE,SPCE,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'323 * =,'S' BCI 1,PA VFD 8,'303,8,'105 ='CE' DAC LINK LINK SET TLNK SPCE JST DOCL DAC BL DAC EMIT DAC SMIS * * **** -DUP **** ( N--- N (N) ) DUPLICATE ONLY IF NONZERO * HEAD FNUL,-DUP,DDUP TLNK SET * VFD 1,0,1,FNUL,6,4,8,'255 * =,'-' BCI 1,DU VFD 8,'120 ='P' DAC LINK LINK SET TLNK DDUP EQU * LDA 1,1 SZE JMP PUSH NEXT * * THIS SYSTEM DOES NOT NEED TRAVERSE, NFA AND PFA ARE OK * * **** LATEST **** * HEAD FNUL,LATEST,LTST,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'314 * =,'L' BCI 2,ATES VFD 8,'124 ='T' DAC LINK LINK SET TLNK LTST JST DOCL DAC CURR DAC AT DAC AT DAC SMIS * * THE NEXT 4 OPERATORS CAN DEPEND ON COMPUTER WORD SIZE. * THEY CONVERT ADDRESSES WITHIN THE NAME FIELDS OF FORTH * DICTIONARY ENTRIES. * * **** LFA **** (PFA --- LFA) GET LINK FIELD ADDRESS * HEAD FNUL,LFA,LFA,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'314 * =,'L' VFD 8,'306,8,'101 ='FA' DAC LINK LINK SET TLNK LFA JST DOCL DAC TWO DAC SUB DAC SMIS * * **** CFA **** (PFA --- CFA) GET CODE FIELD ADDRESS * HEAD FNUL,CFA,CFA,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'303 * =,'C' VFD 8,'306,8,'101 ='FA' DAC LINK LINK SET TLNK CFA JST DOCL DAC ONE DAC SUB DAC SMIS * * **** NFA **** (PFA --- NFA) GET NAME FIELD ADDRESS * HEAD FNUL,NFA,NFA,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'316 * =,'N' VFD 8,'306,8,'101 ='FA' DAC LINK LINK SET TLNK NFA JST DOCL DAC LFA NFA1 DAC ONE DAC SUB DECREMENT WORD POINTER DAC DUP DAC AT GET WORD DAC ZERO DAC GRTR LOOKING FOR POSITIVE WORD DAC ZBRA DAC NFA1 DAC SMIS * * **** PFA **** (NFA --- PFA) GET PARAMETER FIELD ADDRESS * HEAD FNUL,PFA,PFA,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'320 * =,'P' VFD 8,'306,8,'101 ='FA' DAC LINK LINK SET TLNK PFA JST DOCL DAC DUP DAC BYTE DAC CAT GET FIRST BYTE DAC LIT OCT 37 DAC AND LOWER 5 BITS DAC CELL CONVERT TO WORD ADDRESS (/ BY 2) DAC ONEP ADD ONE (ROUND UP) DAC PLUS ADD NFA DAC TWOP SKIP LINK AND CODE FIELDS DAC SMIS * * THE NEXT 7 OPERATIONS ARE USED BY THE COMPILER, FOR * COMPILE-TIME SYNTAX-ERROR CHECKS. * * **** !CSP **** * HEAD FNUL,!CSP,SCSP,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'241 * =,'!' BCI 1,CS VFD 8,'120 ='P' DAC LINK LINK SET TLNK SCSP JST DOCL DAC SPAT DAC CSP DAC STOR DAC SMIS * * **** ?ERROR **** * HEAD FNUL,?ERROR,QERR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'277 * =,'?' BCI 2,ERRO VFD 8,'122 ='R' DAC LINK LINK SET TLNK QERR JST DOCL DAC SWAP DAC ZBRA DAC QER1 DAC EROR DAC BRAN DAC QER2 QER1 DAC DROP QER2 DAC SMIS * * **** ?COMP **** * HEAD FNUL,?COMP,QCMP,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'277 * =,'?' BCI 1,CO VFD 8,'315,8,'120 ='MP' DAC LINK LINK SET TLNK QCMP JST DOCL DAC STAT DAC AT DAC ZEQU DAC LIT OCT 21 DAC QERR DAC SMIS * * **** ?EXEC **** * HEAD FNUL,?EXEC,QEXC,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'277 * =,'?' BCI 1,EX VFD 8,'305,8,'103 ='EC' DAC LINK LINK SET TLNK QEXC JST DOCL DAC STAT DAC AT DAC LIT OCT 22 DAC QERR DAC SMIS * * **** ?PAIRS **** * HEAD FNUL,?PAIRS,QPRS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'277 * =,'?' BCI 2,PAIR VFD 8,'123 ='S' DAC LINK LINK SET TLNK QPRS JST DOCL DAC SUB DAC LIT OCT 23 DAC QERR DAC SMIS * * **** ?CSP **** * HEAD FNUL,?CSP,QCSP,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'277 * =,'?' BCI 1,CS VFD 8,'120 ='P' DAC LINK LINK SET TLNK QCSP JST DOCL DAC SPAT DAC CSP DAC AT DAC SUB DAC LIT OCT 24 DAC QERR DAC SMIS * * **** ?LOADING **** * HEAD FNUL,?LOADING,QLDG,DOCL TLNK SET * VFD 1,0,1,FNUL,6,8,8,'277 * =,'?' BCI 3,LOADIN VFD 8,'107 ='G' DAC LINK LINK SET TLNK QLDG JST DOCL DAC BLK DAC AT DAC ZEQU DAC LIT OCT 26 DAC QERR DAC SMIS * * **** COMPILE **** * HEAD FNUL,COMPILE,COMP,DOCL TLNK SET * VFD 1,0,1,FNUL,6,7,8,'303 * =,'C' BCI 2,OMPI VFD 8,'314,8,'105 ='LE' DAC LINK LINK SET TLNK COMP JST DOCL DAC QCMP DAC FRMR DAC DUP DAC ONEP DAC TOR DAC AT DAC COMA DAC SMIS * * **** [ **** STOP COMPILATION, ENTER EXECUTION STATE. * HEAD FIMD,[,LBRC,DOCL TLNK SET * VFD 1,0,1,FIMD,6,1,8,'133 * =,'[' DAC LINK LINK SET TLNK LBRC JST DOCL DAC ZERO DAC STAT DAC STOR DAC SMIS * * **** ] **** ENTER COMPILATION STATE. * HEAD FNUL,],RBRC,DOCL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'135 * =,']' DAC LINK LINK SET TLNK RBRC JST DOCL DAC LIT OCT 100 NOT 300 BECAUSE MS BIT CLEAR ON H16 DAC STAT DAC STOR DAC SMIS * * **** SMUDGE **** ALTER LATEST WORD NAME (SO THAT DICTIONARY SEARCH * WON'T FIND A PARTIALLY-COMPLETE ENTRY). * HEAD FNUL,SMUDGE,SMDG,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'323 * =,'S' BCI 2,MUDG VFD 8,'105 ='E' DAC LINK LINK SET TLNK SMDG JST DOCL DAC LTST DAC LIT OCT 020000 DAC TOGL DAC SMIS * * **** HEX **** * HEAD FNUL,HEX,HEX,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'310 * =,'H' VFD 8,'305,8,'130 ='EX' DAC LINK LINK SET TLNK HEX JST DOCL DAC LIT DEC 16 DAC BASE DAC STOR DAC SMIS * * **** DECIMAL **** * HEAD FNUL,DECIMAL,DEC,DOCL TLNK SET * VFD 1,0,1,FNUL,6,7,8,'304 * =,'D' BCI 2,ECIM VFD 8,'301,8,'114 ='AL' DAC LINK LINK SET TLNK DEC JST DOCL DAC LIT DEC 10 DAC BASE DAC STOR DAC SMIS * * **** OCT **** * HEAD FNUL,OCT,OCT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'317 * =,'O' VFD 8,'303,8,'124 ='CT' DAC LINK LINK SET TLNK OCT JST DOCL DAC LIT DEC 8 DAC BASE DAC STOR DAC SMIS * * **** (;CODE) **** * HEAD FNUL,(;CODE),PSCD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,7,8,'250 * =,'(' BCI 2,;COD VFD 8,'305,8,'051 ='E)' DAC LINK LINK SET TLNK PSCD JST DOCL DAC FRMR SHOULD POINT AT JST INSTRUCTION DAC AT PICK UP THAT INSTRUCTION DAC LTST DAC PFA DAC CFA DAC STOR DAC SMIS * * ***** THE DEFINITION OF ';CODE' WAS MOVED TO THE END OF * THE DICTIONARY, BECAUSE IT IS NOT PURE CODE (IT IS PATCHED * WHEN A FORTH ASSEMBLER IS LOADED). * * * **** ,'<' BCI 2,BUIL VFD 8,'304,8,'123 ='DS' DAC LINK LINK SET TLNK BULD JST DOCL DAC ZERO DAC CON DAC SMIS * * **** DOES> **** * HEAD FNUL,DOES>,DOES,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'304 * =,'D' BCI 1,OE VFD 8,'323,8,'076 ='S>' DAC LINK LINK SET TLNK DOES JST DOCL DAC FRMR DAC LTST DAC PFA DAC STOR DAC PSCD JST DODS PICKED UP BY PSCD * * **** COUNT **** * ( ADDR --- CADDR+1 COUNT ) * HEAD FNUL,COUNT,CNT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'303 * =,'C' BCI 1,OU VFD 8,'316,8,'124 ='NT' DAC LINK LINK SET TLNK CNT JST DOCL DAC BYTE DAC DUP DAC ONEP DAC SWAP DAC CAT DAC SMIS * * **** TYPE **** * ( CADDR COUNT --- ) TYPE STRING OF CHARACTERS * HEAD FNUL,TYPE,TYPE,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'324 * =,'T' BCI 1,YP VFD 8,'105 ='E' DAC LINK LINK SET TLNK TYPE JST DOCL DAC DDUP DAC ZBRA DAC TYP2 DAC OVER DAC PLUS DAC SWAP DAC XDO TYP1 DAC I DAC CAT DAC EMIT DAC XLOP DAC TYP1 DAC BRAN DAC TYP3 TYP2 DAC DROP TYP3 DAC SMIS * * **** -TRAILING **** REDUCE CHARACTER COUNT OF STRING * TO OMIT TRAILING SPACES * ( CADDR COUNT2 --- CADDR COUNT2 ) * HEAD FNUL,-TRAILING,DTRA,DOCL TLNK SET * VFD 1,0,1,FNUL,6,9,8,'255 * =,'-' BCI 3,TRAILI VFD 8,'316,8,'107 ='NG' DAC LINK LINK SET TLNK DTRA JST DOCL DAC DUP DAC ZERO DAC XDO DTR1 DAC OVER DAC OVER DAC PLUS DAC ONE DAC SUB DAC CAT DAC BL DAC SUB DAC ZBRA DAC DTR2 DAC LEAV DAC BRAN DAC DTR3 DTR2 DAC ONE DAC SUB DTR3 DAC XLOP DAC DTR1 DAC SMIS * * **** (.") **** USED ONLY BY COMPILER. COMPILED BY '."' * HEAD FNUL,(."),PDTQ,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'250 * =,'(' BCI 1,." VFD 8,'051 =')' DAC LINK LINK SET TLNK PDTQ JST DOCL DAC R DAC CNT DAC DUP DAC CELL DAC ONEP DAC FRMR DAC PLUS DAC TOR DAC TYPE DAC SMIS * * **** ." **** TYPE ASCII MESSAGE. * HEAD FIMD,.",DOTQ,DOCL TLNK SET * VFD 1,0,1,FIMD,6,2,8,'256 * =,'.' VFD 8,'042 ='"' DAC LINK LINK SET TLNK DOTQ JST DOCL DAC LIT VFD 16,CDQT DAC STAT DAC AT DAC ZBRA DAC DTQ1 DAC COMP DAC PDTQ DAC WORD DAC HERE DAC BYTE DAC CAT DAC CELL DAC ONEP DAC ALOT DAC BRAN DAC DTQ2 DTQ1 DAC WORD DAC HERE DAC CNT DAC TYPE DTQ2 DAC SMIS * * **** EXPECT **** READ N CHARACTERS TO MEMORY * (AND TERMINATE WITH NULLS). * ( ADDR N --- ) WORD ADDRESS! * HEAD FNUL,EXPECT,EXPC,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'305 * =,'E' BCI 2,XPEC VFD 8,'124 ='T' DAC LINK LINK SET TLNK EXPC JST DOCL DAC SWAP DAC BYTE DAC SWAP DAC OVER DAC PLUS DAC OVER DAC XDO EXP1 EQU * IFN PTW DAC BLK DAC AT DAC ZLES -VE INDICATES PAPERTAPE DAC ZBRA DAC EXP2 DAC PTRK DAC BRAN DAC EXP3 ENDC EXP2 DAC KEY EXP3 DAC DUP DAC LIT VFD 16,CDEL DAC EQAL DAC ZBRA DAC EXP4 DAC DROP DAC LIT VFD 16,CBS DAC OVER DAC I DAC EQAL DAC DUP DAC FRMR DAC TWO DAC SUB DAC PLUS DAC TOR DAC SUB DAC BRAN DAC EXP7 EXP4 DAC DUP DAC LIT VFD 16,CCR DAC EQAL DAC ZBRA DAC EXP5 DAC LEAV DAC DROP DAC BL DAC ZERO DAC BRAN DAC EXP6 EXP5 DAC DUP EXP6 DAC I DAC CSTR DAC ZERO DAC I DAC ONEP DAC CSTR DAC ZERO DAC I DAC TWOP DAC CSTR IFZ ECHO EXP7 DAC DROP ELSE IFN PTW EXP7 DAC BLK DAC AT DAC ZEQU ASR? DAC ZBRA DAC EXP8 DAC EMIT DAC BRAN DAC EXP9 EXP8 DAC DROP EXP9 EQU * ELSE EXP7 DAC EMIT ENDC ENDC DAC XLOP DAC EXP1 DAC DROP DAC SMIS * * **** QUERY **** * HEAD FNUL,QUERY,QURY,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'321 * =,'Q' BCI 1,UE VFD 8,'322,8,'131 ='RY' DAC LINK LINK SET TLNK QURY JST DOCL DAC TIB DAC AT DAC LIT OCT 120 DAC EXPC DAC ZERO DAC IN DAC STOR DAC SMIS * * **** THE NULL **** TLNK SET * VFD 1,0,1,FIMD,6,1,1,0,7,0 * =,NULL DAC LINK LINK SET TLNK NULL JST DOCL * THE NULL OPERATION (ASCII 0) STOPS INTERPRETATION/COMPILATION * AT END OF A TERMINAL INPUT LINE, OR A DISK SCREEN. ALL DISK * BUFFERS MUST TERMINATE WITH NULLS, AND 'EXPECT' PLACES NULLS * AFTER EACH TERMINAL INPUT LINE. DAC BLK DAC AT IFN PTW DAC ONEP -1 -> 0, 0 -> 1 DAC LIT OCT 177776 DAC AND ASR OR PTR -> ZERO ENDC DAC ZBRA DAC NUL2 DAC ONE DAC BLK DAC PSTR DAC ZERO DAC IN DAC STOR DAC BLK DAC AT DAC BSCR DAC MOD DAC ZEQU DAC ZBRA DAC NUL1 DAC QEXC DAC FRMR RETURN FROM INTERPRET DAC DROP NUL1 DAC BRAN DAC NUL3 NUL2 DAC FRMR RETURN FROM INTERPRET DAC DROP NUL3 DAC SMIS * * **** FILL **** FILL WORDS * ( ADDR COUNT PATTERN --- ) * HEAD FNUL,FILL,FILL,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'306 * =,'F' BCI 1,IL VFD 8,'114 ='L' DAC LINK LINK SET TLNK FILL JST DOCL DAC SWAP DAC TOR DAC OVER DAC STOR DAC DUP DAC ONEP DAC FRMR DAC ONE DAC SUB DAC MOVE DAC SMIS * * **** ERASE **** ERASE WORDS * ( ADDR COUNT --- ) * HEAD FNUL,ERASE,ERAS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'305 * =,'E' BCI 1,RA VFD 8,'323,8,'105 ='SE' DAC LINK LINK SET TLNK ERAS JST DOCL DAC ZERO DAC FILL DAC SMIS * * **** BLANKS **** FILL WORDS WITH SPACE CHARACTERS * ( ADDR COUNT --- ) * HEAD FNUL,BLANKS,BLKS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'302 * =,'B' BCI 2,LANK VFD 8,'123 ='S' DAC LINK LINK SET TLNK BLKS JST DOCL DAC BL DAC DUP DAC LIT DEC 256 DAC USTR SHIFT TO UPPER BYTE DAC OR OR IN LOWER BYTE DAC FILL DAC SMIS * * **** HOLD **** * HEAD FNUL,HOLD,HOLD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'310 * =,'H' BCI 1,OL VFD 8,'104 ='D' DAC LINK LINK SET TLNK HOLD JST DOCL DAC LIT DEC -1 DAC HLD DAC PSTR DAC HLD DAC AT DAC CSTR DAC SMIS * * **** PAD **** * HEAD FNUL,PAD,PAD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'320 * =,'P' VFD 8,'301,8,'104 ='AD' DAC LINK LINK SET TLNK PAD JST DOCL DAC HERE DAC LIT VFD 16,KPAD DAC PLUS DAC SMIS * * **** WORD **** READ NEXT WORD FROM INPUT STREAM USING CHAR * AS DELIMITER * ( CHAR --- ) * HEAD FNUL,WORD,WORD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'327 * =,'W' BCI 1,OR VFD 8,'104 ='D' DAC LINK LINK SET TLNK WORD JST DOCL DAC BLK DISK BLOCK DAC AT IFN PTW DAC ONEP -1 -> 0, 0 -> 1 DAC LIT OCT 177776 DAC AND ASR OR PTR -> ZERO ENDC DAC ZBRA ZERO IS TERMINAL DAC WRD1 IFN DISK DAC BLK DAC AT DAC BLCK DAC BRAN DAC WRD2 ELSE DAC ONE TRUE - ALWAYS DAC LIT OCT 6 DISK RANGE DAC EROR ENDC WRD1 DAC TIB DAC AT WRD2 DAC BYTE DAC IN OFFSET IN INPUT BUFFER DAC AT DAC PLUS ADD TO BASE ADDRESS DAC SWAP DAC ENCL DAC HERE DAC LIT DEC 17 34 BYTES DAC ERAS DAC IN DAC PSTR DAC OVER DAC SUB DAC TOR DAC R DAC HERE DAC BYTE DAC CSTR DAC PLUS DAC HERE DAC BYTE DAC ONEP DAC FRMR DAC CMOV DAC SMIS * * **** (NUMBER) **** * ( D1 CADDR1 --- D2 CADDR2 ) * HEAD FNUL,(NUMBER),PNUM,DOCL TLNK SET * VFD 1,0,1,FNUL,6,8,8,'250 * =,'(' BCI 3,NUMBER VFD 8,'051 =')' DAC LINK LINK SET TLNK PNUM JST DOCL PNM1 DAC ONEP DAC DUP DAC TOR DAC CAT DAC BASE DAC AT DAC DIGT DAC ZBRA DAC PNM3 DAC SWAP DAC BASE DAC AT DAC USTR DAC DROP DAC ROT DAC BASE DAC AT DAC USTR DAC DPLS DAC DPL DAC AT DAC ONEP DAC ZBRA DAC PNM2 DAC ONE DAC DPL DAC PSTR PNM2 DAC FRMR DAC BRAN DAC PNM1 PNM3 DAC FRMR DAC SMIS * * **** NUMBER **** * ( CADDR --- D ) * HEAD FNUL,NUMBER,NUMB,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'316 * =,'N' BCI 2,UMBE VFD 8,'122 ='R' DAC LINK LINK SET TLNK NUMB JST DOCL DAC ZERO DAC ZERO DAC ROT DAC DUP DAC ONEP DAC CAT DAC LIT VFD 16,CMNS DAC EQAL DAC DUP DAC TOR DAC PLUS DAC LIT DAC -1 NUM1 DAC DPL DAC STOR DAC PNUM DAC DUP DAC CAT DAC ZBRA DAC NUM2 DAC DUP DAC CAT DAC LIT VFD 16,CDOT DAC SUB DAC ZERO DAC QERR DAC ZERO DAC BRAN DAC NUM1 NUM2 DAC DROP DAC FRMR DAC ZBRA DAC NUM3 DAC DMNS NUM3 DAC SMIS * * **** -FIND **** * ( --- PFA B TF ) (FOUND) * ( --- FF ) (NOT FOUND) * * ACCEPTS THE NEXT TEXT WORD (DELIMITED BY BLANKS) IN THE * INPUT STREAM TO HERE, AND SEARCHES THE CONTEXT AND THEN * CURRENT VOCABULARIES FOR A MATCHING ENTRY. IF FOUND, THE * DICTIONARY ENTRY'S PARAMETER FIELD ADDRESS, ITS LENGTH * BYTE, AND A BOOLEAN TRUE IS LEFT. OTHERWISE, ONLY A * BOOLEAN FALSE IS LEFT. * * HEAD FNUL,-FIND,DFND,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'255 * =,'-' BCI 1,FI VFD 8,'316,8,'104 ='ND' DAC LINK LINK SET TLNK DFND JST DOCL DAC BL DAC WORD DAC HERE DAC CNT DAC UPPR DAC HERE DAC CONT DAC AT DAC AT DAC PFND DAC DUP DAC ZEQU DAC ZBRA DAC DFN1 DAC DROP DAC HERE DAC LTST DAC PFND DFN1 DAC SMIS * * **** UPPER **** SETS STRINGS TO UPPER CASE - TO ALLOW * LOWER AS WELL AS UPPER CASE FROM TERMINAL. * ( COUNT CADDR --- ) * HEAD FNUL,UPPER,UPPR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'325 * =,'U' BCI 1,PP VFD 8,'305,8,'122 ='ER' DAC LINK LINK SET TLNK UPPR JST DOCL DAC OVER DAC PLUS DAC SWAP DAC XDO UPR1 DAC I DAC CAT DAC LIT OCT 340 =LOWERCASE-A-1 DAC GRTR DAC I DAC CAT DAC LIT OCT 373 =LOWERCASE-Z+1 DAC LESS DAC AND DAC ZBRA DAC UPR2 DAC I DAC CAT DAC LIT OCT 40 DAC XOR DAC I DAC CSTR UPR2 DAC XLOP DAC UPR1 DAC SMIS * * **** (ABORT) **** * HEAD FNUL,(ABORT),PABT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,7,8,'250 * =,'(' BCI 2,ABOR VFD 8,'324,8,'051 ='T)' DAC LINK LINK SET TLNK PABT JST DOCL DAC ABRT DAC SMIS * * **** ERROR **** * HEAD FNUL,ERROR,EROR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'305 * =,'E' BCI 1,RR VFD 8,'317,8,'122 ='OR' DAC LINK LINK SET TLNK EROR JST DOCL DAC WARN DAC AT DAC ZLES DAC ZBRA DAC ERR1 DAC PABT ERR1 DAC HERE DAC CNT DAC TYPE DAC PDTQ * STRG $ ?$ VFD 8,3,8,'240 =3,' ' VFD 8,'277,8,'240 ='? ' DAC MESS DAC SPST DAC IN DAC AT DAC BLK DAC AT DAC QUIT DAC SMIS * * **** ID. **** * HEAD FNUL,ID.,IDDT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'311 * =,'I' VFD 8,'304,8,'056 ='D.' DAC LINK LINK SET TLNK IDDT JST DOCL DAC PAD DAC LIT OCT 20 SINCE WORDS - THATS 32 CHARACTERS DAC LIT VFD 8,337,8,337 TWO UNDERSCORES DAC FILL DAC DUP DAC PFA DAC LFA DAC OVER DAC SUB DAC PAD DAC SWAP DAC MOVE DAC PAD DAC CNT DAC LIT OCT 37 DAC AND DAC TYPE DAC SPCE DAC SMIS * * **** CREATE **** * MODIFIED TO PUT HLT (FOR NOW) AT CFA * HEAD FNUL,CREATE,CRAT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'303 * =,'C' BCI 2,REAT VFD 8,'105 ='E' DAC LINK LINK SET TLNK CRAT JST DOCL DAC DFND DAC ZBRA DAC CRT1 DAC DROP DAC NFA DAC IDDT DAC LIT DEC 4 DAC MESS DAC SPCE CRT1 DAC HERE DAC DUP ( HERE HERE ) DAC DUP ( HERE HERE HERE ) DAC BYTE ( HERE HERE C-HERE ) DAC CAT ( HERE HERE FIRST-BYTE ) DAC WDTH DAC AT DAC MIN DAC CELL DAC ONEP ( HERE HERE WORDS-REQUD ) DAC DUP ( HERE HERE WORDS-REQUD WORDS-REQUD ) DAC ALOT ( HERE HERE WORDS-REQUD ) DAC SWAP ( HERE WORDS-REQUD HERE ) DAC DUP ( HERE WORDS-REQUD HERE HERE ) DAC LIT OCT 020000 SET SMUDGE BIT, LEAVE TOP CLEAR DAC TOGL ( HERE WORDS-REQUD HERE ) * DAC PLUS ( HERE LFA ) DAC ONE ( HERE LFA ONE ) DAC SUB ( HERE LFA-1 ) DAC DUP ( HERE LFA-1 LFA-1 ) DAC AT DAC LIT OCT 177577 CLEAR TOP BIT DAC AND DAC SWAP DAC STOR ( HERE ) * DAC LTST DAC COMA DAC CURR DAC AT DAC STOR LINK FIELD DAC ZERO HLT INSTRUCTION DAC COMA DAC SMIS * * **** [COMPILE] **** * HEAD FIMD,[COMPILE],BCMP,DOCL TLNK SET * VFD 1,0,1,FIMD,6,9,8,'333 * =,'[' BCI 3,COMPIL VFD 8,'305,8,'135 ='E]' DAC LINK LINK SET TLNK BCMP JST DOCL DAC DFND DAC ZEQU DAC ZERO DAC QERR DAC DROP DAC CFA DAC COMA DAC SMIS * * **** LITERAL **** * HEAD FIMD,LITERAL,LTRL,DOCL TLNK SET * VFD 1,0,1,FIMD,6,7,8,'314 * =,'L' BCI 2,ITER VFD 8,'301,8,'114 ='AL' DAC LINK LINK SET TLNK LTRL JST DOCL DAC STAT DAC AT DAC ZBRA DAC LIT1 DAC COMP DAC LIT DAC COMA LIT1 DAC SMIS * * **** DLITERAL **** * HEAD FIMD,DLITERAL,DLIT,DOCL TLNK SET * VFD 1,0,1,FIMD,6,8,8,'304 * =,'D' BCI 3,LITERA VFD 8,'114 ='L' DAC LINK LINK SET TLNK DLIT JST DOCL DAC STAT DAC AT DAC ZBRA DAC DLT1 DAC SWAP DAC LTRL DAC LTRL DLT1 DAC SMIS * * **** U< **** UNSIGNED LESS-THAN, NEEDED FOR '?STACK' * : U< >R 0 R> 0 DMINUS D+ SWAP DROP 0< ; * HEAD FNUL,U<,ULES,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'325 * =,'U' VFD 8,'074 ='<' DAC LINK LINK SET TLNK ULES JST DOCL DAC TOR DAC ZERO DAC FRMR DAC ZERO DAC DMNS DAC DPLS DAC SWAP DAC DROP DAC ZLES DAC SMIS * * **** ?STACK **** ERROR CHECK. * HEAD FNUL,?STACK,QSTK,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'277 * =,'?' BCI 2,STAC VFD 8,'113 ='K' DAC LINK LINK SET TLNK QSTK JST DOCL DAC SZRO DAC AT DAC SPAT DAC ONEP DAC ULES DAC ONE DAC QERR DAC SPAT DAC HERE DAC LIT OCT 100 DAC PLUS DAC ULES DAC TWO DAC QERR DAC SMIS * * **** INTERPRET **** * HEAD FNUL,INTERPRET,ITRP,DOCL TLNK SET * VFD 1,0,1,FNUL,6,9,8,'311 * =,'I' BCI 3,NTERPR VFD 8,'305,8,'124 ='ET' DAC LINK LINK SET TLNK ITRP JST DOCL ITR1 DAC DFND FIND NEXT WORD DAC ZBRA FOUND? DAC ITR4 NO DAC STAT COMPARE STATE TO LENGTH BYTE DAC AT DAC LESS DAC ZBRA DAC ITR2 DAC CFA DAC COMA DAC BRAN DAC ITR3 ITR2 DAC CFA DAC EXEC ITR3 DAC QSTK DAC BRAN DAC ITR7 ITR4 DAC HERE DAC BYTE DAC NUMB DAC DPL DAC AT DAC ONEP DAC ZBRA DAC ITR5 DAC DLIT DAC BRAN DAC ITR6 ITR5 DAC DROP DAC LTRL ITR6 DAC QSTK ITR7 DAC BRAN DAC ITR1 * * **** IMMEDIATE **** * HEAD FNUL,IMMEDIATE,IMMD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,9,8,'311 * =,'I' BCI 3,MMEDIA VFD 8,'324,8,'105 ='TE' DAC LINK LINK SET TLNK IMMD JST DOCL DAC LTST DAC LIT OCT 040000 DAC TOGL DAC SMIS * * **** VOCABULARY **** * HEAD FNUL,VOCABULARY,VCAB,DOCL TLNK SET * VFD 1,0,1,FNUL,6,10,8,'326 * =,'V' BCI 4,OCABULAR VFD 8,'131 ='Y' DAC LINK LINK SET TLNK VCAB JST DOCL DAC BULD DAC LIT OCT 120201 DAC COMA DAC CURR DAC AT DAC CFA DAC COMA DAC HERE DAC VOCL DAC AT DAC COMA DAC VOCL DAC STOR DAC DOES DOVC DAC TWOP DAC CONT DAC STOR DAC SMIS * * ***** THE DEFINITION OF 'FORTH' WAS MOVED TO NEAR THE END OF THE * DICTIONARY, BECAUSE IT IS NOT PURE CODE. * * * **** DEFINITIONS **** * HEAD FNUL,DEFINITIONS,DFNS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,11,8,'304 * =,'D' BCI 4,EFINITIO VFD 8,'316,8,'123 ='NS' DAC LINK LINK SET TLNK DFNS JST DOCL DAC CONT DAC AT DAC CURR DAC STOR DAC SMIS * * **** ( **** * HEAD FIMD,(,PARN,DOCL TLNK SET * VFD 1,0,1,FIMD,6,1,8,'050 * =,'(' DAC LINK LINK SET TLNK PARN JST DOCL DAC LIT VFD 16,CRPR =')' DAC WORD DAC SMIS * * **** QUIT **** * HEAD FNUL,QUIT,QUIT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'321 * =,'Q' BCI 1,UI VFD 8,'124 ='T' DAC LINK LINK SET TLNK QUIT JST DOCL DAC ZERO DAC BLK DAC STOR DAC LBRC QUT1 DAC RPST DAC CR QUT2 DAC QURY DAC ITRP IFN PTW DAC BLK DAC AT DAC ONEP PAPERTAPE? DAC ZBRA YES - LOOP DAC QUT2 ENDC DAC STAT DAC AT DAC ZEQU DAC ZBRA DAC QUT3 DAC PDTQ * STRG $ OK VFD 8,3,8,'240 =3,' ' VFD 8,'317,8,'313 ='OK' QUT3 DAC BRAN DAC QUT1 * * **** ABORT **** * HEAD FNUL,ABORT,ABRT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'301 * =,'A' BCI 1,BO VFD 8,'322,8,'124 ='RT' DAC LINK LINK SET TLNK ABRT JST DOCL DAC SPST DAC DEC DAC SPCE DAC CR DAC PDTQ * STRG FIG-FORTH V 0.9$ VFD 8,17,8,'306 =17,'F' BCI 7,IG-FORTH V 0. VFD 8,'271,8,'240 ='9 ' IFN HSA DAC PDTQ * STRG HSA$ VFD 8,4,8,'310 =4,'H' BCI 1,SA VFD 8,'240 =' ' ENDC IFN XTND DAC PDTQ * STRG EXA$ VFD 8,4,8,'305 =4,'E' BCI 1,XA VFD 8,'240 =' ' ENDC IFZ DISK DAC PDTQ * STRG NO- VFD 8,3,8,'316 =3,'N' VFD 8,'317,8,'255 ='O-' ENDC DAC PDTQ * STRG DISK$ VFD 8,5,8,'304 =5,'D' BCI 1,IS VFD 8,'313,8,'240 ='K ' * DAC SZRO DAC AT DAC HERE DAC SUB DAC LIT OCT 100 DAC SUB DAC UDOT DAC PDTQ * STRG WORDS FREE VFD 8,10,8,'327 =10,'W' BCI 4,ORDS FRE VFD 8,'305 ='E' * DAC FRTH DAC DFNS DAC QUIT * * COLD START * * THE ACTUAL CODE IS DOWN NEAR ORGN AT '1000 * CLOSE TO THE ENTRY POINT * * **** COLD **** * HEAD FNUL,COLD,COLD TLNK SET * VFD 1,0,1,FNUL,6,4,8,'303 * =,'C' BCI 1,OL VFD 8,'104 ='D' DAC LINK LINK SET TLNK COLD EQU * JMP CENT * * **** S->D **** * HEAD FNUL,S->D,STOD TLNK SET * VFD 1,0,1,FNUL,6,4,8,'323 * =,'S' BCI 1,-> VFD 8,'104 ='D' DAC LINK LINK SET TLNK STOD EQU * LDA 1,1 CSA COPY SIGN TO CARRY CRA SSC NEGATIVE? JMP PUSH NO - PUSH ZERO LDA =-1 JMP PUSH YES - SIGN EXTEND * * NOTE - THIS SYSTEM DOESN'T NEED THE OPERATIONS '+-' AND 'D+-', * BECAUSE 'M*' AND 'M/' ARE DEFINED IN CODE. * * **** ABS **** * HEAD FNUL,ABS,ABS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'301 * =,'A' VFD 8,'302,8,'123 ='BS' DAC LINK LINK SET TLNK ABS JST DOCL DAC DUP DAC ZLES DAC ZBRA DAC ABS1 DAC MINS ABS1 DAC SMIS * * **** DABS **** * HEAD FNUL,DABS,DABS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'304 * =,'D' BCI 1,AB VFD 8,'123 ='S' DAC LINK LINK SET TLNK DABS JST DOCL DAC DUP DAC ZLES DAC ZBRA DAC DAB1 DAC DMNS DAB1 DAC SMIS * * **** MIN **** * HEAD FNUL,MIN,MIN,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'315 * =,'M' VFD 8,'311,8,'116 ='IN' DAC LINK LINK SET TLNK MIN JST DOCL DAC OVER DAC OVER DAC GRTR DAC ZBRA DAC MIN1 DAC SWAP MIN1 DAC DROP DAC SMIS * * **** MAX **** * HEAD FNUL,MAX,MAX,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'315 * =,'M' VFD 8,'301,8,'130 ='AX' DAC LINK LINK SET TLNK MAX JST DOCL DAC OVER DAC OVER DAC LESS DAC ZBRA DAC MAX1 DAC SWAP MAX1 DAC DROP DAC SMIS * * **** M* **** * HEAD FNUL,M*,MSTR TLNK SET * VFD 1,0,1,FNUL,6,2,8,'315 * =,'M' VFD 8,'052 ='*' DAC LINK LINK SET TLNK MSTR EQU * IFZ HSA * SOFTWARE SIGNED MULTIPLY LDA =-1 STA T3 ASSUME -VE MULTIPLIER, SIGN EXTENSION CRA IAB CLEAR B LDA 2,1 MULTIPLICAND LGL 1 TOP BIT TO CARRY STA 2,1 MULTIPLICAND LDA =-15 COUNTER STA T1 SSC WAS TOP BIT SET? JMP MST2 NO - DON'T SUBTRACT MUTIPLIER * YES - THIS BIT WORTH -2^15 LDA 1,1 GET MULTIPLIER CAS ='100000 IS IT MIN INT. VALUE? SKP JMP MST1 SO NEGATED IS +2^15 TCA NEGATE SMI NEGATIVE RESULT? JMP MST1 NO, B = 0 ALREADY * NEGATED MULTIPLIER IS -VE SO ORIGINAL IS +VE IAB NO - PRESERVE A CRA STA T3 SIGN EXTENSION LDA =-1 SET B TO -1 IAB MST1 IAB SWAP ACCUM. WORDS TO RIGHT PLACE JMP UST1 JUMP INTO UNSIGNED ROUTINE FOR 15 BITS * * TOP BIT OF MULTIPLICAND CLEAR, SO ACCUMULATOR * STARTS AT ZERO, BUT NEED TO SORT SIGN EXTEND * OF MULTIPLIER MST2 LDA 1,1 GET MULTIPLIER CSA SIGN TO CARRY CRA SSC POSITIVE? STA T3 YES - CLEAR SIGN EXTENSION JMP MST1 OFF TO UNSIGNED ROUTINE EJCT ELSE * HARDWARE SIGNED MULTIPLY LDA 2,1 MPY 1,1 RESULT IN 16-0-15 FORMAT * IT WOULD REALY HAVE HELPED IF OVERFLOW * WENT TO C, BUT IT DOESN'T CAS ='100000 OVERFLOW? SKP NO JMP MST1 YES IAB STA 2,1 SAVE LOWER 15 BITS CRA CLEAR B IAB LRS 1 FORM CORRECT MS WORD STA 1,1 IAB GET BACK 2^15 BIT FROM B2 LGL 1 PUT INTO A1 ERA 2,1 OR IN LOWER 15 BITS STA 2,1 NEXT * OVERFLOW * -2^15 * -2^15 => -2^30, SHOULD BE +2^30 MST1 LDA ='040000 STA 1,1 CRA STA 2,1 NEXT ENDC EJCT * * **** M/ **** * HEAD FNUL,M/,MSLA TLNK SET * VFD 1,0,1,FNUL,6,2,8,'315 * =,'M' VFD 8,'057 ='/' DAC LINK LINK SET TLNK MSLA EQU * IFZ HSA JST SSDV NEXT ELSE LDA 2,1 MS WORD OF DIVIDEND ALS 1 SHIFT UP ONE BIT SRC OVERFLOW? JMP DVS2 YES, DO SOFTWARE DIVIDE IAB LDA 3,1 LS WORD OF DIVIDEND CSA TOP BIT TO CARRY IAB ACA 2^15 BIT INTO A, LSB * * AT THIS POINT KNOW THAT WE HAVE A * A VALID 31-BIT DIVIDEND, SO CAN USE H/W INSTRUCTION DIV 1,1 IRS 0 DISCARD DIVISOR SRC OVERFLOW? JMP DVS1 STA 1,1 QUOTIENT IAB STA 2,1 REMAINDER NEXT DVS1 CRA STA 1,1 QUOTIENT STA 2,1 REMAINDER NEXT * DVS2 JST SSDV NEXT EJCT ENDC * SOFTWARE SIGNED DIVIDE SSDV DAC ** LDA 2,1 MS WORD OF DIVIDEND STA T4 SMI NEGATIVE? JMP SSD1 LDA 3,1 LS WORD OF DIVIDEND TCA NEGATE STA 3,1 RCB ERA ='100000 MIN. INT VALUE? SNZ NO SCB YES - SET CARRY LDA 2,1 MS WORD OF DIVIDEND ERA =-1 COMPLEMENT ACA ADD ANY CARRY IN STA 2,1 SSD1 LDA 1,1 DIVISOR STA T5 SPL NEGATIVE? TCA YES - NEGATE STA 1,1 JST DIVU UNSIGNED DIVIDE LDA T4 ORIGINAL SIGN OF DIVIDEND SMI JMP SSD2 LDA 2,1 REMAINDER TCA STA 2,1 SSD2 LDA T4 ORIGINAL SIGN OF DIVIDEND ERA T5 ORIGINAL SIGN OF DIVISOR SMI JMP* SSDV LDA 1,1 QUOTIENT TCA STA 1,1 JMP* SSDV EJCT * * **** * **** * HEAD FNUL,*,STAR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'052 * =,'*' DAC LINK LINK SET TLNK STAR JST DOCL DAC MSTR DAC DROP DAC SMIS * * **** /MOD **** * HEAD FNUL,/MOD,SLMD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'257 * =,'/' BCI 1,MO VFD 8,'104 ='D' DAC LINK LINK SET TLNK SLMD JST DOCL DAC TOR DAC STOD DAC FRMR DAC MSLA DAC SMIS * * **** / **** * HEAD FNUL,/,SLSH,DOCL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'057 * =,'/' DAC LINK LINK SET TLNK SLSH JST DOCL DAC SLMD DAC SWAP DAC DROP DAC SMIS * * **** MOD **** * HEAD FNUL,MOD,MOD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'315 * =,'M' VFD 8,'317,8,'104 ='OD' DAC LINK LINK SET TLNK MOD JST DOCL DAC SLMD DAC DROP DAC SMIS * * **** */MOD **** * HEAD FNUL,*/MOD,SSMD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'252 * =,'*' BCI 1,/M VFD 8,'317,8,'104 ='OD' DAC LINK LINK SET TLNK SSMD JST DOCL DAC TOR DAC MSTR DAC FRMR DAC MSLA DAC SMIS * * **** */ **** * HEAD FNUL,*/,SSLA,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'252 * =,'*' VFD 8,'057 ='/' DAC LINK LINK SET TLNK SSLA JST DOCL DAC SSMD DAC SWAP DAC DROP DAC SMIS * * **** M/MOD **** * HEAD FNUL,M/MOD,MSMD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'315 * =,'M' BCI 1,/M VFD 8,'317,8,'104 ='OD' DAC LINK LINK SET TLNK MSMD JST DOCL DAC TOR DAC ZERO DAC R DAC USLA DAC FRMR DAC SWAP DAC TOR DAC USLA DAC FRMR DAC SMIS EJCT IFN PTW ****************************************************************** * * PAPERTAPE I/O * ****************************************************************** * * **** PTR **** * TAKE SUBSEQUENT INPUT FROM PAPERTAPE READER * HEAD FNUL,PTR,PTR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'320 * =,'P' VFD 8,'324,8,'122 ='TR' DAC LINK LINK SET TLNK PTR JST DOCL DAC LIT DEC -1 DAC BLK DAC STOR DAC SMIS * * **** PTRK **** * GET A CHARACTER FROM PAPERTAPE * HEAD FNUL,PTRK,PTRK,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'320 * =,'P' BCI 1,TR VFD 8,'113 ='K' DAC LINK LINK SET TLNK PTRK JST DOCL PTK1 DAC PTRC DAC DUP DAC ZBRA DISCARD NULLS DAC PTK2 DAC DUP DAC LIT VFD 16,CLF DAC EQAL LINE FEED? DAC ZBRA NO - RETAIN DAC PTK3 ELSE FALL THROUGH AND DISCARD * PTK2 DAC DROP DAC BRAN DAC PTK1 * PTK3 DAC DUP DAC LIT VFD 16,CEOT END OF TAPE? DAC EQAL DAC ZBRA NO DAC PTK4 * DAC DROP DAC ZERO DAC BLK DAC STOR DAC LIT VFD 16,CCR REPLACE EOT WITH CR * PTK4 DAC SMIS ENDC EJCT IFN DISK ****************************************************************** * * DISK I/O (SECTION COMMON TO ALL OPERATING SYSTEMS) * NOTE THAT EACH OPERATING SYSTEM DEFINED 'R/W' - READ * OR WRITE A 1024-BYTE RANDOM-ACCESS BLOCK. * ****************************************************************** * * **** +BUF **** * HEAD FNUL,+BUF,PBUF,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'253 * =,'+' BCI 1,BU VFD 8,'106 ='F' DAC LINK LINK SET TLNK PBUF JST DOCL DAC BBUF DAC LIT OCT 4 DAC PLUS DAC PLUS DAC DUP DAC LIMT DAC AT DAC EQAL DAC ZBRA DAC PBF1 DAC DROP DAC FRST DAC AT PBF1 DAC DUP DAC PREV DAC AT DAC SUB DAC SMIS * * **** UPDATE **** * HEAD FNUL,UPDATE,UPDT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'325 * =,'U' BCI 2,PDAT VFD 8,'105 ='E' DAC LINK LINK SET TLNK UPDT JST DOCL DAC PREV DAC AT DAC AT DAC LIT OCT 100000 DAC OR DAC PREV DAC AT DAC STOR DAC SMIS * * **** EMPTY-BUFFERS **** * HEAD FNUL,EMPTY-BUFFERS,MTBF,DOCL TLNK SET * VFD 1,0,1,FNUL,6,13,8,'305 * =,'E' BCI 5,MPTY-BUFFE VFD 8,'322,8,'123 ='RS' DAC LINK LINK SET TLNK MTBF JST DOCL DAC FRST DAC AT DAC LIMT DAC AT DAC OVER DAC SUB DAC ERAS DAC SMIS * * **** FLUSH **** * SOME SYSTEMS DEFINE THIS IN THE EDITOR, NOT HERE. * HEAD FNUL,FLUSH,FLSH,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'306 * =,'F' BCI 1,LU VFD 8,'323,8,'110 ='SH' DAC LINK LINK SET TLNK FLSH JST DOCL DAC LIMT DAC AT DAC FRST DAC AT DAC XDO FLS1 DAC I DAC AT DAC ZLES DAC ZBRA DAC FLS2 DAC I DAC TWOP DAC I DAC AT DAC LIT OCT 77777 DAC AND DAC ZERO DAC RW FLS2 DAC BBUF DAC LIT OCT 4 DAC PLUS DAC XPLO DAC FLS1 DAC MTBF DAC SMIS * * **** DR0 **** * SELECT DRIVE #0 * HEAD FNUL,DR0,DR0,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'304 * =,'D' VFD 8,'322,8,'060 ='R0' DAC LINK LINK SET TLNK DR0 JST DOCL DAC ZERO DAC OFST DAC STOR DAC SMIS * * **** DR1 **** * SELECT DRIVE #1 * HEAD FNUL,DR1,DR1,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'304 * =,'D' VFD 8,'322,8,'061 ='R1' DAC LINK LINK SET TLNK DR1 JST DOCL DAC LIT DEC 240 DAC OFST DAC STOR DAC SMIS * * **** BUFFER **** * HEAD FNUL,BUFFER,BUFR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'302 * =,'B' BCI 2,UFFE VFD 8,'122 ='R' DAC LINK LINK SET TLNK BUFR JST DOCL DAC USE DAC AT DAC DUP DAC TOR BUF1 DAC PBUF DAC ZBRA DAC BUF1 DAC USE DAC STOR DAC R DAC AT DAC ZLES DAC ZBRA DAC BUF2 DAC R DAC TWOP DAC R DAC AT DAC LIT OCT 77777 DAC AND DAC ZERO DAC RW BUF2 DAC R DAC STOR DAC R DAC PREV DAC STOR DAC FRMR DAC TWOP DAC SMIS * * **** BLOCK **** * HEAD FNUL,BLOCK,BLCK,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'302 * =,'B' BCI 1,LO VFD 8,'303,8,'113 ='CK' DAC LINK LINK SET TLNK BLCK JST DOCL * CHANGED TO MASK OFF THE UPDATE BIT WHEN COMPARING DAC OFST DAC AT DAC PLUS DAC TOR DAC PREV DAC AT DAC DUP DAC AT DAC LIT OCT 077777 DAC AND DAC R DAC SUB DAC ZBRA DAC BLK3 BLK1 DAC PBUF DAC ZEQU DAC ZBRA DAC BLK2 DAC DROP DAC R DAC BUFR DAC DUP DAC R DAC ONE DAC RW DAC TWO DAC SUB BLK2 DAC DUP DAC AT DAC LIT OCT 077777 DAC AND DAC R DAC SUB DAC ZEQU DAC ZBRA DAC BLK1 DAC DUP DAC PREV DAC STOR BLK3 DAC FRMR DAC DROP DAC TWOP DAC SMIS * * **** (LINE) **** * HEAD FNUL,(LINE),PLIN,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'250 * =,'(' BCI 2,LINE VFD 8,'051 =')' DAC LINK LINK SET TLNK PLIN JST DOCL DAC TOR DAC CL DAC BBUF DAC SSMD DAC FRMR DAC BSCR DAC STAR DAC PLUS DAC BLCK DAC PLUS DAC CL DAC SMIS * * **** .LINE **** * HEAD FNUL,.LINE,DLIN,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'256 * =,'.' BCI 1,LI VFD 8,'316,8,'105 ='NE' DAC LINK LINK SET TLNK DLIN JST DOCL DAC PLIN DAC DTRA DAC TYPE DAC SMIS ENDC * * **** MESSAGE **** * HEAD FNUL,MESSAGE,MESS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,7,8,'315 * =,'M' BCI 2,ESSA VFD 8,'307,8,'105 ='GE' DAC LINK LINK SET TLNK MESS JST DOCL DAC WARN DAC AT DAC ZBRA DAC MES2 IFN DISK DAC DDUP DAC ZBRA DAC MES1 DAC LIT OCT 4 DAC OFST DAC AT DAC BSCR DAC SLSH DAC SUB DAC DLIN MES1 DAC BRAN DAC MES3 ELSE DAC ONE TRUE - ALWAYS DAC LIT OCT 6 DISK RANGE DAC EROR ENDC MES2 DAC PDTQ * STRG MSG #$ VFD 8,6,8,'315 =6,'M' VFD 8,'323,8,'307 ='SG' VFD 8,'240,8,'243 =' #' VFD 8,'240 =' ' DAC DOT MES3 DAC SMIS IFN DISK * * **** LOAD **** * HEAD FNUL,LOAD,LOAD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'314 * =,'L' BCI 1,OA VFD 8,'104 ='D' DAC LINK LINK SET TLNK LOAD JST DOCL DAC BLK DAC AT DAC TOR DAC IN DAC AT DAC TOR DAC ZERO DAC IN DAC STOR DAC BSCR DAC STAR DAC BLK DAC STOR DAC ITRP DAC FRMR DAC IN DAC STOR DAC FRMR DAC BLK DAC STOR DAC SMIS * * **** --> **** * HEAD FNUL,-->,AROW,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'255 * =,'-' VFD 8,'255,8,'076 ='->' DAC LINK LINK SET TLNK AROW JST DOCL DAC QLDG DAC ZERO DAC IN DAC STOR DAC BSCR DAC BLK DAC AT DAC OVER DAC MOD DAC SUB DAC BLK DAC PSTR DAC SMIS * * **** R/W **** ( ADDRESS SCREEN# FLAG ==> ) * HEAD FNUL,R/W,RW,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'322 * =,'R' VFD 8,'257,8,'127 ='/W' DAC LINK LINK SET TLNK RW JST DOCL DAC DROP DAC DROP DAC DROP DAC SMIS ENDC EJCT ****************************************************************** * * MISCELLANEOUS HIGHER LEVEL * ****************************************************************** * * **** ' **** * HEAD FIMD,',TICK,DOCL TLNK SET * VFD 1,0,1,FIMD,6,1,8,'047 * =,''' DAC LINK LINK SET TLNK TICK JST DOCL DAC DFND DAC ZEQU DAC ZERO DAC QERR DAC DROP DAC LTRL DAC SMIS * * **** FORGET **** * HEAD FNUL,FORGET,FRGT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'306 * =,'F' BCI 2,ORGE VFD 8,'124 ='T' DAC LINK LINK SET TLNK FRGT JST DOCL DAC CURR DAC AT DAC CONT DAC AT DAC SUB DAC LIT OCT 30 DAC QERR DAC TICK DAC DUP DAC FENC DAC AT DAC LESS DAC LIT OCT 25 DAC QERR DAC DUP DAC NFA DAC DP DAC STOR DAC LFA DAC AT DAC CONT DAC AT DAC STOR DAC SMIS * * * * **** BACK **** * HEAD FNUL,BACK,BACK,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'302 * =,'B' BCI 1,AC VFD 8,'113 ='K' DAC LINK LINK SET TLNK BACK JST DOCL * JUST COMPILE THE TARGET WORD * NOT THE DIFFERENCE DAC COMA DAC SMIS * * **** BEGIN **** * HEAD FIMD,BEGIN,BGIN,DOCL TLNK SET * VFD 1,0,1,FIMD,6,5,8,'302 * =,'B' BCI 1,EG VFD 8,'311,8,'116 ='IN' DAC LINK LINK SET TLNK BGIN JST DOCL DAC QCMP DAC HERE DAC ONE DAC SMIS * * **** ENDIF **** * HEAD FIMD,ENDIF,ENDF,DOCL TLNK SET * VFD 1,0,1,FIMD,6,5,8,'305 * =,'E' BCI 1,ND VFD 8,'311,8,'106 ='IF' DAC LINK LINK SET TLNK ENDF JST DOCL DAC QCMP DAC TWO DAC QPRS DAC HERE DAC SWAP DAC STOR DAC SMIS * * **** THEN **** * HEAD FIMD,THEN,THEN,DOCL TLNK SET * VFD 1,0,1,FIMD,6,4,8,'324 * =,'T' BCI 1,HE VFD 8,'116 ='N' DAC LINK LINK SET TLNK THEN JST DOCL DAC ENDF DAC SMIS * * **** DO **** * HEAD FIMD,DO,DO,DOCL TLNK SET * VFD 1,0,1,FIMD,6,2,8,'304 * =,'D' VFD 8,'117 ='O' DAC LINK LINK SET TLNK DO JST DOCL DAC COMP DAC XDO DAC HERE DAC LIT DEC 3 DAC SMIS * * **** LOOP **** * HEAD FIMD,LOOP,LOOP,DOCL TLNK SET * VFD 1,0,1,FIMD,6,4,8,'314 * =,'L' BCI 1,OO VFD 8,'120 ='P' DAC LINK LINK SET TLNK LOOP JST DOCL DAC LIT DEC 3 DAC QPRS DAC COMP DAC XLOP DAC BACK DAC SMIS * * **** +LOOP **** * HEAD FIMD,+LOOP,PLOP,DOCL TLNK SET * VFD 1,0,1,FIMD,6,5,8,'253 * =,'+' BCI 1,LO VFD 8,'317,8,'120 ='OP' DAC LINK LINK SET TLNK PLOP JST DOCL DAC LIT DEC 3 DAC QPRS DAC COMP DAC XPLO DAC BACK DAC SMIS * * **** UNTIL **** * HEAD FIMD,UNTIL,UNTL,DOCL TLNK SET * VFD 1,0,1,FIMD,6,5,8,'325 * =,'U' BCI 1,NT VFD 8,'311,8,'114 ='IL' DAC LINK LINK SET TLNK UNTL JST DOCL DAC ONE DAC QPRS DAC COMP DAC ZBRA DAC BACK DAC SMIS * * **** END **** * HEAD FIMD,END,END,DOCL TLNK SET * VFD 1,0,1,FIMD,6,3,8,'305 * =,'E' VFD 8,'316,8,'104 ='ND' DAC LINK LINK SET TLNK END JST DOCL DAC UNTL DAC SMIS * * **** AGAIN **** * HEAD FIMD,AGAIN,AGAN,DOCL TLNK SET * VFD 1,0,1,FIMD,6,5,8,'301 * =,'A' BCI 1,GA VFD 8,'311,8,'116 ='IN' DAC LINK LINK SET TLNK AGAN JST DOCL DAC ONE DAC QPRS DAC COMP DAC BRAN DAC BACK DAC SMIS * * **** REPEAT **** * HEAD FIMD,REPEAT,RPET,DOCL TLNK SET * VFD 1,0,1,FIMD,6,6,8,'322 * =,'R' BCI 2,EPEA VFD 8,'124 ='T' DAC LINK LINK SET TLNK RPET JST DOCL DAC TOR DAC TOR DAC AGAN DAC FRMR DAC FRMR DAC TWO DAC SUB DAC ENDF DAC SMIS * * **** IF **** * HEAD FIMD,IF,IF,DOCL TLNK SET * VFD 1,0,1,FIMD,6,2,8,'311 * =,'I' VFD 8,'106 ='F' DAC LINK LINK SET TLNK IF JST DOCL DAC COMP DAC ZBRA DAC HERE DAC ZERO DAC COMA DAC TWO DAC SMIS * * **** ELSE **** * HEAD FIMD,ELSE,ELSE,DOCL TLNK SET * VFD 1,0,1,FIMD,6,4,8,'305 * =,'E' BCI 1,LS VFD 8,'105 ='E' DAC LINK LINK SET TLNK ELSE JST DOCL DAC TWO DAC QPRS DAC COMP DAC BRAN DAC HERE DAC ZERO DAC COMA DAC SWAP DAC TWO DAC ENDF DAC TWO DAC SMIS * * **** WHILE **** * HEAD FIMD,WHILE,WHIL,DOCL TLNK SET * VFD 1,0,1,FIMD,6,5,8,'327 * =,'W' BCI 1,HI VFD 8,'314,8,'105 ='LE' DAC LINK LINK SET TLNK WHIL JST DOCL DAC IF DAC TWOP DAC SMIS * * * * **** SPACES **** * HEAD FNUL,SPACES,SPCS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,6,8,'323 * =,'S' BCI 2,PACE VFD 8,'123 ='S' DAC LINK LINK SET TLNK SPCS JST DOCL DAC ZERO DAC MAX DAC DDUP DAC ZBRA DAC SPC2 DAC ZERO DAC XDO SPC1 DAC SPCE DAC XLOP DAC SPC1 SPC2 DAC SMIS * * **** <# **** * HEAD FNUL,<#,BDGS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'274 * =,'<' VFD 8,'043 ='#' DAC LINK LINK SET TLNK BDGS JST DOCL DAC PAD DAC BYTE DAC HLD DAC STOR DAC SMIS * * **** #> **** * HEAD FNUL,#>,EDGS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'243 * =,'#' VFD 8,'076 ='>' DAC LINK LINK SET TLNK EDGS JST DOCL DAC DROP DAC DROP DAC HLD DAC AT DAC PAD DAC BYTE DAC OVER DAC SUB DAC SMIS * * **** SIGN **** * HEAD FNUL,SIGN,SIGN,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'323 * =,'S' BCI 1,IG VFD 8,'116 ='N' DAC LINK LINK SET TLNK SIGN JST DOCL DAC ROT DAC ZLES DAC ZBRA DAC SGN1 DAC LIT VFD 16,CMNS DAC HOLD SGN1 DAC SMIS * * **** # **** * HEAD FNUL,#,DIG,DOCL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'043 * =,'#' DAC LINK LINK SET TLNK DIG JST DOCL DAC BASE DAC AT DAC MSMD DAC ROT DAC LIT DEC 9 DAC OVER DAC LESS DAC ZBRA DAC DIG1 DAC LIT OCT 7 DAC PLUS DIG1 DAC LIT VFD 16,CZRO DAC PLUS DAC HOLD DAC SMIS * * **** #S **** * HEAD FNUL,#S,DIGS,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'243 * =,'#' VFD 8,'123 ='S' DAC LINK LINK SET TLNK DIGS JST DOCL DGS1 DAC DIG DAC OVER DAC OVER DAC OR DAC ZEQU DAC ZBRA DAC DGS1 DAC SMIS * * **** D.R **** * HEAD FNUL,D.R,DDTR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,3,8,'304 * =,'D' VFD 8,'256,8,'122 ='.R' DAC LINK LINK SET TLNK DDTR JST DOCL DAC TOR DAC SWAP DAC OVER DAC DABS DAC BDGS DAC DIGS DAC SIGN DAC EDGS DAC FRMR DAC OVER DAC SUB DAC SPCS DAC TYPE DAC SMIS * * **** .R **** * HEAD FNUL,.R,DOTR,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'256 * =,'.' VFD 8,'122 ='R' DAC LINK LINK SET TLNK DOTR JST DOCL DAC TOR DAC STOD DAC FRMR DAC DDTR DAC SMIS * * **** D. **** * HEAD FNUL,D.,DDOT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'304 * =,'D' VFD 8,'056 ='.' DAC LINK LINK SET TLNK DDOT JST DOCL DAC ZERO DAC DDTR DAC SPCE DAC SMIS * * **** . **** * HEAD FNUL,.,DOT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'056 * =,'.' DAC LINK LINK SET TLNK DOT JST DOCL DAC STOD DAC DDOT DAC SMIS * * **** ? **** * HEAD FNUL,?,QUST,DOCL TLNK SET * VFD 1,0,1,FNUL,6,1,8,'077 * =,'?' DAC LINK LINK SET TLNK QUST JST DOCL DAC AT DAC DOT DAC SMIS * * **** U. **** * HEAD FNUL,U.,UDOT,DOCL TLNK SET * VFD 1,0,1,FNUL,6,2,8,'325 * =,'U' VFD 8,'056 ='.' DAC LINK LINK SET TLNK UDOT JST DOCL DAC ZERO DAC DDOT DAC SMIS ****************************************************************** * * UTILITY SECTION. * ****************************************************************** IFN DISK * * **** LIST **** * HEAD FNUL,LIST,LIST,DOCL TLNK SET * VFD 1,0,1,FNUL,6,4,8,'314 * =,'L' BCI 1,IS VFD 8,'124 ='T' DAC LINK LINK SET TLNK LIST JST DOCL DAC DEC DAC CR DAC DUP DAC SCR DAC STOR DAC PDTQ * STRG SCR #$ VFD 8,6,8,'323 =6,'S' VFD 8,'303,8,'322 ='CR' VFD 8,'240,8,'243 =' #' VFD 8,'240 =' ' DAC DOT DAC LIT OCT 20 DAC ZERO DAC XDO LST1 DAC CR DAC I DAC THRE DAC DOTR DAC SPCE DAC I DAC SCR DAC AT DAC DLIN DAC XLOP DAC LST1 DAC CR DAC SMIS * * **** INDEX **** LIST FIRST LINE OF A RANGE OF DISK SCREENS. * HEAD FNUL,INDEX,INDX,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'311 * =,'I' BCI 1,ND VFD 8,'305,8,'130 ='EX' DAC LINK LINK SET TLNK INDX JST DOCL DAC CR DAC ONEP DAC SWAP DAC XDO IDX1 DAC CR DAC I DAC THRE DAC DOTR DAC SPCE DAC ZERO DAC I DAC DLIN DAC QTRM DAC ZBRA DAC IDX2 DAC LEAV IDX2 DAC XLOP DAC IDX1 DAC SMIS * * **** TRIAD **** LIST DISK SCREENS THREE PER PAGE. * HEAD FNUL,TRIAD,TRAD,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'324 * =,'T' BCI 1,RI VFD 8,'301,8,'104 ='AD' DAC LINK LINK SET TLNK TRAD JST DOCL DAC LIT OCT 214 FORM FEED DAC EMIT DAC THRE DAC SLSH DAC THRE DAC STAR DAC THRE DAC OVER DAC PLUS DAC SWAP DAC XDO TRA1 DAC CR DAC I DAC LIST DAC XLOP DAC TRA1 DAC CR DAC LIT OCT 17 DAC MESS DAC CR DAC SMIS ENDC * * **** VLIST **** * HEAD FNUL,VLIST,VLST,DOCL TLNK SET * VFD 1,0,1,FNUL,6,5,8,'326 * =,'V' BCI 1,LI VFD 8,'323,8,'124 ='ST' DAC LINK LINK SET TLNK VLST JST DOCL DAC LIT OCT 200 DAC OUT DAC STOR DAC CONT DAC AT DAC AT VLS1 DAC OUT DAC AT DAC LIT OCT 100 DAC GRTR DAC ZBRA DAC VLS2 DAC CR DAC ZERO DAC OUT DAC STOR VLS2 DAC DUP DAC IDDT DAC SPCE DAC SPCE DAC PFA DAC LFA DAC AT DAC DUP DAC ZEQU DAC QTRM DAC OR DAC ZBRA DAC VLS1 DAC DROP DAC SMIS * * **** BYE **** * HEAD FNUL,BYE,BYE TLNK SET * VFD 1,0,1,FNUL,6,3,8,'302 * =,'B' VFD 8,'331,8,'105 ='YE' DAC LINK LINK SET TLNK BYE EQU * JMP STOP * IFN DBGW * * **** DEBUG **** * HEAD FNUL,DEBUG,DBUG TLNK SET * VFD 1,0,1,FNUL,6,5,8,'304 * =,'D' BCI 1,EB VFD 8,'325,8,'107 ='UG' DAC LINK LINK SET TLNK DBUG EQU * JMP PDBG ENDC ****************************************************************** * * THE FOLLOWING TWO DEFINITIONS ARE NOT PURE CODE, SO THEY WERE * MOVED HERE, NEAR THE END OF THE DICTIONARY. * ****************************************************************** * * **** ;CODE **** CREATE NEW DATA TYPE WITH CODE ROUTINE WRITTEN * IN ASSEMBLY. * HEAD FIMD,;CODE,SEMC,DOCL TLNK SET * VFD 1,0,1,FIMD,6,5,8,'273 * =,';' BCI 1,CO VFD 8,'304,8,'105 ='DE' DAC LINK LINK SET TLNK SEMC JST DOCL DAC QCSP DAC COMP DAC LBRC DAC SMDG DAC SMIS DAC PSCD WON'T WORK... HLT STOP EXECUTION * NOTE: LATER, THE ASSEMBLER WILL PATCH THIS DEFINITION. * * **** FORTH **** * HEAD FIMD,FORTH,FRTH,DODS TLNK SET * VFD 1,0,1,FIMD,6,5,8,'306 * =,'F' BCI 1,OR VFD 8,'324,8,'110 ='TH' DAC LINK LINK SET TLNK FRTH JST DODS DAC DOVC * * OCT 120201 DUMMY HEADER AT INTERSECTION DAC XTSK XXVC OCT 0 THE VOCABULARY LINK (FOR FUTURE USE) * * **** TASK **** *TSK HEAD FIMD,TASK,TASK,DOCL TLNK SET * XTSK VFD 1,0,1,FIMD,6,4,8,'324 * =,'T' BCI 1,AS VFD 8,'113 ='K' DAC LINK LINK SET TLNK TASK JST DOCL DAC SMIS * ****************************************************************** * TERMINAL I/O ****************************************************************** * * **** EMIT **** PEMT LDA 1,1 ANA ='177 LOSE TOP BIT CAS ='40 JMP EMT2 >'40 JMP EMT2 ='40 * IS A CONTROL CHARACTER EMT1 LDA 1,1 GET WHOLE CHARACTER BACK JST OUT1 JMP POP * * INCREMENT 'OUT', UNLESS A CONTROL CHARACTER BEING OUTPUT. EMT2 LDA UP ADD ='21 STA T1 IRS* T1 JMP EMT1 * OUT1 DAC ** SKS '104 JMP *-1 OCP '104 OTA '4 JMP *-1 JMP* OUT1 * OUT2 DAC ** ARR 8 JST OUT1 ALR 8 JST OUT1 JMP* OUT2 * * **** KEY **** PKEY SKS '104 SKIP IF NOT BUSY JMP *-1 OCP '4 SELECT INPUT MODE INA '1004 INPUT JMP *-1 IFZ ECLF JMP PUSH ELSE CAS KCCR JMP PUSH SKP JMP PUSH LDA KCLF JST OUT1 LDA KCCR JMP PUSH * KCCR VFD 16,CCR KCLF VFD 16,CLF ENDC * * **** ?TERMINAL **** PQTR SKS '104 SKIP IF NOT BUSY JMP *-1 OCP '4 SELECT INPUT MODE LDA =1 SKS '4 SKIP IF READY CRA JMP PUSH * * **** CR **** PCR JST CRLF NEXT * CRLF DAC ** LDA CRL1 JST OUT2 JMP* CRLF CRL1 VFD 8,CCR,8,CLF * * PAPERTAPE ROUTINES * IFN PTW PPTC OCP '1 START READER INA '1001 INPUT JMP *-1 OCP '101 STOP READER JMP PUSH ENDC * * * DEBUG * * IFN DBGW OCTC BSS 1 * OCTL DAC ** IAB LDA =-6 STA OCTC CRA LLR 1 MSB ROTATES INTO A * OCT1 ADD XZRO JST OUT1 CRA LLR 3 IRS OCTC JMP OCT1 JMP* OCTL * DSPC DAC ** LDA XSPC JST OUT1 JMP* DSPC XSPC VFD 16,CSPC * PDBG LDA IP JST OCTL * JST DSPC LDA 0 JST OCTL * JST DSPC LDA 1,1 JST OCTL * JST DSPC LDA 2,1 JST OCTL * JST DSPC LDA 3,1 JST OCTL * JST DSPC LDA 4,1 JST OCTL * JST DSPC LDA 5,1 JST OCTL * JST DSPC LDA* RP JST OCTL * JST CRLF * NEXT ENDC ****************************************************************** * * STACKS AND BUFFERS * ****************************************************************** * * 'XTIB', 'XR0', AND 'XUP' ARE ONLY USED IN BOOT-UP TABLE; * THEREFORE THE AREAS DEFINED HERE CAN BE MOVED AT RUN TIME. XTIB BSS 42 TERMINAL INPUT BUFFER XR0 BES 50 FOR RETURN STACK XUP BSS '100 ROOM FOR '100 USER VARIABLES * * NOTE - 'UP', 'OPENF', 'INTERM', AND DISK BUFFERS ARE * INITIALIZED AT COLD START, OR AT FIRST TIME THROUGH. * * IFN DISK * * ROOM FOR 3 1K DISK BUFFERS * * INITIALIZE BUFFERS' UPDATE BITS, AND TERMINATING NULLS, TO ZERO. * NOTE - THESE BUFFERS ARE CLEARED AT COLD START, ANYWAY, * BECAUSE A STAND-ALONE BOOT MAY NOT INITIALIZE HIGH MEMORY; * AND ALSO SO THAT THE NUMBER OR LOCATION OF BUFFERS CAN BE * CHANGED AT RUN TIME. DSKB OCT 0 BSS 512 OCT 0 OCT 0 BSS 512 OCT 0 OCT 0 BSS 512 OCT 0 ENDB EQU * CAUTION - 'ENDB' - 'DSKB' MUST BE EXACT MULTIPLE * OF THE BUFFER LENGTH PLUS 4. * ENDC * * DICTIONARY STARTS HERE XDP BSS 128 FOR DICTIONARY AND COMP. STACK * THIS IS JUST NOMINAL - SEE MSZ, BELOW XS0 BSS 2 START OF COMPUTATION STACK * 2 WORDS IN CASE OF EMPTY STACK * ****************************************************************** * * START-UP CODE - CALCULATE TOP OF MEMORY * ****************************************************************** ORG XTIB DELIBERATELY OVERLAY MSZ DAC ** CRA SSM JUST TOP BIT IFZ XTND LGR 1 DIVIDE BY 2 ENDC * A POINTS ONE BEYOND MAXIMUM MEMORY JMP MSZ2 * MSZ1 LDA T2 STA* T1 PUT ORIGINAL DATA BACK (JUST IN CASE) LDA T1 MSZ2 SUB MS4K SPL SHOULD ALWAYS BE POSITIVE HLT TRAP NEVER-ENDING LOOP STA T1 LDA* T1 STA T2 SAVE ORIGINAL CONTENTS CRA STA* T1 CMA ALL ONES LDA* T1 SZE JMP MSZ1 DIDN'T CLEAR CMA GET ALL ONES STA* T1 IRS* T1 SHOULD SKIP JMP MSZ1 DIDN'T SKIP * * HAVE MEMORY HERE... LDA T2 STA* T1 PUT ORIGINAL DATA BACK LDA T1 ADD MS4K JUST ABOVE MEMORY SUB MSRV WORDS TO RESERVE SUB =2 TWO WORDS FOR EMPTY STACK CAS MXDB NOP OK - GREATER SKP OK - EQUAL HLT NO SPACE FOR DICTIONARY * * SAVE CALCULATED TOP OF STACK STA OXS0 * * PATCH SO NEVER CALL AGAIN LDA MSZ RETURN ADDRESS SUB =1 POINT AT JST STA T1 NOP LDA *-1 STA* T1 JMP* MSZ * MS4K DEC 4096 MSRV VFD 16,RSRV MXDB DAC XDP+'100 MINIMUM DICTIONARY SPACE * ORG NXTY FOR CONSTANT POOL FIN NXTZ EQU * END ORGN $ ****************************************************************** * XEMACS LOCAL VARIABLES * * LOCAL VARIABLES: * MODE: FUNDAMENTAL * END: