--- /dev/null
+\ 8086/8 Assembler for hForth\r
+\\r
+\ This 8088 Assembler has been rewritten by Sheen Lee for hForth\r
+\\r
+\ ----------------------------------------------------------------------------\r
+\ This 8088 Assembler was originally written by Mike Perry and\r
+\ Steve Pollack. It has been rewritten by Martin Tracy\r
+\ and rewritten again by Rick VanNorman (to adapt it to a\r
+\ 32-bit environment).\r
+\ Programmers who are familiar with the original F83 assembler\r
+\ will find the following major differences:\r
+\\r
+\ 1. the mode #) is now simply )\r
+\ 2. the mode S#) has disappeared.\r
+\ 3. conditional macros have been replaced by local labels.\r
+\ 4. REPZ and REPNZ are now REPE and REPNE.\r
+\ 5. JZ JNZ JC JNC and more error checks have been added.\r
+\ 6. the JMP and CALL instructions now have an indirect mode:\r
+\\r
+\ MYLABEL # JMP means JMP to this label, but\r
+\ MYVECTOR ) JMP means JMP indirectly through this address.\r
+\ ----------------------------------------------------------------------------\r
+\r
+\ Further modifications by Wonyong Koh\r
+\\r
+\ 1996. 11. 29.\r
+\ Revise ';CODE' for control-flow stack.\r
+\ 1996. 4. 15.\r
+\ ';CODE' is fixed. END-CODE is changed.\r
+\ 1995. 11. 27.\r
+\ ';CODE' is redefined following the change of 'DOES>' and 'doCREATE'.\r
+\\r
+\ o 'MOV', 'JMP', etc are renamed to 'MOV,', 'JMP,', etc. You can\r
+\ use Standard Forth words 'AND', 'OR', 'XOR' between 'CODE' and\r
+\ 'END-CODE' with no confliction.\r
+\ o ANS Standard word ';CODE' is added.\r
+\ o The definition of '1MI' for hForth 8086 ROM Model is better to be\r
+\ : 1MI RAM/ROM@ ROM CREATE C, RAM/ROM! DOES> C@ xb, ;\r
+\ rather than\r
+\ : 1MI CREATE C, DOES> C@ xb, ;\r
+\ However, I did not bother and simply put 'ROM' and 'RAM' in\r
+\ 'ASM8086.F' since '1MI' won't be used in any other places.\r
+\r
+CHAR " PARSE CPU" ENVIRONMENT? DROP\r
+CHAR " PARSE 8086" COMPARE\r
+[IF] CR .( This assembler is for 8086 only.) ABORT [THEN]\r
+\r
+BASE @\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM@ [THEN]\r
+GET-ORDER GET-CURRENT\r
+\r
+WORDLIST WORDLIST-NAME ASSEMBLER-WORDLIST\r
+\r
+: ASSEMBLER\r
+ GET-ORDER NIP ASSEMBLER-WORDLIST SWAP SET-ORDER ;\r
+ALSO ASSEMBLER DEFINITIONS\r
+\r
+HEX\r
+\r
+\ ----------------------------------------------------- System dependant words\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : codeB! C! ;\r
+ : codeB, xhere DUP 1+ TOxhere C! ;\r
+ : code2B, xhere DUP CELL+ TOxhere ! ;\r
+ : code4B, SWAP code2B, code2B, ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : codeB! C! ;\r
+ : codeB, HERE DUP 1+ TO HERE C! ;\r
+ : code2B, HERE DUP CELL+ TO HERE ! ;\r
+ : code4B, SWAP code2B, code2B, ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : codeB, xhere DUP 1+ TO xhere codeB! ;\r
+ : code2B, xhere DUP CELL+ TO xhere code! ;\r
+ : code4B, SWAP code2B, code2B, ;\r
+[THEN]\r
+\r
+\ ----------------------------------------------------------------- Predicates\r
+\r
+\ true if offset requires 2 bytes.\r
+: BIG? ( o - f)\r
+ 0080 + FF00 AND 0= INVERT ;\r
+\r
+\ Error action of several words.\r
+: huh? ( w)\r
+ INVERT IF ." ? " SOURCE TYPE ABORT THEN ;\r
+\r
+\ aborts if relative distance is too far.\r
+: ?FAR ( o )\r
+ BIG? INVERT huh? ;\r
+\r
+\ --------------------------------------------------------------- Local labels\r
+\r
+DECIMAL 16 CONSTANT MXL# HEX\r
+\r
+\ unresolved fwd reference associative stack. Emptied by INIT.\r
+\ Associate stacks can be "popped" from the middle, or wherever\r
+\ the key is found.\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ RAM\r
+[THEN]\r
+\r
+CREATE FWDS\r
+ 2 CELLS ALLOT ( pointers)\r
+ MXL# 2 * CELLS ALLOT ( pairs)\r
+\r
+\ resolved label value array. Cleared by INIT.\r
+CREATE BWDS\r
+ MXL# CELLS ALLOT\r
+\r
+\ pushes unresolved reference.\r
+: LPUSH ( value=here' key=label#)\r
+ FWDS 2@ = 0= huh? ( full?) FWDS @ 2! 2 CELLS FWDS +! ;\r
+\r
+\ pops any unresolved references.\r
+: LPOP ( key=label# - value=addr true | key 0)\r
+ >R FWDS @ FWDS 2 CELLS +\r
+ BEGIN 2DUP = 0= ( end start) WHILE\r
+ DUP @ R@ = IF ( found!)\r
+ DUP CELL+ @ ( addr) >R\r
+ SWAP 2 CELLS - DUP FWDS ! 2@ ROT 2! \ promote last pair\r
+ R> R> ( addr key) -1 OR ( addr true)\r
+ EXIT\r
+ THEN\r
+ 2 CELLS +\r
+ REPEAT\r
+ 2DROP R> 0 ;\r
+\r
+\ returns the address of the label n or 0 if unresolved.\r
+: L? ( n - a | 0)\r
+ DUP MXL# U< huh? CELLS BWDS + @ ;\r
+\r
+\ assigns HERE to label n-1. Resolves any forward references.\r
+\ Assumes 8-bit relative displacements.\r
+: L: ( n - a)\r
+ DUP L? 0= huh? ( should be unknown)\r
+ xhere OVER CELLS BWDS + ! ( now known)\r
+ BEGIN DUP LPOP ( a -1 | n 0) WHILE\r
+ xhere OVER - 1- SWAP OVER ?FAR codeB! ( resolve ref)\r
+ REPEAT\r
+ 2DROP ;\r
+\r
+: L# ( n - a ) \ retrieves the value of label n-1.\r
+ DUP L?\r
+ ?DUP 0= IF xhere 1+ 2DUP SWAP LPUSH THEN\r
+ NIP ;\r
+\r
+\ ------------------------------------------------------------------ Variables\r
+\r
+VARIABLE WORD= \ WORD/BYTE switch -- normally WORD.\r
+VARIABLE FAR= \ NEAR/FAR switch -- normally NEAR.\r
+VARIABLE LOG= \ holds op mask for logical opcodes. See B/L?\r
+\r
+: WORD TRUE WORD= ! ;\r
+: BYTE FALSE WORD= ! ;\r
+: FAR TRUE FAR= ! ;\r
+\r
+\ ------------------------------------------------ base switches to octal here\r
+\r
+: OCTAL [ DECIMAL ] 8 BASE ! ;\r
+\r
+OCTAL\r
+\r
+\ ------------------------------------------------------------------ Registers\r
+\r
+\ defines n register-id-modes used for building opcodes.\r
+: REGS ( n id )\r
+ SWAP 0 DO\r
+ DUP I 11 * SWAP 1000 * OR CONSTANT\r
+ LOOP\r
+ DROP ;\r
+\r
+10 1 REGS AL CL DL BL AH CH DH BH\r
+10 2 REGS AX CX DX BX SP BP SI DI\r
+10 4 REGS [BX+SI] [BX+DI] [BP+SI] [BP+DI] [SI] [DI] [BP] [BX]\r
+ 4 4 REGS [SI+BX] [DI+BX] [SI+BP] [DI+BP]\r
+ 4 10 REGS ES CS SS DS\r
+ 2 20 REGS ) #\r
+\r
+\ ----------------------------------------------------------------- Mode tests\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ ROM\r
+[THEN]\r
+\r
+: MD \ determines if a mode is a member of the given class.\r
+ CREATE ( mode - ) 1000 * ,\r
+ DOES> ( mode - f) @ AND 0= INVERT ;\r
+\r
+ 1 MD R8? ( mode - 8-bit-register?)\r
+ 2 MD R16? ( mode - 16-bit-register?)\r
+ 3 MD REG? ( mode - 8/16-bit-register?)\r
+ 4 MD [x]? ( mode - indirect/indexed?)\r
+10 MD SEG? ( mode - segment-register?)\r
+\r
+: RLOW ( register-mode - r/m-mask ) 07 AND ;\r
+: RMID ( register-mode - reg-mask ) 70 AND ;\r
+\r
+\ --------------------------------------------------------- Special mode tests\r
+\r
+\ true if n takes two bytes or sign-extend is not permitted.\r
+: B/L? ( n - f)\r
+ BIG? LOG= @ OR ;\r
+\r
+\ true if mem -> acc\r
+: >ACC? ( mode reg - f)\r
+ RLOW 0= SWAP ) = AND ;\r
+\r
+: ?MAD ( f ) IF ." Mode? " SOURCE TYPE ABORT THEN ;\r
+: ?ACC ( mode ) DUP AX = SWAP AL = OR INVERT ?MAD ;\r
+\r
+\ ----------------------------------------------------------- Opcode compilers\r
+\r
+: OP, ( opcode mask | mask opcode ) OR codeB, ;\r
+\r
+: W, ( opcode mode ) R16? NEGATE OP, ;\r
+: WORD, ( opcode ) WORD= @ NEGATE OP, ;\r
+\r
+: RR, ( register-mode1 register-mode2 )\r
+ RMID SWAP RLOW OR 300 OP, ;\r
+\r
+: ,/C, ( n 16-bit? )\r
+ IF code2B, ELSE codeB, THEN ;\r
+\r
+\ ---------------------------------------------------------- Address compilers\r
+\r
+\ compiles memory->register operand.\r
+: MEM, ( a/o mode register-mode)\r
+ RMID OVER ) = IF\r
+ 6 OP, DROP code2B, ( direct )\r
+ ELSE\r
+ OVER RLOW OR ( reg:r/m field) ROT ROT ( field addr mode)\r
+ ( mode) [BP] = OVER 0= AND IF ( 0 [BP] exception..)\r
+ SWAP 100 OP, codeB, ( ...requires offset)\r
+ ELSE SWAP OVER BIG? IF\r
+ 200 OP, ( 2-byte offset) code2B,\r
+ ELSE OVER IF\r
+ 100 OP, ( 1-byte offset) codeB,\r
+ ELSE\r
+ OP, ( zero offset)\r
+ THEN THEN THEN\r
+ THEN ;\r
+\r
+\ register-mode selects BYTE/WORD w-field.\r
+: WMEM, ( a/o mode register-mode opcode )\r
+ OVER W, MEM, ;\r
+\r
+\ selects between register->register and memory->register.\r
+: R/M, ( [operand] mode register-mode )\r
+ OVER REG? IF RR, ELSE MEM, THEN ;\r
+\r
+\ R/M, but modifies opcode with BYTE/WORD.\r
+: WR/M, ( [operand] mode register-mode opcode )\r
+ 2 PICK DUP REG? IF\r
+ W, RR, ( register->register)\r
+ ELSE\r
+ DROP WORD, MEM, WORD ( memory ->register)\r
+ THEN ;\r
+\r
+\ ---------------------------------------------------------- Opcode generators\r
+\r
+\ one-byte opcodes with implied operands.\r
+: 1MI\r
+ CREATE C,\r
+ DOES> C@ codeB, ;\r
+\r
+\ two-byte opcodes with implied operands.\r
+: 2MI\r
+ CREATE C,\r
+ DOES> C@ codeB, 12 codeB, ;\r
+\r
+\ jump to a one-byte displacement.\r
+: 3MI\r
+ CREATE C,\r
+ DOES> C@ codeB, ( a ) xhere - 1- DUP ?FAR codeB, ;\r
+\r
+\ LDS LEA LES opcodes.\r
+: 4MI\r
+ CREATE C,\r
+ DOES> C@ codeB, ( mem reg) OVER REG? ?MAD MEM, ;\r
+\r
+\ string opcodes.\r
+: 5MI\r
+ CREATE C,\r
+ DOES> C@ WORD, WORD ;\r
+\r
+\ one-byte opcodes with single operands.\r
+: 7MI\r
+ CREATE C,\r
+ DOES> C@ 366 WR/M, ;\r
+\r
+\ IN and OUT. Syntax for both: port/DX AL/AX IN/OUT\r
+: 8MI\r
+ CREATE C,\r
+ DOES> C@ OVER ?ACC ROT\r
+ DUP # = OVER DX = OR INVERT ?MAD\r
+ # = IF\r
+ SWAP W, codeB,\r
+ ELSE\r
+ 10 OR SWAP W,\r
+ THEN ;\r
+\r
+\ INC and DEC. Syntax is: r/mem opcode.\r
+: 9MI\r
+ CREATE C,\r
+ DOES> C@ OVER SEG? ?MAD\r
+ OVER R16? IF\r
+ 100 OR SWAP RLOW OP,\r
+ ELSE\r
+ 376 WR/M,\r
+ THEN ;\r
+\r
+\ shift and rotate group. Syntax is: r/mem [ CL | 1 ] opcode.\r
+: 10MI\r
+ CREATE C,\r
+ DOES> C@ OVER CL = IF\r
+ NIP 322\r
+ ELSE\r
+ OVER 1 = IF NIP THEN\r
+ 320\r
+ THEN\r
+ WR/M, ;\r
+\r
+\ CALL and JMP.\r
+: 11MI\r
+ CREATE C, C,\r
+ DOES> >R ( ... mode) DUP REG? FAR= @ AND ?MAD R>\r
+ OVER # = ( [d]addr # ^opcode) IF\r
+ NIP FAR= @ IF\r
+ 1+ C@ codeB, code4B,\r
+ ELSE\r
+ C@ SWAP xhere - 2 - SWAP OVER\r
+ BIG? INVERT OVER 1 AND ( JMP?) AND IF\r
+ 2 OP, codeB,\r
+ ELSE\r
+ codeB, 1- code2B,\r
+ THEN\r
+ THEN\r
+ ELSE ( r/mem ^opcode)\r
+ 377 codeB,\r
+ 1+ C@ FAR= @ INVERT 10 AND XOR R/M,\r
+ THEN\r
+ 0 FAR= ! ;\r
+\r
+\ POP and PUSH.\r
+: 12MI\r
+ CREATE C, C, C,\r
+ DOES> OVER REG? IF\r
+ C@ OVER R8? ?MAD SWAP RLOW OP,\r
+ ELSE 1+ OVER SEG? IF\r
+ C@ OVER CS = OVER 1 AND ( POP) AND ?MAD\r
+ RLOW SWAP RMID OP,\r
+ ELSE\r
+ COUNT SWAP C@ codeB, MEM,\r
+ THEN THEN ;\r
+\r
+\ Note: BIG # AL is not detected as an error.\r
+: 13MA ( operand reg opcode )\r
+ >R OVER REG? IF\r
+ R> OVER W, SWAP RR, ( reg->reg)\r
+ ELSE OVER DUP [x]? SWAP ) = OR IF\r
+ R> 2 OR WMEM, ( mem->reg)\r
+ ELSE\r
+ SWAP # - ?MAD ( # ->reg)\r
+ DUP RLOW 0= ( AL/AX?) IF\r
+ R> 4 OR OVER W, R16? ,/C, ( # ->acc)\r
+ ELSE ( data reg)\r
+ OVER B/L? OVER R16? 2DUP AND ROT ROT ( data reg m m f)\r
+ NEGATE SWAP INVERT 2 AND OR 200 OP, ( data reg m)\r
+ SWAP RLOW 300 OR R> OP, ,/C,\r
+ THEN\r
+ THEN THEN ;\r
+\r
+: 13MB ( operand opcode )\r
+ >R ROT DUP REG? IF\r
+ R> WMEM, ( reg->mem)\r
+ ELSE\r
+ # - ?MAD ( # ->mem) ( data mem)\r
+ 2 PICK B/L? DUP INVERT 2 AND 200 OR WORD,\r
+ ROT ROT R> MEM, WORD= @ AND ,/C, WORD\r
+ THEN ;\r
+\r
+\ adds, subtracts and logicals.\r
+: 13MI\r
+ CREATE C, C,\r
+ DOES> COUNT SWAP C@ LOG= !\r
+ OVER REG? IF 13MA ELSE 13MB THEN ;\r
+\r
+\ RET.\r
+: 14MI\r
+ CREATE C,\r
+ DOES> C@ FAR= @ 10 AND OR 0 FAR= ! ( [offset] opcode)\r
+ DUP codeB,\r
+ 1 AND 0= IF code2B, THEN ; ( offset +RET )\r
+\r
+\r
+\ Segment override prefices.\r
+\r
+: SEG ( seg ) RMID 46 OP, ;\r
+\r
+: CS: CS SEG ;\r
+: DS: DS SEG ;\r
+: ES: ES SEG ;\r
+: SS: SS SEG ;\r
+\r
+\ ------------------------------------------------------- Special opcode TEST\r
+: TEST, ( source dest )\r
+ DUP REG? IF\r
+ OVER REG? IF\r
+ 204 OVER W, SWAP RR, ( reg->reg)\r
+ ELSE\r
+ SWAP # - ?MAD ( # ->reg)\r
+ DUP RLOW 0= ( AL/AX?) IF\r
+ 250 OVER W, ( # ->acc)\r
+ ELSE\r
+ 366 OVER W, DUP RLOW 300 OP,\r
+ THEN\r
+ R16? ,/C,\r
+ THEN\r
+ ELSE ( [offset] mode mem)\r
+ ROT DUP REG? IF\r
+ 204 WMEM, ( reg->mem)\r
+ ELSE\r
+ # - ?MAD ( # ->mem)\r
+ 366 WORD, 0 MEM, WORD= @ ,/C, WORD\r
+ THEN\r
+ THEN ;\r
+\r
+\ -------------------------------------------------- base switches to hex here\r
+\r
+HEX\r
+\r
+\ --------------------------------------------------------- Special opcode MOV\r
+\r
+: MOV, ( source destination )\r
+ DUP SEG? IF\r
+ 8E codeB, R/M, ( mem->seg)\r
+ ELSE DUP REG? IF\r
+ 2DUP >ACC? IF\r
+ A0 SWAP W, DROP code2B, ( mem->acc)\r
+ ELSE OVER SEG? IF\r
+ SWAP 8C codeB, RR, ( seg->reg)\r
+ ELSE OVER # = IF\r
+ NIP DUP R16? SWAP RLOW OVER 8 AND OR B0 OP, ,/C, ( # ->reg)\r
+ ELSE\r
+ 8A OVER W, R/M, ( mem->reg)\r
+ THEN THEN THEN\r
+ ELSE ROT DUP SEG? IF\r
+ 8C codeB, MEM, ( seg->mem)\r
+ ELSE DUP # = IF\r
+ DROP C6 WORD, 0 MEM, WORD= @ ,/C, ( # ->mem)\r
+ ELSE 2DUP >ACC? IF\r
+ A2 SWAP W, DROP code2B, ( acc->mem)\r
+ ELSE\r
+ 88 OVER W, R/M, ( reg->mem)\r
+ THEN THEN THEN THEN THEN\r
+ WORD ;\r
+\r
+\ ----------------------------------------------- Special opcodes INT and XCHG\r
+\r
+: INT, ( n )\r
+ DUP 3 = IF DROP CC codeB, EXIT THEN\r
+ CD codeB, codeB, ;\r
+\r
+: XCHG, ( mem reg)\r
+ DUP REG? IF\r
+ OVER REG? OVER AX = AND IF\r
+ DROP RLOW 90 OP, ( reg->AX )\r
+ ELSE OVER AX = IF\r
+ NIP RLOW 90 OP, ( AX- >reg)\r
+ ELSE\r
+ 86 WR/M, ( mem->reg)\r
+ THEN THEN\r
+ ELSE\r
+ ROT 86 WR/M, ( reg->mem)\r
+ THEN ;\r
+\r
+\ -------------------------------------------------------------------- Opcodes\r
+\r
+ 37 1MI AAA, D5 2MI AAD, D4 2MI AAM, 3F 1MI AAS,\r
+00 10 13MI ADC, 00 00 13MI ADD, 02 20 13MI AND, 9A E8 11MI CALL,\r
+ 98 1MI CBW, F8 1MI CLC, FC 1MI CLD, FA 1MI CLI,\r
+ F5 1MI CMC, 00 38 13MI CMP, A6 5MI CMPS, 99 1MI CWD,\r
+ 27 1MI DAA, 2F 1MI DAS, 08 9MI DEC, 30 7MI DIV,\r
+ ( ESC ) F4 1MI HLT, 38 7MI IDIV, 28 7MI IMUL,\r
+ E4 8MI IN, 00 9MI INC, ( INT ) CE 1MI INTO,\r
+ CF 1MI IRET,\r
+\r
+ 9F 1MI LAHF,\r
+ C5 4MI LDS, 8D 4MI LEA, C4 4MI LES, F0 1MI LOCK,\r
+ AC 5MI LODS, E2 3MI LOOP, E1 3MI LOOPE, E0 3MI LOOPNE,\r
+ ( MOV, ) A4 5MI MOVS, 20 7MI MUL, 18 7MI NEG,\r
+ 90 1MI NOP, 10 7MI NOT, 02 08 13MI OR, E6 8MI OUT,\r
+ 8F 07 58 12MI POP, 9D 1MI POPF,\r
+ FF 36 50 12MI PUSH, 9C 1MI PUSHF,\r
+ 10 10MI RCL, 18 10MI RCR,\r
+ F3 1MI REP, F2 1MI REPNE, F3 1MI REPE,\r
+ C3 14MI RET, 00 10MI ROL, 8 10MI ROR, 9E 1MI SAHF,\r
+ 38 10MI SAR, 00 18 13MI SBB, AE 5MI SCAS, ( SEG )\r
+ 20 10MI SHL, 28 10MI SHR, F9 1MI STC, FD 1MI STD,\r
+ FB 1MI STI, AA 5MI STOS, 00 28 13MI SUB, ( TEST, )\r
+ 9B 1MI WAIT, ( XCHG ) D7 1MI XLAT, 02 30 13MI XOR,\r
+ C2 14MI +RET,\r
+EA E9 11MI JMP,\r
+\r
+ 70 3MI JO,\r
+ 71 3MI JNO,\r
+ 72 3MI JB, 72 3MI JC,\r
+ 73 3MI JAE, 73 3MI JNC,\r
+ 74 3MI JE, 74 3MI JZ,\r
+ 75 3MI JNE, 75 3MI JNZ,\r
+ 76 3MI JBE,\r
+ 77 3MI JA, 77 3MI JNBE,\r
+ 78 3MI JS,\r
+ 79 3MI JNS,\r
+ 7A 3MI JPE,\r
+ 7B 3MI JPO,\r
+ 7C 3MI JL, 7C 3MI JNGE,\r
+ 7D 3MI JGE, 7D 3MI JNL,\r
+ 7E 3MI JLE, 7E 3MI JNG,\r
+ 7F 3MI JG, 7F 3MI JNLE,\r
+ E3 3MI JCXZ,\r
+ EB 3MI JU,\r
+\r
+\ ----------------------------------------------------------------------------\r
+\r
+: INIT-ASM \ initializes local labels and switches.\r
+ FWDS 2 CELLS + DUP FWDS !\r
+ MXL# 2* CELLS + FWDS CELL+ !\r
+ BWDS MXL# CELLS 0 FILL\r
+ 0 FAR= ! WORD ;\r
+\r
+: END-CODE\r
+ PREVIOUS notNONAME? IF linkLast 0 TO notNONAME? THEN ;\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : NEXT, ( a macro)\r
+ AD codeB, \ LODSW\r
+ E0FF code2B, ; \ JMP AX\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : NEXT, ( a macro)\r
+ 2E codeB, \ CS:\r
+ AD codeB, \ LODSW\r
+ E0FF code2B, ; \ JMP AX\r
+[THEN]\r
+\r
+\ ----------------------------------------------------------------------------\r
+\r
+FORTH-WORDLIST SET-CURRENT \ add the following word in FORTH-WORDLIST\r
+\r
+\ CODE ( '<spaces>name' -- ) \ TOOLS EXT\r
+\ Skip leading space delimiters. Parse name delimited by a\r
+\ space. Create a definition for name, called a\r
+\ 'code definition,' with the execution semantics defined below.\r
+\ Process subsequent characters in the parse area in an\r
+\ implementation-defined manner, thus generating corresponding\r
+\ machine code. Those characters typically represent source code\r
+\ in a programming language, usually some form of assembly\r
+\ language. The process continues, refilling the input buffer\r
+\ as needed, until an implementation-defined ending sequence is\r
+\ processed.\r
+\\r
+\ name Execution:( i*x --- j*x )\r
+\ Execute the machine code sequence that was generated\r
+\ following CODE.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : CODE ( "<spaces>name" -- ) \ TOOLS EXT\r
+ -1 TO notNONAME?\r
+ xhere ALIGNED DUP TOxhere \ align code address\r
+ head, \ register a word in dictionary\r
+ ALSO ASSEMBLER\r
+ INIT-ASM ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : CODE ( "<spaces>name" -- ) \ TOOLS EXT\r
+ -1 TO notNONAME?\r
+ ALIGN head, \ register a word in dictionary\r
+ ALSO ASSEMBLER\r
+ INIT-ASM ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : CODE ( "<spaces>name" -- )\r
+ -1 TO notNONAME?\r
+ xhere ALIGNED \ align code address and reserve\r
+ CELL+ DUP TO xhere \ one cell for 'xt>name' pointer\r
+ head, \ register a word in dictionary\r
+ ALSO ASSEMBLER\r
+ INIT-ASM ;\r
+[THEN]\r
+\r
+\ ;CODE Compilation: ( C: colon-sys -- ) \ TOOLS EXT\r
+\ Interpretation: Interpretation semantics for this word\r
+\ are undefined.\r
+\ Append the run-time semantics below to the current definition.\r
+\ End the current definition, allow it to be found in the\r
+\ dictionary, and enter interpretation state, consuming\r
+\ colon-sys. Process subsequent characters in the parse area in\r
+\ an implementation-defined manner, thus generating corresponding\r
+\ machine code. Those characters typically represent source code\r
+\ in a programming language, usually some form of assembly\r
+\ language. The process continues, refilling the input buffer as\r
+\ needed, until an implementation-defined ending sequence is\r
+\ processed.\r
+\\r
+\ Run-time:( -- ) ( R: nest-sys -- )\r
+\ Replace the execution semantics of the most recent definition\r
+\ with the name execution semantics given below. Return control\r
+\ to the calling definition specified by nest-sys. An ambiguous\r
+\ condition exists if the most recen definition was not defined\r
+\ with CREATE or a user-defined word that calls CREATE.\r
+\\r
+\ name Execution:( i*x --- j*x )\r
+\ Perform the machine code sequence that was generated\r
+\ following ;CODE.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+: ;CODE\r
+ bal 1- IF -22 THROW THEN \ control structure mismatch\r
+ NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+ bal- POSTPONE [\r
+ xhere 2 CELLS - TOxhere\r
+ ALSO ASSEMBLER INIT-ASM\r
+ ; COMPILE-ONLY IMMEDIATE\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+: ;CODE\r
+ bal 1- IF -22 THROW THEN \ control structure mismatch\r
+ NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+ bal- POSTPONE [\r
+ HERE 2 CELLS - TO HERE\r
+ ALSO ASSEMBLER INIT-ASM\r
+ ; COMPILE-ONLY IMMEDIATE\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+: ;CODE\r
+ bal 1- IF -22 THROW THEN \ control structure mismatch\r
+ NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+ bal- POSTPONE [\r
+ xhere 2 CELLS - TO xhere\r
+ ALSO ASSEMBLER INIT-ASM\r
+ ; COMPILE-ONLY IMMEDIATE\r
+[THEN]\r
+\r
+\ Define some useful non-Standard CODE definitions\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+CODE PC@ ( portAddr -- char )\r
+ BX DX MOV, \ MOV DX,BX\r
+ DX AL IN, \ IN AL,DX\r
+ BX BX XOR, \ XOR BX,BX\r
+ AL BL MOV, \ MOV BL,AL\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE PC! ( char portAddr -- )\r
+ BX DX MOV, \ MOV DX,BX\r
+ AX POP, \ POP AX\r
+ DX AL OUT, \ OUT DX,AL\r
+ BX POP, \ POP BX\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE L@ ( segment offset -- x )\r
+ DS DX MOV, \ MOV DX,DS\r
+ DS POP, \ POP DS\r
+ 0 [BX] BX MOV, \ MOV BX,[BX]\r
+ DX DS MOV, \ MOV DS,DX\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE LC@ ( segment offset -- char )\r
+ DS DX MOV, \ MOV DX,DS\r
+ DS POP, \ POP DS\r
+ 0 [BX] BL MOV, \ MOV BL,[BX]\r
+ BH BH XOR, \ XOR BH,BH\r
+ DX DS MOV, \ MOV DS,DX\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE L! ( x segment offset -- )\r
+ DS DX MOV, \ MOV DX,DS\r
+ DS POP, \ POP DS\r
+ 0 [BX] POP, \ POP [BX]\r
+ DX DS MOV, \ MOV DS,DX\r
+ BX POP, \ POP BX\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE LC! ( char segment offset -- )\r
+ DS DX MOV, \ MOV DX,DS\r
+ DS POP, \ POP DS\r
+ AX POP, \ POP AX\r
+ AL 0 [BX] MOV, \ MOV [BX],AL\r
+ DX DS MOV, \ MOV DS,DX\r
+ BX POP, \ POP BX\r
+ NEXT,\r
+END-CODE\r
+\r
+DECIMAL\r
+: LDUMP ( segment offset u -- )\r
+ ?DUP\r
+ IF BASE @ >R HEX \ segment offset u R: BASE@\r
+ 1- 16 / 1+\r
+ 0 DO CR OVER 4 U.R [CHAR] : EMIT DUP 4 U.R SPACE 2DUP\r
+ 16 0 DO 2DUP LC@ 3 U.R CHAR+ LOOP\r
+ 2SWAP SPACE SPACE\r
+ 16 0 DO 2DUP LC@ 127 AND DUP 0 BL WITHIN\r
+ OVER 127 = OR\r
+ IF DROP [CHAR] _ THEN\r
+ EMIT CHAR+\r
+ LOOP 2DROP\r
+ enough? IF LEAVE THEN\r
+ LOOP\r
+ R> BASE !\r
+ THEN 2DROP ;\r
+\r
+CODE DS@ ( -- data_segment_addr )\r
+ BX PUSH,\r
+ DS BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE CS@ ( -- code_segment_addr )\r
+ BX PUSH,\r
+ CS BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+envQList SET-CURRENT\r
+-1 CONSTANT ASM8086\r
+\r
+SET-CURRENT SET-ORDER\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM! [THEN]\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\ ASSEMBLER TEST PROGRAM\r
+\r
+CHAR " PARSE CPU" ENVIRONMENT? DROP\r
+CHAR " PARSE 8086" COMPARE\r
+[IF] CR .( This assembler is for 8086 only.) ABORT [THEN]\r
+\r
+BASE @\r
+GET-ORDER\r
+MARKER ~ASMTEST\r
+\r
+VARIABLE TEST-POINTER\r
+\r
+: 2CONSTANT\r
+ CREATE , , DOES> 2@ ;\r
+\r
+: INIT-TEST ( -- )\r
+ xhere TEST-POINTER ! ;\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : ZZ ( N1 ... NN -- )\r
+ xhere\r
+ BEGIN ( n ... n addr)\r
+ 1- DUP C@\r
+ ROT <> IF\r
+ TEST-POINTER @ 10 DUMP\r
+ -1 ABORT" failed"\r
+ THEN\r
+ DUP\r
+ TEST-POINTER @ = UNTIL\r
+ DROP\r
+ INIT-TEST ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : ZZ ( N1 ... NN -- )\r
+ xhere\r
+ BEGIN ( n ... n addr)\r
+ 1- DUP codeB@\r
+ ROT <> IF\r
+ TEST-POINTER @ 10 DUMP\r
+ -1 ABORT" failed"\r
+ THEN\r
+ DUP\r
+ TEST-POINTER @ = UNTIL\r
+ DROP\r
+ INIT-TEST ;\r
+[THEN]\r
+\r
+\ ---------- all is in hex from here to end\r
+\r
+HEX\r
+\r
+ALSO ASSEMBLER\r
+\r
+INIT-ASM\r
+\r
+\ ----------\r
+\r
+1234 CONSTANT BVAR\r
+1235 CONSTANT WVAR\r
+1237 CONSTANT LVAR\r
+\r
+123B CONSTANT SUBR\r
+\r
+9876 5432 2CONSTANT FARSUB\r
+\r
+\ ----------\r
+\r
+INIT-TEST\r
+\r
+AAA, 37 ZZ\r
+AAD, D5 0A ZZ\r
+AAM, D4 0A ZZ\r
+AAS, 3F ZZ\r
+\r
+DX BX ADC, 11 D3 ZZ\r
+0 [BX+SI] CX ADC, 13 08 ZZ\r
+CX 0 [BX+SI] ADC, 11 08 ZZ\r
+3456 # WVAR ) ADC, 81 16 35 12 56 34 ZZ\r
+5 # AX ADC, 15 05 00 ZZ\r
+\r
+\ ----------\r
+\r
+BX SP ADD, 01 DC ZZ\r
+ES: 967 [BX+DI] BP ADD, 26 03 A9 67 09 ZZ\r
+AX 967 [BX+DI] ADD, 01 81 67 09 ZZ\r
+AX 0 [BX+DI] ADD, 01 01 ZZ\r
+6789 # SI ADD, 81 C6 89 67 ZZ\r
+5432 # WVAR ) WORD ADD, 81 06 35 12 32 54 ZZ\r
+5 # AX ADD, 05 05 00 ZZ\r
+SP DI AND, 21 E7 ZZ\r
+DS: 1234 [BP+SI] BL AND, 3E 22 9A 34 12 ZZ\r
+BP CS: 4567 [BP+SI] AND, 2E 21 AA 67 45 ZZ\r
+BP 0 [BP+SI] AND, 21 2A ZZ\r
+6789 # BX AND, 81 E3 89 67 ZZ\r
+1234 # WVAR ) WORD AND, 81 26 35 12 34 12 ZZ\r
+5 # AL AND, 24 05 ZZ\r
+\r
+\ ----------\r
+\r
+xhere 48 - # CALL, E8 B5 FF ZZ\r
+FARSUB # FAR CALL, 9A 76 98 32 54 ZZ\r
+WVAR [BP+DI] CALL, FF 93 35 12 ZZ\r
+0 [BP+DI] CALL, FF 13 ZZ\r
+CX CALL, FF D1 ZZ\r
+LVAR ) FAR CALL, FF 1E 37 12 ZZ\r
+\r
+CBW, 98 ZZ\r
+CLC, F8 ZZ\r
+CLD, FC ZZ\r
+CLI, FA ZZ\r
+CMC, F5 ZZ\r
+\r
+\ ----------\r
+\r
+67 # CH CMP, 82 FD 67 ZZ\r
+ AH BH CMP, 38 E7 ZZ\r
+0 [SI] CL CMP, 3A 0C ZZ\r
+SS: AL 0 [SI] CMP, 36 38 04 ZZ\r
+ 9678 # WVAR ) WORD CMP, 81 3E 35 12 78 96 ZZ\r
+ 5432 # AX CMP, 3D 32 54 ZZ\r
+\r
+BYTE CMPS, A6 ZZ\r
+WORD CMPS, A7 ZZ\r
+\r
+CWD, 99 ZZ\r
+\r
+\ ----------\r
+\r
+DAA, 27 ZZ\r
+DAS, 2F ZZ\r
+\r
+BX DEC, 4B ZZ\r
+BL DEC, FE CB ZZ\r
+BVAR [SI] BYTE DEC, FE 8C 34 12 ZZ\r
+WVAR [DI] WORD DEC, FF 8D 35 12 ZZ\r
+0 [SI] WORD DEC, FF 0C ZZ\r
+\r
+CL DIV, F6 F1 ZZ\r
+BX DIV, F7 F3 ZZ\r
+BVAR ) BYTE DIV, F6 36 34 12 ZZ\r
+HLT, F4 ZZ\r
+\r
+\ ----------\r
+\r
+CL IDIV, F6 F9 ZZ\r
+BX IDIV, F7 FB ZZ\r
+BVAR ) BYTE IDIV, F6 3E 34 12 ZZ\r
+\r
+CL IMUL, F6 E9 ZZ\r
+BX IMUL, F7 EB ZZ\r
+BVAR ) BYTE IMUL, F6 2E 34 12 ZZ\r
+\r
+7B # AL IN, E4 7B ZZ\r
+7B # AX IN, E5 7B ZZ\r
+DX AL IN, EC ZZ\r
+DX AX IN, ED ZZ\r
+\r
+\ ----------\r
+\r
+AX INC, 40 ZZ\r
+AL INC, FE C0 ZZ\r
+5 [SI] BYTE INC, FE 44 05 ZZ\r
+0 [BP] WORD INC, FF 46 00 ZZ\r
+\r
+17 INT, CD 17 ZZ\r
+3 INT, CC ZZ\r
+\r
+INTO, CE ZZ\r
+\r
+IRET, CF ZZ\r
+\r
+\ ----------\r
+\r
+xhere 3 + JA, 77 01 ZZ\r
+xhere 4 - JA, 77 FA ZZ\r
+\r
+xhere 3 + JAE, 73 01 ZZ\r
+xhere 4 - JNC, 73 FA ZZ\r
+\r
+xhere 3 + JB, 72 01 ZZ\r
+xhere 4 - JC, 72 FA ZZ\r
+\r
+xhere 3 + JBE, 76 01 ZZ\r
+xhere 4 - JBE, 76 FA ZZ\r
+\r
+\ ----------\r
+\r
+xhere 3 + JCXZ, E3 01 ZZ\r
+\r
+xhere 3 + JE, 74 01 ZZ\r
+xhere 4 - JZ, 74 FA ZZ\r
+\r
+xhere 3 + JG, 7F 01 ZZ\r
+xhere 4 - JG, 7F FA ZZ\r
+\r
+xhere 3 + JGE, 7D 01 ZZ\r
+xhere 4 - JGE, 7D FA ZZ\r
+\r
+\ ----------\r
+\r
+xhere 3 + JL, 7C 01 ZZ\r
+xhere 4 - JL, 7C FA ZZ\r
+\r
+xhere 3 + JLE, 7E 01 ZZ\r
+xhere 4 - JLE, 7E FA ZZ\r
+\r
+xhere 7 + JU, EB 05 ZZ\r
+\r
+xhere 1234 + # JMP, E9 31 12 ZZ\r
+FARSUB # FAR JMP, EA 76 98 32 54 ZZ\r
+WVAR ) JMP, FF 26 35 12 ZZ\r
+BX JMP, FF E3 ZZ\r
+LVAR [SI] FAR JMP, FF AC 37 12 ZZ\r
+0 [SI] FAR JMP, FF 2C ZZ\r
+\r
+\ ----------\r
+\r
+xhere 3 + JNE, 75 01 ZZ\r
+xhere 4 - JNZ, 75 FA ZZ\r
+\r
+xhere 3 + JNO, 71 01 ZZ\r
+xhere 3 + JNS, 79 01 ZZ\r
+\r
+xhere 3 + JPO, 7B 01 ZZ\r
+xhere 4 - JPO, 7B FA ZZ\r
+\r
+\ ----------\r
+\r
+xhere 3 + JO, 70 01 ZZ\r
+\r
+xhere 3 + JPE, 7A 01 ZZ\r
+xhere 4 - JPE, 7A FA ZZ\r
+\r
+xhere 3 + JS, 78 01 ZZ\r
+\r
+LAHF, 9F ZZ\r
+\r
+LVAR [BX] AX LDS, C5 87 37 12 ZZ\r
+0 [BX] AX LDS, C5 07 ZZ\r
+\r
+LVAR [BX] BX LEA, 8D 9F 37 12 ZZ\r
+0 [BX] BX LEA, 8D 1F ZZ\r
+\r
+\ ----------\r
+\r
+LVAR [BX] BX LES, C4 9F 37 12 ZZ\r
+0 [BX] BX LES, C4 1F ZZ\r
+\r
+LOCK, BYTE LODS, F0 AC ZZ\r
+WORD LODS, AD ZZ\r
+\r
+xhere 8 - LOOP, E2 F6 ZZ\r
+xhere 9 - LOOPE, E1 F5 ZZ\r
+xhere 3 + LOOPNE, E0 01 ZZ\r
+\r
+\ ----------\r
+\r
+0 [SI] SI MOV, 8B 34 ZZ\r
+2 [SI] SI MOV, 8B 74 02 ZZ\r
+DS: AL BVAR [BP] MOV, 3E 88 86 34 12 ZZ\r
+AX WVAR [BX] MOV, 89 87 35 12 ZZ\r
+AX 0 [BX] MOV, 89 07 ZZ\r
+DS: BVAR [BP] AL MOV, 3E 8A 86 34 12 ZZ\r
+WVAR [BX] AX MOV, 8B 87 35 12 ZZ\r
+DX CX MOV, 8B CA ZZ\r
+DX AX MOV, 8B C2 ZZ\r
+WVAR ) BP MOV, 8B 2E 35 12 ZZ\r
+BP WVAR ) MOV, 89 2E 35 12 ZZ\r
+9876 # DX MOV, BA 76 98 ZZ\r
+1 # DX MOV, BA 01 00 ZZ\r
+1 # DL MOV, B2 01 ZZ\r
+LVAR # WORD WVAR ) MOV, C7 06 35 12 37 12 ZZ\r
+67 # BVAR ) BYTE MOV, C6 06 34 12 67 ZZ\r
+CX SS MOV, 8E D1 ZZ\r
+DS CX MOV, 8C D9 ZZ\r
+WVAR ) ES MOV, 8E 06 35 12 ZZ\r
+CS WVAR ) MOV, 8C 0E 35 12 ZZ\r
+\r
+BYTE MOVS, A4 ZZ\r
+WORD MOVS, A5 ZZ\r
+\r
+\ ----------\r
+\r
+CL MUL, F6 E1 ZZ\r
+BX MUL, F7 E3 ZZ\r
+BVAR ) BYTE MUL, F6 26 34 12 ZZ\r
+\r
+BL NEG, F6 DB ZZ\r
+BX NEG, F7 DB ZZ\r
+WVAR [BX] WORD NEG, F7 9F 35 12 ZZ\r
+\r
+NOP, 90 ZZ\r
+BL NOT, F6 D3 ZZ\r
+BX NOT, F7 D3 ZZ\r
+WVAR [BX] WORD NOT, F7 97 35 12 ZZ\r
+0 [BX] WORD NOT, F7 17 ZZ\r
+\r
+\ ----------\r
+\r
+BH DL OR, 08 FA ZZ\r
+0 [SI] DH OR, 0A 34 ZZ\r
+BL 0 [SI] OR, 08 1C ZZ\r
+6789 # BX OR, 81 CB 89 67 ZZ\r
+7698 # WVAR ) WORD OR, 81 0E 35 12 98 76 ZZ\r
+5 # AX OR, 0D 05 00 ZZ\r
+\r
+44 # AX OUT, E7 44 ZZ\r
+45 # AL OUT, E6 45 ZZ\r
+DX AX OUT, EF ZZ\r
+DX AL OUT, EE ZZ\r
+\r
+\ ----------\r
+\r
+AX POP, 58 ZZ\r
+ES POP, 07 ZZ\r
+WVAR [BX] WORD POP, 8F 87 35 12 ZZ\r
+\r
+POPF, 9D ZZ\r
+\r
+AX PUSH, 50 ZZ\r
+CS PUSH, 0E ZZ\r
+WVAR [BX] WORD PUSH, FF B7 35 12 ZZ\r
+0 [BX] WORD PUSH, FF 37 ZZ\r
+\r
+PUSHF, 9C ZZ\r
+\r
+\ ----------\r
+\r
+CX 1 RCL, D1 D1 ZZ\r
+AX CL RCL, D3 D0 ZZ\r
+WVAR ) WORD RCL, D1 16 35 12 ZZ\r
+WVAR ) CL WORD RCL, D3 16 35 12 ZZ\r
+\r
+CL 1 RCR, D0 D9 ZZ\r
+AL CL RCR, D2 D8 ZZ\r
+BVAR ) BYTE RCR, D0 1E 34 12 ZZ\r
+BVAR ) CL BYTE RCR, D2 1E 34 12 ZZ\r
+\r
+\ ----------\r
+\r
+REP, BYTE LODS, F3 AC ZZ\r
+REPE, BYTE LODS, F3 AC ZZ\r
+REPNE, BYTE LODS, F2 AC ZZ\r
+\r
+RET, C3 ZZ\r
+5 +RET, C2 05 00 ZZ\r
+FAR RET, CB ZZ\r
+1234 FAR +RET, CA 34 12 ZZ\r
+\r
+\r
+\ ----------\r
+\r
+CL 1 ROR, D0 C9 ZZ\r
+\r
+AL CL ROR, D2 C8 ZZ\r
+BVAR ) BYTE ROR, D0 0E 34 12 ZZ\r
+BVAR ) CL BYTE ROR, D2 0E 34 12 ZZ\r
+\r
+\r
+CL 1 ROL, D0 C1 ZZ\r
+AL CL ROL, D2 C0 ZZ\r
+BVAR ) BYTE ROL, D0 06 34 12 ZZ\r
+BVAR ) CL BYTE ROL, D2 06 34 12 ZZ\r
+\r
+SAHF, 9E ZZ\r
+\r
+\r
+\ ----------\r
+\r
+CL 1 SHL, D0 E1 ZZ\r
+AL CL SHL, D2 E0 ZZ\r
+BVAR ) BYTE SHL, D0 26 34 12 ZZ\r
+BVAR ) CL BYTE SHL, D2 26 34 12 ZZ\r
+\r
+\ ----------\r
+\r
+CL 1 SAR, D0 F9 ZZ\r
+AL CL SAR, D2 F8 ZZ\r
+BVAR ) BYTE SAR, D0 3E 34 12 ZZ\r
+BVAR ) CL BYTE SAR, D2 3E 34 12 ZZ\r
+\r
+CH BH SBB, 18 EF ZZ\r
+0 [SI] CX SBB, 1B 0C ZZ\r
+CL 0 [SI] SBB, 18 0C ZZ\r
+6789 # BX SBB, 81 DB 89 67 ZZ\r
+9988 # WVAR ) WORD SBB, 81 1E 35 12 88 99 ZZ\r
+5 # AX SBB, 1D 05 00 ZZ\r
+\r
+\ ----------\r
+\r
+BYTE SCAS, AE ZZ\r
+WORD SCAS, AF ZZ\r
+\r
+CL 1 SHR, D0 E9 ZZ\r
+AL CL SHR, D2 E8 ZZ\r
+BVAR ) BYTE SHR, D0 2E 34 12 ZZ\r
+BVAR ) CL BYTE SHR, D2 2E 34 12 ZZ\r
+\r
+STC, F9 ZZ\r
+\r
+STD, FD ZZ\r
+\r
+\ ----------\r
+\r
+STI, FB ZZ\r
+\r
+BYTE STOS, AA ZZ\r
+WORD STOS, AB ZZ\r
+\r
+DH DL SUB, 28 F2 ZZ\r
+0 [SI] CX SUB, 2B 0C ZZ\r
+DL 0 [SI] SUB, 28 14 ZZ\r
+6789 # BX SUB, 81 EB 89 67 ZZ\r
+1234 # WVAR ) WORD SUB, 81 2E 35 12 34 12 ZZ\r
+5 # AX SUB, 2D 05 00 ZZ\r
+\r
+\ ----------\r
+\r
+SI SI TEST, 85 F6 ZZ\r
+CX 0 [SI] TEST, 85 0C ZZ\r
+6789 # BX TEST, F7 C3 89 67 ZZ\r
+1239 # WVAR ) WORD TEST, F7 06 35 12 39 12 ZZ\r
+5 # AX TEST, A9 05 00 ZZ\r
+\r
+WAIT, 9B ZZ\r
+\r
+DI AX XCHG, 97 ZZ\r
+BL AL XCHG, 86 C3 ZZ\r
+BX CX XCHG, 87 CB ZZ\r
+DX WVAR ) XCHG, 87 16 35 12 ZZ\r
+\r
+\ ----------\r
+\r
+XLAT, D7 ZZ\r
+\r
+BX SI XOR, 31 DE ZZ\r
+0 [SI] CX XOR, 33 0C ZZ\r
+DX 0 [SI] XOR, 31 14 ZZ\r
+6789 # BX XOR, 81 F3 89 67 ZZ\r
+1234 # WVAR ) WORD XOR, 81 36 35 12 34 12 ZZ\r
+5 # AX XOR, 35 05 00 ZZ\r
+\r
+\ ----------\r
+\r
+INIT-ASM\r
+1 L: BX POP,\r
+ BX POP,\r
+ 1 L# JNZ, 5B 5B 75 FC ZZ\r
+\r
+ 2 L# JNZ,\r
+ BX POP,\r
+ BX POP,\r
+2 L: BX POP, 75 02 5B 5B 5B ZZ\r
+\r
+3 L: BX POP,\r
+ 4 L# JNZ,\r
+ BX POP,\r
+ 3 L# JNZ,\r
+4 L: BX POP, 5B 75 03 5B 75 FA 5B ZZ\r
+\r
+5 L: BX POP,\r
+ 6 L# JNZ,\r
+ BX POP,\r
+ 6 L# JNZ,\r
+ BX POP,\r
+6 L: BX POP,\r
+ 5 L# JNZ, 5B 75 04 5B 75 01 5B 5B 75 F6 ZZ\r
+\r
+\r
+\ ---------- back to decimal here\r
+\r
+~ASMTEST\r
+SET-ORDER\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\\r
+\ CLOCK.F\r
+\ Displaying time on screen using hForth multitasker\r
+\ HIOMULTI.F or HIOMULT2.F must be loaded first.\r
+\\r
+\ 1995. 11. 5.\r
+\ Wonyong Koh\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+\r
+Ðe\8bi·³Â\89\9db-WORDLIST GET-ORDER 1+ SET-ORDER\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+DECIMAL\r
+0 60 CELLS 60 CELLS HAT CLOCK CLOCK BUILD\r
+\r
+:NONAME CLOCK ACTIVATE\r
+ BEGIN\r
+ \8cq¤b·± @ 0 DO PAUSE LOOP\r
+ GRAPHIC? SCREEN-UPDATED? AND IF\r
+ BASE @ DECIMAL\r
+ MAX-X 20 - DUP >R\r
+ 0 BL EFONT!\r
+ TIME&DATE DROP DROP DROP \ second minute hour\r
+ 12 MOD\r
+ S>D <# # # #>\r
+ R> 1+ DUP >R 0 2SWAP xySTR!\r
+ R> 2 + DUP >R 0 [CHAR] : EFONT!\r
+ S>D <# # # #>\r
+ R> 1+ DUP >R 0 2SWAP xySTR!\r
+ R> 2 + DUP >R 0 [CHAR] : EFONT!\r
+ S>D <# # # #>\r
+ R> 1+ DUP >R 0 2SWAP xySTR!\r
+ R> 2 + 0 BL EFONT!\r
+ BASE ! THEN\r
+ AGAIN\r
+; EXECUTE\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
--- /dev/null
+\\r
+\ COREEXT.F\r
+\ More Core Extention wordset words for hForth - code definitions\r
+\\r
+\ COREEXT.F can be loaded as following order:\r
+\\r
+\ << OPTIONAL.F\r
+\ << ASM8086.F\r
+\ << COREEXT.F\r
+\\r
+\ 1996. 2. 9.\r
+\ Wonyong Koh\r
+\\r
+\ 1997. 6. 5.\r
+\ Fix colon definition of do?DO.\r
+\ 1997. 2. 28.\r
+\ Facelift to be used with other CPUs.\r
+\ 1996. 11. 29.\r
+\ Provide CODE definition of ROLL.\r
+\ Revise '?DO' for control-flow stack.\r
+\ Revise 'C"' to catch exception -24 'parsed string overflow'.\r
+\r
+BASE @\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM@ [THEN]\r
+GET-ORDER GET-CURRENT\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ <> ( x1 x2 -- flag ) \ CORE EXT\r
+\ Return false if x1 is the same as x2.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : <> = 0= ;\r
+[ELSE] DROP\r
+ CODE <>\r
+ AX POP,\r
+ AX BX CMP,\r
+ -1 # BX MOV,\r
+ 1 L# JNE,\r
+ BX INC,\r
+ 1 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ 0<> ( x -- flag ) \ CORE EXT\r
+\ flag is true if and only if x is not equal to zero.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : 0<> 0 <> ;\r
+[ELSE] DROP\r
+ CODE 0<>\r
+ BX BX OR,\r
+ -1 # BX MOV,\r
+ 1 L# JNZ,\r
+ BX INC,\r
+ 1 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ 0> ( n -- flag ) \ CORE EXT\r
+\ flag is true if and only if n is greater than zero.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : 0> 0 > ;\r
+[ELSE] DROP\r
+ CODE 0>\r
+ BX AX MOV,\r
+ AX DEC,\r
+ CWD,\r
+ DX NOT,\r
+ DX BX MOV,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ 2>R ( x1 x2 -- ) ( R: -- x1 x2 ) \ CORE EXT\r
+\ Transfer cell pair to the return stack.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : 2>R SWAP R> SWAP >R SWAP >R >R ;\r
+[ELSE] DROP\r
+ CODE 2>R\r
+ AX POP,\r
+ 2 CELLS # BP SUB,\r
+ AX 1 CELLS [BP] MOV,\r
+ BX 0 [BP] MOV,\r
+ BX POP,\r
+ NEXT,\r
+ END-CODE COMPILE-ONLY\r
+[THEN]\r
+\r
+\ 2R> ( -- x1 x2 ) ( R: x1 x2 -- ) \ CORE EXT\r
+\ Transfer cell pair from the return stack.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : 2R> R> R> SWAP R> SWAP >R SWAP ;\r
+[ELSE] DROP\r
+ CODE 2R>\r
+ BX PUSH,\r
+ 1 CELLS [BP] AX MOV,\r
+ 0 [BP] BX MOV,\r
+ AX PUSH,\r
+ 2 CELLS # BP ADD,\r
+ NEXT,\r
+ END-CODE COMPILE-ONLY\r
+[THEN]\r
+\r
+\ 2R@ ( -- x1 x2 ) ( R: x1 x2 -- x1 x2 ) \ CORE EXT\r
+\ Copy cell pair from the return stack.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : 2R@ R> R> R> 2DUP >R >R SWAP ROT >R ;\r
+[ELSE] DROP\r
+ CODE 2R@\r
+ BX PUSH,\r
+ 1 CELLS [BP] AX MOV,\r
+ 0 [BP] BX MOV,\r
+ AX PUSH,\r
+ NEXT,\r
+ END-CODE COMPILE-ONLY\r
+[THEN]\r
+\r
+HEX\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+\ do?DO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )\r
+\ Run-time funtion of ?DO.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ CHAR " PARSE model" ENVIRONMENT? DROP\r
+ CHAR " PARSE ROM Model" COMPARE 0=\r
+ CHAR " PARSE model" ENVIRONMENT? DROP\r
+ CHAR " PARSE RAM Model" COMPARE 0= OR\r
+ [IF]\r
+ : do?DO\r
+ 2DUP = IF 2DROP R> @ >R EXIT THEN\r
+ >R\r
+ \ get max-negative\r
+ [ -1 BL PARSE MAX-N ENVIRONMENT? DROP - ] LITERAL\r
+ + R> OVER - SWAP R> SWAP >R SWAP >R CELL+ >R ; COMPILE-ONLY\r
+ [THEN]\r
+ CHAR " PARSE model" ENVIRONMENT? DROP\r
+ CHAR " PARSE EXE Model" COMPARE 0=\r
+ [IF]\r
+ : do?DO\r
+ 2DUP = IF 2DROP R> code@ >R EXIT THEN\r
+ >R\r
+ \ get max-negative\r
+ [ -1 BL PARSE MAX-N ENVIRONMENT? DROP - ] LITERAL\r
+ + R> OVER - SWAP R> SWAP >R SWAP >R CELL+ >R ; COMPILE-ONLY\r
+ [THEN]\r
+[ELSE] DROP\r
+ CODE do?DO\r
+ AX POP,\r
+ AX BX CMP,\r
+ 1 L# JE,\r
+ 1 CELLS # SI ADD,\r
+ 2 CELLS # BP SUB,\r
+ 8000 # AX ADD,\r
+ AX 1 CELLS [BP] MOV,\r
+ AX BX SUB,\r
+ BX 0 [BP] MOV,\r
+ BX POP,\r
+ NEXT,\r
+ 1 L:\r
+ BX POP,\r
+ CS:\r
+ 0 [SI] SI MOV,\r
+ NEXT,\r
+ END-CODE COMPILE-ONLY\r
+[THEN]\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ ?DO ( C: -- do-sys ) \ CORE EXT\r
+\ Run-time: ( n1|u1 n2|u2 -- ) ( R: -- | loop-sys )\r
+\ Start a ?DO ... LOOP structure in a colon definition.\r
+\ On execution do as DO only if n1|u1 is not equal to n2|u2.\r
+: ?DO\r
+ 0 rakeVar !\r
+ POSTPONE do?DO xhere 0 code, \ leave ?DO-orig\r
+ xhere bal+ \ leave DO-dest\r
+ ; COMPILE-ONLY IMMEDIATE\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ NONSTANDARD-WORDLIST SET-CURRENT\r
+ : doC" ( -- c-addr ) R> DUP COUNT + ALIGNED >R ; COMPILE-ONLY\r
+ FORTH-WORDLIST SET-CURRENT\r
+[THEN]\r
+\r
+\ C" ( "ccc<">" -- )\r
+\ Run-time: ( -- c-addr )\r
+\ Parse ccc delimetered by " . Return the counted string, c-addr.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : C" [CHAR] " PARSE\r
+ DUP [ BL PARSE /COUNTED-STRING ENVIRONMENT? DROP ] LITERAL\r
+ > IF -18 THROW THEN \ parsed string overflow\r
+ POSTPONE doC" xhere pack" TOxhere ; COMPILE-ONLY IMMEDIATE\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : C" [CHAR] " PARSE\r
+ DUP [ BL PARSE /COUNTED-STRING ENVIRONMENT? DROP ] LITERAL\r
+ > IF -18 THROW THEN \ parsed string overflow\r
+ POSTPONE doC" HERE pack" TO HERE ; COMPILE-ONLY IMMEDIATE\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : C" [CHAR] " PARSE\r
+ DUP [ BL PARSE /COUNTED-STRING ENVIRONMENT? DROP ] LITERAL\r
+ > IF -18 THROW THEN \ parsed string overflow\r
+ ALIGN HERE DUP POSTPONE LITERAL\r
+ pack" ALIGNED TO HERE ; COMPILE-ONLY IMMEDIATE\r
+[THEN]\r
+\r
+\ ERASE ( addr u -- ) \ CORE EXT\r
+\ If u is greater than zero, clear all bits in each of u\r
+\ consecutive address units of memory beginning at addr .\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ CR .( ERASE need to be CODE defined.) CR\r
+ .( No ANS Standard word except MOVE and ERASE can access address unit directly.)\r
+\ ABORT\r
+[ELSE] DROP\r
+ CODE ERASE\r
+ DI POP,\r
+ BX BX OR,\r
+ 1 L# JZ,\r
+ DS AX MOV,\r
+ AX ES MOV, \ set ES same as DS\r
+ SI DX MOV, \ save SI\r
+ DI SI MOV,\r
+ AL AL XOR,\r
+ AL 0 [SI] MOV,\r
+ BX CX MOV,\r
+ DI INC,\r
+ CX DEC,\r
+ REP, BYTE MOVS,\r
+ DX SI MOV,\r
+ 1 L:\r
+ BX POP,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ ROLL ( xu xu-1 ... x0 u -- xu-1 ... x0 xu ) \ CORE EXT\r
+\ Remove u. Rotate u+1 items on the top of the stack. An\r
+\ ambiguous condition exists if there are less than u+2 items\r
+\ on the stack before ROLL is executed.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : ROLL\r
+ DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow\r
+ 2 - OVER U< IF -4 THROW THEN\r
+ DUP 1+ PICK >R >R \ x_u ... x1 x0 R: x_u u\r
+ sp@ DUP CELL+ R> CELLS MOVE DROP R> ;\r
+[ELSE] DROP\r
+ CODE ROLL\r
+ userP ) DI MOV,\r
+ 1 CELLS [DI] DI MOV, \ sp0\r
+ SP DI SUB,\r
+ DI 1 SAR, \ depth-1 in DI\r
+ DI DEC,\r
+ 1 L# JS,\r
+ BX DI CMP,\r
+ 1 L# JB,\r
+ SI DX MOV,\r
+ BX CX MOV,\r
+ BX 1 SHL,\r
+ SP BX ADD,\r
+ BX DI MOV,\r
+ DI SI MOV,\r
+ 1 CELLS # SI SUB,\r
+ 0 [BX] BX MOV,\r
+ STD,\r
+ REP, WORD MOVS,\r
+ CLD,\r
+ AX POP,\r
+ DX SI MOV,\r
+ NEXT,\r
+ 1 L:\r
+ -4 # BX MOV,\r
+ ' THROW # JMP,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ TUCK ( x1 x2 -- x2 x1 x2 ) \ CORE EXT\r
+\ Copy the first (top) stack item below the second stack item.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : TUCK SWAP OVER ;\r
+[ELSE] DROP\r
+ CODE TUCK\r
+ AX POP,\r
+ BX PUSH,\r
+ AX PUSH,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ U> ( u1 u2 -- flag ) \ CORE EXT\r
+\ flag is true if and only if u1 is greater than u2.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : U> SWAP U< ;\r
+[ELSE] DROP\r
+CODE U>\r
+ AX POP,\r
+ AX BX CMP,\r
+ -1 # BX MOV,\r
+ 1 L# JB,\r
+ BX INC,\r
+ 1 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ CS-PICK \ TOOLS EXT\r
+\ Execution: ( C: destu ... orig0|dest0 -- destu ... orig0|dest0 destu )\r
+\ ( S: u -- )\r
+\ Interpretation: Interpretation semantics for this word are undefined.\r
+\\r
+\ Remove u. Copy destu to the top of the control-flow\r
+\ stack. An ambiguous condition exists if there are\r
+\ less than u+1 items, each of which shall be an orig\r
+\ or dest, on the control-flow stack before CS-PICK is\r
+\ executed.\r
+\\r
+\ If the control-flow stack is implemented using the\r
+\ data stack, u shall be the topmost item on the data\r
+\ stack.\r
+: CS-PICK ( destu ... orig0|dest0 u -- destu ... orig0|dest0 destu )\r
+ DUP 2* 1+ PICK \ check destu; dest type is 0\r
+ IF -22 THROW THEN \ control structure mismatch\r
+ DUP >R 0 SWAP \ destu ... orig0|dest0 0 u R: u\r
+ 1+ 0 DO I 2* 1+ PICK OR LOOP \ dest type is 0; orig type is 1\r
+ 1 INVERT AND IF -22 THROW THEN \ ORed types should be 0\r
+ R> 2* 1+ PICK 0\r
+ bal 1+ TO bal ; COMPILE-ONLY\r
+\r
+\ CS-ROLL \ TOOLS EXT\r
+\ Execution: ( C: origu|destu origu-1|destu-1 ... orig0|dest0 --\r
+\ origu-1|destu-1 ... orig0|dest0 origu|destu )\r
+\ ( S: u -- )\r
+\ Interpretation: Interpretation semantics for this word are undefined.\r
+\\r
+\ Remove u. Rotate u+1 elements on top of the\r
+\ control-flow stack so that origu|destu is on top of\r
+\ the control-flow stack. An ambiguous condition\r
+\ exists if there are less than u+1 items, each of\r
+\ which shall be an orig or dest, on the control-flow\r
+\ stack before CS-ROLL is executed.\r
+\\r
+\ If the control-flow stack is implemented using the\r
+\ data stack, u shall be the topmost item on the data\r
+\ stack.\r
+: CS-ROLL ( origu|destu origu-1|destu-1 ... orig0|dest0 u --\r
+ \ origu-1|destu-1 ... orig0|dest0 origu|destu )\r
+ DUP >R 0 SWAP \ destu ... orig0|dest0 0 u R: u\r
+ 1+ 0 DO I 2* 1+ PICK OR LOOP \ dest type is 0; orig type is 1\r
+ 1 INVERT AND IF -22 THROW THEN \ ORed types should be 0\r
+ R@ 2* 1+ ROLL\r
+ R> 2* 1+ ROLL ; COMPILE-ONLY\r
+\r
+SET-CURRENT SET-ORDER\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM! [THEN]\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\\r
+\\r
+\\r
+\\r
+\ We CANNOT access code!\r
+\ We CANNOT change the compiler!\r
+\ We CANNOT do anything!\r
+\\r
+\ But we want a debugger!\r
+\ Ok, here it is....\r
+\\r
+\\r
+\ ********************************************************************\r
+\ * *\r
+\ * Debugger for ANSI Forth Programs *\r
+\ * *\r
+\ * *\r
+\ * Contributed to the community by *\r
+\ * *\r
+\ * Joerg Plewe, 1dec94 *\r
+\ * *\r
+\ * This code can be used and copied free of charge. *\r
+\ * All rights reserved. *\r
+\ * *\r
+\ * Comments, hints and bug reports are welcome. Please email to *\r
+\ * *\r
+\ * jps@Forth-eV.de *\r
+\ * *\r
+\ * *\r
+\ * testet with: F68KANS (>jan94), pfe0.9.7, thisForth *\r
+\ * *\r
+\ * Special thanks to Ulrich Hoffmann and Bernd Paysan *\r
+\ * for testing and commenting. *\r
+\ * *\r
+\ * V0.1: Added treatment of nesting levels *\r
+\ * V0.2: Decompiler feature *\r
+\ * V0.3: worked in hints from the net *\r
+\ ********************************************************************\r
+\\r
+\\r
+\ The following code provides a simple debugging tool for ANSI Forth\r
+\ programs. It may be used to debug colon- and DOES>- and :NONAME-code\r
+\ on source level.\r
+\\r
+\ The debugger expects your system to be a well behaved Forth system.\r
+\ (Like my F68KANS :-)\r
+\ When you suspect that your problems arise from the compiler itself\r
+\ (do you use an optimizer?), please use another tool.\r
+\\r
+\\r
+\ Usage:\r
+\\r
+\ There are two pairs of words switching the debugger on and off.\r
+\\r
+\ +DEBUG, -DEBUG\r
+\ These two control a global switch, which has effects both a compile-\r
+\ and runtime. When used at compiletime, -DEBUG will completely switch\r
+\ of the debugger. So no debugging code is generated. This allows you\r
+\ to leave your code with all debugging statements in it and test it\r
+\ without debugger.\r
+\ At runtime, -DEBUG switches off the evaluation of debugging code.\r
+\ So your code will behave as normal, just a bit slower.\r
+\\r
+\ [DBG, DBG]\r
+\ You will have to use [DBG at compiletime in front of a ':' or a DOES>\r
+\ to tell the debugger to generate special debugging code. [DBG is\r
+\ valid until switched off with DBG]. DBG] may appear anywhere in the source!\r
+\ So it is possible to debug only the first part of a word and then to switch\r
+\ of the debugger causing 'original' code to be generated for the rest.\r
+\ It is not possible to generate normal code a the beginning of a definition\r
+\ and debugging code in the end!\r
+\\r
+\ E.g.\r
+\ : FOO CREATE [DBG 0 , DOES> @ ; DBG]\r
+\\r
+\ will only debug the DOES>-part of the definition. The reason is that [DBG\r
+\ only switches the behaviour of ':' and DOES>.\r
+\\r
+\\r
+\ Think about the difference of +-DEBUG and [DBG]!\r
+\\r
+\\r
+\ There some additional words to control the debugger a runtime. These\r
+\ words have short names to be typepable at debugtime. But of course\r
+\ you may also compile them into your code. Thsi gives you the\r
+\ possibility to realize breakpoints etc.\r
+\\r
+\ [+I], [-I]\r
+\ Interactive. This switch controls wether you do singlestepping or a\r
+\ kind of code animation. When singlestepping, you can type any number\r
+\ of Forth statements between two steps. The next step is peformed when\r
+\ simply pressing <return>.\r
+\\r
+\ [+V], [-V]\r
+\ Verbose. [+V] adds a stack dump to the output on each step.\r
+\\r
+\ [+S], [-S]\r
+\ Silent. [+S] switches off all outputs and the program begins to run.\r
+\ Pressing a key switches it back to interactive mode.\r
+\\r
+\ [>L] ( n -- )\r
+\ Goto Level of nesting. This option recieves a parameter (don't forget).\r
+\ It lets the debugger run in '[+S] [-I] [-V]'-mode until the given\r
+\ level of nesting is reached the next time. Then the previous state of\r
+\ the debugger is restored.\r
+\ Note that the given level may be lower, higher or equal to the current level.\r
+\ You can overwrite the settings invoked be [>L] with further debugger\r
+\ commands.\r
+\ Suppose you are on level 1, than\r
+\ 1 [>L] [-S]\r
+\ will give you an animation of your code until the next word on nestinglevel 1\r
+\ is reached.\r
+\\r
+\ [Y]\r
+\ Step over. This command will avoid nesting to deeper levels. It is\r
+\ equivalent to a [>L] with the current level. So the example above can\r
+\ be written as:\r
+\ [Y] [-S]\r
+\\r
+\\r
+\ [DEF]\r
+\ Default: [+I] [-V] [-S], no nestlevel targeting\r
+\\r
+\\r
+\ The debugger also supports a decompiler feature for words compiled with the\r
+\ debugger on. The decompiler is envoked by\r
+\\r
+\ DSEE <name>\r
+\\r
+\ and decompiles the whole word at once. For this decompiler works completely\r
+\ different from these you maybe know, it has e.g. the possibility to\r
+\ decompile even things which were in you source with the compiler off.\r
+\ This means, sequences like '... [ 1 2 3 + + ] LITERAL ...' will\r
+\ reappear while decompiling.\r
+\\r
+\\r
+\ 0!DBG\r
+\\r
+\ This is the debugger's reset. It sets back e.g. the level of nesting.\r
+\ You should use this at the beginning of a file you compile, e.g.\r
+\ 0!DBG\r
+\ in the first line.\r
+\\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\ WORKS WITH\r
+\\r
+\ F68KANS (>jan94) portable 68k nativecode Forth by me\r
+\ pfe0.9.7 by Dirk Zoller\r
+\ thisForth by Wil Baden\r
+\\r
+\ Reported to work with:\r
+\\r
+\ gforth by Bernd Paysan (paysan@informatik.tu-muenchen.de)\r
+\ iForth by Marcel Hendrix (mhx@bbs.forth-ev.de)\r
+\\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\ ENVIRONMENTAL DEPENDENCIES\r
+\\r
+\ When the decompiler option is used:\r
+\ The Control Stack (CS) has to be the data stack.\r
+\\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\ RESTRICTIONS:\r
+\\r
+\ The generation of debugging code can only be invoked with the words\r
+\ ':', DOES> and :NONAME (or words which use them, after the debugger\r
+\ has been compiled).\r
+\\r
+\ The debugger is steered by some string literals: debugging is switched\r
+\ off when the debugger's outer interpreter finds the words DBG] or ';'.\r
+\ The words a compiled as string literals into the debugger, so no\r
+\ definitions including them will be able to do theire job!\r
+\ Further, the words ';' and '[' have a special meaning for the\r
+\ debugger (they both switch off the Forth compiler).\r
+\\r
+\ In the current state, the debugger cannot handle floating point\r
+\ literals. This will be removed in one of the next releases.\r
+\\r
+\\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\ HOW IT WORKS\r
+\\r
+\ A standard system does not let you examine the code. You do not know\r
+\ anything about it's location in memory or it's structure. You do not\r
+\ know wether it is direct or inderect threaded or native code.\r
+\ But most debuggers exactly do that: they examine the code, and sometimes\r
+\ even modify it at runtime (e.g. to set breakpoints in native code systems).\r
+\ They need detailed knowledge about the code and the CPU it runs on.\r
+\ In most cases, additional knowledge about the structure of the\r
+\ dictionary is needed, too.\r
+\\r
+\ For all that cannot be done with an ANSI Forth system, this debugger\r
+\ tries a completely different way.\r
+\ From the things said above, it is clear that once the code is\r
+\ generated, there is no possibility for debugging any more. So an ANSI\r
+\ debugger has to generate a special debugging code. In order to do that,\r
+\ it must define a new compiler, because an ANSI system does not\r
+\ let you manipulate the outer interpreter.\r
+\ My debugger uses an own outer interpreter which generates, let's say,\r
+\ 'self debugging code'.\r
+\ (Thanks to the standard comittee for providing REFILL)\r
+\\r
+\ The next serious problem is how to access the source? There are\r
+\ different input sources like TIB, files, blocks or strings. Perhaps for\r
+\ blocks it would be possible to compile the blocknumber into the code.\r
+\ Then the right block could be accessed at runtime.\r
+\ Files would be more complicated, because they are represented by a\r
+\ single number, which may be OS dependent. Reaccessing a file from\r
+\ this number later means to implement a completely new\r
+\ file word set. I did not want to do that!\r
+\ With source from TIB or a string, the source retrieval will be\r
+\ impossible at all.\r
+\ So the only way to solve the problem is to compile the source together\r
+\ with the generated code!\r
+\ (Thanks to the standard comittee for providing SLITERAL)\r
+\\r
+\ The following code is generated (in general) for a Forth word <word>:\r
+\\r
+\ [ S" <word>" ] SLITERAL dodebug nodecomp @ IF <word> THEN\r
+\\r
+\ (So make sure that you have enough space in your code area!)\r
+\\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\ REMARKS\r
+\\r
+\ V0.2 initially did not work with Wil Baden's thisForth.\r
+\ The reason seemed to be\r
+\ that VALUES cannot be POSTPONEd in thisForth. So I turned the VALUE\r
+\ 'decompile' into the VARIABLE 'nodecomp'.\r
+\ thisForth had (has?) some problems with it's REFILL. Wil Baden send\r
+\ me a valid definition:\r
+\\r
+\ : REFILL ( -- flag ) next-char eof <> ;\r
+\\r
+\ Don't wonder about what you see when debugging thisForth programs!\r
+\ The debugger also sees thisForth's macro expansions!!\r
+\\r
+\r
+\r
+\ CR .( ANSI Forth debugger V0.3 by Joerg Plewe, 1dec94 ) CR\r
+\r
+MARKER *debugger*\r
+\r
+\\r
+\ customization\r
+\\r
+ \ Compile the decompiler feature?\r
+ \ This will introduce an environmental dependency!\r
+\ TRUE CONSTANT withDSEE\r
+\r
+\ Try to find out wether the control stack is the data stack.\r
+\ In this case, the system fullfills the environmental dependency\r
+MARKER *check_for_controlstack*\r
+FALSE VARIABLE CSisDS CSisDS !\r
+VARIABLE saveDEPTH\r
+\r
+: checker\r
+ [ DEPTH saveDEPTH ! ]\r
+ IF \ IF should change the controlstack\r
+ [ DEPTH saveDEPTH @ > CSisDS ! ] \ datastack changed?\r
+ THEN ;\r
+\r
+CSisDS @ *check_for_controlstack* CONSTANT withDSEE\r
+\r
+\r
+\r
+\r
+: is_defined ( <name> -- flag )\r
+ BL WORD FIND NIP ;\r
+\r
+\ prelude\r
+\ is_defined ON is_defined OFF AND 0=\r
+\ [IF]\r
+: ON ( addr -- ) TRUE SWAP ! ;\r
+: OFF ( addr -- ) FALSE SWAP ! ;\r
+\ [THEN]\r
+\r
+\r
+\r
+\r
+\\r
+\ switching debugger globally\r
+\\r
+VARIABLE use_debugger use_debugger ON\r
+ \ use the debugger at all?\r
+VARIABLE nodecomp nodecomp ON\r
+ \ controls decompiling vs. debugging at runtime\r
+VARIABLE creating_dbgcode creating_dbgcode OFF \ internal switch\r
+VARIABLE nestlevel 0 nestlevel ! \ level of nesting\r
+\r
+\r
+\r
+: +DEBUG ( -- )\r
+ use_debugger ON ;\r
+\r
+: -DEBUG ( -- )\r
+ use_debugger OFF ;\r
+\r
+\r
+\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\\r
+\ executing watches\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\r
+10 CONSTANT #watches\r
+CREATE watchlist #watches CELLS ALLOT\r
+\r
+: slot ( n -- addr )\r
+ CELLS watchlist + ;\r
+\r
+: watch_execute ( xt -- flag )\r
+ DEPTH >R EXECUTE DEPTH R> - \ may ONLY return a flag!\r
+ ABORT" A watch is not legal: not returning ONLY a flag!"\r
+ ;\r
+\r
+\r
+: do_watch ( n -- flag )\r
+ DUP 0 #watches WITHIN\r
+ IF\r
+ slot @ DUP \ if slot @ gives 0, this is\r
+ \ uses as a FALSE\r
+ IF watch_execute THEN\r
+ ELSE DROP FALSE THEN ;\r
+\r
+: do_watches ( -- flag )\r
+ FALSE\r
+ #watches 0 DO I do_watch 0= 0= OR LOOP ;\r
+\r
+\r
+: find_free_slot ( -- n | -1 )\r
+ #watches 0\r
+ DO\r
+ I slot @ 0=\r
+ IF I UNLOOP EXIT THEN\r
+ LOOP\r
+ -1 ;\r
+\r
+: 0!WATCHES ( -- )\r
+ watchlist #watches CELLS ERASE ;\r
+\r
+0!WATCHES\r
+\r
+\r
+: :WATCH ( -- xt ) ( C: -- colon-sys )\r
+ use_debugger @ -DEBUG \ no debugging of the watches\r
+ :NONAME ;\r
+\r
+: ;WATCH ( xt -- ) ( C: colon-sys -- )\r
+ POSTPONE ;\r
+ SWAP use_debugger !\r
+ find_free_slot DUP 0< 0=\r
+ IF\r
+ DUP >R slot !\r
+ R> ." ( Slot #" . ." filled with watch.) "\r
+ ELSE\r
+ 2DROP TRUE ABORT" Cannot add more watches!"\r
+ THEN ;\r
+IMMEDIATE\r
+\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\\r
+\ we need some routines for service\r
+\\r
+\r
+\\r
+\ is a string a number?\r
+\\r
+: ?negate ( n sign -- n' ) 0< IF NEGATE THEN ;\r
+: ?dnegate ( d sign -- d' ) 0< IF DNEGATE THEN ;\r
+\r
+: number? ( addr c -- FALSE | u 1 | ud -1 )\r
+ \ Tries to find out, wether the given string can be interpreted\r
+ \ as a numeric literal.\r
+ \ Returns a flag and the converted number, if possible.\r
+ 0 >R \ push default sign\r
+ OVER C@ [CHAR] - = IF R> DROP -1 >R THEN \ - sign?\r
+ OVER C@ [CHAR] + = IF R> DROP 1 >R THEN \ + sign?\r
+ R@ ABS /STRING\r
+ 0. 2SWAP >NUMBER ( ud2 c-addr2 u2 )\r
+ ?DUP 0= IF DROP D>S R> ?negate 1 EXIT THEN ( exit: single )\r
+ 1 = SWAP C@ [CHAR] . = AND \ with a '.', it is double\r
+ IF R> ?dnegate -1 EXIT THEN ( exit: double )\r
+ R> DROP 2DROP FALSE\r
+ ;\r
+\r
+\r
+\r
+\\r
+\ things to be done while debugging\r
+\\r
+\r
+CREATE debugTIB 80 CHARS ALLOT\r
+: eval_debug_statements ( -- )\r
+ \ A simple outer interpreter for interactive input at\r
+ \ debugtime.\r
+ BEGIN\r
+ CR ." > " debugTIB DUP 80 ACCEPT SPACE DUP\r
+ WHILE\r
+ ['] EVALUATE CATCH IF ." Oops!?" CR THEN\r
+ REPEAT\r
+ 2DROP ;\r
+\r
+\r
+: .next_statement ( addr len -- )\r
+ \ addr len shows the name of the following statement in the\r
+ \ source code. .next_statement formats and prints it.\r
+ nestlevel @ 2* SPACES\r
+ nodecomp @ IF\r
+ ." Nxt[" nestlevel @ S>D <# #S #> TYPE ." ]: "\r
+ THEN\r
+ TYPE\r
+ ;\r
+\r
+\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\\r
+\ steering the debugger\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+VARIABLE debugstate 0 debugstate !\r
+ \ Bit 0 = Interactive\r
+ \ Bit 1 = Silent\r
+ \ Bit 2 = Verbose\r
+\r
+: +debugstate: ( state <name> -- )\r
+ CREATE ,\r
+ DOES> @ debugstate @ OR debugstate ! ;\r
+\r
+: -debugstate: ( state <name> -- )\r
+ CREATE INVERT ,\r
+ DOES> @ debugstate @ AND debugstate ! ;\r
+\r
+: ?debugstate: ( state <name> -- )\r
+ CREATE ,\r
+ DOES> @ debugstate @ AND 0<> ;\r
+\r
+1 DUP +debugstate: (+I) DUP -debugstate: [-I] ?debugstate: [?I]\r
+2 DUP +debugstate: [+S] DUP -debugstate: [-S] ?debugstate: [?S]\r
+4 DUP +debugstate: [+V] DUP -debugstate: [-V] ?debugstate: [?V]\r
+\r
+\\r
+\ define some additional rules\r
+\\r
+: [+I] ( -- ) \ interactive can never be silent\r
+ [-S] (+I) ;\r
+\r
+VARIABLE target_nestlevel -1 target_nestlevel !\r
+VARIABLE savedebugstate debugstate @ savedebugstate !\r
+\r
+\r
+: check_nesting ( -- )\r
+ \ Checks wether the execution has reached a defined level\r
+ \ of nexting (target_nestlevel). In this case, it switches off\r
+ \ targetting (-1!) and restore the previously saved state\r
+ \ of the debugger.\r
+ target_nestlevel @ nestlevel @ =\r
+ IF\r
+ -1 target_nestlevel ! \ switch targeting off\r
+ savedebugstate @ debugstate !\r
+ THEN ;\r
+\r
+\r
+: [>L] ( n -- ) \ goto level\r
+ target_nestlevel !\r
+ debugstate @ savedebugstate !\r
+ [+S] [-I] [-V]\r
+ ;\r
+\r
+\r
+: [Y] ( -- ) \ step over\r
+ nestlevel @ [>L]\r
+ ;\r
+\r
+\r
+\r
+: [DEF] ( -- ) \ the default behaviour\r
+ -1 target_nestlevel !\r
+ [+I] [-V] [-S] ;\r
+\r
+[DEF]\r
+\r
+\r
+\\r
+\\r
+\ check: what has to be displayed?\r
+\\r
+\\r
+: ?.next_statement ( addr len -- )\r
+ \ When the debugger is not running silent, the following\r
+ \ has to be displayed. When not beeing interactive, a CR\r
+ \ has to be added.\r
+ [?S] 0=\r
+ IF\r
+ .next_statement\r
+ [?I] 0= IF CR THEN\r
+ ELSE 2DROP THEN\r
+ ;\r
+\r
+\r
+: ?eval_debug_statements ( -- )\r
+ \ When the debugger is interactive but not silent, we want\r
+ \ to evaluate statements.\r
+ [?I] [?S] 0= AND\r
+ IF eval_debug_statements THEN ;\r
+\r
+: ?.s ( -- )\r
+ \ Perhaps, a stackdump is needed. This is indicated by the\r
+ \ verbose mode.\r
+ [?V] [?S] 0= AND\r
+ IF .S CR THEN ;\r
+\r
+: ?>[+I] ( -- )\r
+ \ Oh oh. Return to interactive mode when a key is pressed\r
+ \ or a watch is activated.\r
+ nodecomp @\r
+ IF\r
+ EKEY? IF KEY DROP [+I] THEN\r
+ do_watches IF [+I] THEN\r
+ THEN ;\r
+\r
+\r
+: dodebug ( addr len -- )\r
+ \ This word is executed between two statements in the source.\r
+ \ Note I had to do some stack juggling for the stack has to\r
+ \ be 'original' when showing the stackdump!\r
+ use_debugger @ IF \ wonna debug anyway?\r
+ check_nesting\r
+ ?>[+I]\r
+ >R >R ?.s R> R> ( >R's for addr len )\r
+ ?.next_statement\r
+ ?eval_debug_statements\r
+ ELSE 2DROP THEN\r
+ ;\r
+\r
+\r
+\r
+\r
+\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\\r
+\ this section is to create debugging code\r
+\\r
+\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\r
+\r
+\r
+\\r
+\ THIS word is the main point:\r
+\ It compiles code suitable for debugging.\r
+\ Or better: it compiles self-debugging code\r
+\\r
+: .source, ( c-addr -- )\r
+ STATE @ DUP >R 0= IF ] THEN \ switch compiler on for SLITERAL\r
+ COUNT\r
+ POSTPONE SLITERAL ( POSTPONE) ALIGN\r
+ POSTPONE dodebug\r
+ R> 0= IF POSTPONE [ THEN \ switch compiler off when it was off\r
+ ;\r
+\r
+CREATE wordbuf 64 CHARS ALLOT\r
+\r
+: >wordbuf ( c-addr -- )\r
+ DUP C@ CHAR+ wordbuf SWAP CHARS MOVE ;\r
+\r
+\r
+: C$= ( c-addr addr u -- flag )\r
+ ROT COUNT COMPARE 0= ;\r
+\r
+: $;= ( c-addr -- flag ) S" ;" C$= ;\r
+: $DBG]= ( c-addr -- flag ) S" DBG]" C$= ;\r
+: $[= ( c-addr -- flag ) S" [" C$= ;\r
+\r
+\r
+: apply_semantic ( xt +-1 -- ? )\r
+ 0< STATE @ AND\r
+ IF COMPILE, ELSE EXECUTE THEN ;\r
+\r
+\r
+: compile_number ( u 1 | ud -1 -- )\r
+ STATE @ 0<>\r
+ IF\r
+ 0< IF POSTPONE 2LITERAL ELSE POSTPONE LITERAL THEN\r
+ ELSE DROP THEN ;\r
+\r
+\r
+: compiler_error ( c-addr -- )\r
+ ." Not found in dictionary: " wordbuf COUNT TYPE\r
+ -13 THROW ;\r
+\r
+\r
+\\r
+\ handling the nesting level\r
+\\r
+: +nest ( -- )\r
+ 1 nestlevel +! ;\r
+: -nest ( -- )\r
+ -1 nestlevel +! ;\r
+\r
+\r
+\r
+: endof_dbgd_def? ( -- flag ) \ end of debugged definition?\r
+ wordbuf $;=\r
+ wordbuf $DBG]= OR\r
+ ;\r
+\r
+: compiler_off? ( -- flag ) \ a word, which switches the compiler off?\r
+ wordbuf $;=\r
+ wordbuf $[= OR\r
+ ;\r
+\r
+\r
+\r
+\\r
+\ compile conditinal branches to skip 'real' code for decompiling\r
+\\r
+withDSEE [IF]\r
+\r
+CREATE CSbuffer 20 CELLS ALLOT\r
+VARIABLE decompilerIF decompilerIF OFF\r
+VARIABLE saveDEPTH 0 saveDEPTH !\r
+VARIABLE CSsaved 0 CSsaved !\r
+\r
+: saveCS ( ? -- )\r
+ \ Save control structure information from the data stack\r
+ \ to a special buffer.\r
+ \ The variable saveDEPTH has to be set!!\r
+ 0 CSsaved !\r
+ BEGIN\r
+ DEPTH saveDEPTH @ <>\r
+ WHILE\r
+ CSbuffer CSsaved @ CELLS + !\r
+ 1 CSsaved +!\r
+ REPEAT ;\r
+\r
+: restoreCS ( -- ? )\r
+ \ restore control structure information from the buffer to stack\r
+ BEGIN\r
+ CSsaved @\r
+ WHILE\r
+ -1 CSsaved +!\r
+ CSbuffer CSsaved @ CELLS + @\r
+ REPEAT ;\r
+\r
+\r
+: decompiler_jump ( -- )\r
+ \ Under right conditions, compile a 'nodecomp @ IF'\r
+ \ The possible change on data stack (IF) is cleared, so that\r
+ \ words like LITERAL do not come into trouble.\r
+ \ The Control Stack CS defined in the ANSI document may consist\r
+ \ of some entries on the common data stack (which, indeed, is implemented\r
+ \ in most Forth systems). But the data stack has to be unchanged by the\r
+ \ debugger when compiling a word: ' ... [ 1 2 3 + + ] LITERAL ...'\r
+ \ In this example, 'LITERAL' wants to compile the number 6, and not some\r
+ \ token left on the stack by the decompiler's IF. For it is unknown,\r
+ \ what IF will place in an arbitary Forth system, this complicated\r
+ \ construction has to be made.\r
+ STATE @ compiler_off? 0= AND\r
+ IF\r
+ DEPTH saveDEPTH ! \ DEPTH of stack 'before'\r
+ POSTPONE nodecomp POSTPONE @\r
+ POSTPONE IF \ now compile IF. It may change stack!\r
+ saveCS \ stackeffect of IF removed\r
+ decompilerIF ON \ ok, there is an IF\r
+ THEN\r
+ ;\r
+\r
+: decompiler_target ( -- )\r
+ \ Resolve the decompiler IF compiled\r
+ decompilerIF @\r
+ IF\r
+ restoreCS \ prepare stack with IF-values\r
+ POSTPONE THEN \ and resolve the jump.\r
+ decompilerIF OFF \ done!\r
+ THEN\r
+ ;\r
+\r
+[ELSE] ( withDSEE )\r
+: decompiler_jump ; IMMEDIATE\r
+: decompiler_target ; IMMEDIATE\r
+[THEN] ( withDSEE )\r
+\r
+\r
+\r
+\\r
+\ now construct a complete outer interpreter\r
+\\r
+\r
+\ a special hack to allow F68KANS to handle files with tabs etc.\r
+is_defined F68kAns\r
+ [IF] blankbits [ELSE] BL [THEN]\r
+ CONSTANT whitespace\r
+\r
+\r
+: create_debugging_code ( -- )\r
+ POSTPONE +nest\r
+ creating_dbgcode @ >R creating_dbgcode ON\r
+ BEGIN \ loop to EOF\r
+ BEGIN \ loop to EOL\r
+ whitespace WORD DUP C@\r
+ WHILE\r
+ >wordbuf\r
+ wordbuf .source,\r
+ endof_dbgd_def? IF POSTPONE -nest THEN\r
+ decompiler_jump\r
+ wordbuf FIND ( c-addr 0 | xt +1 | xt -1 ) ?DUP\r
+ IF apply_semantic\r
+ ELSE ( caddr )\r
+ COUNT number? ?DUP\r
+ IF compile_number ELSE compiler_error THEN\r
+ THEN\r
+ decompiler_target\r
+ endof_dbgd_def? IF R> creating_dbgcode ! EXIT ( **) THEN\r
+ REPEAT DROP\r
+ REFILL 0= UNTIL\r
+ R> creating_dbgcode !\r
+;\r
+\r
+\r
+\r
+\r
+\r
+\r
+\\r
+\ Define the decompiler\r
+\\r
+withDSEE [IF]\r
+: DSEE ( <name> -- )\r
+ \ Show a decompiler listing of a word compiled with the debugger.\r
+ \ A non-debugger word will be executed instead.\r
+ CR\r
+ nodecomp @ >R FALSE nodecomp !\r
+ debugstate @ >R [-I] [-V] [-S]\r
+ ' EXECUTE\r
+ R> debugstate !\r
+ R> nodecomp !\r
+ ;\r
+[ELSE]\r
+: DSEE ( <name> -- )\r
+ CR BL WORD DROP\r
+ ." Debugger compiled without decompiler option! "\r
+ ;\r
+[THEN]\r
+\r
+\r
+\\r
+\ Now the replacements for the code-beginning words.\r
+\\r
+\r
+: debug: ( <name> -- )\r
+ : create_debugging_code ;\r
+\r
+: debug:NONAME ( -- xt )\r
+ :NONAME create_debugging_code ;\r
+\r
+\r
+: debugDOES>\r
+ creating_dbgcode @ IF POSTPONE -nest THEN\r
+ \ when the decompiler is invoked between ':' and 'DOES>',\r
+ \ there has to be a '-nest' compiled before 'DOES>'.\r
+ POSTPONE DOES> create_debugging_code ;\r
+\r
+\r
+\\r
+\ switching the debugger on and off\r
+\\r
+VARIABLE debugging debugging OFF\r
+\r
+: [DBG\r
+ debugging ON ; IMMEDIATE\r
+\r
+: DBG]\r
+ debugging OFF ; IMMEDIATE\r
+\r
+\r
+: 0!DBG ( -- )\r
+ \ reset the debugger\r
+ 0 nestlevel !\r
+ POSTPONE [DBG\r
+ +DEBUG\r
+ [DEF]\r
+ creating_dbgcode OFF\r
+ ;\r
+\r
+\r
+\r
+\\r
+\ redefinition of the code generating defining words\r
+\\r
+: : ( <name> -- )\r
+ use_debugger @ debugging @ AND\r
+ IF debug: ELSE : THEN ;\r
+\r
+: DOES> ( <name> -- )\r
+ use_debugger @ debugging @ AND\r
+ IF debugDOES> ELSE POSTPONE DOES> THEN ; IMMEDIATE\r
+\r
+: :NONAME ( <name> -- )\r
+ use_debugger @ debugging @ AND\r
+ IF debug:NONAME ELSE :NONAME THEN ;\r
+\r
+\r
+\\r
+\ OK\r
+\\r
+CR\r
+.( The words for you are: ) CR\r
+.( +DEBUG -DEBUG to switch debugging on/off globally ) CR\r
+.( [DBG DBG] to envoke and terminate generation ) CR\r
+.( of debugging code at compiletime ) CR\r
+.( :WATCH ;WATCH Define a watch function returning a flag ) CR\r
+.( 0!WATCHES to remove all watch functions ) CR\r
+.( [+I] [-I] Interactive mode on/off ) CR\r
+.( [+S] [-S] Silent mode on/off ) CR\r
+.( [+V] [-V] Verbose mode on/off ) CR\r
+.( [>L] [Y] level targeting control ) CR\r
+.( [DEF] DEFault settings ) CR\r
+withDSEE [IF]\r
+.( DSEE Decompile words compiled with debugger ) CR\r
+[THEN]\r
+.( 0!DBG Reset the debugger when something goes wrong ) CR\r
+\r
+\r
+\1a
\ No newline at end of file
--- /dev/null
+\ Listing in "Towards a Discipline of ANS Forth Programming"\r
+\ Originally published in Forth Dimensions XVIII, No.4, pp5-14\r
+\ Adapted to hForth v0.9.9 by Wonyong Koh\r
+\ An ANS compliance problem in v0.9.7 is fixed now.\r
+\ 'dest+' should not be necessary.\r
+\r
+\ Dijkstra Guarded Command Control Structures\r
+\ M. Edward Borasky\r
+\ 03-AUG-96\r
+\\r
+\ Environmental dependencies:\r
+\\r
+\ Requires AGAIN from the CORE EXT word set\r
+\ Requires AHEAD from the TOOLS EXT word set\r
+\ Requires CS-PICK from the TOOLS EXT word set\r
+\ Requires CS-ROLL from the TOOLS EXT word set\r
+\ Requires PICK from the CORE EXT word set\r
+\ Requires ROLL from the CORE EXT word set\r
+\ Requires THROW from the EXCEPTION word set\r
+\ Requires hForth word COMPILE-ONLY or equivalent\r
+\ Requires .( from CORE EXT word set (test sequence only)\r
+\r
+\ hForth has the capability to flag a word COMPILE-ONLY. On\r
+\ other systems, COMPILE-ONLY can be ignored by defining it as\r
+\ follows:\r
+\r
+BL WORD COMPILE-ONLY FIND NIP 0= [IF]\r
+ : COMPILE-ONLY ;\r
+[THEN]\r
+\r
+: {IF \ start a conditional\r
+ ( -- 0 )\r
+\r
+ 0 \ put counter on stack\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+: IF> \ right-arrow for {IF ... FI}\r
+ ( count -- count+1 )\r
+ ( C: -- orig1 )\r
+\r
+ 1+ >R \ increment and save count\r
+ POSTPONE IF \ create orig1\r
+ R> \ restore count\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+: |IF| \ bar for {IF ... FI}\r
+ ( count -- count )\r
+ ( C: orig ... orig1 -- orig ... orig2 )\r
+\r
+ >R \ save count\r
+ POSTPONE AHEAD \ new orig\r
+ 1 CS-ROLL \ old orig to top of CFStack\r
+ POSTPONE THEN \ resolve old orig\r
+ R> \ restore count\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+: BAD{IF...FI} \ abort if there is no TRUE condition\r
+ ( -- )\r
+\r
+ CR ." {IF ... FI}: no TRUE condition" CR \ error message\r
+ -22 THROW \ 'control structure mismatch'\r
+;\r
+\r
+: FI} \ end of conditional\r
+ ( count -- )\r
+ ( C: orig1 ... orign -- )\r
+\r
+ >R \ save count\r
+ POSTPONE AHEAD \ new orig\r
+ 1 CS-ROLL \ old orig\r
+ POSTPONE THEN \ resolve old orig\r
+\r
+ \ if we got here, none of the guards were TRUE\r
+ \ so abort\r
+ POSTPONE BAD{IF...FI} \ compile the abort\r
+ R> \ restore count\r
+\r
+ 0 ?DO \ resolve all remaining origs\r
+ POSTPONE THEN\r
+ LOOP\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+: {DO \ start a loop\r
+ ( C: -- dest )\r
+\r
+ POSTPONE BEGIN \ create dest\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+: DO> \ right arrow for {DO ... OD}\r
+ ( C: dest -- orig1 dest )\r
+\r
+ POSTPONE IF \ create orig\r
+ 1 CS-ROLL \ bring dest back to top of CFStack\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+: |DO| \ bar for {DO ... OD}\r
+ ( C: orig1 dest -- dest )\r
+\r
+ 0 CS-PICK \ copy the dest\r
+ POSTPONE AGAIN \ resolve the copy\r
+ 1 CS-ROLL \ old orig\r
+ POSTPONE THEN \ resolve old orig\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+: OD} \ end of loop\r
+ ( C: orig dest -- )\r
+ POSTPONE AGAIN \ resolve dest\r
+ POSTPONE THEN \ resolve orig\r
+; COMPILE-ONLY IMMEDIATE\r
+\r
+\r
+\ Simple test words\r
+\r
+: TEST1 \ print the relationship between 'x' and 'y'\r
+ ( x y -- )\r
+\r
+ {IF\r
+ 2DUP = IF> CR ." = "\r
+ |IF|\r
+ 2DUP > IF> CR ." > "\r
+ |IF|\r
+ 2DUP < IF> CR ." < "\r
+ FI}\r
+ 2DROP\r
+;\r
+\r
+\ execute TEST1 for all three combinations\r
+\r
+CR .( 5 0 TEST1 )\r
+5 0 TEST1\r
+\r
+CR .( 5 5 TEST1 )\r
+5 5 TEST1\r
+\r
+CR .( 0 5 TEST1 )\r
+0 5 TEST1\r
+\r
+: TEST2 \ deliberately erroneous test case --\r
+ \ 'equal' case left out!\r
+ ( x y -- )\r
+\r
+ {IF\r
+ 2DUP < IF> CR ." < "\r
+ |IF|\r
+ 2DUP > IF> CR ." > "\r
+ FI}\r
+ 2DROP\r
+;\r
+\r
+CR .( Since TEST2 aborts if 'x' and 'y' are equal, we will )\r
+CR .( test TEST2 later; first we will compile and test USEFUL )\r
+\r
+\ define arguments\r
+VARIABLE x 5 6553 * x !\r
+VARIABLE y 6551 5 * y !\r
+\r
+: USEFUL \ sets both 'x' and 'y' to GCD(x, y)\r
+ ( -- )\r
+\r
+ {DO\r
+ x @ y @ > DO> y @ NEGATE x +!\r
+ |DO|\r
+ y @ x @ > DO> x @ NEGATE y +!\r
+ OD}\r
+;\r
+\r
+CR .( Before: x, y = ) x @ . y @ . CR\r
+CR .( USEFUL ) USEFUL\r
+CR .( After: x, y = ) x @ . y @ . CR\r
+\r
+CR .( Now we'll test TEST2 )\r
+\r
+CR .( 5 0 TEST2 )\r
+5 0 TEST2\r
+\r
+CR .( 0 5 TEST2 )\r
+0 5 TEST2\r
+\r
+CR .( 5 5 TEST2 )\r
+5 5 TEST2\r
--- /dev/null
+\\r
+\ DOSEXEC.F\r
+\ call DOS executables in hForth\r
+\\r
+\ By 1994.12 Lee,Sheen\r
+\\r
+\ 1995. 10. 28. Revised by Wonyong Koh.\r
+\ 1996. 12. 14. Revise (DOSEXEC).\r
+\\r
+\ Usage:\r
+\ parseDOSEXEC ( c_addr u -- )\r
+\ Extract DOS program name from the string 'c_addr u', pass the\r
+\ remaining string to the DOS program and empty the input source.\r
+\ DOS> ( "program_name command_line" -- )\r
+\ Parse the following input source and transfer it to 'parseDOSEXEC'.\r
+\ Program name should include full directory path.\r
+\ Example:\r
+\ DOS> C:\BIN\DOS\EDIT.COM TEST.TXT\r
+\ Q ( "command_line" -- )\r
+\ Start Q editor. Current path is C:\BIN\Q.EXE.\r
+\ U ( "command_line" -- )\r
+\ Start U editor. Current path is C:\BIN\UEDIT\U.EXE.\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+BL WORD DOS-WORDLIST FIND NIP [IF]\r
+ GET-ORDER DOS-WORDLIST SWAP 1+ SET-ORDER\r
+ DOS-WORDLIST SET-CURRENT\r
+[THEN]\r
+\r
+HEX\r
+CREATE PARA-BLOCK \ Parameter block for EXEC dos fuction\r
+ 0 , \ environment block\r
+ 0 , \ offset of CMD-LINE\r
+ DS@ , \ segment of CMD-LINE\r
+ 0 , 0 , \ no data in PSP #1\r
+ 0 , 0 , \ no data in PSP #2\r
+\r
+CODE ((DOSEXEC)) ( asciiz-addr command-line-addr -- 0 | error-code )\r
+ BX PARA-BLOCK CELL+ ) MOV,\r
+\r
+ 1000 # BX MOV, \ reserve 64 KB\r
+ CS AX MOV,\r
+ AX ES MOV,\r
+\r
+ CHAR " PARSE model" ENVIRONMENT? DROP\r
+ CHAR " PARSE EXE Model" COMPARE 0=\r
+ [IF]\r
+ 10 # AX SUB, \ PSP//code-segment//data-segment/HERE\r
+ AX ES MOV, \ HERE 16 / 1+ CS DS - 10 + +\r
+ DS CX MOV, \ is program size in # paragraphs\r
+ AX CX SUB,\r
+ CX BX ADD,\r
+ [THEN]\r
+\r
+ 4A # AH MOV, \ function number for SET BLOCK function\r
+ 21 INT, \ ES: memory area segment address\r
+\r
+ DX POP, \ name of the program\r
+ DS AX MOV,\r
+ AX ES MOV,\r
+ PARA-BLOCK # BX MOV, \ ES:BX points to parameter block\r
+ 4B00 # AX MOV, \ function number for EXEC function\r
+ 21 INT, \ call dos function\r
+\r
+ 0 # BX MOV,\r
+ 1 L# JNC,\r
+ AX BX MOV,\r
+ iorOffset # BX ADD,\r
+1 L:\r
+ NEXT,\r
+END-CODE\r
+\r
+\ Make all other tasks sleep except SystemTask before calling DOS program.\r
+\ Call DOS program, then awake the tasks temperarily being slept.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : (DOSEXEC)\r
+ 0 >R \ # of tasks to be awaken\r
+ \ save active task list on return stack\r
+ follower \ current task's follower\r
+ BEGIN\r
+ @ CELL+ \ next task's follower\r
+ DUP follower <>\r
+ WHILE\r
+ DUP cell- DUP @ ['] wake = IF R> SWAP >R 1+ >R ELSE DROP THEN\r
+ REPEAT DROP\r
+\r
+ ((DOSEXEC))\r
+ \ restore active tasks\r
+ BEGIN R> ?DUP\r
+ WHILE R> ['] wake SWAP ! 1- >R\r
+ REPEAT ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : (DOSEXEC)\r
+ 0 >R \ # of tasks to be awaken\r
+ \ save active task list on return stack\r
+ follower \ current task's follower\r
+ BEGIN\r
+ @ code@ CELL+ CELL+ code@ \ next task's follower\r
+ DUP follower <>\r
+ WHILE\r
+ DUP @ cell- DUP code@ ['] wake = IF R> SWAP >R 1+ >R ELSE DROP THEN\r
+ REPEAT DROP\r
+\r
+ ((DOSEXEC))\r
+ \ restore active tasks\r
+ BEGIN R> ?DUP\r
+ WHILE R> ['] wake SWAP code! 1- >R\r
+ REPEAT ;\r
+[THEN]\r
+\r
+\ Call DOS program identified with the name and pass remaining input source\r
+\ to the program. This word modifies input source, which is against ANS\r
+\ Forth Standard recommandation.\r
+: parseDOSEXEC ( c_addr u -- )\r
+ asciiz SOURCE >IN @ /STRING \ asciiz c_addr u\r
+ 2DUP + 0D SWAP C!\r
+ SWAP 1- TUCK C! \ asciiz c_addr-1\r
+ (DOSEXEC) THROW\r
+ SOURCE >IN ! DROP ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+BL WORD Ðe\8bi·³Â\89\9db-WORDLIST FIND NIP [IF]\r
+ GET-ORDER Ðe\8bi·³Â\89\9db-WORDLIST SWAP 1+ SET-ORDER\r
+[THEN]\r
+\r
+: DOS> ( "program_name command_line" -- )\r
+ BL PARSE parseDOSEXEC ;\r
+\r
+: Q ( "command_line" -- )\r
+ [ BL WORD Ðe\8bi·³Â\89\9db-WORDLIST FIND NIP [IF]\r
+ ] GRAPHIC? DUP IF TEXT THEN\r
+ S" C:\BIN\Q.EXE" parseDOSEXEC IF HGRAPHIC THEN [ [ELSE]\r
+ ] S" C:\BIN\Q.EXE" parseDOSEXEC [ [THEN] ]\r
+ ;\r
+\r
+: U ( "command_line" -- )\r
+ S" C:\BIN\UEDIT\U.EXE" parseDOSEXEC ;\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\\r
+\ DOUBLE.F\r
+\ Double wordset words for hForth\r
+\\r
+\ Worning: Not fully tested yet. Maybe contains some bugs.\r
+\\r
+\ 1997. 2. 28.\r
+\ Facelift to be used with other CPUs.\r
+\ 1996. 7. 19.\r
+\ Fix 'M+'. Thanks M. Edward Borasky.\r
+\r
+BASE @\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM@ [THEN]\r
+GET-ORDER GET-CURRENT\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ 2LITERAL Compilation: ( x1 x2 -- ) \ DOUBLE\r
+\ Run-time: ( -- x1 x2 )\r
+\ Append the run-time semantics below to the current definition.\r
+\ On run-time, place cell pair x1 x2 on the stack.\r
+: 2LITERAL SWAP POSTPONE LITERAL POSTPONE LITERAL ; IMMEDIATE COMPILE-ONLY\r
+\r
+\ 2CONSTANT ( x1 x2 '<spaces>name' -- ) \ DOUBLE\r
+\ name Execution: ( -- x1 x2 )\r
+\ Create a definition for name with the execution semantics.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+ [IF]\r
+ : 2CONSTANT CREATE SWAP , , DOES> DUP @ SWAP CELL+ @ ;\r
+ [ELSE] DROP\r
+ : 2CONSTANT CREATE SWAP , , DOES>\r
+ ;CODE\r
+ 0 [BX] PUSH,\r
+ 1 CELLS [BX] BX MOV,\r
+ NEXT,\r
+ END-CODE\r
+ [THEN]\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ :NONAME EXECUTE POSTPONE 2LITERAL ;\r
+ CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+ [IF]\r
+ : 2CONSTANT CREATE SWAP , , compiles> DOES> DUP @ SWAP CELL+ @ ;\r
+ [ELSE] DROP\r
+ : 2CONSTANT CREATE SWAP , , compiles> DOES>\r
+ ;CODE\r
+ 0 [BX] PUSH,\r
+ 1 CELLS [BX] BX MOV,\r
+ NEXT,\r
+ END-CODE\r
+ [THEN]\r
+[THEN]\r
+\r
+\ 2VARIABLE ( '<spaces>name' -- ) \ DOUBLE\r
+\ name Execution: ( -- a_addr )\r
+\ Create a definition for name with the execution semantics.\r
+: 2VARIABLE CREATE 2 CELLS ALLOT ;\r
+\r
+\ D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE\r
+\ Add two double numbers, giving the double sum.\r
+\\r
+\ Already defined in .ASM source.\r
+\r
+\ D- ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE\r
+\ Subtract d2|ud2 from d1|ud1, giving the difference d3|ud3.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D- DNEGATE D+ ;\r
+[ELSE] DROP\r
+ CODE D-\r
+ BX DX MOV,\r
+ AX POP,\r
+ BX POP,\r
+ CX POP,\r
+ AX CX SUB,\r
+ CX PUSH,\r
+ DX BX SBB,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ D. ( d -- ) \ DOUBLE\r
+\ Display d in free field format followed by a space.\r
+\\r
+\ Already defined in .ASM source.\r
+\r
+\ D.R ( d n -- ) \ DOUBLE\r
+\ Display d right-justified in field of width n.\r
+\\r
+\ Already defined in OPTIONAL.F .\r
+\r
+\ D0< ( d -- flag ) \ DOUBLE\r
+\ flag is true if and only if d is less than 0.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D0< NIP 0< ;\r
+[ELSE] DROP\r
+ CODE D0<\r
+ CX POP,\r
+ BX AX MOV,\r
+ CWD,\r
+ DX BX MOV,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ D0= ( xd -- flag ) \ DOUBLE\r
+\ flag is true if and only if d is 0.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D0= OR 0= ;\r
+[ELSE] DROP\r
+ CODE D0=\r
+ CX POP,\r
+ CX BX OR,\r
+ -1 # BX MOV,\r
+ 1 L# JZ,\r
+ BX INC,\r
+ 1 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ D2* ( xd1 -- xd2 ) \ DOUBLE\r
+\ xd2 is the result of shifting xd1 one bit toward the\r
+\ most-significant bit, filling the vacated least-significant\r
+\ bit with zero.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D2* 2DUP D+ ;\r
+[ELSE] DROP\r
+ CODE D2*\r
+ AX POP,\r
+ AX 1 SHL,\r
+ BX 1 RCL,\r
+ AX PUSH,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ D2/ ( xd1 -- xd2 ) \ DOUBLE\r
+\ xd2 is the result of shifting xd1 one bit toward the least-\r
+\ significant bit, leaving the most-significant bit unchanged.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D2/ >R 1 RSHIFT R@ 1 AND IF TRUE 1 RSHIFT INVERT OR THEN R> 2/ ; \ by W. Baden\r
+[ELSE] DROP\r
+ CODE D2/\r
+ AX POP,\r
+ BX 1 SAR,\r
+ AX 1 RCR,\r
+ AX PUSH,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ D< ( d1 d2 --- flag ) \ DOUBLE\r
+\ flag is true if and only if d1 is less than d2.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D< ROT 2DUP = IF 2DROP U< EXIT THEN\r
+ 2SWAP 2DROP > ;\r
+[ELSE] DROP\r
+ CODE D<\r
+ CX POP,\r
+ DX POP,\r
+ AX POP,\r
+ BX DX CMP,\r
+ 0 # BX MOV,\r
+ 1 L# JZ,\r
+ 2 L# JGE,\r
+ BX DEC,\r
+ NEXT,\r
+ 1 L:\r
+ CX AX CMP,\r
+ 2 L# JAE,\r
+ BX DEC,\r
+ 2 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ D= ( xd1 xd2 --- flag ) \ DOUBLE\r
+\ flag is true if and only if xd1 is bit-for-bit the same as xd2.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D= D- OR 0= ;\r
+[ELSE] DROP\r
+ CODE D=\r
+ CX POP,\r
+ DX POP,\r
+ AX POP,\r
+ BX DX CMP,\r
+ 0 # BX MOV,\r
+ 1 L# JNZ,\r
+ CX AX CMP,\r
+ 1 L# JNZ,\r
+ BX DEC,\r
+ 1 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ D>S ( d -- n ) \ DOUBLE\r
+\ n is the equivalent of d. An ambiguous condition exists if\r
+\ d lies outside the range of a signed single-cell number.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : D>S OVER S>D NIP <> IF -11 THROW THEN ; \ result out of range\r
+[ELSE] DROP\r
+ CODE D>S\r
+ AX POP,\r
+ CWD,\r
+ BX DX CMP,\r
+ 1 L# JNE,\r
+ AX BX MOV,\r
+ NEXT,\r
+ 1 L:\r
+ -11 # BX MOV, \ result out of range\r
+ ' THROW # JMP,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ DABS ( d --- ud ) \ DOUBLE\r
+\ ud is the absolute value of d.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : DABS DUP 0< IF DNEGATE THEN ;\r
+[ELSE] DROP\r
+ CODE DABS\r
+ BX BX OR,\r
+ 1 L# JNS,\r
+ AX POP,\r
+ AX NEG,\r
+ 0 # BX ADC,\r
+ BX NEG,\r
+ AX PUSH,\r
+ 1 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ DMAX ( d1 d2 --- d3 ) \ DOUBLE\r
+\ d3 is the greater of d1 and d2.\r
+: DMAX 2OVER 2OVER D< IF 2SWAP THEN 2DROP ;\r
+\r
+\ DMIN ( d1 d2 --- d3 ) \ DOUBLE\r
+\ d3 is the lesser of d1 and d2.\r
+: DMIN 2OVER 2OVER D< 0= IF 2SWAP THEN 2DROP ;\r
+\r
+\ DNEGATE ( d1 --- d2 ) \ DOUBLE\r
+\ d2 is the negation of d1.\r
+\ Already defined in .ASM source.\r
+\r
+\ M*/ ( d1 n1 +n2 --- d2 ) \ DOUBLE\r
+\ Multiply d1 by n1 producing the triple-cell intermediate\r
+\ result t. Divide t by +n2 giving the double-cell quotient d2.\r
+\ An ambiguous condition exists if +n2 is zero or negative, or\r
+\ the quotient lies outside of the range of a double-precision\r
+\ signed integer.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ \ by Wil Baden\r
+ : T* TUCK UM* 2SWAP UM* SWAP >R 0 D+ R> ROT ROT ; ( u . u -- u . . )\r
+ : T/ DUP >R UM/MOD ROT ROT R> UM/MOD NIP SWAP ; ( u . . u -- u . )\r
+ : M*/ >R T* R> T/ ; ( u . u u -- u . )\r
+[ELSE] DROP\r
+ CODE M*/\r
+ BX BX OR,\r
+ 1 L# JZ,\r
+ 2 L# JS,\r
+ CX POP, \ n1\r
+ DI POP, \ high significant part of d1\r
+ AX POP, \ low significant part of d1\r
+ DI DX MOV,\r
+ CX DX XOR,\r
+ DX PUSH, \ save sign of the result\r
+ BX PUSH, \ save n2\r
+ CX CX OR,\r
+ 3 L# JNS,\r
+ CX NEG, \ ABS(n1)\r
+ 3 L:\r
+ DI DI OR,\r
+ 4 L# JNS,\r
+ AX NEG, \ DABS(d1)\r
+ 0 # DI ADC,\r
+ DI NEG,\r
+ 4 L:\r
+ CX MUL, \ lower partial product DX:AX\r
+ AX DI XCHG, \ lower partial product DX:DI\r
+ DX BX MOV, \ lower partial product BX:DI\r
+ CX MUL, \ lower partial product BX:DI, upper partial product DX:AX\r
+ BX AX ADD,\r
+ 0 # DX ADC, \ intermediate product DX:AX:DI\r
+ BX POP, \ restore n2\r
+ BX DX CMP,\r
+ 5 L# JAE,\r
+ BX DIV,\r
+ AX DI XCHG, \ upper part of the quotient in DI\r
+ BX DIV, \ quotient DI:AX\r
+ DI DI OR,\r
+ 5 L# JS, \ DI:AX does not fit in double signed integer\r
+ CX POP, \ restore sign of the result\r
+ CX CX OR,\r
+ 6 L# JNS,\r
+ AX NEG, \ DNEGATE\r
+ 0 # DI ADC,\r
+ DI NEG,\r
+ 6 L:\r
+ AX PUSH,\r
+ DI BX MOV,\r
+ NEXT,\r
+ 5 L:\r
+ -11 # BX MOV, \ result out of range\r
+ ' THROW # JMP,\r
+ 2 L:\r
+ -12 # BX MOV, \ argument type mismatch\r
+ ' THROW # JMP,\r
+ 1 L:\r
+ -10 # BX MOV, \ divide by zero\r
+ ' THROW # JMP,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ M+ ( d1|ud1 n --- d2|ud2 ) \ DOUBLE\r
+\ Add n to d1|ud1, giving the sum d2|ud2.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : M+ S>D D+ ;\r
+[ELSE] DROP\r
+ CODE M+\r
+ BX AX MOV, \ move stack top to AX for sign-extend\r
+ CWD, \ DX:AX now has 32-bit value\r
+ BX POP, \ upper half of second argument\r
+ CX POP, \ lower half of second argument\r
+ AX CX ADD, \ add lower halves\r
+ DX BX ADC, \ add upper halves with carry - sum now in BX:CX\r
+ CX PUSH, \ push lower half of result to stack\r
+ NEXT, \ finished\r
+ END-CODE\r
+[THEN]\r
+\r
+\ 2ROT ( x1 x2 x3 x4 x5 x6 -- x3 x4 x5 x6 x1 x2 ) \ DOUBLE EXT\r
+\ Rotate the top three cell pairs on the stack bringing cell\r
+\ pair x1 x2 to the top of the stack.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : 2ROT 2>R 2SWAP 2R> 2SWAP ;\r
+[ELSE] DROP\r
+ CODE 2ROT\r
+ CX POP,\r
+ DX POP,\r
+ AX POP,\r
+ SP DI MOV,\r
+ 1 CELLS [DI] AX XCHG,\r
+ 0 [DI] DX XCHG,\r
+ CX PUSH,\r
+ BX PUSH,\r
+ AX PUSH,\r
+ DX BX MOV,\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+\ DU< ( ud1 ud2 --- flag ) \ DOUBLE EXT\r
+\ flag is true if and only if ud1 is less than ud2.\r
+CHAR " PARSE ASM8086" ENVIRONMENT? 0=\r
+[IF]\r
+ : DU< ROT 2DUP = IF 2DROP U< EXIT THEN\r
+ 2SWAP 2DROP U> ;\r
+[ELSE] DROP\r
+ CODE DU<\r
+ CX POP,\r
+ DX POP,\r
+ AX POP,\r
+ BX DX CMP,\r
+ 0 # BX MOV,\r
+ 1 L# JZ,\r
+ 2 L# JAE,\r
+ BX DEC,\r
+ NEXT,\r
+ 1 L:\r
+ CX AX CMP,\r
+ 2 L# JAE,\r
+ BX DEC,\r
+ 2 L:\r
+ NEXT,\r
+ END-CODE\r
+[THEN]\r
+\r
+envQList SET-CURRENT\r
+-1 CONSTANT DOUBLE\r
+-1 CONSTANT DOUBLE-EXT\r
+\r
+SET-CURRENT SET-ORDER\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM! [THEN]\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+TITLE hForth 8086 EXE Model\r
+\r
+PAGE 62,132 ;62 lines per page, 132 characters per line\r
+\r
+;===============================================================\r
+;\r
+; hForth 8086 EXE model v0.9.9 by Wonyong Koh, 1997\r
+;\r
+; 1997 6. 4.\r
+; Fix the problem that data are corrupted at segment boundary\r
+; when .EXE file saved by SAVE-INPUT-AS is larger\r
+; than 64 KB. Now code segment is full 64 KB in\r
+; assembly source.\r
+; 1997. 2. 19.\r
+; Split environmental variable systemID into CPU and Model.\r
+; 1997. 2. 6.\r
+; Add Neal Crook's comments on assembly definitions.\r
+; 1997. 1. 25.\r
+; Add $THROWMSG macro and revise accordingly.\r
+; 1997. 1. 18.\r
+; Replace 'LODS CS:CSDummy' with 'LODS WORD PTR CS:[SI]'. This\r
+; opcode works for TASM v0.9.9 and MASM v6.11.\r
+; 1997. 1. 18.\r
+; Remove 'NullString' from assembly source.\r
+; 1996. 12. 18.\r
+; Revise 'head,'.\r
+; 1996. 12. 3.\r
+; Revise PICK to catch stack underflow.\r
+; 1996. 12. 3.\r
+; Implement control-flow stack on data stack. Control-flow stack\r
+; item consists of two data stack items, one for value\r
+; and one for the type of control-flow stack item.\r
+;\r
+; control-flow stack item data stack representation\r
+; dest control-flow_destination 0\r
+; orig control-flow_origin 1\r
+; of-sys OF_origin 2\r
+; case-sys x (any value) 3\r
+; do-sys ?DO_origin DO_destination\r
+; colon-sys xt_of_current_definition -1\r
+;\r
+; Add PICK.\r
+; 'bal' is now the depth of control-flow stack.\r
+; Drop 'lastXT'.\r
+; Introduce 'notNONAME?'\r
+; Add 'bal+' and 'bal-'. Drop 'orig+', 'orig-', 'dest+', 'dest-',\r
+; 'dosys+', and 'dosys-'.\r
+; Revise ':NONAME', ':', ';', 'linkLast', 'head,', RECURSE, 'DOES>',\r
+; CONSTANT, CREATE, VALUE, VARIABLE, and QUIT.\r
+; This change makes RECURSE work properly in ':NONAME ... ;'\r
+; and '... DOES> ... ;'.\r
+; Revise 'rake', AGAIN, AHEAD, IF, THEN, +LOOP, BEGIN, DO, ELSE, LOOP,\r
+; UNTIL, and WHILE.\r
+;\r
+; 1996. 11. 29.\r
+; Revise SLITERAL, '."', 'doS"' to allow a string larger than\r
+; max char size.\r
+; Revise $INSTR and remove 'do."'.\r
+; Revise 'pack"'.\r
+; 1996. 8. 17.\r
+; Revise MAX-UD.\r
+; 1996. 8. 10.\r
+; Replace 'COMPILE,' with 'code,' in the definition of 'compileCREATE'.\r
+; 1996. 6. 19.\r
+; Fix '/STRING'.\r
+;\r
+; Changes from 0.9.7\r
+;\r
+; 1996. 2. 10.\r
+; Revise FM/MOD and SM/REM to catch result-out-of-range error in\r
+; '80000. 2 FM/MOD'.\r
+; 1996. 1. 19.\r
+; Rename 'x,' to 'code,'; 'x@' to 'code@'; 'x!' to 'code!';\r
+; 'xb@' to 'codeB@' and 'xb!' to 'codeB!'.\r
+; 1996. 1. 7\r
+; Rename non-Standard 'parse-word' to PARSE-WORD.\r
+; 1995. 12. 2\r
+; Drop '?doLIST' and revise 'optiCOMPILE,'.\r
+; 1995. 11. 28\r
+; Drop 'LIT,:' all together.\r
+; Return CELLS to non-IMMEDIATE definition.\r
+;\r
+; Changes from 0.9.6\r
+;\r
+; 1995. 11. 25.\r
+; Make 'lastXT' VALUE word.\r
+; 1995. 11. 23.\r
+; Revise doCREATE, CREATE, pipe, DOES>, and >BODY.\r
+; 'pipe' is no longer processor-dependent.\r
+; 1995. 11. 17.\r
+; Move ERASE to ASM8086.F.\r
+;\r
+; Changes from 0.9.5\r
+;\r
+; 1995. 11. 15.\r
+; Fix MOVE to check whether 'u' is 0.\r
+; Add ERASE.\r
+; 1995. 11. 5.\r
+; Revise 'orig+', 'dosys+', etc to catch 'DO IF LOOP' mismatch.\r
+; 1995. 10. 30.\r
+; Change 'lastName' to VALUE type. Remove '(lastName)'.\r
+;\r
+; Changes from 0.9.2\r
+;\r
+; 1995. 9. 6.\r
+; Move terminal input buffer (TIB) at the end of the memory to\r
+; prevent accidental overwriting it. It was too close\r
+; to HERE and might be overwritten by ALLOT or , .\r
+; TIB address is only known to REFILL . Revise REFILL .\r
+; Move PAD also with TIB.\r
+; 1995. 9. 5.\r
+; Revise EVALUATE for FILE words.\r
+; 1995. 8. 21\r
+; Chris Jakeman kindly report several bugs and made suggestions.\r
+; CHARS is added in the definition of /STRING .\r
+; '1chars/' is introduced to convert # address units to # chars.\r
+; 'skipPARSE' is introduced. 'parse-word' and 'WORD' are\r
+; redefined using it.\r
+;\r
+; Changes from 0.9.0\r
+;\r
+; 1995. 7. 21.\r
+; Make HERE VALUE type and remove 'hereP'. Revise 'xhere'\r
+; and remove 'TOxhere'.\r
+; Make SOURCE-ID VALUE type, replace TOsource-id with\r
+; "TO SOURCE-ID" and remove TOsource-id .\r
+; 1995. 7. 20.\r
+; Make 'ekey? , 'ekey , 'emit? , 'emit , 'init-i/o , 'prompt\r
+; and 'boot VALUE type and replace "'emit @ EXECUTE"\r
+; with "'emit EXECUTE".\r
+; 1995. 7. 19.\r
+; Add doVALUE , doTO , VALUE and TO .\r
+; Replace 'DUP' with '?DUP' in the definition of "(')".\r
+; Replace 'CREATEd' with 'doCREATE' and remove CREATEd .\r
+; 1995. 7. 6.\r
+; Move "'init-i/o @ EXECUTE" from QUIT to THROW according\r
+; to the suggestion from Chris Jakeman.\r
+; 1995. 6. 25.\r
+; Fix code definition of SPACES .\r
+; 1995. 6. 14.\r
+; Revise $ENVIR for portability.\r
+; 'CR' is a system dependent definition.\r
+; 1995. 6. 9.\r
+; Rename '.ok' and '.OKay' as '.prompt' and '.ok' respectively.\r
+; 1995. 6. 5.\r
+; Fix SOURCE-ID .\r
+; 1995. 5. 2.\r
+; Redefine $CONST .\r
+;\r
+;; hForth EXE ¡¡\95I·e A\8ba åËa\9d¡ \90a\92å 8086·\81 ¡A¡¡\9f¡ ¡¡\95IµA xÂ\81´á\r
+;; hForth RAM ¡¡\95I·i \89¡Áa¬á e\97i´ö¯s\93¡\94a.\r
+;;\r
+;; hForth RAM ¡¡\95I\89Á \94a\9fe ¸ñ\97i·i ´a\9c\81µA ¸â´ö¯s\93¡\94a. \8b¡\89\81´á ¸÷·\81\97i·i\r
+;; Ða\90a\95¡ \89¡Ã¡»¡ ´g\89¡ Å¡\97a A\8ba åËa·\81 µ¡ÏaU º\81¡\9fi \94a\9e\81\8b¡ ¶áÐe\r
+;; Å¡\97a \90{ i 4\88\81 e·i \94áÐ\96¯s\93¡\94a. ´áQ§i\9f¡ ¤aÈw¥¥µA¬á aÇa\9d¡µÁ ¡y\r
+;; \88\81·\81 °w¸ñ ¸÷·\81\9fi ¤a\8e\81´ö¯s\93¡\94a.\r
+;;\r
+;; 1. ¬a¸å·\81 \8a\81¹¡\9fi ¤a\8e\81´ö¯s\93¡\94a. hForth RAM ¡¡\95IµA¬á\93e Å¡\97a, ·¡\9fq,\r
+;; ¸a\9ea ¸a\9f¡\88a ´a\9c\81Àá\9cñ ¡¡\96\81 ¬ãµa ·¶´ö»¡ e\r
+;;\r
+;; //·µ\8b¡/·¡\9fq/·¡\9fq\88a\9f¡Ç±/Å¡\97a>\r
+;;\r
+;; hForth EXE ¡¡\95IµA¬á\93e Å¡\97a ¸a\9f¡\9fi 8086 Ïa\9d¡A¬á·\81 \94a\9fe\r
+;; A\8ba åËa\9d¡ ´a\9c\81Àá\9cñ µ«\89v¯s\93¡\94a\r
+;;\r
+;; CS A\8ba åËa: //·¡\9fq\88a\9f¡Ç±/Å¡\97a>\r
+;; DS, SS A\8ba åËa: //¯¡Ç±Îa/·µ\8b¡/·¡\9fq>\r
+;;\r
+;; µa\8b¡¬á '¯¡Ç±Îa(xt)'\93e Å¡\97a·\81 ¯¡¸b µ¡ÏaU º\81¡·³\93¡\94a. $NAME\r
+;; aÇa\9d¡\9fi \94áÐa\89¡ $CODE, $COLON, $CONST, $VAR, $USER, $ENVIR\r
+;; aÇa\9d¡\9fi ¤a\8e\81´ö¯s\93¡\94a. RAM ¡¡\95I·\81 $VAR\93e ¡¡\96\81 $CONST\9fi °á¬á\r
+;; \89¡Áv¯s\93¡\94a.\r
+;;\r
+;; 2. head,µÁ name>xt\9fi ¤a\8e\81´ö¯s\93¡\94a. ¯¡Ç±Îa(xt)\9fi head,µA\89A \88å\91A\r
+;; º\89 ®\81 ·¶\8b¡ \98\81¢\85µA : , CONSTANT , CREATE , VARIABLE·i ROM\r
+;; ¡¡\95IÀá\9cñ ¤a\8e\81´ö¯s\93¡\94a. name>xt\88a ROM ¡¡\95I\89Á \88{´a¹v\8b¡ \98\81¢\85µA\r
+;; (search-wordlist)·\81 \8b¡\89\81´á ¸÷·\81\9fi ROM ¡¡\95I\89Á \88{\89A\r
+;; ¤a\8e\81´ö¯s\93¡\94a (°w¸ñ ¸÷·\81\93e \89¡Ã© Ï©¶a\88a ´ô¯s\93¡\94a).\r
+;;\r
+;; 3. CS: ¡w\9dw·i $NEXT aÇa\9d¡µÁ \8b¡\89\81´á ¸÷·\81-doLIT, doCONST,\r
+;; doCREATE, doUSER, doLOOP, do+LOOP, 0branch, branch-µA\r
+;; \94áÐ\96¯s\93¡\94a. doVAR\9fi ¨\96¯s\93¡\94a.\r
+;;\r
+;; 4. Å¡\97a A\8ba åËa·\81 µ¡ÏaU º\81¡·¥ 'Å¡\97a-º\81¡(code-addr)'\9ca\93e\r
+;; ¸a\9eaÑw·i \95¡·³Ð\96¯s\93¡\94a. x@ , x! , xb@ , xb!·\81 \91A \8b¡\89\81´á ¸÷·\81\9fi\r
+;; \94áÐ\96¯s\93¡\94a. x@, x!, xP\9fi °á¬á ?call , COMPILE, , optiCOMPILE,\r
+;; , THEN , >BODY , pipe , rake , xhere , TOxhere \8b¡\89\81´á ¸÷·\81\9fi\r
+;; \89¡Áv¯s\93¡\94a. xb@µÁ xb!\93e \90aº\97µA \94áÐi ´áQ§i\9cá\88a Å¡\97a ¸a\9f¡µA\r
+;; ¤a·¡Ëa\88t·i ·ª\89¡ ³i ®\81 ·¶\89A \90ý´á \96\81´ö¯s\93¡\94a.\r
+;;\r
+;; 5. S" , SLITERAL , ."·i ¤a\8e\81´ö¯s\93¡\94a. $INSTR aÇa\9d¡µÁ do."µÁ\r
+;; doS"·i ¨\96¯s\93¡\94a.\r
+;;\r
+;; 6. ¬a¶w¸a ¢\81\9fe\88t statusµÁ follower\88a Å¡\97a ¸a\9f¡·\81 º\81¡\9fi \88a\9f¡Ç¡\89A\r
+;; Ð\96¯s\93¡\94a. \88b ¸b´ó·¡ ¸a¯¥·\81 ¬a¶w¸a ¢\81\9fe\88t·i Àx·i ®\81 ·¶\95¡\9d¢\r
+;; Å¡\97a ¸a\9f¡µA \88a\9f¡Ç±\88t·i \90ý´ö¯s\93¡\94a. wakeµÁ PAUSE\9fi\r
+;; ¤a\8e\81´ö¯s\93¡\94a. ¤a\8e\85 °w¸ñ ¸÷·\81\93e RAM ¡¡\95I¥¡\94a 6% ¸÷\95¡ \93a\9f³\93¡\94a.\r
+;; wakeµÁ PAUSE\9fi \8b¡\89\81´á\9d¡ ¸÷·\81Ð\96¯s\93¡\94a. wakeµÁ PAUSE·\81 \8b¡\89\81´á\r
+;; ¸÷·\81\93e RAM ¡¡\95I·\81 °w¸ñ ¸÷·\81¥¡\94a 30% ¸÷\95¡ ¨a\9fs\93¡\94a.\r
+;;\r
+;; 7. '+'µÁ '-' \97w·\81 µa\9cá °w¸ñ ¸÷·\81\97i·i \8b¡\89\81´á ¸÷·\81\9d¡ ¤a\8e\81´ö¯s\93¡\94a.\r
+;; ¶¥\9c\81·\81 °w¸ñ ¸÷·\81\97i·e \94õ¦\9b·± i\9d¡ \90q\89a \96\81´ö¯s\93¡\94a.\r
+;;\r
+;;\r
+; hForth EXE model is derived from hForth RAM model and adapted\r
+; to segmented 8086 memory model.\r
+;\r
+; Differences from hForth RAM model is described below. No low\r
+; level CODE definitions is changed and only four words to access\r
+; code segment address are added. Some macros in the assembler\r
+; source and high level colon definitions are redefined.\r
+;\r
+; 1. The structure of the dictionary is changed. Code space is\r
+; separated into different 8086 segment. Name and data spaces\r
+; are combined in hForth EXE model as below\r
+;\r
+; CS segment: //pointer_to_name/code>\r
+; DS,SS segment: //xt/link/name>\r
+;\r
+; while they are intermingled in hForth RAM model as below\r
+;\r
+; //link/name/pointer_to_name/code>\r
+;\r
+; where xt is the starting address of code. $NAME macro is added\r
+; and $CODE, $COLON, $CONST, $VAR, $USER and $ENVIR macros are\r
+; redefined in assembly source. $VAR in RAM model source is\r
+; replaced with $CONST.\r
+;\r
+; 2. 'head,' and 'name>xt' are redefined. Redefine ':', 'CONSTANT',\r
+; 'CREATE', 'VARIABLE' similar to hForth 8086 ROM model since xt\r
+; can be given to 'head,'. Set code definition of\r
+; '(search-wordlist)' same as in ROM model since 'name>xt' is\r
+; the same as ROM model redefined (although colon definition need\r
+; not be changed at all).\r
+;\r
+; 3. CS: suffix is added into $NEXT macro and CODE definitions -\r
+; 'doLIT', 'doCONST', 'doCREATE', 'doUSER', 'doLOOP', 'do+LOOP',\r
+; '0branch', 'branch'. 'doVAR' is removed.\r
+;\r
+; 4. New data type 'code-addr' in introduced which is offset in CS:\r
+; segment. CODE definitions 'x@', 'x!', 'xb@' and 'xb!' and system\r
+; variable 'xP' is added. '?call', 'COMPILE,', ; 'optiCOMPILE,',\r
+; 'THEN', '>BODY', 'pipe', 'rake', 'xhere' ; and 'TOxhere' are\r
+; redefined using 'x@', 'x!' and 'xP'. 'xb@' and 'xb!' will be used\r
+; by assembler to read and write byte values in code space.\r
+;\r
+; 5. 'S"', 'SLITERAL' and '."' are redefined. $INSTR macro and 'do."'\r
+; and 'doS"' are dropped.\r
+;\r
+; 6. USER variable 'status' and 'follower' points code space\r
+; addresses. Pointer to user variable area are added into code\r
+; space for each task. Revise 'wake' and 'PAUSE'. High level\r
+; definitions of 'wake' and 'PAUSE' are about 6% slower compared to\r
+; RAM model. CODE definitions of 'wake' and 'PAUSE' are given,\r
+; which makes task-switching 30% faster than RAM model.\r
+;\r
+; 7. Many high level colon definitions such as '+' and '-' are\r
+; redefined as CODE definitions. Colon definitions are left as\r
+; comments in assembly source.\r
+;\r
+;===============================================================\r
+;\r
+; 8086/8 register usages\r
+; Double segment model. DS and SS are same but CS is different.\r
+; The direction bit must be cleared before returning to Forth\r
+; interpreter(CLD).\r
+; SP: data stack pointer\r
+; BP: return stack pointer\r
+; SI: Forth virtual machine instruction pointer\r
+; BX: top of data stack item\r
+; All other registers are free.\r
+;\r
+; Structure of a task\r
+; userP points follower.\r
+; //userP//<return_stack//<data_stack//\r
+; //user_area/user1/taskName/throwFrame/stackTop/status/follower/sp0/rp0\r
+;\r
+;===============================================================\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Assembly Constants\r
+;;;;;;;;;;;;;;;;\r
+\r
+TRUEE EQU -1\r
+FALSEE EQU 0\r
+\r
+CHARR EQU 1 ;byte size of a character\r
+CELLL EQU 2 ;byte size of a cell\r
+MaxChar EQU 0FFh ;Extended character set\r
+ ; Use 07Fh for ASCII only\r
+MaxSigned EQU 07FFFh ;max value of signed integer\r
+MaxUnsigned EQU 0FFFFh ;max value of unsigned integer\r
+MaxNegative EQU 8000h ;max value of negative integer\r
+ ; Used in doDO\r
+\r
+PADSize EQU 258 ;PAD area size\r
+RTCells EQU 64 ;return stack size\r
+DTCells EQU 256 ;data stack size\r
+\r
+BASEE EQU 10 ;default radix\r
+OrderDepth EQU 10 ;depth of search order stack\r
+\r
+COMPO EQU 020h ;lexicon compile only bit\r
+IMMED EQU 040h ;lexicon immediate bit\r
+SEMAN EQU 080h ;lexicon compilation semantics bit\r
+MASKK EQU 1Fh ;lexicon bit mask\r
+ ;extended character set\r
+ ;maximum name length = 1Fh\r
+\r
+BKSPP EQU 8 ;backspace\r
+TABB EQU 9 ;tab\r
+LFF EQU 10 ;line feed\r
+CRR EQU 13 ;carriage return\r
+DEL EQU 127 ;delete\r
+\r
+CALLL EQU 0E890h ;NOP CALL opcodes\r
+\r
+; Memory allocation\r
+; code segment ||code>--||\r
+; data segment ||name/data>WORDworkarea|--//--|PAD|TIB||\r
+\r
+; Initialize assembly variables\r
+\r
+_SLINK = 0 ;force a null link\r
+_FLINK = 0 ;force a null link\r
+_ENVLINK = 0 ;farce a null link\r
+_THROW = 0 ;current throw str addr offset\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Assembly macros\r
+;;;;;;;;;;;;;;;;\r
+\r
+; Adjust an address to the next cell boundary.\r
+\r
+$ALIGN MACRO\r
+ EVEN ;for 16 bit systems\r
+ ENDM\r
+\r
+; Add a name to name space of dictionary.\r
+\r
+$STR MACRO LABEL,STRING\r
+LABEL:\r
+ _LEN = $\r
+ DB 0,STRING\r
+ _CODE = $\r
+ORG _LEN\r
+ DB _CODE-_LEN-1\r
+ORG _CODE\r
+ $ALIGN\r
+ ENDM\r
+\r
+; Add a THROW message in name space. THROW messages won't be\r
+; needed if target system do not need names of Forth words.\r
+\r
+$THROWMSG MACRO STRING\r
+ _LEN = $\r
+ DB 0,STRING\r
+ _CODE = $\r
+ORG _LEN\r
+ DB _CODE-_LEN-1\r
+ _THROW = _THROW + CELLL\r
+ORG AddrTHROWMsgTbl - _THROW\r
+ DW _LEN\r
+ORG _CODE\r
+ ENDM\r
+\r
+; Compile a definition header in name space.\r
+\r
+$NAME MACRO LEX,NAME,LABEL,AddrNAME,LINK\r
+ $ALIGN ;force to cell boundary\r
+ DW LABEL ;xt\r
+ DW LINK ;link\r
+ _NAME = $\r
+ LINK = $ ;link points to a name string\r
+ AddrNAME = $\r
+ DB LEX,NAME ;name string\r
+ $ALIGN\r
+ ENDM\r
+\r
+; Compile a code definition.\r
+\r
+$CODE MACRO NAME,LABEL\r
+ DW NAME\r
+LABEL: ;assembly label\r
+ ENDM\r
+\r
+; Compile a colon definition.\r
+\r
+$COLON MACRO NAME,LABEL\r
+ $CODE NAME,LABEL\r
+ NOP ;align to cell boundary\r
+ CALL DoLIST ;include CALL doLIST\r
+ ENDM\r
+\r
+; Compile a system CONSTANT and VARIABLE.\r
+\r
+$CONST MACRO NAME,LABEL,VALUE\r
+ DW CompileCONST\r
+ $CODE NAME,LABEL\r
+ NOP\r
+ CALL DoCONST\r
+ DW VALUE\r
+ $NEXT\r
+ ENDM\r
+\r
+; Compile a system VALUE header.\r
+\r
+$VALUE MACRO NAME,LABEL,OFFSET\r
+ $CODE NAME,LABEL\r
+ NOP\r
+ CALL DoVALUE\r
+ DW OFFSET\r
+ ENDM\r
+\r
+; Compile a system USER variable.\r
+\r
+$USER MACRO NAME,LABEL,OFFSET\r
+ $CODE NAME,LABEL\r
+ NOP\r
+ CALL DoUSER\r
+ DW OFFSET\r
+ ENDM\r
+\r
+; Compile a environment query string header.\r
+\r
+$ENVIR MACRO LEX,NAME,LABEL\r
+ $ALIGN ;force to cell boundary\r
+ DW LABEL ;xt\r
+ DW _ENVLINK ;link\r
+ _ENVLINK = $ ;link points to a name string\r
+ DB LEX,NAME ;name string\r
+ $ALIGN\r
+ ENDM\r
+\r
+; Assemble inline direct threaded code ending.\r
+\r
+$NEXT MACRO\r
+ LODS WORD PTR CS:[SI]\r
+ JMP AX ;jump directly to code address\r
+ $ALIGN\r
+ ENDM\r
+\r
+;===============================================================\r
+\r
+FIRST SEGMENT PARA PUBLIC 'CODES'\r
+FIRST ENDS\r
+\r
+;===============================================================\r
+\r
+DATA SEGMENT\r
+\r
+ $STR CPUStr,'8086'\r
+ $STR ModelStr,'EXE Model'\r
+ $STR VersionStr,'0.9.9'\r
+\r
+; system variables.\r
+\r
+ $ALIGN ;align to cell boundary\r
+AddrTickEKEYQ DW RXQ ;'ekey?\r
+AddrTickEKEY DW RXFetch ;'ekey\r
+AddrTickEMITQ DW TXQ ;'emit?\r
+AddrTickEMIT DW TXStore ;'emit\r
+AddrTickINIT_IO DW Set_IO ;'init-i/o\r
+AddrTickPrompt DW DotOK ;'prompt\r
+AddrTickBoot DW HI ;'boot\r
+AddrSOURCE_ID DW 0 ;SOURCE-ID\r
+AddrHERE DW DTOP ;data space pointer\r
+AddrXHere DW CTOP ;code space pointer\r
+AddrTickDoWord DW OptiCOMPILEComma ;nonimmediate word - compilation\r
+ DW EXECUTE ;nonimmediate word - interpretation\r
+ DW DoubleAlsoComma ;not found word - compilateion\r
+ DW DoubleAlso ;not found word - interpretation\r
+ DW EXECUTE ;immediate word - compilation\r
+ DW EXECUTE ;immediate word - interpretation\r
+AddrBASE DW 10 ;BASE\r
+AddrMemTop DW 0FFFEh ;memTop\r
+AddrBal DW 0 ;bal\r
+AddrNotNONAMEQ DW 0 ;notNONAME?\r
+AddrRakeVar DW 0 ;rakeVar\r
+AddrNumberOrder DW 2 ;#order\r
+ DW AddrFORTH_WORDLIST ;search order stack\r
+ DW AddrNONSTANDARD_WORDLIST\r
+ DW (OrderDepth-2) DUP (0)\r
+AddrCurrent DW AddrFORTH_WORDLIST ;current pointer\r
+AddrFORTH_WORDLIST DW LASTFORTH ;FORTH-WORDLIST\r
+ DW AddrNONSTANDARD_WORDLIST;wordlist link\r
+ DW FORTH_WORDLISTName ;name of the WORDLIST\r
+AddrNONSTANDARD_WORDLIST DW LASTSYSTEM ;NONSTANDARD-WORDLIST\r
+ DW 0 ;wordlist link\r
+ DW NONSTANDARD_WORDLISTName;name of the WORDLIST\r
+AddrEnvQList DW LASTENV ;envQList\r
+AddrUserP DW SysUserP ;user pointer\r
+SysTask DW SysUserP ;system task's tid\r
+SysUser1 DW ? ;user1\r
+SysTaskName DW SystemTaskName ;taskName\r
+SysThrowFrame DW ? ;throwFrame\r
+SysStackTop DW ? ;stackTop\r
+SysStatus DW XSysStatus ;status\r
+SysUserP:\r
+SysFollower DW XSysFollower ;follower\r
+ DW SPP ;system task's sp0\r
+ DW RPP ;system task's rp0\r
+\r
+AddrNumberOrder0 DW 2 ;#order0\r
+ DW AddrFORTH_WORDLIST ;search order stack\r
+ DW AddrNONSTANDARD_WORDLIST\r
+ DW (OrderDepth-2) DUP (0)\r
+\r
+AddrAbortQMsg DW 2 DUP (?)\r
+AddrBalance DW ?\r
+AddrErrWord DW 2 DUP (?)\r
+AddrHLD DW ?\r
+AddrLastName DW ?\r
+AddrSourceVar DW 2 DUP (?)\r
+AddrToIN DW ?\r
+AddrSTATE DW ?\r
+AddrSpecialCompQ DW ?\r
+\r
+RStack DW RTCells DUP (0AAAAh) ;to see how deep stack grows\r
+RPP EQU $-CELLL\r
+DStack DW DTCells DUP (05555h) ;to see how deep stack grows\r
+SPP EQU $-CELLL\r
+\r
+; THROW code messages\r
+\r
+ DW 58 DUP (?) ;number of throw messages = 58\r
+AddrTHROWMsgTbl:\r
+ ;THROW code\r
+ $THROWMSG 'ABORT' ;-01\r
+ $THROWMSG 'ABORT"' ;-02\r
+ $THROWMSG 'stack overflow' ;-03\r
+ $THROWMSG 'stack underflow' ;-04\r
+ $THROWMSG 'return stack overflow' ;-05\r
+ $THROWMSG 'return stack underflow' ;-06\r
+ $THROWMSG 'do-loops nested too deeply during execution' ;-07\r
+ $THROWMSG 'dictionary overflow' ;-08\r
+ $THROWMSG 'invalid memory address' ;-09\r
+ $THROWMSG 'division by zero' ;-10\r
+ $THROWMSG 'result out of range' ;-11\r
+ $THROWMSG 'argument type mismatch' ;-12\r
+ $THROWMSG 'undefined word' ;-13\r
+ $THROWMSG 'interpreting a compile-only word' ;-14\r
+ $THROWMSG 'invalid FORGET' ;-15\r
+ $THROWMSG 'attempt to use zero-length string as a name' ;-16\r
+ $THROWMSG 'pictured numeric output string overflow' ;-17\r
+ $THROWMSG 'parsed string overflow' ;-18\r
+ $THROWMSG 'definition name too long' ;-19\r
+ $THROWMSG 'write to a read-only location' ;-20\r
+ $THROWMSG 'unsupported operation (e.g., AT-XY on a too-dumb terminal)' ;-21\r
+ $THROWMSG 'control structure mismatch' ;-22\r
+ $THROWMSG 'address alignment exception' ;-23\r
+ $THROWMSG 'invalid numeric argument' ;-24\r
+ $THROWMSG 'return stack imbalance' ;-25\r
+ $THROWMSG 'loop parameters unavailable' ;-26\r
+ $THROWMSG 'invalid recursion' ;-27\r
+ $THROWMSG 'user interrupt' ;-28\r
+ $THROWMSG 'compiler nesting' ;-29\r
+ $THROWMSG 'obsolescent feature' ;-30\r
+ $THROWMSG '>BODY used on non-CREATEd definition' ;-31\r
+ $THROWMSG 'invalid name argument (e.g., TO xxx)' ;-32\r
+ $THROWMSG 'block read exception' ;-33\r
+ $THROWMSG 'block write exception' ;-34\r
+ $THROWMSG 'invalid block number' ;-35\r
+ $THROWMSG 'invalid file position' ;-36\r
+ $THROWMSG 'file I/O exception' ;-37\r
+ $THROWMSG 'non-existent file' ;-38\r
+ $THROWMSG 'unexpected end of file' ;-39\r
+ $THROWMSG 'invalid BASE for floating point conversion' ;-40\r
+ $THROWMSG 'loss of precision' ;-41\r
+ $THROWMSG 'floating-point divide by zero' ;-42\r
+ $THROWMSG 'floating-point result out of range' ;-43\r
+ $THROWMSG 'floating-point stack overflow' ;-44\r
+ $THROWMSG 'floating-point stack underflow' ;-45\r
+ $THROWMSG 'floating-point invalid argument' ;-46\r
+ $THROWMSG 'compilation word list deleted' ;-47\r
+ $THROWMSG 'invalid POSTPONE' ;-48\r
+ $THROWMSG 'search-order overflow' ;-49\r
+ $THROWMSG 'search-order underflow' ;-50\r
+ $THROWMSG 'compilation word list changed' ;-51\r
+ $THROWMSG 'control-flow stack overflow' ;-52\r
+ $THROWMSG 'exception stack overflow' ;-53\r
+ $THROWMSG 'floating-point underflow' ;-54\r
+ $THROWMSG 'floating-point unidentified fault' ;-55\r
+ $THROWMSG 'QUIT' ;-56\r
+ $THROWMSG 'exception in sending or receiving a character' ;-57\r
+ $THROWMSG '[IF], [ELSE], or [THEN] exception' ;-58\r
+\r
+ $NAME 3,'RX?',RXQ,NameRXQ,_SLINK\r
+ $NAME 3,'RX@',RXFetch,NameRXFetch,_SLINK\r
+ $NAME SEMAN+3,'TX?',TXQ,NameTXQ,_SLINK\r
+ $NAME 3,'TX!',TXStore,NameTXStore,_SLINK\r
+ $NAME 2,'CR',CR,NameCR,_FLINK\r
+ $NAME 3,'BYE',BYE,NameBYE,_FLINK\r
+ $NAME 2,'hi',HI,NameHI,_SLINK\r
+ $STR HiStr1,'hForth '\r
+ $STR CPUQStr,'CPU'\r
+ $STR ModelQStr,'model'\r
+ $STR VersionQStr,'version'\r
+ $STR HiStr2,' by Wonyong Koh, 1997'\r
+ $STR HiStr3,'ALL noncommercial and commercial uses are granted.'\r
+ $STR HiStr4,'Please send comment, bug report and suggestions to:'\r
+ $STR HiStr5,' wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr'\r
+ $NAME 4,'COLD',COLD,NameCOLD,_SLINK\r
+ $NAME 7,'set-i/o',Set_IO,NameSet_IO,_SLINK\r
+ $STR Set_IOstr,'CON'\r
+ $NAME 8,'redirect',Redirect,NameRedirect,_SLINK\r
+ $NAME 6,'asciiz',ASCIIZ,NameASCIIZ,_SLINK\r
+ $NAME 5,'stdin',STDIN,NameSTDIN,_SLINK\r
+ $NAME IMMED+2,'<<',FROM,NameFROM,_SLINK\r
+ $STR FROMstr,'Do not use << in a definition.'\r
+ $NAME 5,'same?',SameQ,NameSameQ,_SLINK\r
+ $NAME 17,'(search-wordlist)',ParenSearch_Wordlist,NameParenSearch_Wordlist,_SLINK\r
+ $NAME 5,'?call',QCall,NameQCall,_SLINK\r
+ $NAME COMPO+4,'pipe',Pipe,NamePipe,_SLINK\r
+ $NAME 3,'xt,',xtComma,NamextComma,_SLINK\r
+ $NAME COMPO+13,'compileCREATE',CompileCREATE,NameCompileCREATE,_SLINK\r
+ $NAME COMPO+12,'compileCONST',CompileCONST,NameCompileCONST,_SLINK\r
+ $NAME COMPO+5,'doLIT',DoLIT,NameDoLIT,_SLINK\r
+ $NAME COMPO+7,'doCONST',DoCONST,NameDoCONST,_SLINK\r
+ $NAME COMPO+8,'doCREATE',DoCREATE,NameDoCREATE,_SLINK\r
+ $NAME COMPO+7,'doVALUE',DoVALUE,NameDoVALUE,_SLINK\r
+ $NAME COMPO+4,'doTO',DoTO,NameDoTO,_SLINK\r
+ $NAME COMPO+6,'doUSER',DoUSER,NameDoUSER,_SLINK\r
+ $NAME COMPO+6,'doLIST',DoLIST,NameDoLIST,_SLINK\r
+ $NAME COMPO+6,'doLOOP',DoLOOP,NameDoLOOP,_SLINK\r
+ $NAME COMPO+7,'do+LOOP',DoPLOOP,NameDoPLOOP,_SLINK\r
+ $NAME COMPO+7,'0branch',ZBranch,NameZBranch,_SLINK\r
+ $NAME COMPO+6,'branch',Branch,NameBranch,_SLINK\r
+ $NAME COMPO+3,'rp@',RPFetch,NameRPFetch,_SLINK\r
+ $NAME COMPO+3,'rp!',RPStore,NameRPStore,_SLINK\r
+ $NAME 3,'sp@',SPFetch,NameSPFetch,_SLINK\r
+ $NAME 3,'sp!',SPStore,NameSPStore,_SLINK\r
+ $NAME 3,'um+',UMPlus,NameUMPlus,_SLINK\r
+ $NAME 5,'code!',CodeStore,NameCodeStore,_SLINK\r
+ $NAME 6,'codeB!',CodeBStore,NameCodeBStore,_SLINK\r
+ $NAME 5,'code@',CodeFetch,NameCodeFetch,_SLINK\r
+ $NAME 6,'codeB@',CodeBFetch,NameCodeBFetch,_SLINK\r
+ $NAME 5,'code,',CodeComma,NameCodeComma,_SLINK\r
+ $NAME 5,'ALIGN',ALIGNN,NameALIGNN,_FLINK\r
+ $NAME 7,'ALIGNED',ALIGNED,NameALIGNED,_FLINK\r
+ $NAME 5,'pack"',PackQuote,NamePackQuote,_SLINK\r
+ $NAME 5,'CELLS',CELLS,NameCELLS,_FLINK\r
+ $NAME 5,'CHARS',CHARS,NameCHARS,_FLINK\r
+ $NAME 7,'1chars/',OneCharsSlash,NameOneCharsSlash,_SLINK\r
+ $NAME 1,'!',Store,NameStore,_FLINK\r
+ $NAME 2,'0<',ZeroLess,NameZeroLess,_FLINK\r
+ $NAME 2,'0=',ZeroEquals,NameZeroEquals,_FLINK\r
+ $NAME 2,'2*',TwoStar,NameTwoStar,_FLINK\r
+ $NAME 2,'2/',TwoSlash,NameTwoSlash,_FLINK\r
+ $NAME COMPO+2,'>R',ToR,NameToR,_FLINK\r
+ $NAME 1,'@',Fetch,NameFetch,_FLINK\r
+ $NAME 3,'AND',ANDD,NameANDD,_FLINK\r
+ $NAME 2,'C!',CStore,NameCStore,_FLINK\r
+ $NAME 2,'C@',CFetch,NameCFetch,_FLINK\r
+ $NAME 4,'DROP',DROP,NameDROP,_FLINK\r
+ $NAME 3,'DUP',DUPP,NameDUPP,_FLINK\r
+ $NAME 7,'EXECUTE',EXECUTE,NameEXECUTE,_FLINK\r
+ $NAME COMPO+4,'EXIT',EXIT,NameEXIT,_FLINK\r
+ $NAME 4,'MOVE',MOVE,NameMOVE,_FLINK\r
+ $NAME 2,'OR',ORR,NameORR,_FLINK\r
+ $NAME 4,'OVER',OVER,NameOVER,_FLINK\r
+ $NAME COMPO+2,'R>',RFrom,NameRFrom,_FLINK\r
+ $NAME COMPO+2,'R@',RFetch,NameRFetch,_FLINK\r
+ $NAME 4,'SWAP',SWAP,NameSWAP,_FLINK\r
+ $NAME 3,'XOR',XORR,NameXORR,_FLINK\r
+ $NAME SEMAN+7,'#order0',NumberOrder0,NameNumberOrder0,_SLINK\r
+ $NAME 6,"'ekey?",TickEKEYQ,NameTickEKEYQ,_SLINK\r
+ $NAME 5,"'ekey",TickEKEY,NameTickEKEY,_SLINK\r
+ $NAME 6,"'emit?",TickEMITQ,NameTickEMITQ,_SLINK\r
+ $NAME 5,"'emit",TickEMIT,NameTickEMIT,_SLINK\r
+ $NAME 9,"'init-i/o",TickINIT_IO,NameTickINIT_IO,_SLINK\r
+ $NAME 7,"'prompt",TickPrompt,NameTickPrompt,_SLINK\r
+ $NAME 5,"'boot",TickBoot,NameTickBoot,_SLINK\r
+ $NAME 9,'SOURCE-ID',SOURCE_ID,NameSOURCE_ID,_FLINK\r
+ $NAME 4,'HERE',HERE,NameHERE,_FLINK\r
+ $NAME 5,'xhere',XHere,NameXHere,_SLINK\r
+ $NAME SEMAN+7,"'doWord",TickDoWord,NameTickDoWord,_SLINK\r
+ $NAME SEMAN+4,'BASE',BASE,NameBASE,_FLINK\r
+ $NAME SEMAN+11,'THROWMsgTbl',THROWMsgTbl,NameTHROWMsgTbl,_SLINK\r
+ $NAME 6,'memTop',MemTop,NameMemTop,_SLINK\r
+ $NAME 3,'bal',Bal,NameBal,_SLINK\r
+ $NAME 10,'notNONAME?',NotNONAMEQ,NameNotNONAMEQ,_SLINK\r
+ $NAME SEMAN+7,'rakeVar',RakeVar,NameRakeVar,_SLINK\r
+ $NAME SEMAN+6,'#order',NumberOrder,NameNumberOrder,_SLINK\r
+ $NAME SEMAN+7,'current',Current,NameCurrent,_SLINK\r
+ $NAME SEMAN+14,'FORTH-WORDLIST',FORTH_WORDLIST,NameFORTH_WORDLIST,_FLINK\r
+FORTH_WORDLISTName EQU _NAME-0\r
+ $NAME SEMAN+20,'NONSTANDARD-WORDLIST',NONSTANDARD_WORDLIST,NameNONSTANDARD_WORDLIST,_FLINK\r
+NONSTANDARD_WORDLISTName EQU _NAME-0\r
+ $NAME SEMAN+8,'envQList',EnvQList,NameEnvQList,_SLINK\r
+ $NAME SEMAN+5,'userP',UserP,NameUserP,_SLINK\r
+ $NAME SEMAN+10,'SystemTask',SystemTask,NameSystemTask,_SLINK\r
+SystemTaskName EQU _NAME-0\r
+ $NAME 8,'follower',Follower,NameFollower,_SLINK\r
+ $NAME 6,'status',Status,NameStatus,_SLINK\r
+ $NAME 8,'stackTop',StackTop,NameStackTop,_SLINK\r
+ $NAME 10,'throwFrame',ThrowFrame,NameThrowFrame,_SLINK\r
+ $NAME 8,'taskName',TaskName,NameTaskName,_SLINK\r
+ $NAME 5,'user1',User1,NameUser1,_SLINK\r
+ $ENVIR 3,'CPU',CPU\r
+ $ENVIR 5,'model',Model\r
+ $ENVIR 7,'version',Version\r
+ $ENVIR 15,'/COUNTED-STRING',SlashCOUNTED_STRING\r
+ $ENVIR 5,'/HOLD',SlashHOLD\r
+ $ENVIR 4,'/PAD',SlashPAD\r
+ $ENVIR 17,'ADDRESS-UNIT-BITS',ADDRESS_UNIT_BITS\r
+ $ENVIR 4,'CORE',CORE\r
+ $ENVIR 7,'FLOORED',FLOORED\r
+ $ENVIR 8,'MAX-CHAR',MAX_CHAR\r
+ $ENVIR 5,'MAX-D',MAX_D\r
+ $ENVIR 5,'MAX-N',MAX_N\r
+ $ENVIR 5,'MAX-U',MAX_U\r
+ $ENVIR 6,'MAX-UD',MAX_UD\r
+ $ENVIR 18,'RETURN-STACK-CELLS',RETURN_STACK_CELLS\r
+ $ENVIR 11,'STACK-CELLS',STACK_CELLS\r
+ $ENVIR 9,'EXCEPTION',EXCEPTION\r
+ $ENVIR 13,'EXCEPTION-EXT',EXCEPTION_EXT\r
+ $ENVIR 9,'WORDLISTS',WORDLISTS\r
+ $NAME 3,"(')",ParenTick,NameParenTick,_SLINK\r
+ $NAME 4,'(d.)',ParenDDot,NameParenDDot,_SLINK\r
+ $NAME 3,'.ok',DotOK,NameDotOK,_SLINK\r
+ $STR DotOKStr,'ok'\r
+ $NAME 7,'.prompt',DotPrompt,NameDotOK,_SLINK\r
+ $NAME SEMAN+1,'0',Zero,NameZero,_SLINK\r
+ $NAME SEMAN+1,'1',One,NameOne,_SLINK\r
+ $NAME SEMAN+2,'-1',MinusOne,NameMinusOne,_SLINK\r
+ $NAME SEMAN+9,'abort"msg',AbortQMsg,NameAbortQMsg,_SLINK\r
+ $NAME 4,'bal+',BalPlus,NameBalPlus,_SLINK\r
+ $NAME 4,'bal-',BalMinus,NameBalMinus,_SLINK\r
+ $NAME 5,'cell-',CellMinus,NameCellMinus,_SLINK\r
+ $NAME 12,'COMPILE-ONLY',COMPILE_ONLY,NameCOMPILE_ONLY,_SLINK\r
+ $NAME COMPO+4,'doDO',DoDO,NameDoDO,_SLINK\r
+ $NAME SEMAN+7,'errWord',ErrWord,NameErrWord,_SLINK\r
+ $NAME 5,'head,',HeadComma,NameHeadComma,_SLINK\r
+ $STR HEADCstr,'redefine '\r
+ $NAME SEMAN+3,'hld',HLD,NameHLD,_SLINK\r
+ $NAME 9,'interpret',Interpret,NameInterpret,_SLINK\r
+ $NAME 12,'optiCOMPILE,',OptiCOMPILEComma,NameOptiCOMPILEComma,_SLINK\r
+ $NAME 10,'singleOnly',SingleOnly,NameSingleOnly,_SLINK\r
+ $NAME 11,'singleOnly,',SingleOnlyComma,NameSingleOnlyComma,_SLINK\r
+ $NAME 12,'(doubleAlso)',ParenDoubleAlso,NameParenDoubleAlso,_SLINK\r
+ $NAME 10,'doubleAlso',DoubleAlso,NameDoubleAlso,_SLINK\r
+ $NAME 11,'doubleAlso,',DoubleAlsoComma,NameDoubleAlsoComma,_SLINK\r
+ $NAME IMMED+2,'-.',MinusDot,NameMinusDot,_SLINK\r
+ $NAME 8,'lastName',LastName,NameLastName,_SLINK\r
+ $NAME 8,'linkLast',LinkLast,NameLinkLast,_SLINK\r
+ $NAME 7,'name>xt',NameToXT,NameNameToXT,_SLINK\r
+ $NAME 9,'skipPARSE',SkipPARSE,NameSkipPARSE,_SLINK\r
+ $NAME 12,'specialComp?',SpecialCompQ,NameSpecialCompQ,_SLINK\r
+ $NAME 10,'PARSE-WORD',PARSE_WORD,NamePARSE_WORD,_SLINK\r
+ $NAME COMPO+4,'rake',rake,Namerake,_SLINK\r
+ $NAME 3,'rp0',RPZero,NameRPZero,_SLINK\r
+ $NAME 11,'search-word',Search_word,NameSearch_word,_SLINK\r
+ $NAME SEMAN+9,'sourceVar',SourceVar,NameSourceVar,_SLINK\r
+ $NAME 3,'sp0',SPZero,NameSPZero,_SLINK\r
+ $NAME COMPO+5,'PAUSE',PAUSE,NamePAUSE,_SLINK\r
+ $NAME COMPO+4,'wake',Wake,NameWake,_SLINK\r
+ $NAME 1,'#',NumberSign,NameNumberSign,_FLINK\r
+ $NAME 2,'#>',NumberSignGreater,NameNumberSignGreater,_FLINK\r
+ $NAME 2,'#S',NumberSignS,NameNumberSignS,_FLINK\r
+ $NAME 1,"'",Tick,NameTick,_FLINK\r
+ $NAME 1,'+',Plus,NamePlus,_FLINK\r
+ $NAME 2,'+!',PlusStore,NamePlusStore,_FLINK\r
+ $NAME 1,',',Comma,NameComma,_FLINK\r
+ $NAME 1,'-',Minus,NameMinus,_FLINK\r
+ $NAME 1,'.',Dot,NameDot,_FLINK\r
+ $NAME 1,'/',Slash,NameSlash,_FLINK\r
+ $NAME 4,'/MOD',SlashMOD,NameSlashMOD,_FLINK\r
+ $NAME 7,'/STRING',SlashSTRING,NameSlashSTRING,_FLINK\r
+ $NAME 2,'1+',OnePlus,NameOnePlus,_FLINK\r
+ $NAME 2,'1-',OneMinus,NameOneMinus,_FLINK\r
+ $NAME 2,'2!',TwoStore,NameTwoStore,_FLINK\r
+ $NAME 2,'2@',TwoFetch,NameTwoFetch,_FLINK\r
+ $NAME 5,'2DROP',TwoDROP,NameTwoDROP,_FLINK\r
+ $NAME 4,'2DUP',TwoDUP,NameTwoDUP,_FLINK\r
+ $NAME 5,'2SWAP',TwoSWAP,NameTwoSWAP,_FLINK\r
+ $NAME 1,':',COLON,NameCOLON,_FLINK\r
+ $NAME 7,':NONAME',ColonNONAME,NameColonNONAME,_FLINK\r
+ $NAME IMMED+COMPO+1,';',Semicolon,NameSemicolon,_FLINK\r
+ $NAME 1,'<',LessThan,NameLessThan,_FLINK\r
+ $NAME 2,'<#',LessNumberSign,NameLessNumberSign,_FLINK\r
+ $NAME 1,'=',Equals,NameEquals,_FLINK\r
+ $NAME 1,'>',GreaterThan,NameGreaterThan,_FLINK\r
+ $NAME SEMAN+3,'>IN',ToIN,NameToIN,_FLINK\r
+ $NAME 7,'>NUMBER',ToNUMBER,NameToNUMBER,_FLINK\r
+ $NAME 4,'?DUP',QuestionDUP,NameQuestionDUP,_FLINK\r
+ $NAME 5,'ABORT',ABORT,NameABORT,_FLINK\r
+ $NAME 6,'ACCEPT',ACCEPT,NameACCEPT,_FLINK\r
+ $NAME IMMED+COMPO+5,'AGAIN',AGAIN,NameAGAIN,_FLINK\r
+ $NAME IMMED+COMPO+5,'AHEAD',AHEAD,NameAHEAD,_FLINK\r
+ $NAME SEMAN+2,'BL',BLank,NameBLank,_FLINK\r
+ $NAME 5,'CATCH',CATCH,NameCATCH,_FLINK\r
+ $NAME 5,'CELL+',CELLPlus,NameCELLPlus,_FLINK\r
+ $NAME 5,'CHAR+',CHARPlus,NameCHARPlus,_FLINK\r
+ $NAME COMPO+8,'COMPILE,',COMPILEComma,NameCOMPILEComma,_FLINK\r
+ $NAME 8,'CONSTANT',CONSTANT,NameCONSTANT,_FLINK\r
+ $NAME 5,'COUNT',COUNT,NameCOUNT,_FLINK\r
+ $NAME 6,'CREATE',CREATE,NameCREATE,_FLINK\r
+ $NAME 2,'D+',DPlus,NameDPlus,_FLINK\r
+ $NAME 2,'D.',DDot,NameDDot,_FLINK\r
+ $NAME 7,'DECIMAL',DECIMAL,NameDECIMAL,_FLINK\r
+ $NAME 5,'DEPTH',DEPTH,NameDEPTH,_FLINK\r
+ $NAME 7,'DNEGATE',DNEGATE,NameDNEGATE,_FLINK\r
+ $NAME 4,'EKEY',EKEY,NameEKEY,_FLINK\r
+ $NAME 4,'EMIT',EMIT,NameEMIT,_FLINK\r
+ $NAME 6,'FM/MOD',FMSlashMOD,NameFMSlashMOD,_FLINK\r
+ $NAME 11,'GET-CURRENT',GET_CURRENT,NameGET_CURRENT,_FLINK\r
+ $NAME 4,'HOLD',HOLD,NameHOLD,_FLINK\r
+ $NAME COMPO+1,'I',I,NameI,_FLINK\r
+ $NAME IMMED+COMPO+2,'IF',IFF,NameIFF,_FLINK\r
+ $NAME 6,'INVERT',INVERT,NameINVERT,_FLINK\r
+ $NAME 3,'KEY',KEY,NameKEY,_FLINK\r
+ $NAME IMMED+COMPO+7,'LITERAL',LITERAL,NameLITERAL,_FLINK\r
+ $NAME 6,'NEGATE',NEGATE,NameNEGATE,_FLINK\r
+ $NAME 3,'NIP',NIP,NameNIP,_FLINK\r
+ $NAME 5,'PARSE',PARSE,NamePARSE,_FLINK\r
+ $NAME 4,'QUIT',QUIT,NameQUIT,_FLINK\r
+ $STR QUITstr,' Exception # '\r
+ $NAME 6,'REFILL',REFILL,NameREFILL,_FLINK\r
+ $NAME 3,'ROT',ROT,NameROT,_FLINK\r
+ $NAME 3,'S>D',SToD,NameSToD,_FLINK\r
+ $NAME 15,'SEARCH-WORDLIST',SEARCH_WORDLIST,NameSEARCH_WORDLIST,_FLINK\r
+ $NAME 4,'SIGN',SIGN,NameSIGN,_FLINK\r
+ $NAME 6,'SOURCE',SOURCE,NameSOURCE,_FLINK\r
+ $NAME 5,'SPACE',SPACE,NameSPACE,_FLINK\r
+ $NAME SEMAN+5,'STATE',STATE,NameSTATE,_FLINK\r
+ $NAME IMMED+COMPO+4,'THEN',THENN,NameTHENN,_FLINK\r
+ $NAME 5,'THROW',THROW,NameTHROW,_FLINK\r
+ $NAME 4,'TYPE',TYPEE,NameTYPEE,_FLINK\r
+ $NAME 2,'U<',ULess,NameULess,_FLINK\r
+ $NAME 3,'UM*',UMStar,NameUMStar,_FLINK\r
+ $NAME 6,'UM/MOD',UMSlashMOD,NameUMSlashMOD,_FLINK\r
+ $NAME COMPO+6,'UNLOOP',UNLOOP,NameUNLOOP,_FLINK\r
+ $NAME 6,'WITHIN',WITHIN,NameWITHIN,_FLINK\r
+ $NAME IMMED+COMPO+1,'[',LeftBracket,NameLeftBracket,_FLINK\r
+ $NAME 1,']',RightBracket,NameRightBracket,_FLINK\r
+ $NAME IMMED+1,'(',Paren,NameParen,_FLINK\r
+ $NAME 1,'*',Star,NameStar,_FLINK\r
+ $NAME 2,'*/',StarSlash,NameStarSlash,_FLINK\r
+ $NAME 5,'*/MOD',StarSlashMOD,NameStarSlashMOD,_FLINK\r
+ $NAME IMMED+COMPO+5,'+LOOP',PlusLOOP,NamePlusLOOP,_FLINK\r
+ $NAME IMMED+COMPO+2,'."',DotQuote,NameDotQuote,_FLINK\r
+ $NAME 5,'2OVER',TwoOVER,NameTwoOVER,_FLINK\r
+ $NAME 5,'>BODY',ToBODY,NameToBODY,_FLINK\r
+ $NAME IMMED+COMPO+6,'ABORT"',ABORTQuote,NameABORTQuote,_FLINK\r
+ $NAME 3,'ABS',ABSS,NameABSS,_FLINK\r
+ $NAME 5,'ALLOT',ALLOT,NameALLOT,_FLINK\r
+ $NAME IMMED+COMPO+5,'BEGIN',BEGIN,NameBEGIN,_FLINK\r
+ $NAME 2,'C,',CComma,NameCComma,_FLINK\r
+ $NAME 4,'CHAR',CHAR,NameCHAR,_FLINK\r
+ $NAME IMMED+COMPO+2,'DO',DO,NameDO,_FLINK\r
+ $NAME IMMED+COMPO+5,'DOES>',DOESGreater,NameDOESGreater,_FLINK\r
+ $NAME IMMED+COMPO+4,'ELSE',ELSEE,NameELSEE,_FLINK\r
+ $NAME 12,'ENVIRONMENT?',ENVIRONMENTQuery,NameENVIRONMENTQuery,_FLINK\r
+ $NAME 8,'EVALUATE',EVALUATE,NameEVALUATE,_FLINK\r
+ $NAME 4,'FILL',FILL,NameFILL,_FLINK\r
+ $NAME 4,'FIND',FIND,NameFIND,_FLINK\r
+ $NAME 9,'IMMEDIATE',IMMEDIATE,NameIMMEDIATE,_FLINK\r
+ $NAME COMPO+1,'J',J,NameJ,_FLINK\r
+ $NAME IMMED+COMPO+5,'LEAVE',LEAVEE,NameLEAVEE,_FLINK\r
+ $NAME IMMED+COMPO+4,'LOOP',LOOPP,NameLOOPP,_FLINK\r
+ $NAME 6,'LSHIFT',LSHIFT,NameLSHIFT,_FLINK\r
+ $NAME 2,'M*',MStar,NameMStar,_FLINK\r
+ $NAME 3,'MAX',MAX,NameMAX,_FLINK\r
+ $NAME 3,'MIN',MIN,NameMIN,_FLINK\r
+ $NAME 3,'MOD',MODD,NameMODD,_FLINK\r
+ $NAME 4,'PICK',PICK,NamePICK,_FLINK\r
+ $NAME IMMED+COMPO+8,'POSTPONE',POSTPONE,NamePOSTPONE,_FLINK\r
+ $NAME IMMED+COMPO+7,'RECURSE',RECURSE,NameRECURSE,_FLINK\r
+ $NAME IMMED+COMPO+6,'REPEAT',REPEATT,NameREPEAT,_FLINK\r
+ $NAME 6,'RSHIFT',RSHIFT,NameRSHIFT,_FLINK\r
+ $NAME IMMED+COMPO+8,'SLITERAL',SLITERAL,NameSLITERAL,_FLINK\r
+ $NAME IMMED+COMPO+2,'S"',SQuote,NameSQuote,_FLINK\r
+ $STR SQUOTstr1,'Use of S" in interpretation state is non-portable.'\r
+ $STR SQUOTstr2,'Use instead CHAR " PARSE word" or BL PARSE word .'\r
+ $NAME 6,'SM/REM',SMSlashREM,NameSMSlashREM,_FLINK\r
+ $NAME 6,'SPACES',SPACES,NameSPACES,_FLINK\r
+ $NAME IMMED+2,'TO',TO,NameTO,_FLINK\r
+ $NAME 2,'U.',UDot,NameUDot,_FLINK\r
+ $NAME IMMED+COMPO+5,'UNTIL',UNTIL,NameUNTIL,_FLINK\r
+ $NAME 5,'VALUE',VALUE,NameVALUE,_FLINK\r
+ $NAME 8,'VARIABLE',VARIABLE,NameVARIABLE,_FLINK\r
+ $NAME IMMED+COMPO+5,'WHILE',WHILEE,NameWHILE,_FLINK\r
+ $NAME 4,'WORD',WORDD,NameWORDD,_FLINK\r
+ $NAME IMMED+COMPO+3,"[']",BracketTick,NameBracketTick,_FLINK\r
+ $NAME IMMED+COMPO+6,'[CHAR]',BracketCHAR,NameBracketCHAR,_FLINK\r
+ $NAME IMMED+1,'\',Backslash,NameBackslash,_FLINK\r
+ $NAME 5,'EKEY?',EKEYQuestion,NameEKEYQuestion,_FLINK\r
+ $NAME 5,'EMIT?',EMITQuestion,NameEMITQuestion,_FLINK\r
+\r
+LASTENV EQU _ENVLINK-0\r
+LASTSYSTEM EQU _SLINK-0 ;last SYSTEM word name address\r
+LASTFORTH EQU _FLINK-0 ;last FORTH word name address\r
+\r
+DTOP EQU $-0 ;next available memory in data space\r
+\r
+DATA ENDS\r
+\r
+;===============================================================\r
+\r
+CODE SEGMENT PARA PUBLIC 'CODES'\r
+\r
+ASSUME CS:CODE,DS:DATA,SS:DATA\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Main entry points and COLD start data\r
+;;;;;;;;;;;;;;;;\r
+\r
+XSysStatus DW Wake ;for multitasker\r
+XSysFollower DW XSysStatus ;for multitasker\r
+ DW SysUserP ;for multitasker\r
+\r
+ORIG: MOV DX,CS\r
+ ADD DX,1000h ;64KB full segment\r
+ MOV DS,DX ;new data segment\r
+ CLI ;disable interrupts, old 808x CPU bug\r
+ MOV SS,DX ;SS is same as DS\r
+ MOV SP,OFFSET SPP ;initialize SP\r
+ STI ;enable interrupts\r
+ MOV BP,OFFSET RPP ;initialize RP\r
+ CLD ;direction flag, increment\r
+ XOR AX,AX ;MS-DOS only\r
+ MOV CS:Redirect1stQ,AX ;MS-DOS only\r
+ JMP COLD ;to high level cold start\r
+\r
+;;;;;;;;;;;;;;;;\r
+; System dependent words -- Must be re-definded for each system.\r
+;;;;;;;;;;;;;;;;\r
+; I/O words must be redefined if serial communication is used instead of\r
+; keyboard. Following words are for MS-DOS system.\r
+\r
+; RX? ( -- flag )\r
+; Return true if key is pressed.\r
+\r
+ $CODE NameRXQ,RXQ\r
+ PUSH BX\r
+ MOV AH,0Bh ;get input status of STDIN\r
+ INT 021h\r
+ CBW\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; RX@ ( -- u )\r
+; Receive one keyboard event u.\r
+\r
+ $CODE NameRXFetch,RXFetch\r
+ PUSH BX\r
+ XOR BX,BX\r
+ MOV AH,08h ;MS-DOS Read Keyboard\r
+ INT 021h\r
+ ADD BL,AL ;MOV BL,AL and OR AL,AL\r
+ JNZ RXFET1 ;extended character code?\r
+ INT 021h\r
+ MOV BH,AL\r
+RXFET1: $NEXT\r
+\r
+; TX? ( -- flag )\r
+; Return true if output device is ready or device state is\r
+; indeterminate.\r
+\r
+ $CONST NameTXQ,TXQ,TRUEE ;always true for MS-DOS\r
+\r
+; TX! ( u -- )\r
+; Send char to the output device.\r
+\r
+ $CODE NameTXStore,TXStore\r
+ MOV DX,BX ;char in DL\r
+ MOV AH,02h ;MS-DOS Display output\r
+ INT 021H ;display character\r
+ POP BX\r
+ $NEXT\r
+\r
+; CR ( -- ) \ CORE\r
+; Carriage return and linefeed.\r
+;\r
+; : CR carriage-return-char EMIT linefeed-char EMIT ;\r
+\r
+ $COLON NameCR,CR\r
+ DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT\r
+\r
+; BYE ( -- ) \ TOOLS EXT\r
+; Return control to the host operation system, if any.\r
+\r
+ $CODE NameBYE,BYE\r
+ MOV AX,04C00h ;close all files and\r
+ INT 021h ; return to MS-DOS\r
+ $ALIGN\r
+\r
+; hi ( -- )\r
+;\r
+; : hi CR ." hForth "\r
+; S" CPU" ENVIRONMENT? DROP TYPE SPACE\r
+; S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT\r
+; S" version" ENVIRONMENT? DROP TYPE\r
+; ." by Wonyong Koh, 1997" CR\r
+; ." ALL noncommercial and commercial uses are granted." CR\r
+; ." Please send comment, bug report and suggestions to:" CR\r
+; ." wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;\r
+\r
+ $COLON NameHI,HI\r
+ DW CR,DoLIT,HiStr1,COUNT,TYPEE\r
+ DW DoLIT,CPUQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE,SPACE\r
+ DW DoLIT,ModelQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE\r
+ DW SPACE,DoLIT,'v',EMIT\r
+ DW DoLIT,VersionQStr,COUNT,ENVIRONMENTQuery,DROP,TYPEE\r
+ DW DoLIT,HiStr2,COUNT,TYPEE,CR\r
+ DW DoLIT,HiStr3,COUNT,TYPEE,CR\r
+ DW DoLIT,HiStr4,COUNT,TYPEE,CR\r
+ DW DoLIT,HiStr5,COUNT,TYPEE,CR,EXIT\r
+\r
+; COLD ( -- )\r
+; The cold start sequence execution word.\r
+;\r
+; : COLD sp0 sp! rp0 rp! \ initialize stack\r
+; 'init-i/o EXECUTE\r
+; 'boot EXECUTE\r
+; QUIT ; \ start interpretation\r
+\r
+ $COLON NameCOLD,COLD\r
+ DW SPZero,SPStore,RPZero,RPStore\r
+ DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE\r
+ DW QUIT\r
+\r
+; set-i/o ( -- )\r
+; Set input/output device.\r
+;\r
+; : set-i/o S" CON" stdin ; \ MS-DOS only\r
+\r
+ $COLON NameSet_IO,Set_IO\r
+ DW DoLIT,Set_IOstr ;MS-DOS only\r
+ DW COUNT,STDIN ;MS-DOS only\r
+ DW EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; MS-DOS only words -- not necessary for other systems.\r
+;;;;;;;;;;;;;;;;\r
+; File input using MS-DOS redirection function without using FILE words.\r
+\r
+; redirect ( c-addr -- flag )\r
+; Redirect standard input from the device identified by ASCIIZ\r
+; string stored at c-addr. Return error code.\r
+\r
+ $CODE NameRedirect,Redirect\r
+ MOV DX,BX\r
+ MOV AX,CS:Redirect1stQ\r
+ OR AX,AX\r
+ JZ REDIRECT2\r
+ MOV AH,03Eh\r
+ MOV BX,CS:RedirHandle\r
+ INT 021h ; close previously opend file\r
+REDIRECT2: MOV AX,03D00h ; open file read-only\r
+ MOV CS:Redirect1stQ,AX ; set Redirect1stQ true\r
+ INT 021h\r
+ JC REDIRECT1 ; if error\r
+ MOV CS:RedirHandle,AX\r
+ XOR CX,CX\r
+ MOV BX,AX\r
+ MOV AX,04600H\r
+ INT 021H\r
+ JC REDIRECT1\r
+ XOR AX,AX\r
+REDIRECT1: MOV BX,AX\r
+ $NEXT\r
+Redirect1stQ DW 0 ; true after the first redirection\r
+RedirHandle DW ? ; redirect file handle\r
+\r
+; asciiz ( ca1 u -- ca2 )\r
+; Return ASCIIZ string.\r
+;\r
+; : asciiz HERE SWAP 2DUP + 0 SWAP C! CHARS MOVE HERE ;\r
+\r
+ $COLON NameASCIIZ,ASCIIZ\r
+ DW HERE,SWAP,TwoDUP,Plus,DoLIT,0\r
+ DW SWAP,CStore,CHARS,MOVE,HERE,EXIT\r
+\r
+; stdin ( ca u -- )\r
+;\r
+; : stdin asciiz redirect ?DUP\r
+; IF -38 THROW THEN \ non-existent file\r
+; ; COMPILE-ONLY\r
+\r
+ $COLON NameSTDIN,STDIN\r
+ DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1\r
+ DW DoLIT,-38,THROW\r
+STDIN1 DW EXIT\r
+\r
+; << ( "<spaces>ccc" -- )\r
+; Redirect input from the file 'ccc'. Should be used only in\r
+; interpretation state.\r
+;\r
+; : << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN\r
+; PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+ $COLON NameFROM,FROM\r
+ DW DoLIT,AddrSTATE,Fetch,ZBranch,FROM1\r
+ DW CR\r
+ DW DoLIT,FROMstr\r
+ DW COUNT,TYPEE,ABORT\r
+FROM1 DW PARSE_WORD,STDIN,SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Non-Standard words - Processor-dependent definitions\r
+; 16 bit Forth for 8086/8\r
+;;;;;;;;;;;;;;;;\r
+\r
+; PAUSE ( -- )\r
+; Stop current task and transfer control to the task of which\r
+; 'status' USER variable is stored in 'follower' USER variable\r
+; of current task.\r
+;\r
+; : PAUSE rp@ DUP sp@ stackTop ! follower @ code@ >R ; COMPILE-ONLY\r
+;\r
+; $COLON NamePAUSE,PAUSE\r
+; DW RPFetch,DUPP,SPFetch,StackTop,Store\r
+; DW Follower,Fetch,CodeFetch,ToR,EXIT\r
+\r
+ $CODE NamePAUSE,PAUSE\r
+ PUSH BX\r
+ XCHG BP,SP\r
+ PUSH SI\r
+ XCHG BP,SP\r
+ PUSH BP\r
+ MOV BX,WORD PTR AddrUserP\r
+StackTopOffset = SysStackTop - SysUserP\r
+ MOV [BX+StackTopOffset],SP\r
+FollowerOffset = SysFollower - SysUserP\r
+ MOV BX,[BX+FollowerOffset]\r
+ MOV SI,CS:[BX]\r
+ $NEXT\r
+\r
+; wake ( -- )\r
+; Wake current task.\r
+;\r
+; : wake R> CELL+ code@ userP ! \ userP points 'follower' of current task\r
+; stackTop @ sp! DROP \ set data stack\r
+; rp! ; COMPILE-ONLY \ set return stack\r
+;\r
+; $COLON NameWake,Wake\r
+; DW RFrom,CELLPlus,CodeFetch,DoLIT,AddrUserP,Store\r
+; DW StackTop,Fetch,SPStore,DROP,RPStore,EXIT\r
+\r
+ $CODE NameWake,Wake\r
+ MOV BX,CS:[SI+CELLL]\r
+ MOV WORD PTR AddrUserP,BX\r
+ MOV SP,[BX+StackTopOffset]\r
+ POP BP\r
+ XCHG BP,SP\r
+ POP SI\r
+ XCHG BP,SP\r
+ POP BX\r
+ $NEXT\r
+\r
+; same? ( c-addr1 c-addr2 u -- -1|0|1 )\r
+; Return 0 if two strings, ca1 u and ca2 u, are same; -1 if\r
+; string, ca1 u is smaller than ca2 u; 1 otherwise. Used by\r
+; '(search-wordlist)'. Code definition is preferred to speed up\r
+; interpretation. Colon definition is shown below.\r
+;\r
+; : same? ?DUP IF \ null strings are always same\r
+; 0 DO OVER C@ OVER C@ XOR\r
+; IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN\r
+; CHAR+ SWAP CHAR+ SWAP\r
+; LOOP\r
+; THEN 2DROP 0 ;\r
+;\r
+; $COLON NameSameQ,SameQ\r
+; DW QuestionDUP,ZBranch,SAMEQ4\r
+; DW DoLIT,0,DoDO\r
+; SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2\r
+; DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan\r
+; DW TwoStar,OnePlus,EXIT\r
+; SAMEQ2 DW CHARPlus,SWAP,CHARPlus\r
+; DW DoLOOP,SAMEQ3\r
+; SAMEQ4 DW TwoDROP,DoLIT,0,EXIT\r
+\r
+ $CODE NameSameQ,SameQ\r
+ MOV CX,BX\r
+ MOV AX,DS\r
+ MOV ES,AX\r
+ MOV DX,SI ;save SI\r
+ MOV BX,-1\r
+ POP DI\r
+ POP SI\r
+ OR CX,CX\r
+ JZ SAMEQ5\r
+ REPE CMPSB\r
+ JL SAMEQ1\r
+ JZ SAMEQ5\r
+ INC BX\r
+SAMEQ5: INC BX\r
+SAMEQ1: MOV SI,DX\r
+ $NEXT\r
+\r
+; (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)\r
+; Search word list for a match with the given name.\r
+; Return execution token and not-compile-only flag and\r
+; -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.\r
+;\r
+; format is: wid---->[ a ]\r
+; |\r
+; V\r
+; [ xt' ][ a' ][ccbbaann][ggffeedd]...\r
+; |\r
+; +--------+\r
+; V\r
+; [ xt'' ][ a'' ][ccbbaann][ggffeedd]...\r
+;\r
+; a, a' etc. point to the cell that contains the name of the\r
+; word. The length is in the low byte of the cell (little byte\r
+; for little-endian, big byte for big-endian).\r
+; Eventually, a''' contains 0 to indicate the end of the wordlist\r
+; (oldest entry). a=0 indicates an empty wordlist.\r
+; xt is the xt of the word. aabbccddeedd etc. is the name of\r
+; the word, packed into cells.\r
+;\r
+; : (search-wordlist)\r
+; ROT >R SWAP DUP 0= IF -16 THROW THEN\r
+; \ attempt to use zero-length string as a name\r
+; >R \ wid R: ca1 u\r
+; BEGIN @ \ ca2 R: ca1 u\r
+; DUP 0= IF R> R> 2DROP EXIT THEN \ not found\r
+; DUP COUNT [ =MASK ] LITERAL AND R@ = \ ca2 ca2+char f\r
+; IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u\r
+; same? \ ca2 flag\r
+; \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.\r
+; THEN\r
+; WHILE cell- \ pointer to next word in wordlist\r
+; REPEAT\r
+; R> R> 2DROP DUP name>xt SWAP \ xt ca2\r
+; C@ 2DUP [ =seman ] LITERAL AND 0= 0= \ xt char xt f\r
+; AND TO specialComp?\r
+; DUP [ =compo ] LITERAL AND 0= SWAP\r
+; [ =immed ] LITERAL AND 0= 2* 1+ ;\r
+;\r
+; $COLON NameParenSearch_Wordlist,ParenSearch_Wordlist\r
+; DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6\r
+; DW ToR\r
+; PSRCH1 DW Fetch\r
+; DW DUPP,ZBranch,PSRCH9\r
+; DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals\r
+; DW ZBranch,PSRCH5\r
+; DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ\r
+; PSRCH5 DW ZBranch,PSRCH3\r
+; DW CellMinus,Branch,PSRCH1\r
+; PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP\r
+; DW CFetch,TwoDUP,DoLIT,SEMAN,ANDD,ZeroEquals,ZeroEquals\r
+; DW ANDD,DoTO,AddrSpecialCompQ\r
+; DW DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP\r
+; DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT\r
+; PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT\r
+; PSRCH6 DW DoLIT,-16,THROW\r
+\r
+ $CODE NameParenSearch_Wordlist,ParenSearch_Wordlist\r
+ POP AX ;u\r
+ POP DX ;c-addr\r
+ OR AX,AX\r
+ JZ PSRCH1\r
+ PUSH SI\r
+ MOV CX,DS\r
+ MOV ES,CX\r
+ SUB CX,CX\r
+PSRCH2: MOV BX,[BX]\r
+ OR BX,BX\r
+ JZ PSRCH4 ; end of wordlist?\r
+ MOV CL,[BX]\r
+ SUB BX,CELLL ;pointer to nextword\r
+ AND CL,MASKK ;max name length = MASKK\r
+ CMP CL,AL\r
+ JNZ PSRCH2\r
+ MOV SI,DX\r
+ MOV DI,BX\r
+ ADD DI,CELLL+CHARR\r
+ REPE CMPSB\r
+ JNZ PSRCH2\r
+ POP SI\r
+ PUSH [BX-CELLL] ;xt\r
+ MOV AL,0FFh\r
+ MOV CL,[BX+CELLL]\r
+ AND AL,CL ;test SEMAN = 080h\r
+ CBW\r
+ CWD\r
+ AND DX,[BX-CELLL]\r
+ MOV AddrSpecialCompQ,DX\r
+ XOR DX,DX\r
+ TEST CL,COMPO\r
+ JNZ PSRCH5\r
+ DEC DX\r
+PSRCH5: PUSH DX\r
+ TEST CL,IMMED\r
+ MOV BX,-1\r
+ JZ PSRCH3\r
+ NEG BX\r
+PSRCH3: $NEXT\r
+PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name\r
+ JMP THROW\r
+PSRCH4: POP SI\r
+ $NEXT\r
+\r
+; ?call ( xt1 -- xt1 0 | code-addr xt2 )\r
+; Return xt of the CALLed run-time word if xt starts with machine\r
+; CALL instruction and leaves the next cell address after the\r
+; CALL instruction. Otherwise leaves the original xt1 and zero.\r
+;\r
+; : ?call DUP code@ call-code =\r
+; IF CELL+ DUP code@ SWAP CELL+ DUP ROT + EXIT THEN\r
+; \ Direct Threaded Code 8086 relative call\r
+; 0 ;\r
+;\r
+; $COLON NameQCall,QCall\r
+; DW DUPP,CodeFetch,DoLIT,CALLL,Equals,ZBranch,QCALL1\r
+; DW CELLPlus,DUPP,CodeFetch,SWAP,CELLPlus,DUPP,ROT,Plus\r
+; DW EXIT\r
+; QCALL1 DW DoLIT,0,EXIT\r
+\r
+ $CODE NameQCall,QCall\r
+ MOV AX,CS:[BX]\r
+ CMP AX,CALLL\r
+ JE QCALL1\r
+ PUSH BX\r
+ XOR BX,BX\r
+ $NEXT\r
+QCALL1: ADD BX,2*CELLL\r
+ PUSH BX\r
+ ADD BX,CS:[BX-CELLL]\r
+ $NEXT\r
+\r
+; xt, ( xt1 -- xt2 )\r
+; Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and\r
+; CREATE . Return xt2 of current definition.\r
+;\r
+; : xt, xhere ALIGNED DUP TO xhere SWAP\r
+; call-code code, \ Direct Threaded Code\r
+; xhere CELL+ - code, ; \ 8086 relative call\r
+;\r
+; $COLON NamextComma,xtComma\r
+; DW XHere,ALIGNED,DUPP,DoTO,AddrXHere,SWAP\r
+; DW DoLIT,CALLL,CodeComma\r
+; DW XHere,CELLPlus,Minus,CodeComma,EXIT\r
+\r
+ $CODE NamextComma,xtComma\r
+ MOV AX,AddrXHere\r
+ XCHG BX,AX\r
+ INC BX\r
+ AND BX,0FFFEh\r
+ MOV WORD PTR CS:[BX],CALLL\r
+ MOV CX,BX\r
+ ADD CX,2*CELLL\r
+ MOV AddrXHere,CX\r
+ SUB AX,CX\r
+ MOV CS:[BX+CELLL],AX\r
+ $NEXT\r
+\r
+; doLIT ( -- x )\r
+; Push an inline literal. The inline literal is at the current\r
+; value of the fpc, so put it onto the stack and point past it.\r
+\r
+ $CODE NameDoLIT,DoLIT\r
+ PUSH BX\r
+ LODS WORD PTR CS:[SI]\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; doCONST ( -- x )\r
+; Run-time routine of CONSTANT and initializable system\r
+; VARIABLE. When you quote a constant or variable you execute\r
+; its code, which consists of a call to here, followed by an\r
+; inline literal. The literal is a constant (for a CONSTANT) or\r
+; the address at which a VARIABLE's value is stored. Although\r
+; you come here as the result of a native machine call, you\r
+; never go back to the return address -- you jump back up a\r
+; level by continuing at the new fpc value. For 8086, Z80 the\r
+; inline literal is at the return address stored on the top of\r
+; the hardware stack.\r
+\r
+ $CODE NameDoCONST,DoCONST\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,CS:[BX]\r
+ $NEXT\r
+\r
+; doVALUE ( -- x )\r
+; Run-time routine of VALUE. Return the value of VALUE word.\r
+; This is like an invocation of doCONST for a VARIABLE but\r
+; instead of returning the address of the variable, we return\r
+; the value of the variable -- in other words, there is another\r
+; level of indirection.\r
+\r
+ $CODE NameDoVALUE,DoVALUE\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,CS:[BX]\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; doCREATE ( -- a-addr )\r
+; Run-time routine of CREATE. For CREATEd words with an\r
+; associated DOES>, get the address of the CREATEd word's data\r
+; space and execute the DOES> actions. For CREATEd word without\r
+; an associated DOES>, return the address of the CREATE'd word's\r
+; data space. A CREATEd word starts its execution through this\r
+; routine in exactly the same way as a colon definition uses\r
+; doLIST. In other words, we come here through a native machine\r
+; branch.\r
+;\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | a-addr |\r
+;\r
+; The DOES> address holds a native call to doLIST. This routine\r
+; doesn't alter the fpc. We never come back *here* so we never\r
+; need to preserve an address that would bring us back *here*.\r
+;\r
+; Example : myVARIABLE CREATE , DOES> ;\r
+; 56 myVARIABLE JIM\r
+; JIM \ stacks the address of the data cell that contains 56\r
+;\r
+; : doCREATE SWAP \ switch BX and top of 8086 stack item\r
+; DUP CELL+ code@ SWAP code@ ?DUP IF EXECUTE THEN\r
+; ; COMPILE-ONLY\r
+;\r
+; $COLON NameDoCREATE,DoCREATE\r
+; DW SWAP,CELLPlus,DUPP,CodeFetch,SWAP,CodeFetch\r
+; DW QuestionDUP,ZBranch,DOCREAT1\r
+; DW EXECUTE\r
+; DOCREAT1 DW EXIT\r
+\r
+ $CODE NameDoCREATE,DoCREATE\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV AX,CS:[BX]\r
+ MOV BX,CS:[BX+CELLL]\r
+ OR AX,AX\r
+ JNZ DOCREAT1\r
+ $NEXT\r
+DOCREAT1: JMP AX\r
+ $ALIGN\r
+\r
+; doTO ( x -- )\r
+; Run-time routine of TO. Store x at the address in the\r
+; following cell. The inline literal holds the address\r
+; to be modified.\r
+\r
+ $CODE NameDoTO,DoTO\r
+ LODS WORD PTR CS:[SI]\r
+ XCHG BX,AX\r
+ MOV [BX],AX\r
+ POP BX\r
+ $NEXT\r
+\r
+; doUSER ( -- a-addr )\r
+; Run-time routine of USER. Return address of data space.\r
+; This is like doCONST but a variable offset is added to the\r
+; result. By changing the value at AddrUserP (which happens\r
+; on a taskswap) the whole set of user variables is switched\r
+; to the set for the new task.\r
+\r
+ $CODE NameDoUSER,DoUSER\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,CS:[BX]\r
+ ADD BX,AddrUserP\r
+ $NEXT\r
+\r
+; doLIST ( -- ) ( R: -- nest-sys )\r
+; Process colon list.\r
+; The first word of a definition (the xt for the word) is a\r
+; native machine-code instruction for the target machine. For\r
+; high-level definitions, that code is emitted by xt, and\r
+; performs a call to doLIST. doLIST executes the list of xt that\r
+; make up the definition. The final xt in the definition is EXIT.\r
+; The address of the first xt to be executed is passed to doLIST\r
+; in a target-specific way. Two examples:\r
+; Z80, 8086: native machine call, leaves the return address on\r
+; the hardware stack pointer, which is used for the data stack.\r
+\r
+ $CODE NameDoLIST,DoLIST\r
+ SUB BP,2\r
+ MOV [BP],SI ;push return stack\r
+ POP SI ;new list address\r
+ $NEXT\r
+\r
+; doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Run time routine for LOOP.\r
+\r
+ $CODE NameDoLOOP,DoLOOP\r
+ INC WORD PTR [BP] ;increase loop count\r
+ JO DoLOOP1 ;?loop end\r
+ MOV SI,CS:[SI] ;no, go back\r
+ $NEXT\r
+DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+ ADD BP,2*CELLL ;clear return stack\r
+ $NEXT\r
+\r
+; do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Run time routine for +LOOP.\r
+\r
+ $CODE NameDoPLOOP,DoPLOOP\r
+ ADD WORD PTR [BP],BX ;increase loop count\r
+ JO DoPLOOP1 ;?loop end\r
+ MOV SI,CS:[SI] ;no, go back\r
+ POP BX\r
+ $NEXT\r
+DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+ ADD BP,2*CELLL ;clear return stack\r
+ POP BX\r
+ $NEXT\r
+\r
+; 0branch ( flag -- )\r
+; Branch if flag is zero.\r
+\r
+ $CODE NameZBranch,ZBranch\r
+ OR BX,BX ;?flag=0\r
+ JZ ZBRAN1 ;yes, so branch\r
+ ADD SI,CELLL ;point IP to next cell\r
+ POP BX\r
+ $NEXT\r
+ZBRAN1: MOV SI,CS:[SI] ;IP:=(IP)\r
+ POP BX\r
+ $NEXT\r
+\r
+; branch ( -- )\r
+; Branch to an inline address.\r
+\r
+ $CODE NameBranch,Branch\r
+ MOV SI,CS:[SI] ;IP:=(IP)\r
+ $NEXT\r
+\r
+; rp@ ( -- a-addr )\r
+; Push the current RP to the data stack.\r
+\r
+ $CODE NameRPFetch,RPFetch\r
+ PUSH BX\r
+ MOV BX,BP\r
+ $NEXT\r
+\r
+; rp! ( a-addr -- )\r
+; Set the return stack pointer.\r
+\r
+ $CODE NameRPStore,RPStore\r
+ MOV BP,BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; sp@ ( -- a-addr )\r
+; Push the current data stack pointer.\r
+\r
+ $CODE NameSPFetch,SPFetch\r
+ PUSH BX\r
+ MOV BX,SP\r
+ $NEXT\r
+\r
+; sp! ( a-addr -- )\r
+; Set the data stack pointer.\r
+\r
+ $CODE NameSPStore,SPStore\r
+ MOV SP,BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; um+ ( u1 u2 -- u3 1|0 )\r
+; Add two unsigned numbers, return the sum and carry.\r
+\r
+ $CODE NameUMPlus,UMPlus\r
+ XOR CX,CX\r
+ POP AX\r
+ ADD BX,AX\r
+ PUSH BX ;push sum\r
+ RCL CX,1 ;get carry\r
+ MOV BX,CX\r
+ $NEXT\r
+\r
+; code! ( x code-addr -- )\r
+; Store x at a code space address.\r
+\r
+ $CODE NameCodeStore,CodeStore\r
+ POP CS:[BX]\r
+ POP BX\r
+ $NEXT\r
+\r
+; codeB! ( b code-addr -- )\r
+; Store byte at a code space address.\r
+\r
+ $CODE NameCodeBStore,CodeBStore\r
+ POP AX\r
+ MOV CS:[BX],AL\r
+ POP BX\r
+ $NEXT\r
+\r
+; code@ ( code-addr -- x )\r
+; Push the contents at code space addr to the data stack.\r
+\r
+ $CODE NameCodeFetch,CodeFetch\r
+ MOV BX,CS:[BX]\r
+ $NEXT\r
+\r
+; codeB@ ( code-addr -- b )\r
+; Push the contents at code space byte addr to the data stack.\r
+\r
+ $CODE NameCodeBFetch,CodeBFetch\r
+ MOV BL,CS:[BX]\r
+ XOR BH,BH\r
+ $NEXT\r
+\r
+; code, ( x -- )\r
+; Reserve one cell in code space and store x in it.\r
+;\r
+; : code, xhere DUP CELL+ TO xhere code! ; COMPILE-ONLY\r
+;\r
+; $COLON NameCodeComma,CodeComma\r
+; DW XHere,DUPP,CELLPlus,DoTO,AddrXHere,CodeStore,EXIT\r
+\r
+ $CODE NameCodeComma,CodeComma\r
+ MOV DI,AddrXHere\r
+ MOV CS:[DI],BX\r
+ ADD DI,CELLL\r
+ POP BX\r
+ MOV AddrXHere,DI\r
+ $NEXT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Standard words - Processor-dependent definitions\r
+; 16 bit Forth for 8086/8\r
+;;;;;;;;;;;;;;;;\r
+\r
+; ALIGN ( -- ) \ CORE\r
+; Align the data space pointer.\r
+;\r
+; : ALIGN HERE ALIGNED TO HERE ;\r
+\r
+ $COLON NameALIGNN,ALIGNN\r
+ DW HERE,ALIGNED,DoTO,AddrHERE,EXIT\r
+\r
+; ALIGNED ( addr -- a-addr ) \ CORE\r
+; Align address to the cell boundary.\r
+;\r
+; : ALIGNED DUP 0 cell-size UM/MOD DROP DUP\r
+; IF cell-size SWAP - THEN + ;\r
+;\r
+; $COLON NameALIGNED,ALIGNED\r
+; DW DUPP,DoLIT,0,DoLIT,CELLL\r
+; DW UMSlashMOD,DROP,DUPP\r
+; DW ZBranch,ALGN1\r
+; DW DoLIT,CELLL,SWAP,Minus\r
+; ALGN1 DW Plus,EXIT\r
+\r
+ $CODE NameALIGNED,ALIGNED\r
+ INC BX\r
+ AND BX,0FFFEh\r
+ $NEXT\r
+\r
+; pack" is dependent of cell alignment.\r
+;\r
+; pack" ( c-addr u a-addr -- a-addr2 )\r
+; Place a string c-addr u at a-addr and gives the next\r
+; cell-aligned address. Fill the rest of the last cell with\r
+; null character.\r
+;\r
+; : pack" OVER max-char > IF -18 THROW THEN \ parsed string overflow\r
+; 2DUP SWAP CHARS + CHAR+ ALIGNED DUP >R \ ca u aa aa+u+1\r
+; cell- 0 SWAP ! \ fill 0 at the end of string\r
+; 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u\r
+; CHARS MOVE R> ;\r
+;\r
+; $COLON NamePackQuote,PackQuote\r
+; DW OVER,DoLIT,MaxChar,GreaterThan,ZBranch,PACKQ1\r
+; DW DoLIT,-18,THROW\r
+; PACKQ1 DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,ALIGNED,DUPP,ToR\r
+; DW CellMinus,DoLIT,0,SWAP,Store\r
+; DW TwoDUP,CStore,CHARPlus,SWAP\r
+; DW CHARS,MOVE,RFrom,EXIT\r
+\r
+ $CODE NamePackQuote,PackQuote\r
+ POP AX\r
+ PUSH AX\r
+ CMP AX,MaxChar\r
+ JG PACKQ1\r
+ MOV DI,BX\r
+ MOV DX,SI\r
+ MOV AX,DS\r
+ MOV ES,AX\r
+ POP CX\r
+ POP SI\r
+ MOV BYTE PTR [DI],CL\r
+ INC DI\r
+ REP MOVSB\r
+ TEST DI,1 ;odd address?\r
+ JZ PACKQ2\r
+ MOV BYTE PTR [DI],0\r
+ INC DI\r
+PACKQ2: MOV BX,DI\r
+ MOV SI,DX\r
+ $NEXT\r
+PACKQ1: MOV BX,-18\r
+ JMP THROW\r
+ $ALIGN\r
+\r
+; CELLS ( n1 -- n2 ) \ CORE\r
+; Calculate number of address units for n1 cells.\r
+;\r
+; : CELLS cell-size * ; \ slow, very portable\r
+; : CELLS 2* ; \ fast, must be redefined for each system\r
+;\r
+; $COLON NameCELLS,CELLS\r
+; DW TwoStar,EXIT\r
+\r
+ $CODE NameCELLS,CELLS\r
+ SHL BX,1\r
+ $NEXT\r
+\r
+; CHARS ( n1 -- n2 ) \ CORE\r
+; Calculate number of address units for n1 characters.\r
+;\r
+; : CHARS char-size * ; \ slow, very portable\r
+; : CHARS ; \ fast, must be redefined for each system\r
+\r
+ $COLON NameCHARS,CHARS\r
+ DW EXIT\r
+\r
+; 1chars/ ( n1 -- n2 )\r
+; Calculate number of chars for n1 address units.\r
+;\r
+; : 1chars/ 1 CHARS / ; \ slow, very portable\r
+; : 1chars/ ; \ fast, must be redefined for each system\r
+\r
+ $COLON NameOneCharsSlash,OneCharsSlash\r
+ DW EXIT\r
+\r
+; ! ( x a-addr -- ) \ CORE\r
+; Store x at a aligned address.\r
+\r
+ $CODE NameStore,Store\r
+ POP [BX]\r
+ POP BX\r
+ $NEXT\r
+\r
+; 0< ( n -- flag ) \ CORE\r
+; Return true if n is negative.\r
+\r
+ $CODE NameZeroLess,ZeroLess\r
+ MOV AX,BX\r
+ CWD ;sign extend\r
+ MOV BX,DX\r
+ $NEXT\r
+\r
+; 0= ( x -- flag ) \ CORE\r
+; Return true if x is zero.\r
+\r
+ $CODE NameZeroEquals,ZeroEquals\r
+ OR BX,BX\r
+ MOV BX,TRUEE\r
+ JZ ZEQUAL1\r
+ INC BX\r
+ZEQUAL1: $NEXT\r
+\r
+; 2* ( x1 -- x2 ) \ CORE\r
+; Bit-shift left, filling the least significant bit with 0.\r
+\r
+ $CODE NameTwoStar,TwoStar\r
+ SHL BX,1\r
+ $NEXT\r
+\r
+; 2/ ( x1 -- x2 ) \ CORE\r
+; Bit-shift right, leaving the most significant bit unchanged.\r
+\r
+ $CODE NameTwoSlash,TwoSlash\r
+ SAR BX,1\r
+ $NEXT\r
+\r
+; >R ( x -- ) ( R: -- x ) \ CORE\r
+; Move top of the data stack item to the return stack.\r
+\r
+ $CODE NameToR,ToR\r
+ SUB BP,CELLL ;adjust RP\r
+ MOV [BP],BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; @ ( a-addr -- x ) \ CORE\r
+; Push the contents at a-addr to the data stack.\r
+\r
+ $CODE NameFetch,Fetch\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; AND ( x1 x2 -- x3 ) \ CORE\r
+; Bitwise AND.\r
+\r
+ $CODE NameANDD,ANDD\r
+ POP AX\r
+ AND BX,AX\r
+ $NEXT\r
+\r
+; C! ( char c-addr -- ) \ CORE\r
+; Store char at c-addr.\r
+\r
+ $CODE NameCStore,CStore\r
+ POP AX\r
+ MOV [BX],AL\r
+ POP BX\r
+ $NEXT\r
+\r
+; C@ ( c-addr -- char ) \ CORE\r
+; Fetch the character stored at c-addr.\r
+\r
+ $CODE NameCFetch,CFetch\r
+ MOV BL,[BX]\r
+ XOR BH,BH\r
+ $NEXT\r
+\r
+; DROP ( x -- ) \ CORE\r
+; Discard top stack item.\r
+\r
+ $CODE NameDROP,DROP\r
+ POP BX\r
+ $NEXT\r
+\r
+; DUP ( x -- x x ) \ CORE\r
+; Duplicate the top stack item.\r
+\r
+ $CODE NameDUPP,DUPP\r
+ PUSH BX\r
+ $NEXT\r
+\r
+; EXECUTE ( i*x xt -- j*x ) \ CORE\r
+; Perform the semantics indentified by execution token, xt.\r
+\r
+ $CODE NameEXECUTE,EXECUTE\r
+ MOV AX,BX\r
+ POP BX\r
+ JMP AX ;jump to the code address\r
+ $ALIGN\r
+\r
+; EXIT ( -- ) ( R: nest-sys -- ) \ CORE\r
+; Return control to the calling definition.\r
+\r
+ $CODE NameEXIT,EXIT\r
+ XCHG BP,SP ;exchange pointers\r
+ POP SI ;pop return stack\r
+ XCHG BP,SP ;restore the pointers\r
+ $NEXT\r
+\r
+; MOVE ( addr1 addr2 u -- ) \ CORE\r
+; Copy u address units from addr1 to addr2 if u is greater\r
+; than zero. This word is CODE defined since no other Standard\r
+; words can handle address unit directly.\r
+\r
+ $CODE NameMOVE,MOVE\r
+ POP DI\r
+ POP DX\r
+ OR BX,BX\r
+ JZ MOVE2\r
+ MOV CX,BX\r
+ XCHG DX,SI ;save SI\r
+ MOV AX,DS\r
+ MOV ES,AX ;set ES same as DS\r
+ CMP SI,DI\r
+ JC MOVE1\r
+ REP MOVSB\r
+ MOV SI,DX\r
+MOVE2: POP BX\r
+ $NEXT\r
+MOVE1: STD\r
+ ADD DI,CX\r
+ DEC DI\r
+ ADD SI,CX\r
+ DEC SI\r
+ REP MOVSB\r
+ CLD\r
+ MOV SI,DX\r
+ POP BX\r
+ $NEXT\r
+\r
+; OR ( x1 x2 -- x3 ) \ CORE\r
+; Return bitwise inclusive-or of x1 with x2.\r
+\r
+ $CODE NameORR,ORR\r
+ POP AX\r
+ OR BX,AX\r
+ $NEXT\r
+\r
+; OVER ( x1 x2 -- x1 x2 x1 ) \ CORE\r
+; Copy second stack item to top of the stack.\r
+\r
+ $CODE NameOVER,OVER\r
+ MOV DI,SP\r
+ PUSH BX\r
+ MOV BX,[DI]\r
+ $NEXT\r
+\r
+; R> ( -- x ) ( R: x -- ) \ CORE\r
+; Move x from the return stack to the data stack.\r
+\r
+ $CODE NameRFrom,RFrom\r
+ PUSH BX\r
+ MOV BX,[BP]\r
+ ADD BP,CELLL ;adjust RP\r
+ $NEXT\r
+\r
+; R@ ( -- x ) ( R: x -- x ) \ CORE\r
+; Copy top of return stack to the data stack.\r
+\r
+ $CODE NameRFetch,RFetch\r
+ PUSH BX\r
+ MOV BX,[BP]\r
+ $NEXT\r
+\r
+; SWAP ( x1 x2 -- x2 x1 ) \ CORE\r
+; Exchange top two stack items.\r
+\r
+ $CODE NameSWAP,SWAP\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ $NEXT\r
+\r
+; XOR ( x1 x2 -- x3 ) \ CORE\r
+; Bitwise exclusive OR.\r
+\r
+ $CODE NameXORR,XORR\r
+ POP AX\r
+ XOR BX,AX\r
+ $NEXT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; System constants and variables\r
+;;;;;;;;;;;;;;;;\r
+\r
+; #order0 ( -- a-addr )\r
+; Start address of default search order.\r
+\r
+ $CONST NameNumberOrder0,NumberOrder0,AddrNumberOrder0\r
+\r
+; 'ekey? ( -- a-addr )\r
+; Execution vector of EKEY?.\r
+\r
+ $VALUE NameTickEKEYQ,TickEKEYQ,AddrTickEKEYQ\r
+\r
+; 'ekey ( -- a-addr )\r
+; Execution vector of EKEY.\r
+\r
+ $VALUE NameTickEKEY,TickEKEY,AddrTickEKEY\r
+\r
+; 'emit? ( -- a-addr )\r
+; Execution vector of EMIT?.\r
+\r
+ $VALUE NameTickEMITQ,TickEMITQ,AddrTickEMITQ\r
+\r
+; 'emit ( -- a-addr )\r
+; Execution vector of EMIT.\r
+\r
+ $VALUE NameTickEMIT,TickEMIT,AddrTickEMIT\r
+\r
+; 'init-i/o ( -- a-addr )\r
+; Execution vector to initialize input/output devices.\r
+\r
+ $VALUE NameTickINIT_IO,TickINIT_IO,AddrTickINIT_IO\r
+\r
+; 'prompt ( -- a-addr )\r
+; Execution vector of '.prompt'.\r
+\r
+ $VALUE NameTickPrompt,TickPrompt,AddrTickPrompt\r
+\r
+; 'boot ( -- a-addr )\r
+; Execution vector of COLD.\r
+\r
+ $VALUE NameTickBoot,TickBoot,AddrTickBoot\r
+\r
+; SOURCE-ID ( -- 0 | -1 ) \ CORE EXT\r
+; Identify the input source. -1 for string (via EVALUATE) and\r
+; 0 for user input device.\r
+\r
+ $VALUE NameSOURCE_ID,SOURCE_ID,AddrSOURCE_ID\r
+\r
+; HERE ( -- addr ) \ CORE\r
+; Return data space pointer.\r
+\r
+ $VALUE NameHERE,HERE,AddrHERE\r
+\r
+; xhere ( -- code-addr )\r
+; Return next available code space address.\r
+\r
+ $VALUE NameXHere,XHere,AddrXHere\r
+\r
+; 'doWord ( -- a-addr )\r
+; Execution vectors for 'interpret'.\r
+\r
+ $CONST NameTickDoWord,TickDoWord,AddrTickDoWord\r
+\r
+; BASE ( -- a-addr ) \ CORE\r
+; Return the address of the radix base for numeric I/O.\r
+\r
+ $CONST NameBASE,BASE,AddrBASE\r
+\r
+; THROWMsgTbl ( -- a-addr ) \ CORE\r
+; Return the address of the THROW message table.\r
+\r
+ $CONST NameTHROWMsgTbl,THROWMsgTbl,AddrTHROWMsgTbl\r
+\r
+; memTop ( -- a-addr )\r
+; Top of free memory.\r
+\r
+ $VALUE NameMemTop,MemTop,AddrMemTop\r
+\r
+; bal ( -- n )\r
+; Return the depth of control-flow stack.\r
+\r
+ $VALUE NameBal,Bal,AddrBal\r
+\r
+; notNONAME? ( -- f )\r
+; Used by ';' whether to do 'linkLast' or not\r
+\r
+ $VALUE NameNotNONAMEQ,NotNONAMEQ,AddrNotNONAMEQ\r
+\r
+; rakeVar ( -- a-addr )\r
+; Used by 'rake' to gather LEAVE.\r
+\r
+ $CONST NameRakeVar,RakeVar,AddrRakeVar\r
+\r
+; #order ( -- a-addr )\r
+; Hold the search order stack depth.\r
+\r
+ $CONST NameNumberOrder,NumberOrder,AddrNumberOrder\r
+\r
+; current ( -- a-addr )\r
+; Point to the wordlist to be extended.\r
+\r
+ $CONST NameCurrent,Current,AddrCurrent\r
+\r
+; FORTH-WORDLIST ( -- wid ) \ SEARCH\r
+; Return wid of Forth wordlist.\r
+\r
+ $CONST NameFORTH_WORDLIST,FORTH_WORDLIST,AddrFORTH_WORDLIST\r
+\r
+; NONSTANDARD-WORDLIST ( -- wid )\r
+; Return wid of non-standard wordlist.\r
+\r
+ $CONST NameNONSTANDARD_WORDLIST,NONSTANDARD_WORDLIST,AddrNONSTANDARD_WORDLIST\r
+\r
+; envQList ( -- wid )\r
+; Return wid of ENVIRONMENT? string list. Never put this wid in\r
+; search-order. It should be used only by SET-CURRENT to add new\r
+; environment query string after addition of a complete wordset.\r
+\r
+ $CONST NameEnvQList,EnvQList,AddrEnvQList\r
+\r
+; userP ( -- a-addr )\r
+; Return address of USER variable area of current task.\r
+\r
+ $CONST NameUserP,UserP,AddrUserP\r
+\r
+; SystemTask ( -- a-addr )\r
+; Return system task's tid.\r
+\r
+ $CONST NameSystemTask,SystemTask,SysTask\r
+\r
+; follower ( -- a-addr )\r
+; Point next task's 'status' USER variable.\r
+\r
+ $USER NameFollower,Follower,SysFollower-SysUserP\r
+\r
+; status ( -- a-addr )\r
+; Status of current task. Point 'pass' or 'wake'.\r
+\r
+ $USER NameStatus,Status,SysStatus-SysUserP\r
+\r
+; stackTop ( -- a-addr )\r
+; Store current task's top of stack position.\r
+\r
+ $USER NameStackTop,StackTop,SysStackTop-SysUserP\r
+\r
+; throwFrame ( -- a-addr )\r
+; THROW frame for CATCH and THROW need to be saved for eack task.\r
+\r
+ $USER NameThrowFrame,ThrowFrame,SysThrowFrame-SysUserP\r
+\r
+; taskName ( -- a-addr )\r
+; Current task's task ID.\r
+\r
+ $USER NameTaskName,TaskName,SysTaskName-SysUserP\r
+\r
+; user1 ( -- a-addr )\r
+; One free USER variable for each task.\r
+\r
+ $USER NameUser1,User1,SysUser1-SysUserP\r
+\r
+; ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be\r
+; EXECUTEd. This wordlist is completely hidden to Forth system except\r
+; ENVIRONMENT? .\r
+\r
+CPU:\r
+ NOP\r
+ CALL DoLIST\r
+ DW DoLIT,CPUStr,COUNT,EXIT\r
+\r
+Model:\r
+ NOP\r
+ CALL DoLIST\r
+ DW DoLIT,ModelStr,COUNT,EXIT\r
+\r
+Version:\r
+ NOP\r
+ CALL DoLIST\r
+ DW DoLIT,VersionStr,COUNT,EXIT\r
+\r
+SlashCOUNTED_STRING:\r
+ NOP\r
+ CALL DoCONST\r
+ DW MaxChar\r
+\r
+SlashHOLD:\r
+ NOP\r
+ CALL DoCONST\r
+ DW PADSize\r
+\r
+SlashPAD:\r
+ NOP\r
+ CALL DoCONST\r
+ DW PADSize\r
+\r
+ADDRESS_UNIT_BITS:\r
+ NOP\r
+ CALL DoCONST\r
+ DW 8\r
+\r
+CORE:\r
+ NOP\r
+ CALL DoCONST\r
+ DW TRUEE\r
+\r
+FLOORED:\r
+ NOP\r
+ CALL DoCONST\r
+ DW TRUEE\r
+\r
+MAX_CHAR:\r
+ NOP\r
+ CALL DoCONST\r
+ DW MaxChar ;max value of character set\r
+\r
+MAX_D:\r
+ NOP\r
+ CALL DoLIST\r
+ DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT\r
+\r
+MAX_N:\r
+ NOP\r
+ CALL DoCONST\r
+ DW MaxSigned\r
+\r
+MAX_U:\r
+ NOP\r
+ CALL DoCONST\r
+ DW MaxUnsigned\r
+\r
+MAX_UD:\r
+ NOP\r
+ CALL DoLIST\r
+ DW MAX_U,MAX_U,EXIT\r
+\r
+RETURN_STACK_CELLS:\r
+ NOP\r
+ CALL DoCONST\r
+ DW RTCells\r
+\r
+STACK_CELLS:\r
+ NOP\r
+ CALL DoCONST\r
+ DW DTCells\r
+\r
+EXCEPTION:\r
+ NOP\r
+ CALL DoCONST\r
+ DW TRUEE\r
+\r
+EXCEPTION_EXT:\r
+ NOP\r
+ CALL DoCONST\r
+ DW TRUEE\r
+\r
+WORDLISTS:\r
+ NOP\r
+ CALL DoCONST\r
+ DW OrderDepth\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Non-Standard words - Colon definitions\r
+;;;;;;;;;;;;;;;;\r
+\r
+; (') ( "<spaces>name" -- xt 1 | xt -1 )\r
+; Parse a name, find it and return execution token and\r
+; -1 or 1 ( IMMEDIATE) if found\r
+;\r
+; : (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN\r
+; errWord 2! \ if not found error\r
+; -13 THROW ; \ undefined word\r
+\r
+ $COLON NameParenTick,ParenTick\r
+ DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1\r
+ DW NIP,EXIT\r
+PTICK1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-13,THROW\r
+\r
+; (d.) ( d -- c-addr u )\r
+; Convert a double number to a string.\r
+;\r
+; : (d.) SWAP OVER DUP 0< IF DNEGATE THEN\r
+; <# #S ROT SIGN #> ;\r
+\r
+ $COLON NameParenDDot,ParenDDot\r
+ DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1\r
+ DW DNEGATE\r
+PARDD1 DW LessNumberSign,NumberSignS,ROT\r
+ DW SIGN,NumberSignGreater,EXIT\r
+\r
+; .ok ( -- )\r
+; Display 'ok'.\r
+;\r
+; : .ok ." ok" ;\r
+\r
+ $COLON NameDotOK,DotOK\r
+ DW DoLIT,DotOKStr\r
+ DW COUNT,TYPEE,EXIT\r
+\r
+; .prompt ( -- )\r
+; Disply Forth prompt. This word is vectored.\r
+;\r
+; : .prompt 'prompt EXECUTE ;\r
+\r
+ $COLON NameDotOK,DotPrompt\r
+ DW TickPrompt,EXECUTE,EXIT\r
+\r
+; 0 ( -- 0 )\r
+; Return zero.\r
+\r
+ $CONST NameZero,Zero,0\r
+\r
+; 1 ( -- 1 )\r
+; Return one.\r
+\r
+ $CONST NameOne,One,1\r
+\r
+; -1 ( -- -1 )\r
+; Return -1.\r
+\r
+ $CONST NameMinusOne,MinusOne,-1\r
+\r
+; abort"msg ( -- a-addr )\r
+; Abort" error message string address.\r
+\r
+ $CONST NameAbortQMsg,AbortQMsg,AddrAbortQMsg\r
+\r
+; bal+ ( -- )\r
+; Increase bal by 1.\r
+;\r
+; : bal+ bal 1+ TO bal ;\r
+;\r
+; $COLON 4,'bal+',BalPlus,_SLINK\r
+; DW Bal,OnePlus,DoTO,AddrBal,EXIT\r
+\r
+ $CODE NameBalPlus,BalPlus\r
+ INC AddrBal\r
+ $NEXT\r
+\r
+; bal- ( -- )\r
+; Decrease bal by 1.\r
+;\r
+; : bal- bal 1- TO bal ;\r
+;\r
+; $COLON NameBalMinus,BalMinus\r
+; DW Bal,OneMinus,DoTO,AddrBal,EXIT\r
+\r
+ $CODE NameBalMinus,BalMinus\r
+ DEC AddrBal\r
+ $NEXT\r
+\r
+; cell- ( a-addr1 -- a-addr2 )\r
+; Return previous aligned cell address.\r
+;\r
+; : cell- [ cell-size NEGATE ] LITERAL + ;\r
+;\r
+; $COLON NameCellMinus,CellMinus\r
+; DW DoLIT,0-CELLL,Plus,EXIT\r
+\r
+ $CODE NameCellMinus,CellMinus\r
+ SUB BX,CELLL\r
+ $NEXT\r
+\r
+; COMPILE-ONLY ( -- )\r
+; Make the most recent definition an compile-only word.\r
+;\r
+; : COMPILE-ONLY lastName [ =compo ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON NameCOMPILE_ONLY,COMPILE_ONLY\r
+ DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )\r
+; Run-time funtion of DO.\r
+;\r
+; : doDO >R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;\r
+;\r
+; $COLON NameDoDO,DoDO\r
+; DW ToR,DoLIT,MaxNegative,Plus,RFrom\r
+; DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT\r
+\r
+ $CODE NameDoDO,DoDO\r
+ SUB BP,2*CELLL\r
+ POP AX\r
+ ADD AX,MaxNegative\r
+ MOV [BP+CELLL],AX\r
+ SUB BX,AX\r
+ MOV [BP],BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; errWord ( -- a-addr )\r
+; Last found word. To be used to display the word causing error.\r
+\r
+ $CONST NameErrWord,ErrWord,AddrErrWord\r
+\r
+; head, ( xt "<spaces>name" -- )\r
+; Parse a word and build a dictionary entry.\r
+;\r
+; : head, >R PARSE-WORD DUP 0=\r
+; IF errWord 2! -16 THROW THEN\r
+; \ attempt to use zero-length string as a name\r
+; DUP =mask > IF -19 THROW THEN \ definition name too long\r
+; 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?\r
+; IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined\r
+; ALIGN R@ , \ align and store xt\r
+; GET-CURRENT @ , \ build wordlist link\r
+; HERE DUP >R pack" ALIGNED TO HERE \ pack the name in name space\r
+; R> DUP R> cell- code! \ store name addr in code space\r
+; TO lastName ;\r
+\r
+ $COLON NameHeadComma,HeadComma\r
+ DW ToR,PARSE_WORD,DUPP,ZBranch,HEADC1\r
+ DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3\r
+ DW DoLIT,-19,THROW\r
+HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2\r
+ DW DROP\r
+ DW DoLIT,HEADCstr\r
+ DW COUNT,TYPEE,TwoDUP,TYPEE,SPACE\r
+HEADC2 DW ALIGNN,RFetch,Comma\r
+ DW GET_CURRENT,Fetch,Comma\r
+ DW HERE,DUPP,ToR,PackQuote,ALIGNED,DoTO,AddrHERE\r
+ DW RFrom,DUPP,RFrom,CellMinus,CodeStore\r
+ DW DoTO,AddrLastName,EXIT\r
+HEADC1 DW DoLIT,AddrErrWord,TwoStore,DoLIT,-16,THROW\r
+\r
+; hld ( -- a-addr )\r
+; Hold a pointer in building a numeric output string.\r
+\r
+ $CONST NameHLD,HLD,AddrHLD\r
+\r
+; interpret ( i*x -- j*x )\r
+; Intrepret input string.\r
+;\r
+; : interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow\r
+; PARSE-WORD DUP\r
+; WHILE 2DUP errWord 2!\r
+; search-word \ ca u 0 | xt f -1 | xt f 1\r
+; DUP IF\r
+; SWAP STATE @ OR 0= \ compile-only in interpretation\r
+; IF -14 THROW THEN \ interpreting a compile-only word\r
+; THEN\r
+; 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE\r
+; REPEAT 2DROP ;\r
+\r
+ $COLON NameInterpret,Interpret\r
+INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2\r
+ DW DoLIT,-4,THROW\r
+INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3\r
+ DW TwoDUP,DoLIT,AddrErrWord,TwoStore\r
+ DW Search_word,DUPP,ZBranch,INTERP5\r
+ DW SWAP,DoLIT,AddrSTATE,Fetch,ORR,ZBranch,INTERP4\r
+INTERP5 DW OnePlus,TwoStar,DoLIT,AddrSTATE,Fetch,OnePlus,Plus,CELLS\r
+ DW DoLIT,AddrTickDoWord,Plus,Fetch,EXECUTE\r
+ DW Branch,INTERP1\r
+INTERP3 DW TwoDROP,EXIT\r
+INTERP4 DW DoLIT,-14,THROW\r
+\r
+; optiCOMPILE, ( xt -- )\r
+; Optimized COMPILE, . Reduce doLIST ... EXIT sequence if\r
+; xt is COLON definition which contains less than two words.\r
+;\r
+; : optiCOMPILE,\r
+; DUP ?call ['] doLIST = IF\r
+; DUP code@ ['] EXIT = IF \ if first word is EXIT\r
+; 2DROP EXIT THEN\r
+; DUP CELL+ code@ ['] EXIT = IF \ if second word is EXIT\r
+; code@ DUP ['] doLIT XOR \ make sure it is not literal\r
+; IF SWAP THEN THEN\r
+; THEN THEN DROP COMPILE, ;\r
+;\r
+; $COLON NameOptiCOMPILEComma,OptiCOMPILEComma\r
+; DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2\r
+; DW DUPP,CodeFetch,DoLIT,EXIT,Equals,ZBranch,OPTC1\r
+; DW TwoDROP,EXIT\r
+; OPTC1 DW DUPP,CELLPlus,CodeFetch,DoLIT,EXIT,Equals\r
+; DW ZBranch,OPTC2\r
+; DW CodeFetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2\r
+; DW SWAP\r
+; OPTC2 DW DROP,COMPILEComma,EXIT\r
+\r
+ $CODE NameOptiCOMPILEComma,OptiCOMPILEComma\r
+ CMP WORD PTR CS:[BX],CALLL\r
+ JNE OPTC1\r
+ MOV AX,CS:[BX+CELLL]\r
+ ADD AX,BX\r
+ ADD AX,2*CELLL\r
+ CMP AX,OFFSET DoLIST\r
+ JNE OPTC1\r
+ MOV DX,OFFSET EXIT\r
+ MOV AX,CS:[BX+2*CELLL]\r
+ CMP AX,DX\r
+ JE OPTC2\r
+ CMP DX,CS:[BX+3*CELLL]\r
+ JNE OPTC1\r
+ CMP AX,OFFSET DoLIT\r
+ JE OPTC1\r
+ MOV BX,AX\r
+OPTC1: JMP COMPILEComma\r
+OPTC2: POP BX\r
+ $NEXT\r
+\r
+; singleOnly ( c-addr u -- x )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, leave a single cell number in interpretation state.\r
+;\r
+; : singleOnly\r
+; 0 DUP 2SWAP OVER C@ [CHAR] -\r
+; = DUP >R IF 1 /STRING THEN\r
+; >NUMBER IF -13 THROW THEN \ undefined word\r
+; 2DROP R> IF NEGATE THEN ;\r
+\r
+ $COLON NameSingleOnly,SingleOnly\r
+ DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+ DW Equals,DUPP,ToR,ZBranch,SINGLEO4\r
+ DW DoLIT,1,SlashSTRING\r
+SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1\r
+ DW DoLIT,-13,THROW\r
+SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2\r
+ DW NEGATE\r
+SINGLEO2 DW EXIT\r
+\r
+; singleOnly, ( c-addr u -- )\r
+; Handle the word not found in the search-order. Compile a\r
+; single cell number in compilation state.\r
+;\r
+; : singleOnly,\r
+; singleOnly LITERAL ;\r
+\r
+ $COLON NameSingleOnlyComma,SingleOnlyComma\r
+ DW SingleOnly,LITERAL,EXIT\r
+\r
+; (doubleAlso) ( c-addr u -- x 1 | x x 2 )\r
+; If the string is legal, leave a single or double cell number\r
+; and size of the number.\r
+;\r
+; : (doubleAlso)\r
+; 0 DUP 2SWAP OVER C@ [CHAR] -\r
+; = DUP >R IF 1 /STRING THEN\r
+; >NUMBER ?DUP\r
+; IF 1- IF -13 THROW THEN \ more than one char is remained\r
+; DUP C@ [CHAR] . XOR \ last char is not '.'\r
+; IF -13 THROW THEN \ undefined word\r
+; R> IF DNEGATE THEN\r
+; 2 EXIT THEN\r
+; 2DROP R> IF NEGATE THEN \ single number\r
+; 1 ;\r
+\r
+ $COLON NameParenDoubleAlso,ParenDoubleAlso\r
+ DW DoLIT,0,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+ DW Equals,DUPP,ToR,ZBranch,DOUBLEA1\r
+ DW DoLIT,1,SlashSTRING\r
+DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4\r
+ DW OneMinus,ZBranch,DOUBLEA3\r
+DOUBLEA2 DW DoLIT,-13,THROW\r
+DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2\r
+ DW RFrom,ZBranch,DOUBLEA5\r
+ DW DNEGATE\r
+DOUBLEA5 DW DoLIT,2,EXIT\r
+DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6\r
+ DW NEGATE\r
+DOUBLEA6 DW DoLIT,1,EXIT\r
+\r
+; doubleAlso ( c-addr u -- x | x x )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, leave a single or double cell number in\r
+; interpretation state.\r
+;\r
+; : doubleAlso\r
+; (doubleAlso) DROP ;\r
+\r
+ $COLON NameDoubleAlso,DoubleAlso\r
+ DW ParenDoubleAlso,DROP,EXIT\r
+\r
+; doubleAlso, ( c-addr u -- )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, compile a single or double cell number in\r
+; compilation state.\r
+;\r
+; : doubleAlso,\r
+; (doubleAlso) 1- IF SWAP LITERAL THEN LITERAL ;\r
+\r
+ $COLON NameDoubleAlsoComma,DoubleAlsoComma\r
+ DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1\r
+ DW SWAP,LITERAL\r
+DOUBC1 DW LITERAL,EXIT\r
+\r
+; -. ( -- )\r
+; You don't need this word unless you care that '-.' returns\r
+; double cell number 0. Catching illegal number '-.' in this way\r
+; is easier than make 'interpret' catch this exception.\r
+;\r
+; : -. -13 THROW ; IMMEDIATE \ undefined word\r
+\r
+ $COLON NameMinusDot,MinusDot\r
+ DW DoLIT,-13,THROW\r
+\r
+; lastName ( -- c-addr )\r
+; Return the address of the last definition name.\r
+\r
+ $VALUE NameLastName,LastName,AddrLastName\r
+\r
+; linkLast ( -- )\r
+; Link the word being defined to the current wordlist.\r
+; Do nothing if the last definition is made by :NONAME .\r
+;\r
+; : linkLast lastName GET-CURRENT ! ;\r
+;\r
+; $COLON NameLinkLast,LinkLast\r
+; DW LastName,GET_CURRENT,Store,EXIT\r
+\r
+ $CODE NameLinkLast,LinkLast\r
+ MOV AX,AddrLastName\r
+ MOV DI,AddrCurrent\r
+ MOV [DI],AX\r
+ $NEXT\r
+\r
+; name>xt ( c-addr -- xt )\r
+; Return execution token using counted string at c-addr.\r
+;\r
+; : name>xt cell- cell- @ ;\r
+;\r
+; $COLON NameNameToXT,NameToXT\r
+; DW CellMinus,CellMinus,Fetch,EXIT\r
+\r
+ $CODE NameNameToXT,NameToXT\r
+ MOV BX,[BX-2*CELLL]\r
+ $NEXT\r
+\r
+; PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )\r
+; Skip leading spaces and parse a word. Return the name.\r
+;\r
+; : PARSE-WORD BL skipPARSE ;\r
+;\r
+; $COLON NamePARSE_WORD,PARSE_WORD\r
+; DW DoLIT,' ',SkipPARSE,EXIT\r
+\r
+ $CODE NamePARSE_WORD,PARSE_WORD\r
+ PUSH BX\r
+ MOV BX,' '\r
+ JMP SkipPARSE\r
+ $ALIGN\r
+\r
+; pipe ( -- ) ( R: xt -- )\r
+; Connect most recently defined word to code following DOES>.\r
+; Structure of CREATEd word:\r
+; |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
+;\r
+; : pipe lastName name>xt ?call DUP IF \ code-addr xt2\r
+; ['] doCREATE = IF\r
+; R> SWAP code! \ change DOES> code of CREATEd word\r
+; EXIT\r
+; THEN THEN\r
+; -32 THROW \ invalid name argument, no-CREATEd last name\r
+; ; COMPILE-ONLY\r
+\r
+ $COLON NamePipe,Pipe\r
+ DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1\r
+ DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1\r
+ DW RFrom,SWAP,CodeStore,EXIT\r
+PIPE1 DW DoLIT,-32,THROW\r
+\r
+; skipPARSE ( char "<chars>ccc<char>" -- c-addr u )\r
+; Skip leading chars and parse a word using char as a\r
+; delimeter. Return the name.\r
+;\r
+; : skipPARSE\r
+; >R SOURCE >IN @ /STRING \ c_addr u R: char\r
+; DUP IF\r
+; BEGIN OVER C@ R@ =\r
+; WHILE 1- SWAP CHAR+ SWAP DUP 0=\r
+; UNTIL R> DROP EXIT\r
+; ELSE THEN\r
+; DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT\r
+; THEN R> DROP ;\r
+;\r
+; $COLON NameSkipPARSE,SkipPARSE\r
+; DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING\r
+; DW DUPP,ZBranch,SKPAR1\r
+; SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3\r
+; DW OneMinus,SWAP,CHARPlus,SWAP\r
+; DW DUPP,ZeroEquals,ZBranch,SKPAR2\r
+; DW RFrom,DROP,EXIT\r
+; SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash\r
+; DW DoLIT,AddrToIN,Store,RFrom,PARSE,EXIT\r
+; SKPAR1 DW RFrom,DROP,EXIT\r
+\r
+ $CODE NameSkipPARSE,SkipPARSE\r
+ MOV AH,BL\r
+ MOV DX,SI\r
+ MOV SI,AddrSourceVar+CELLL\r
+ MOV BX,AddrSourceVar\r
+ MOV CX,AddrToIN\r
+ ADD SI,CX\r
+ SUB BX,CX\r
+ MOV CX,SI\r
+ OR BX,BX\r
+ JZ PARSW1\r
+PARSW5: LODSB\r
+ CMP AL,AH\r
+ JNE PARSW4\r
+ DEC BX\r
+ OR BX,BX\r
+ JNZ PARSW5\r
+ MOV AX,AddrSourceVar\r
+ MOV AddrToIN,AX\r
+PARSW1: PUSH SI\r
+ MOV SI,DX\r
+ $NEXT\r
+PARSW4: DEC SI\r
+ SUB SI,AddrSourceVar+CELLL\r
+ MOV AddrToIN,SI\r
+ XOR BX,BX\r
+ MOV BL,AH\r
+ MOV SI,DX\r
+ JMP PARSE\r
+ $ALIGN\r
+\r
+; specialComp? ( -- xt|0 )\r
+; Return xt for special compilation semantics of the last found\r
+; word. Return 0 if there is no special compilation action.\r
+\r
+ $VALUE NameSpecialCompQ,SpecialCompQ,AddrSpecialCompQ\r
+\r
+; rake ( C: do-sys -- )\r
+; Gathers LEAVEs.\r
+;\r
+; : rake DUP code, rakeVar @\r
+; BEGIN 2DUP U<\r
+; WHILE DUP code@ xhere ROT code!\r
+; REPEAT rakeVar ! DROP\r
+; ?DUP IF \ check for ?DO\r
+; 1 bal+ POSTPONE THEN \ orig type is 1\r
+; THEN bal- ; COMPILE-ONLY\r
+\r
+ $COLON Namerake,rake\r
+ DW DUPP,CodeComma,DoLIT,AddrRakeVar,Fetch\r
+RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2\r
+ DW DUPP,CodeFetch,XHere,ROT,CodeStore,Branch,RAKE1\r
+RAKE2 DW DoLIT,AddrRakeVar,Store,DROP\r
+ DW QuestionDUP,ZBranch,RAKE3\r
+ DW One,BalPlus,THENN\r
+RAKE3 DW BalMinus,EXIT\r
+\r
+; rp0 ( -- a-addr )\r
+; Pointer to bottom of the return stack.\r
+;\r
+; : rp0 userP @ CELL+ CELL+ @ ;\r
+\r
+ $COLON NameRPZero,RPZero\r
+ DW DoLIT,AddrUserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT\r
+\r
+; search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)\r
+; Search dictionary for a match with the given name. Return\r
+; execution token, not-compile-only flag and -1 or 1\r
+; ( IMMEDIATE) if found; c-addr u 0 if not.\r
+;\r
+; : search-word\r
+; #order @ DUP \ not found if #order is 0\r
+; IF 0\r
+; DO 2DUP \ ca u ca u\r
+; I CELLS #order CELL+ + @ \ ca u ca u wid\r
+; (search-wordlist) \ ca u; 0 | w f 1 | w f -1\r
+; ?DUP IF \ ca u; 0 | w f 1 | w f -1\r
+; >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1\r
+; THEN \ ca u\r
+; LOOP 0 \ ca u 0\r
+; THEN ;\r
+\r
+ $COLON NameSearch_word,Search_word\r
+ DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1\r
+ DW DoLIT,0,DoDO\r
+SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch\r
+ DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3\r
+ DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT\r
+SEARCH3 DW DoLOOP,SEARCH2\r
+ DW DoLIT,0\r
+SEARCH1 DW EXIT\r
+\r
+; sourceVar ( -- a-addr )\r
+; Hold the current count and address of the terminal input buffer.\r
+\r
+ $CONST NameSourceVar,SourceVar,AddrSourceVar\r
+\r
+; sp0 ( -- a-addr )\r
+; Pointer to bottom of the data stack.\r
+;\r
+; : sp0 userP @ CELL+ @ ;\r
+\r
+ $COLON NameSPZero,SPZero\r
+ DW DoLIT,AddrUserP,Fetch,CELLPlus,Fetch,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Essential Standard words - Colon definitions\r
+;;;;;;;;;;;;;;;;\r
+\r
+; # ( ud1 -- ud2 ) \ CORE\r
+; Extract one digit from ud1 and append the digit to\r
+; pictured numeric output string. ( ud2 = ud1 / BASE )\r
+;\r
+; : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP\r
+; 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +\r
+; [ CHAR 0 ] LITERAL + HOLD R> ;\r
+;\r
+; $COLON NameNumberSign,NumberSign\r
+; DW DoLIT,0,DoLITFetch,AddrBASE,UMSlashMOD,ToR\r
+; DW DoLITFetch,AddrBASE,UMSlashMOD,SWAP\r
+; DW DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus\r
+; DW DoLIT,'0',Plus,HOLD,RFrom,EXIT\r
+\r
+ $CODE NameNumberSign,NumberSign\r
+ XOR DX,DX\r
+ MOV AX,BX\r
+ MOV CX,AddrBASE\r
+ DIV CX ;0:TOS / BASE\r
+ MOV BX,AX ;quotient\r
+ POP AX\r
+ DIV CX\r
+ PUSH AX ;BX:AX = ud2\r
+ MOV AL,DL\r
+ CMP AL,9\r
+ JBE NUMSN1\r
+ ADD AL,'A'-'9'-1\r
+NUMSN1: ADD AL,'0'\r
+ MOV DI,AddrHLD\r
+ DEC DI\r
+ MOV AddrHLD,DI\r
+ MOV [DI],AL\r
+ $NEXT\r
+\r
+; #> ( xd -- c-addr u ) \ CORE\r
+; Prepare the output string to be TYPE'd.\r
+; ||HERE>WORD/#-work-area|\r
+;\r
+; : #> 2DROP hld @ HERE size-of-PAD + OVER - 1chars/ ;\r
+\r
+ $COLON NameNumberSignGreater,NumberSignGreater\r
+ DW TwoDROP,DoLIT,AddrHLD,Fetch,HERE,DoLIT,PADSize*CHARR,Plus\r
+ DW OVER,Minus,OneCharsSlash,EXIT\r
+\r
+; #S ( ud -- 0 0 ) \ CORE\r
+; Convert ud until all digits are added to the output string.\r
+;\r
+; : #S BEGIN # 2DUP OR 0= UNTIL ;\r
+\r
+ $COLON NameNumberSignS,NumberSignS\r
+NUMSS1 DW NumberSign,TwoDUP,ORR\r
+ DW ZeroEquals,ZBranch,NUMSS1\r
+ DW EXIT\r
+\r
+; ' ( "<spaces>name" -- xt ) \ CORE\r
+; Parse a name, find it and return xt.\r
+;\r
+; : ' (') DROP ;\r
+\r
+ $COLON NameTick,Tick\r
+ DW ParenTick,DROP,EXIT\r
+\r
+; + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Add top two items and gives the sum.\r
+;\r
+; : + um+ DROP ;\r
+;\r
+; $COLON NamePlus,Plus\r
+; DW UMPlus,DROP,EXIT\r
+\r
+ $CODE NamePlus,Plus\r
+ POP AX\r
+ ADD BX,AX\r
+ $NEXT\r
+\r
+; +! ( n|u a-addr -- ) \ CORE\r
+; Add n|u to the contents at a-addr.\r
+;\r
+; : +! SWAP OVER @ + SWAP ! ;\r
+;\r
+; $COLON NamePlusStore,PlusStore\r
+; DW SWAP,OVER,Fetch,Plus\r
+; DW SWAP,Store,EXIT\r
+\r
+ $CODE NamePlusStore,PlusStore\r
+ POP AX\r
+ ADD [BX],AX\r
+ POP BX\r
+ $NEXT\r
+\r
+; , ( x -- ) \ CORE\r
+; Reserve one cell in data space and store x in it.\r
+;\r
+; : , HERE ! HERE CELL+ TO HERE ;\r
+;\r
+; $COLON NameComma,Comma\r
+; DW HERE,Store,HERE,CELLPlus,DoTO,AddrHERE,EXIT\r
+\r
+ $CODE NameComma,Comma\r
+ MOV DI,AddrHERE\r
+ MOV [DI],BX\r
+ ADD DI,CELLL\r
+ MOV AddrHERE,DI\r
+ POP BX\r
+ $NEXT\r
+\r
+; - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Subtract n2|u2 from n1|u1, giving the difference n3|u3.\r
+;\r
+; : - NEGATE + ;\r
+;\r
+; $COLON NameMinus,Minus\r
+; DW NEGATE,Plus,EXIT\r
+;\r
+ $CODE NameMinus,Minus\r
+ POP AX\r
+ SUB AX,BX\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; . ( n -- ) \ CORE\r
+; Display a signed number followed by a space.\r
+;\r
+; : . S>D D. ;\r
+\r
+ $COLON NameDot,Dot\r
+ DW SToD,DDot,EXIT\r
+\r
+; / ( n1 n2 -- n3 ) \ CORE\r
+; Divide n1 by n2, giving single-cell quotient n3.\r
+;\r
+; : / /MOD NIP ;\r
+\r
+ $COLON NameSlash,Slash\r
+ DW SlashMOD,NIP,EXIT\r
+\r
+; /MOD ( n1 n2 -- n3 n4 ) \ CORE\r
+; Divide n1 by n2, giving single-cell remainder n3 and\r
+; single-cell quotient n4.\r
+;\r
+; : /MOD >R S>D R> FM/MOD ;\r
+;\r
+; $COLON NameSlashMOD,SlashMOD\r
+; DW ToR,SToD,RFrom,FMSlashMOD,EXIT\r
+\r
+ $CODE NameSlashMOD,SlashMOD\r
+ POP AX\r
+ CWD\r
+ PUSH AX\r
+ PUSH DX\r
+ JMP FMSlashMOD\r
+ $ALIGN\r
+\r
+; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING\r
+; Adjust the char string at c-addr1 by n chars.\r
+;\r
+; : /STRING DUP >R - SWAP R> CHARS + SWAP ;\r
+;\r
+; $COLON NameSlashSTRING,SlashSTRING\r
+; DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT\r
+\r
+ $CODE NameSlashSTRING,SlashSTRING\r
+ POP AX\r
+ SUB AX,BX\r
+ POP DX\r
+ ADD DX,BX\r
+ PUSH DX\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; 1+ ( n1|u1 -- n2|u2 ) \ CORE\r
+; Increase top of the stack item by 1.\r
+;\r
+; : 1+ 1 + ;\r
+;\r
+; $COLON NameOnePlus,OnePlus\r
+; DW DoLIT,1,Plus,EXIT\r
+\r
+ $CODE NameOnePlus,OnePlus\r
+ INC BX\r
+ $NEXT\r
+\r
+; 1- ( n1|u1 -- n2|u2 ) \ CORE\r
+; Decrease top of the stack item by 1.\r
+;\r
+; : 1- -1 + ;\r
+;\r
+; $COLON NameOneMinus,OneMinus\r
+; DW DoLIT,-1,Plus,EXIT\r
+\r
+ $CODE NameOneMinus,OneMinus\r
+ DEC BX\r
+ $NEXT\r
+\r
+; 2! ( x1 x2 a-addr -- ) \ CORE\r
+; Store the cell pare x1 x2 at a-addr, with x2 at a-addr and\r
+; x1 at the next consecutive cell.\r
+;\r
+; : 2! SWAP OVER ! CELL+ ! ;\r
+;\r
+; $COLON NameTwoStore,TwoStore\r
+; DW SWAP,OVER,Store,CELLPlus,Store,EXIT\r
+;\r
+ $CODE NameTwoStore,TwoStore\r
+ POP [BX]\r
+ POP [BX+CELLL]\r
+ POP BX\r
+ $NEXT\r
+\r
+; 2@ ( a-addr -- x1 x2 ) \ CORE\r
+; Fetch the cell pair stored at a-addr. x2 is stored at a-addr\r
+; and x1 at the next consecutive cell.\r
+;\r
+; : 2@ DUP CELL+ @ SWAP @ ;\r
+;\r
+; $COLON NameTwoFetch,TwoFetch\r
+; DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT\r
+\r
+ $CODE NameTwoFetch,TwoFetch\r
+ PUSH [BX+CELLL]\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; 2DROP ( x1 x2 -- ) \ CORE\r
+; Drop cell pair x1 x2 from the stack.\r
+;\r
+; $COLON NameTwoDROP,TwoDROP\r
+; DW DROP,DROP,EXIT\r
+\r
+ $CODE NameTwoDROP,TwoDROP\r
+ POP BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE\r
+; Duplicate cell pair x1 x2.\r
+;\r
+; $COLON NameTwoDUP,TwoDUP\r
+; DW OVER,OVER,EXIT\r
+\r
+ $CODE NameTwoDUP,TwoDUP\r
+ MOV DI,SP\r
+ PUSH BX\r
+ PUSH [DI]\r
+ $NEXT\r
+\r
+; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE\r
+; Exchange the top two cell pairs.\r
+;\r
+; : 2SWAP ROT >R ROT R> ;\r
+;\r
+; $COLON NameTwoSWAP,TwoSWAP\r
+; DW ROT,ToR,ROT,RFrom,EXIT\r
+\r
+ $CODE NameTwoSWAP,TwoSWAP\r
+ POP AX\r
+ POP CX\r
+ POP DX\r
+ PUSH AX\r
+ PUSH BX\r
+ PUSH DX\r
+ MOV BX,CX\r
+ $NEXT\r
+\r
+; : ( "<spaces>name" -- colon-sys ) \ CORE\r
+; Start a new colon definition using next word as its name.\r
+;\r
+; : : xhere ALIGNED CELL+ TO xhere \ reserve a cell for name pointer\r
+; :NONAME ROT head, -1 TO notNONAME? ;\r
+\r
+ $COLON NameCOLON,COLON\r
+ DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere\r
+ DW ColonNONAME,ROT,HeadComma\r
+ DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT\r
+\r
+; :NONAME ( -- xt colon-sys ) \ CORE EXT\r
+; Create an execution token xt, enter compilation state and\r
+; start the current definition.\r
+;\r
+; : :NONAME bal IF -29 THROW THEN \ compiler nesting\r
+; ['] doLIST xt, DUP -1\r
+; 0 TO notNONAME? 1 TO bal ] ;\r
+\r
+ $COLON NameColonNONAME,ColonNONAME\r
+ DW Bal,ZBranch,NONAME1\r
+ DW DoLIT,-29,THROW\r
+NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1\r
+ DW DoLIT,0,DoTO,AddrNotNONAMEQ\r
+ DW One,DoTO,AddrBal,RightBracket,EXIT\r
+\r
+; ; ( colon-sys -- ) \ CORE\r
+; Terminate a colon definition.\r
+;\r
+; : ; bal 1- IF -22 THROW THEN \ control structure mismatch\r
+; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+; notNONAME? IF \ if the last definition is not created by ':'\r
+; linkLast 0 TO notNONAME? \ link the word to wordlist\r
+; THEN POSTPONE EXIT \ add EXIT at the end of the definition\r
+; 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameSemicolon,Semicolon\r
+ DW Bal,OneMinus,ZBranch,SEMI1\r
+ DW DoLIT,-22,THROW\r
+SEMI1 DW NIP,OnePlus,ZBranch,SEMI2\r
+ DW DoLIT,-22,THROW\r
+SEMI2 DW NotNONAMEQ,ZBranch,SEMI3\r
+ DW LinkLast,DoLIT,0,DoTO,AddrNotNONAMEQ\r
+SEMI3 DW DoLIT,EXIT,COMPILEComma\r
+ DW DoLIT,0,DoTO,AddrBal,LeftBracket,EXIT\r
+\r
+; < ( n1 n2 -- flag ) \ CORE\r
+; Returns true if n1 is less than n2.\r
+;\r
+; : < 2DUP XOR 0< \ same sign?\r
+; IF DROP 0< EXIT THEN \ different signs, true if n1 <0\r
+; - 0< ; \ same signs, true if n1-n2 <0\r
+;\r
+; $COLON NameLessThan,LessThan\r
+; DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1\r
+; DW DROP,ZeroLess,EXIT\r
+; LESS1 DW Minus,ZeroLess,EXIT\r
+\r
+ $CODE NameLessThan,LessThan\r
+ POP AX\r
+ SUB AX,BX\r
+ MOV BX,-1\r
+ JL LESS1\r
+ INC BX\r
+LESS1: $NEXT\r
+\r
+; <# ( -- ) \ CORE\r
+; Initiate the numeric output conversion process.\r
+; ||HERE>WORD/#-work-area|\r
+;\r
+; : <# HERE size-of-PAD + hld ! ;\r
+\r
+ $COLON NameLessNumberSign,LessNumberSign\r
+ DW HERE,DoLIT,PADSize*CHARR,Plus,DoLIT,AddrHLD,Store,EXIT\r
+\r
+; = ( x1 x2 -- flag ) \ CORE\r
+; Return true if top two are equal.\r
+;\r
+; : = XORR 0= ;\r
+;\r
+; $COLON NameEquals,Equals\r
+; DW XORR,ZeroEquals,EXIT\r
+\r
+ $CODE NameEquals,Equals\r
+ POP AX\r
+ CMP BX,AX\r
+ MOV BX,-1\r
+ JE EQUAL1\r
+ INC BX\r
+EQUAL1: $NEXT\r
+\r
+; > ( n1 n2 -- flag ) \ CORE\r
+; Returns true if n1 is greater than n2.\r
+;\r
+; : > SWAP < ;\r
+;\r
+; $COLON NameGreaterThan,GreaterThan\r
+; DW SWAP,LessThan,EXIT\r
+\r
+ $CODE NameGreaterThan,GreaterThan\r
+ POP AX\r
+ SUB AX,BX\r
+ MOV BX,-1\r
+ JG GREAT1\r
+ INC BX\r
+GREAT1: $NEXT\r
+\r
+; >IN ( -- a-addr )\r
+; Hold the character pointer while parsing input stream.\r
+\r
+ $CONST NameToIN,ToIN,AddrToIN\r
+\r
+; >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE\r
+; Add number string's value to ud1. Leaves string of any\r
+; unconverted chars.\r
+;\r
+; : >NUMBER BEGIN DUP\r
+; WHILE >R DUP >R C@ \ ud char R: u c-addr\r
+; DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN\r
+; IF DROP R> R> EXIT THEN\r
+; [ CHAR 0 ] LITERAL - 9 OVER <\r
+; [ CHAR A CHAR 9 1 + - ] LITERAL AND -\r
+; DUP 0 BASE @ WITHIN\r
+; WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING\r
+; REPEAT DROP R> R>\r
+; THEN ;\r
+;\r
+; $COLON NameToNUMBER,ToNUMBER\r
+; TONUM1 DW DUPP,ZBranch,TONUM3\r
+; DW ToR,DUPP,ToR,CFetch,DUPP\r
+; DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2\r
+; DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan\r
+; DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP\r
+; DW DoLIT,0,DoLIT,AddrBASE,Fetch,WITHIN,ZBranch,TONUM2\r
+; DW SWAP,DoLIT,AddrBASE,Fetch,UMStar,DROP,ROT,DoLIT,AddrBASE,Fetch\r
+; DW UMStar,DPlus,RFrom,RFrom,DoLIT,1,SlashSTRING\r
+; DW Branch,TONUM1\r
+; TONUM2 DW DROP,RFrom,RFrom\r
+; TONUM3 DW EXIT\r
+\r
+ $CODE NameToNUMBER,ToNUMBER\r
+ POP DI\r
+TONUM4: OR BX,BX\r
+ JZ TONUM2\r
+ XOR CX,CX\r
+ MOV CL,[DI]\r
+ SUB CX,'0'\r
+ JS TONUM2 ;not valid digit\r
+ CMP CX,'9'-'0'\r
+ JLE TONUM3\r
+ CMP CX,'A'-'0'\r
+ JL TONUM2 ;not valid digit\r
+ SUB CX,'A'-'9'-1\r
+TONUM3: CMP CX,AddrBASE\r
+ JGE TONUM2 ;not valid digit\r
+ POP AX\r
+ MUL AddrBASE\r
+ POP DX\r
+ PUSH AX\r
+ MOV AX,DX\r
+ MUL AddrBASE\r
+ ADD AX,CX\r
+ POP CX\r
+ ADC DX,CX\r
+ PUSH AX\r
+ PUSH DX\r
+ INC DI\r
+ DEC BX\r
+ JMP TONUM4\r
+TONUM2: PUSH DI\r
+ $NEXT\r
+\r
+; ?DUP ( x -- x x | 0 ) \ CORE\r
+; Duplicate top of the stack if it is not zero.\r
+;\r
+; : ?DUP DUP IF DUP THEN ;\r
+;\r
+; $COLON NameQuestionDUP,QuestionDUP\r
+; DW DUPP,ZBranch,QDUP1\r
+; DW DUPP\r
+; QDUP1 DW EXIT\r
+\r
+ $CODE NameQuestionDUP,QuestionDUP\r
+ OR BX,BX\r
+ JZ QDUP1\r
+ PUSH BX\r
+QDUP1: $NEXT\r
+\r
+; ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT\r
+; Reset data stack and jump to QUIT.\r
+;\r
+; : ABORT -1 THROW ;\r
+\r
+ $COLON NameABORT,ABORT\r
+ DW DoLIT,-1,THROW\r
+\r
+; ACCEPT ( c-addr +n1 -- +n2 ) \ CORE\r
+; Accept a string of up to +n1 chars. Return with actual count.\r
+; Implementation-defined editing. Stops at EOL# .\r
+; Supports backspace and delete editing.\r
+;\r
+; : ACCEPT >R 0\r
+; BEGIN DUP R@ < \ ca n2 f R: n1\r
+; WHILE EKEY max-char AND\r
+; DUP BL <\r
+; IF DUP cr# = IF ROT 2DROP R> DROP EXIT THEN\r
+; DUP tab# =\r
+; IF DROP 2DUP + BL DUP EMIT SWAP C! 1+\r
+; ELSE DUP bsp# =\r
+; SWAP del# = OR\r
+; IF DROP DUP\r
+; \ discard the last char if not 1st char\r
+; IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN\r
+; THEN\r
+; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ THEN\r
+; THEN\r
+; REPEAT SWAP R> 2DROP ;\r
+\r
+ $COLON NameACCEPT,ACCEPT\r
+ DW ToR,DoLIT,0\r
+ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5\r
+ DW EKEY,DoLIT,MaxChar,ANDD\r
+ DW DUPP,DoLIT,' ',LessThan,ZBranch,ACCPT3\r
+ DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4\r
+ DW ROT,TwoDROP,RFrom,DROP,EXIT\r
+ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6\r
+ DW DROP,TwoDUP,Plus,DoLIT,' ',DUPP,EMIT,SWAP,CStore,OnePlus\r
+ DW Branch,ACCPT1\r
+ACCPT6 DW DUPP,DoLIT,BKSPP,Equals\r
+ DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1\r
+ DW DUPP,ZBranch,ACCPT1\r
+ DW OneMinus,DoLIT,BKSPP,EMIT,DoLIT,' ',EMIT,DoLIT,BKSPP,EMIT\r
+ DW Branch,ACCPT1\r
+ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore\r
+ DW OnePlus,Branch,ACCPT1\r
+ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT\r
+\r
+; AGAIN ( C: dest -- ) \ CORE EXT\r
+; Resolve backward reference dest. Typically used as\r
+; BEGIN ... AGAIN . Move control to the location specified by\r
+; dest on execution.\r
+;\r
+; : AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+; POSTPONE branch code, bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameAGAIN,AGAIN\r
+ DW ZBranch,AGAIN1\r
+ DW DoLIT,-22,THROW\r
+AGAIN1 DW DoLIT,Branch,COMPILEComma,CodeComma,BalMinus,EXIT\r
+\r
+; AHEAD ( C: -- orig ) \ TOOLS EXT\r
+; Put the location of a new unresolved forward reference onto\r
+; control-flow stack.\r
+;\r
+; : AHEAD POSTPONE branch xhere 0 code,\r
+; 1 bal+ \ orig type is 1\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameAHEAD,AHEAD\r
+ DW DoLIT,Branch,COMPILEComma,XHere,DoLIT,0,CodeComma\r
+ DW One,BalPlus,EXIT\r
+\r
+; BL ( -- char ) \ CORE\r
+; Return the value of the blank character.\r
+;\r
+; : BL blank-char-value EXIT ;\r
+\r
+ $CONST NameBLank,BLank,' '\r
+\r
+; CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION\r
+; Push an exception frame on the exception stack and then execute\r
+; the execution token xt in such a way that control can be\r
+; transferred to a point just after CATCH if THROW is executed\r
+; during the execution of xt.\r
+;\r
+; : CATCH sp@ >R throwFrame @ >R \ save error frame\r
+; rp@ throwFrame ! EXECUTE \ execute\r
+; R> throwFrame ! \ restore error frame\r
+; R> DROP 0 ; \ no error\r
+\r
+ $COLON NameCATCH,CATCH\r
+ DW SPFetch,ToR,ThrowFrame,Fetch,ToR\r
+ DW RPFetch,ThrowFrame,Store,EXECUTE\r
+ DW RFrom,ThrowFrame,Store\r
+ DW RFrom,DROP,DoLIT,0,EXIT\r
+\r
+; CELL+ ( a-addr1 -- a-addr2 ) \ CORE\r
+; Return next aligned cell address.\r
+;\r
+; : CELL+ cell-size + ;\r
+;\r
+; $COLON NameCELLPlus,CELLPlus\r
+; DW DoLIT,CELLL,Plus,EXIT\r
+\r
+ $CODE NameCELLPlus,CELLPlus\r
+ ADD BX,CELLL\r
+ $NEXT\r
+\r
+; CHAR+ ( c-addr1 -- c-addr2 ) \ CORE\r
+; Returns next character-aligned address.\r
+;\r
+; : CHAR+ char-size + ;\r
+;\r
+; $COLON NameCHARPlus,CHARPlus\r
+; DW DoLIT,CHARR,Plus,EXIT\r
+\r
+ $CODE NameCHARPlus,CHARPlus\r
+ INC BX\r
+ $NEXT\r
+\r
+; COMPILE, ( xt -- ) \ CORE EXT\r
+; Compile the execution token on data stack into current\r
+; colon definition.\r
+; Structure of words with special compilation action\r
+; for default compilation behavior\r
+; |compile_xt|name_ptr| execution_code |\r
+;\r
+; : COMPILE, DUP specialComp? = IF DUP cell- cell- code@ EXECUTE EXIT THEN\r
+; code, ;\r
+;\r
+; $COLON NameCOMPILEComma,COMPILEComma\r
+; DW DUPP,SpecialCompQ,Equals,ZBranch,COMPILEC1\r
+; DW DUPP,CellMinus,CellMinus,CodeFetch,EXECUTE,EXIT\r
+; COMPILEC1 DW CodeComma,EXIT\r
+\r
+ $CODE NameCOMPILEComma,COMPILEComma\r
+ CMP BX,AddrSpecialCompQ\r
+ JE COMPILEC1\r
+ MOV DI,AddrXHere\r
+ MOV CS:[DI],BX\r
+ ADD DI,CELLL\r
+ POP BX\r
+ MOV AddrXHere,DI\r
+ $NEXT\r
+COMPILEC1: MOV AX,CS:[BX-2*CELLL]\r
+ JMP AX\r
+ $ALIGN\r
+\r
+; compileCONST ( xt -- )\r
+; Compile a CONSTANT word of which xt is given.\r
+; Structure of CONSTANT word:\r
+; |compile_xt|name_ptr| call-doCONST | x |\r
+;\r
+; : compileCONST\r
+; CELL+ CELL+ code@ POSTPONE LITERAL ;\r
+;\r
+; $COLON NameCompileCONST,CompileCONST\r
+; DW CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT\r
+\r
+ $CODE NameCompileCONST,CompileCONST\r
+ MOV CX,CS:[BX+2*CELLL]\r
+ MOV DI,AddrXHere\r
+ MOV AX,OFFSET DoLIT\r
+ MOV CS:[DI],AX\r
+ MOV CS:[DI+CELLL],CX\r
+ ADD DI,2*CELLL\r
+ POP BX\r
+ MOV AddrXHere,DI\r
+ $NEXT\r
+\r
+; CONSTANT ( x "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- x )\r
+; Create a definition for name which pushes x on the stack on\r
+; execution.\r
+;\r
+; : CONSTANT bal IF -29 THROW THEN \ compiler nesting\r
+; xhere ALIGNED TO xhere\r
+; ['] compileCONST code,\r
+; xhere CELL+ TO xhere\r
+; ['] doCONST xt, head,\r
+; code, linkLast\r
+; lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON NameCONSTANT,CONSTANT\r
+ DW Bal,ZBranch,CONST1\r
+ DW DoLIT,-29,THROW\r
+CONST1 DW XHere,ALIGNED,DoTO,AddrXHere\r
+ DW DoLIT,CompileCONST,CodeComma\r
+ DW XHere,CELLPlus,DoTO,AddrXHere\r
+ DW DoLIT,DoCONST,xtComma,HeadComma\r
+ DW CodeComma,LinkLast\r
+ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; COUNT ( c-addr1 -- c-addr2 u ) \ CORE\r
+; Convert counted string to string specification. c-addr2 is\r
+; the next char-aligned address after c-addr1 and u is the\r
+; contents at c-addr1.\r
+;\r
+; : COUNT DUP CHAR+ SWAP C@ ;\r
+;\r
+; $COLON NameCOUNT,COUNT\r
+; DW DUPP,CHARPlus,SWAP,CFetch,EXIT\r
+\r
+ $CODE NameCOUNT,COUNT\r
+ MOV AX,BX\r
+ INC AX\r
+ MOV BL,[BX]\r
+ XOR BH,BH\r
+ PUSH AX\r
+ $NEXT\r
+\r
+; compileCREATE ( xt -- )\r
+; Compile a CREATEd word of which xt is given.\r
+; Structure of CREATEd word:\r
+; |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
+;\r
+; : compileCREATE\r
+; DUP CELL+ CELL+ code@ \ 0 or DOES>_xt\r
+; IF code, EXIT THEN\r
+; CELL+ CELL+ CELL+ code@ LITERAL ;\r
+\r
+ $COLON NameCompileCREATE,CompileCREATE\r
+ DW DUPP,CELLPlus,CELLPlus,CodeFetch,ZBranch,COMPCREAT1\r
+ DW CodeComma,EXIT\r
+COMPCREAT1 DW CELLPlus,CELLPlus,CELLPlus,CodeFetch,LITERAL,EXIT\r
+\r
+; CREATE ( "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- a-addr )\r
+; Create a data object in RAM/ROM data space, which return\r
+; data object address on execution\r
+;\r
+; : CREATE bal IF -29 THROW THEN \ compiler nesting\r
+; xhere ALIGNED TO xhere\r
+; ['] compileCREATE code,\r
+; xhere CELL+ TO xhere \ reserve space for nfa\r
+; ['] doCREATE xt, head,\r
+; 0 code, \ no DOES> code yet\r
+; ALIGN HERE code, \ >BODY returns this address\r
+; linkLast \ link CREATEd word to current wordlist\r
+; lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON NameCREATE,CREATE\r
+ DW Bal,ZBranch,CREAT1\r
+ DW DoLIT,-29,THROW\r
+CREAT1 DW XHere,ALIGNED,DoTO,AddrXHere\r
+ DW DoLIT,CompileCREATE,CodeComma\r
+ DW XHere,CELLPlus,DoTO,AddrXHere\r
+ DW DoLIT,DoCREATE,xtComma,HeadComma,DoLIT,0,CodeComma\r
+ DW ALIGNN,HERE,CodeComma,LinkLast\r
+ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE\r
+; Add double-cell numbers.\r
+;\r
+; : D+ >R SWAP >R um+ R> R> + + ;\r
+;\r
+; $COLON NameDPlus,DPlus\r
+; DW ToR,SWAP,ToR,UMPlus\r
+; DW RFrom,RFrom,Plus,Plus,EXIT\r
+\r
+ $CODE NameDPlus,DPlus\r
+ POP CX\r
+ POP DX\r
+ POP AX\r
+ ADD CX,AX\r
+ ADC BX,DX\r
+ PUSH CX\r
+ $NEXT\r
+\r
+; D. ( d -- ) \ DOUBLE\r
+; Display d in free field format followed by a space.\r
+;\r
+; : D. (d.) TYPE SPACE ;\r
+\r
+ $COLON NameDDot,DDot\r
+ DW ParenDDot,TYPEE,SPACE,EXIT\r
+\r
+; DECIMAL ( -- ) \ CORE\r
+; Set the numeric conversion radix to decimal 10.\r
+;\r
+; : DECIMAL 10 BASE ! ;\r
+\r
+ $COLON NameDECIMAL,DECIMAL\r
+ DW DoLIT,10,DoLIT,AddrBASE,Store,EXIT\r
+\r
+; DEPTH ( -- +n ) \ CORE\r
+; Return the depth of the data stack.\r
+;\r
+; : DEPTH sp@ sp0 SWAP - cell-size / ;\r
+;\r
+; $COLON NameDEPTH,DEPTH\r
+; DW SPFetch,SPZero,SWAP,Minus\r
+; DW DoLIT,CELLL,Slash,EXIT\r
+\r
+ $CODE NameDEPTH,DEPTH\r
+ PUSH BX\r
+ MOV BX,AddrUserP\r
+ MOV BX,[BX+CELLL]\r
+ SUB BX,SP\r
+ SAR BX,1\r
+ $NEXT\r
+\r
+; DNEGATE ( d1 -- d2 ) \ DOUBLE\r
+; Two's complement of double-cell number.\r
+;\r
+; : DNEGATE INVERT >R INVERT 1 um+ R> + ;\r
+;\r
+; $COLON NameDNEGATE,DNEGATE\r
+; DW INVERT,ToR,INVERT\r
+; DW DoLIT,1,UMPlus\r
+; DW RFrom,Plus,EXIT\r
+\r
+ $CODE NameDNEGATE,DNEGATE\r
+ POP AX\r
+ NEG AX\r
+ PUSH AX\r
+ ADC BX,0\r
+ NEG BX\r
+ $NEXT\r
+\r
+; EKEY ( -- u ) \ FACILITY EXT\r
+; Receive one keyboard event u.\r
+;\r
+; : EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;\r
+\r
+ $COLON NameEKEY,EKEY\r
+EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1\r
+ DW TickEKEY,EXECUTE,EXIT\r
+\r
+; EMIT ( x -- ) \ CORE\r
+; Send a character to the output device.\r
+;\r
+; : EMIT 'emit EXECUTE ;\r
+;\r
+; $COLON NameEMIT,EMIT\r
+; DW TickEMIT,EXECUTE,EXIT\r
+\r
+ $CODE NameEMIT,EMIT\r
+ MOV AX,AddrTickEMIT\r
+ JMP AX\r
+ $ALIGN\r
+\r
+; FM/MOD ( d n1 -- n2 n3 ) \ CORE\r
+; Signed floored divide of double by single. Return mod n2\r
+; and quotient n3.\r
+;\r
+; : FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN\r
+; R@ ABS UM/MOD DUP 0<\r
+; IF DUP 08000h XOR IF -11 THROW THEN THEN \ result out of range\r
+; SWAP R> 0< IF NEGATE THEN\r
+; SWAP R> 0< IF NEGATE OVER IF R@ ROT - SWAP 1- THEN THEN\r
+; R> DROP ;\r
+;\r
+; $COLON 6,'FM/MOD',FMSlashMOD,_FLINK\r
+; DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess\r
+; DW ZBranch,FMMOD1\r
+; DW DNEGATE\r
+; FMMOD1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,FMMOD2\r
+; DW DUPP,DoLIT,08000h,XORR,ZBranch,FMMOD2\r
+; DW DoLIT,-11,THROW\r
+; FMMOD2 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD3\r
+; DW NEGATE\r
+; FMMOD3 DW SWAP,RFrom,ZeroLess,ZBranch,FMMOD4\r
+; DW NEGATE,OVER,ZBranch,FMMOD4\r
+; DW RFetch,ROT,Minus,SWAP,OneMinus\r
+; FMMOD4 DW RFrom,DROP,EXIT\r
+\r
+ $CODE NameFMSlashMOD,FMSlashMOD\r
+ POP DX\r
+ POP AX\r
+ OR DX,DX\r
+ JS FMMOD2\r
+ OR BX,BX\r
+ JZ FMMOD1\r
+ JS FMMOD3\r
+ CMP DX,BX\r
+ JAE FMMOD6\r
+ DIV BX ;positive dividend, positive divisor\r
+ CMP AX,08000h\r
+ JA FMMOD6\r
+ PUSH DX\r
+ MOV BX,AX\r
+ $NEXT\r
+FMMOD3: NEG BX ;positive dividend, negative divisor\r
+ CMP DX,BX\r
+ JAE FMMOD6\r
+ DIV BX\r
+ CMP AX,08000h\r
+ JA FMMOD6\r
+ OR DX,DX\r
+ JZ FMMOD7 ;modulo = 0\r
+ SUB DX,BX\r
+ NOT AX ;AX=-AX-1\r
+ PUSH DX\r
+ MOV BX,AX\r
+ $NEXT\r
+FMMOD2: NEG AX ;DNEGATE\r
+ ADC DX,0\r
+ NEG DX\r
+ OR BX,BX\r
+ JZ FMMOD1\r
+ JS FMMOD4\r
+ CMP DX,BX ;negative dividend, positive divisor\r
+ JAE FMMOD6\r
+ DIV BX\r
+ CMP AX,08000h\r
+ JA FMMOD6\r
+ OR DX,DX\r
+ JZ FMMOD7\r
+ SUB BX,DX\r
+ NOT AX ;AX=-AX-1\r
+ PUSH BX\r
+ MOV BX,AX\r
+ $NEXT\r
+FMMOD7: NEG AX\r
+ PUSH DX\r
+ MOV BX,AX\r
+ $NEXT\r
+FMMOD4: NEG BX ;negative dividend, negative divisor\r
+ CMP DX,BX\r
+ JAE FMMOD6\r
+ DIV BX\r
+ CMP AX,08000h\r
+ JA FMMOD6\r
+ NEG DX\r
+ MOV BX,AX\r
+ PUSH DX\r
+ $NEXT\r
+FMMOD6: MOV BX,-11 ;result out of range\r
+ JMP THROW\r
+FMMOD1: MOV BX,-10 ;divide by zero\r
+ JMP THROW\r
+ $ALIGN\r
+\r
+; GET-CURRENT ( -- wid ) \ SEARCH\r
+; Return the indentifier of the compilation wordlist.\r
+;\r
+; : GET-CURRENT current @ ;\r
+\r
+ $COLON NameGET_CURRENT,GET_CURRENT\r
+ DW DoLIT,AddrCurrent,Fetch,EXIT\r
+\r
+; HOLD ( char -- ) \ CORE\r
+; Add char to the beginning of pictured numeric output string.\r
+;\r
+; : HOLD hld @ 1 CHARS - DUP hld ! C! ;\r
+;\r
+; $COLON NameHOLD,HOLD\r
+; DW DoLIT,AddrHLD,Fetch,DoLIT,0-CHARR,Plus\r
+; DW DUPP,DoLIT,AddrHLD,Store,CStore,EXIT\r
+\r
+ $CODE NameHOLD,HOLD\r
+ MOV DI,AddrHLD\r
+ DEC DI\r
+ MOV AddrHLD,DI\r
+ MOV [DI],BL\r
+ POP BX\r
+ $NEXT\r
+\r
+; I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+; Push the innermost loop index.\r
+;\r
+; : I rp@ [ 1 CELLS ] LITERAL + @\r
+; rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+;\r
+; $COLON NameI,I\r
+; DW RPFetch,DoLIT,CELLL,Plus,Fetch\r
+; DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+ $CODE NameI,I\r
+ PUSH BX\r
+ MOV BX,[BP]\r
+ ADD BX,[BP+2]\r
+ $NEXT\r
+\r
+; IF Compilation: ( C: -- orig ) \ CORE\r
+; Run-time: ( x -- )\r
+; Put the location of a new unresolved forward reference orig\r
+; onto the control flow stack. On execution jump to location\r
+; specified by the resolution of orig if x is zero.\r
+;\r
+; : IF POSTPONE 0branch xhere 0 code,\r
+; 1 bal+ \ orig type is 1\r
+\r
+ $COLON NameIFF,IFF\r
+ DW DoLIT,ZBranch,COMPILEComma,XHere,DoLIT,0,CodeComma\r
+ DW One,BalPlus,EXIT\r
+\r
+; INVERT ( x1 -- x2 ) \ CORE\r
+; Return one's complement of x1.\r
+;\r
+; : INVERT -1 XOR ;\r
+;\r
+; $COLON NameINVERT,INVERT\r
+; DW DoLIT,-1,XORR,EXIT\r
+\r
+ $CODE NameINVERT,INVERT\r
+ NOT BX\r
+ $NEXT\r
+\r
+; KEY ( -- char ) \ CORE\r
+; Receive a character. Do not display char.\r
+;\r
+; : KEY EKEY max-char AND ;\r
+\r
+ $COLON NameKEY,KEY\r
+ DW EKEY,DoLIT,MaxChar,ANDD,EXIT\r
+\r
+; LITERAL Compilation: ( x -- ) \ CORE\r
+; Run-time: ( -- x )\r
+; Append following run-time semantics. Put x on the stack on\r
+; execution\r
+;\r
+; : LITERAL POSTPONE doLIT code, ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameLITERAL,LITERAL\r
+ DW DoLIT,DoLIT,COMPILEComma,CodeComma,EXIT\r
+\r
+; NEGATE ( n1 -- n2 ) \ CORE\r
+; Return two's complement of n1.\r
+;\r
+; : NEGATE INVERT 1+ ;\r
+;\r
+; $COLON NameNEGATE,NEGATE\r
+; DW INVERT,OnePlus,EXIT\r
+\r
+ $CODE NameNEGATE,NEGATE\r
+ NEG BX\r
+ $NEXT\r
+\r
+; NIP ( n1 n2 -- n2 ) \ CORE EXT\r
+; Discard the second stack item.\r
+;\r
+; : NIP SWAP DROP ;\r
+;\r
+; $COLON NameNIP,NIP\r
+; DW SWAP,DROP,EXIT\r
+\r
+ $CODE NameNIP,NIP\r
+ POP AX\r
+ $NEXT\r
+\r
+; PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT\r
+; Scan input stream and return counted string delimited by char.\r
+;\r
+; : PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char\r
+; DUP IF\r
+; OVER CHARS + OVER \ c-addr c-addr+u c-addr R: char\r
+; BEGIN DUP C@ R@ XOR\r
+; WHILE CHAR+ 2DUP =\r
+; UNTIL DROP OVER - 1chars/ DUP\r
+; ELSE NIP OVER - 1chars/ DUP CHAR+\r
+; THEN >IN +!\r
+; THEN R> DROP EXIT ;\r
+;\r
+; $COLON 5,'PARSE',PARSE,_FLINK\r
+; DW ToR,SOURCE,DoLIT,AddrToIN,Fetch,SlashSTRING\r
+; DW DUPP,ZBranch,PARSE4\r
+; DW OVER,CHARS,Plus,OVER\r
+; PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3\r
+; DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1\r
+; PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5\r
+; PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus\r
+; PARSE5 DW DoLIT,AddrToIN,PlusStore\r
+; PARSE4 DW RFrom,DROP,EXIT\r
+\r
+ $CODE NamePARSE,PARSE\r
+ MOV AH,BL\r
+ MOV DX,SI\r
+ MOV SI,AddrSourceVar+CELLL\r
+ MOV BX,AddrSourceVar\r
+ MOV CX,AddrToIN\r
+ ADD SI,CX\r
+ SUB BX,CX\r
+ MOV CX,SI\r
+ PUSH SI\r
+ OR BX,BX\r
+ JZ PARSE1\r
+PARSE5: LODSB\r
+ CMP AL,AH\r
+ JE PARSE4\r
+ DEC BX\r
+ OR BX,BX\r
+ JNZ PARSE5\r
+ MOV BX,SI\r
+ SUB SI,AddrSourceVar+CELLL\r
+ SUB BX,CX\r
+ MOV AddrToIN,SI\r
+PARSE1: MOV SI,DX\r
+ $NEXT\r
+PARSE4: MOV BX,SI\r
+ SUB SI,AddrSourceVar+CELLL\r
+ SUB BX,CX\r
+ DEC BX\r
+ MOV AddrToIN,SI\r
+ MOV SI,DX\r
+ $NEXT\r
+\r
+; QUIT ( -- ) ( R: i*x -- ) \ CORE\r
+; Empty the return stack, store zero in SOURCE-ID, make the user\r
+; input device the input source, and start text interpreter.\r
+;\r
+; : QUIT BEGIN\r
+; rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [\r
+; BEGIN CR REFILL DROP SPACE \ REFILL returns always true\r
+; ['] interpret CATCH ?DUP 0=\r
+; WHILE STATE @ 0= IF .prompt THEN\r
+; REPEAT\r
+; DUP -1 XOR IF \ ABORT\r
+; DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"\r
+; SPACE errWord 2@ TYPE\r
+; SPACE [CHAR] ? EMIT SPACE\r
+; DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception\r
+; CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN\r
+; sp0 sp!\r
+; AGAIN ;\r
+\r
+ $COLON NameQUIT,QUIT\r
+QUIT1 DW RPZero,RPStore,DoLIT,0,DoTO,AddrSOURCE_ID\r
+ DW DoLIT,0,DoTO,AddrBal,LeftBracket\r
+QUIT2 DW CR,REFILL,DROP,SPACE\r
+ DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals\r
+ DW ZBranch,QUIT3\r
+ DW DoLIT,AddrSTATE,Fetch,ZeroEquals,ZBranch,QUIT2\r
+ DW DotPrompt,Branch,QUIT2\r
+QUIT3 DW DUPP,DoLIT,-1,XORR,ZBranch,QUIT5\r
+ DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4\r
+ DW SPACE,DoLIT,AddrAbortQMsg,TwoFetch,TYPEE,Branch,QUIT5\r
+QUIT4 DW SPACE,DoLIT,AddrErrWord,TwoFetch,TYPEE\r
+ DW SPACE,DoLIT,'?',EMIT,SPACE\r
+ DW DUPP,DoLIT,-1,DoLIT,-58,WITHIN,ZBranch,QUIT7\r
+ DW DoLIT,QUITstr\r
+ DW COUNT,TYPEE,Dot,Branch,QUIT5\r
+QUIT7 DW CELLS,DoLIT,AddrTHROWMsgTbl,Plus,Fetch,COUNT,TYPEE\r
+QUIT5 DW SPZero,SPStore,Branch,QUIT1\r
+\r
+; REFILL ( -- flag ) \ CORE EXT\r
+; Attempt to fill the input buffer from the input source. Make\r
+; the result the input buffer, set >IN to zero, and return true\r
+; if successful. Return false if the input source is a string\r
+; from EVALUATE.\r
+;\r
+; : REFILL SOURCE-ID IF 0 EXIT THEN\r
+; memTop [ size-of-PAD CHARS ] LITERAL - DUP\r
+; size-of-PAD ACCEPT sourceVar 2!\r
+; 0 >IN ! -1 ;\r
+\r
+ $COLON NameREFILL,REFILL\r
+ DW SOURCE_ID,ZBranch,REFIL1\r
+ DW DoLIT,0,EXIT\r
+REFIL1 DW MemTop,DoLIT,0-PADSize*CHARR,Plus,DUPP\r
+ DW DoLIT,PADSize*CHARR,ACCEPT,DoLIT,AddrSourceVar,TwoStore\r
+ DW DoLIT,0,DoLIT,AddrToIN,Store,DoLIT,-1,EXIT\r
+\r
+; ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE\r
+; Rotate the top three data stack items.\r
+;\r
+; : ROT >R SWAP R> SWAP ;\r
+;\r
+; $COLON NameROT,ROT\r
+; DW ToR,SWAP,RFrom,SWAP,EXIT\r
+\r
+ $CODE NameROT,ROT\r
+ POP AX\r
+ POP CX\r
+ PUSH AX\r
+ PUSH BX\r
+ MOV BX,CX\r
+ $NEXT\r
+\r
+; S>D ( n -- d ) \ CORE\r
+; Convert a single-cell number n to double-cell number.\r
+;\r
+; : S>D DUP 0< ;\r
+;\r
+; $COLON NameSToD,SToD\r
+; DW DUPP,ZeroLess,EXIT\r
+\r
+ $CODE NameSToD,SToD\r
+ PUSH BX\r
+ MOV AX,BX\r
+ CWD\r
+ MOV BX,DX\r
+ $NEXT\r
+\r
+; SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH\r
+; Search word list for a match with the given name.\r
+; Return execution token and -1 or 1 ( IMMEDIATE) if found.\r
+; Return 0 if not found.\r
+;\r
+; : SEARCH-WORDLIST\r
+; (search-wordlist) DUP IF NIP THEN ;\r
+\r
+ $COLON NameSEARCH_WORDLIST,SEARCH_WORDLIST\r
+ DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1\r
+ DW NIP\r
+SRCHW1 DW EXIT\r
+\r
+; SIGN ( n -- ) \ CORE\r
+; Add a minus sign to the numeric output string if n is negative.\r
+;\r
+; : SIGN 0< IF [CHAR] - HOLD THEN ;\r
+;\r
+; $COLON NameSIGN,SIGN\r
+; DW ZeroLess,ZBranch,SIGN1\r
+; DW DoLIT,'-',HOLD\r
+; SIGN1 DW EXIT\r
+\r
+ $CODE NameSIGN,SIGN\r
+ OR BX,BX\r
+ JNS SIGN1\r
+ MOV AL,'-'\r
+ MOV DI,AddrHLD\r
+ DEC DI\r
+ MOV AddrHLD,DI\r
+ MOV [DI],AL\r
+SIGN1: POP BX\r
+ $NEXT\r
+\r
+; SOURCE ( -- c-addr u ) \ CORE\r
+; Return input buffer string.\r
+;\r
+; : SOURCE sourceVar 2@ ;\r
+\r
+ $COLON NameSOURCE,SOURCE\r
+ DW DoLIT,AddrSourceVar,TwoFetch,EXIT\r
+\r
+; SPACE ( -- ) \ CORE\r
+; Send the blank character to the output device.\r
+;\r
+; : SPACE 32 EMIT ;\r
+;\r
+; $COLON NameSPACE,SPACE\r
+; DW DoLIT,' ',EMIT,EXIT\r
+\r
+ $CODE NameSPACE,SPACE\r
+ PUSH BX\r
+ MOV BX,' '\r
+ MOV AX,AddrTickEMIT\r
+ JMP AX\r
+ $ALIGN\r
+\r
+; STATE ( -- a-addr ) \ CORE\r
+; Return the address of a cell containing compilation-state flag\r
+; which is true in compilation state or false otherwise.\r
+\r
+ $CONST NameSTATE,STATE,AddrSTATE\r
+\r
+; THEN Compilation: ( C: orig -- ) \ CORE\r
+; Run-time: ( -- )\r
+; Resolve the forward reference orig.\r
+;\r
+; : THEN 1- IF -22 THROW THEN \ control structure mismatch\r
+; \ orig type is 1\r
+; xhere SWAP code! bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameTHENN,THENN\r
+ DW OneMinus,ZBranch,THEN1\r
+ DW DoLIT,-22,THROW\r
+THEN1 DW XHere,SWAP,CodeStore,BalMinus,EXIT\r
+\r
+; THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION\r
+; If n is not zero, pop the topmost exception frame from the\r
+; exception stack, along with everything on the return stack\r
+; above the frame. Then restore the condition before CATCH and\r
+; transfer control just after the CATCH that pushed that\r
+; exception frame.\r
+;\r
+; : THROW ?DUP\r
+; IF throwFrame @ rp! \ restore return stack\r
+; R> throwFrame ! \ restore THROW frame\r
+; R> SWAP >R sp! \ restore data stack\r
+; DROP R>\r
+; 'init-i/o EXECUTE\r
+; THEN ;\r
+\r
+ $COLON NameTHROW,THROW\r
+ DW QuestionDUP,ZBranch,THROW1\r
+ DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store\r
+ DW RFrom,SWAP,ToR,SPStore,DROP,RFrom\r
+ DW TickINIT_IO,EXECUTE\r
+THROW1 DW EXIT\r
+\r
+; TYPE ( c-addr u -- ) \ CORE\r
+; Display the character string if u is greater than zero.\r
+;\r
+; : TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;\r
+;\r
+; $COLON NameTYPEE,TYPEE\r
+; DW QuestionDUP,ZBranch,TYPE2\r
+; DW DoLIT,0,DoDO\r
+; TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1\r
+; TYPE2 DW DROP,EXIT\r
+\r
+ $CODE NameTYPEE,TYPEE\r
+ POP DI\r
+ OR BX,BX\r
+ JZ TYPE2\r
+ PUSH SI\r
+ SUB BP,CELLL\r
+ MOV [BP],BX\r
+ MOV BX,DI\r
+TYPE4: MOV DI,BX\r
+ XOR BX,BX\r
+ MOV BL,[DI]\r
+ INC DI\r
+ PUSH DI\r
+ MOV SI,OFFSET TYPE3\r
+ MOV AX,AddrTickEMIT\r
+ JMP AX\r
+TYPE1: DEC WORD PTR [BP]\r
+ JNZ TYPE4\r
+ POP SI\r
+ ADD BP,CELLL\r
+TYPE2: POP BX\r
+ $NEXT\r
+TYPE3 DW TYPE1\r
+\r
+; U< ( u1 u2 -- flag ) \ CORE\r
+; Unsigned compare of top two items. True if u1 < u2.\r
+;\r
+; : U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;\r
+;\r
+; $COLON NameULess,ULess\r
+; DW TwoDUP,XORR,ZeroLess\r
+; DW ZBranch,ULES1\r
+; DW NIP,ZeroLess,EXIT\r
+; ULES1 DW Minus,ZeroLess,EXIT\r
+\r
+ $CODE NameULess,ULess\r
+ POP AX\r
+ SUB AX,BX\r
+ MOV BX,-1\r
+ JB ULES1\r
+ INC BX\r
+ULES1: $NEXT\r
+\r
+; UM* ( u1 u2 -- ud ) \ CORE\r
+; Unsigned multiply. Return double-cell product.\r
+;\r
+; : UM* 0 SWAP cell-size-in-bits 0 DO\r
+; DUP um+ >R >R DUP um+ R> +\r
+; R> IF >R OVER um+ R> + THEN \ if carry\r
+; LOOP ROT DROP ;\r
+;\r
+; $COLON NameUMStar,UMStar\r
+; DW DoLIT,0,SWAP,DoLIT,CELLL*8,DoLIT,0,DoDO\r
+; UMST1 DW DUPP,UMPlus,ToR,ToR\r
+; DW DUPP,UMPlus,RFrom,Plus,RFrom\r
+; DW ZBranch,UMST2\r
+; DW ToR,OVER,UMPlus,RFrom,Plus\r
+; UMST2 DW DoLOOP,UMST1\r
+; DW ROT,DROP,EXIT\r
+\r
+ $CODE NameUMStar,UMStar\r
+ POP AX\r
+ MUL BX\r
+ PUSH AX\r
+ MOV BX,DX\r
+ $NEXT\r
+\r
+; UM/MOD ( ud u1 -- u2 u3 ) \ CORE\r
+; Unsigned division of a double-cell number ud by a single-cell\r
+; number u1. Return remainder u2 and quotient u3.\r
+;\r
+; : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero\r
+; 2DUP U< IF\r
+; NEGATE cell-size-in-bits 0\r
+; DO >R DUP um+ >R >R DUP um+ R> + DUP\r
+; R> R@ SWAP >R um+ R> OR\r
+; IF >R DROP 1+ R> THEN\r
+; ELSE DROP THEN\r
+; R>\r
+; LOOP DROP SWAP EXIT\r
+; ELSE -11 THROW \ result out of range\r
+; THEN ;\r
+;\r
+; $COLON NameUMSlashMOD,UMSlashMOD\r
+; DW DUPP,ZBranch,UMM5\r
+; DW TwoDUP,ULess,ZBranch,UMM4\r
+; DW NEGATE,DoLIT,CELLL*8,DoLIT,0,DoDO\r
+; UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP\r
+; DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2\r
+; DW ToR,DROP,OnePlus,RFrom,Branch,UMM3\r
+; UMM2 DW DROP\r
+; UMM3 DW RFrom,DoLOOP,UMM1\r
+; DW DROP,SWAP,EXIT\r
+; UMM5 DW DoLIT,-10,THROW\r
+; UMM4 DW DoLIT,-11,THROW\r
+\r
+ $CODE NameUMSlashMOD,UMSlashMOD\r
+ OR BX,BX\r
+ JZ UMM1\r
+ POP DX\r
+ CMP DX,BX\r
+ JAE UMM2\r
+ POP AX\r
+ DIV BX\r
+ PUSH DX\r
+ MOV BX,AX\r
+ $NEXT\r
+UMM1: MOV BX,-10 ;divide by zero\r
+ JMP THROW\r
+UMM2: MOV BX,-11 ;result out of range\r
+ JMP THROW\r
+ $ALIGN\r
+\r
+; UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE\r
+; Discard loop-control parameters for the current nesting level.\r
+; An UNLOOP is required for each nesting level before the\r
+; definition may be EXITed.\r
+;\r
+; : UNLOOP R> R> R> 2DROP >R ;\r
+;\r
+; $COLON NameUNLOOP,UNLOOP\r
+; DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT\r
+\r
+ $CODE NameUNLOOP,UNLOOP\r
+ ADD BP,2*CELLL\r
+ $NEXT\r
+\r
+; WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT\r
+; Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or\r
+; (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).\r
+;\r
+; : WITHIN OVER - >R - R> U< ;\r
+;\r
+; $COLON NameWITHIN,WITHIN\r
+; DW OVER,Minus,ToR ;ul <= u < uh\r
+; DW Minus,RFrom,ULess,EXIT\r
+\r
+ $CODE NameWITHIN,WITHIN\r
+ POP AX\r
+ SUB BX,AX\r
+ POP DX\r
+ SUB DX,AX\r
+ CMP DX,BX\r
+ MOV BX,-1\r
+ JB WITHIN1\r
+ INC BX\r
+WITHIN1: $NEXT\r
+\r
+; [ ( -- ) \ CORE\r
+; Enter interpretation state.\r
+;\r
+; : [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameLeftBracket,LeftBracket\r
+ DW DoLIT,0,DoLIT,AddrSTATE,Store,EXIT\r
+\r
+; ] ( -- ) \ CORE\r
+; Enter compilation state.\r
+;\r
+; : ] -1 STATE ! ;\r
+\r
+ $COLON NameRightBracket,RightBracket\r
+ DW DoLIT,-1,DoLIT,AddrSTATE,Store,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Rest of CORE words and two facility words, EKEY? and EMIT?\r
+;;;;;;;;;;;;;;;;\r
+; Following definitions can be removed from assembler source and\r
+; can be colon-defined later.\r
+\r
+; ( ( "ccc<)>" -- ) \ CORE\r
+; Ignore following string up to next ) . A comment.\r
+;\r
+; : ( [CHAR] ) PARSE 2DROP ;\r
+\r
+ $COLON NameParen,Paren\r
+ DW DoLIT,')',PARSE,TwoDROP,EXIT\r
+\r
+; * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Multiply n1|u1 by n2|u2 giving a single product.\r
+;\r
+; : * UM* DROP ;\r
+;\r
+; $COLON NameStar,Star\r
+; DW UMStar,DROP,EXIT\r
+\r
+ $CODE NameStar,Star\r
+ POP AX\r
+ IMUL BX\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; */ ( n1 n2 n3 -- n4 ) \ CORE\r
+; Multiply n1 by n2 producing double-cell intermediate,\r
+; then divide it by n3. Return single-cell quotient.\r
+;\r
+; : */ */MOD NIP ;\r
+\r
+ $COLON NameStarSlash,StarSlash\r
+ DW StarSlashMOD,NIP,EXIT\r
+\r
+; */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE\r
+; Multiply n1 by n2 producing double-cell intermediate,\r
+; then divide it by n3. Return single-cell remainder and\r
+; single-cell quotient.\r
+;\r
+; : */MOD >R M* R> FM/MOD ;\r
+;\r
+; $COLON NameStarSlashMOD,StarSlashMOD\r
+; DW ToR,MStar,RFrom,FMSlashMOD,EXIT\r
+\r
+ $CODE NameStarSlashMOD,StarSlashMOD\r
+ POP AX\r
+ POP CX\r
+ IMUL CX\r
+ PUSH AX\r
+ PUSH DX\r
+ JMP FMSlashMOD\r
+ $ALIGN\r
+\r
+; +LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+; Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Terminate a DO-+LOOP structure. Resolve the destination of all\r
+; unresolved occurences of LEAVE.\r
+; On execution add n to the loop index. If loop index did not\r
+; cross the boundary between loop_limit-1 and loop_limit,\r
+; continue execution at the beginning of the loop. Otherwise,\r
+; finish the loop.\r
+;\r
+; : +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NamePlusLOOP,PlusLOOP\r
+ DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT\r
+\r
+; ." ( "ccc<">" -- ) \ CORE\r
+; Run-time ( -- )\r
+; Compile an inline string literal to be typed out at run time.\r
+;\r
+; : ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameDotQuote,DotQuote\r
+ DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT\r
+\r
+; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE\r
+; Copy cell pair x1 x2 to the top of the stack.\r
+;\r
+; : 2OVER >R >R 2DUP R> R> 2SWAP ;\r
+;\r
+; $COLON NameTwoOVER,TwoOVER\r
+; DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT\r
+\r
+ $CODE NameTwoOVER,TwoOVER\r
+ MOV DI,SP\r
+ PUSH BX\r
+ PUSH [DI+2*CELLL]\r
+ MOV BX,[DI+CELLL]\r
+ $NEXT\r
+\r
+; >BODY ( xt -- a-addr ) \ CORE\r
+; Push data field address of CREATEd word.\r
+;\r
+; : >BODY ?call DUP IF \ code-addr xt2\r
+; ['] doCREATE = IF \ should be call-doCREATE\r
+; CELL+ code@ EXIT\r
+; THEN THEN\r
+; -31 THROW ; \ >BODY used on non-CREATEd definition\r
+\r
+ $COLON NameToBODY,ToBODY\r
+ DW QCall,DUPP,ZBranch,TBODY1\r
+ DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1\r
+ DW CELLPlus,CodeFetch,EXIT\r
+TBODY1 DW DoLIT,-31,THROW\r
+\r
+; ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT\r
+; Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )\r
+; Conditional abort with an error message.\r
+;\r
+; : ABORT" S" POSTPONE ROT\r
+; POSTPONE IF POSTPONE abort"msg POSTPONE 2!\r
+; -2 POSTPONE LITERAL POSTPONE THROW\r
+; POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameABORTQuote,ABORTQuote\r
+ DW SQuote,DoLIT,ROT,COMPILEComma\r
+ DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate\r
+ DW DoLIT,TwoStore,COMPILEComma\r
+ DW DoLIT,-2,LITERAL ; LITERAL is immediate\r
+ DW DoLIT,THROW,COMPILEComma\r
+ DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are\r
+ DW THENN,EXIT ; immediate\r
+\r
+; ABS ( n -- u ) \ CORE\r
+; Return the absolute value of n.\r
+;\r
+; : ABS DUP 0< IF NEGATE THEN ;\r
+;\r
+; $COLON NameABSS,ABSS\r
+; DW DUPP,ZeroLess,ZBranch,ABS1\r
+; DW NEGATE\r
+; ABS1 DW EXIT\r
+\r
+ $CODE NameABSS,ABSS\r
+ OR BX,BX\r
+ JNS ABS1\r
+ NEG BX\r
+ABS1: $NEXT\r
+\r
+; ALLOT ( n -- ) \ CORE\r
+; Allocate n bytes in data space.\r
+;\r
+; : ALLOT HERE + TO HERE ;\r
+\r
+ $COLON NameALLOT,ALLOT\r
+ DW HERE,Plus,DoTO,AddrHERE,EXIT\r
+\r
+; BEGIN ( C: -- dest ) \ CORE\r
+; Start an infinite or indefinite loop structure. Put the next\r
+; location for a transfer of control, dest, onto the data\r
+; control stack.\r
+;\r
+; : BEGIN xhere 0 bal+ \ dest type is 0\r
+; ; COMPILE-ONLY IMMDEDIATE\r
+\r
+ $COLON NameBEGIN,BEGIN\r
+ DW XHere,DoLIT,0,BalPlus,EXIT\r
+\r
+; C, ( char -- ) \ CORE\r
+; Compile a character into data space.\r
+;\r
+; : C, HERE C! HERE CHAR+ TO HERE ;\r
+;\r
+; $COLON NameCComma,CComma\r
+; DW HERE,CStore,HERE,CHARPlus,DoTO,AddrHERE,EXIT\r
+\r
+ $CODE NameCComma,CComma\r
+ MOV DI,AddrHERE\r
+ MOV [DI],BL\r
+ INC DI\r
+ MOV AddrHERE,DI\r
+ POP BX\r
+ $NEXT\r
+\r
+; CHAR ( "<spaces>ccc" -- char ) \ CORE\r
+; Parse next word and return the value of first character.\r
+;\r
+; : CHAR PARSE-WORD DROP C@ ;\r
+\r
+ $COLON NameCHAR,CHAR\r
+ DW PARSE_WORD,DROP,CFetch,EXIT\r
+\r
+; DO Compilation: ( C: -- do-sys ) \ CORE\r
+; Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )\r
+; Start a DO-LOOP structure in a colon definition. Place do-sys\r
+; on control-flow stack, which will be resolved by LOOP or +LOOP.\r
+;\r
+; : DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO\r
+; POSTPONE doDO xhere bal+ \ DO-dest\r
+\r
+ $COLON NameDO,DO\r
+ DW DoLIT,0,RakeVar,Store,DoLIT,0\r
+ DW DoLIT,DoDO,COMPILEComma,XHere,BalPlus,EXIT\r
+\r
+; DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE\r
+; Build run time code of the data object CREATEd.\r
+;\r
+; : DOES> bal 1- IF -22 THROW THEN \ control structure mismatch\r
+; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+; POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameDOESGreater,DOESGreater\r
+ DW Bal,OneMinus,ZBranch,DOES1\r
+ DW DoLIT,-22,THROW\r
+DOES1 DW NIP,OnePlus,ZBranch,DOES2\r
+ DW DoLIT,-22,THROW\r
+DOES2 DW DoLIT,Pipe,COMPILEComma\r
+ DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT\r
+\r
+; ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE\r
+; Run-time: ( -- )\r
+; Start the false clause in an IF-ELSE-THEN structure.\r
+; Put the location of new unresolved forward reference orig2\r
+; onto control-flow stack.\r
+;\r
+; : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMDEDIATE\r
+\r
+ $COLON NameELSEE,ELSEE\r
+ DW AHEAD,TwoSWAP,THENN,EXIT\r
+\r
+; ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE\r
+; Environment query.\r
+;\r
+; : ENVIRONMENT?\r
+; envQList SEARCH-WORDLIST\r
+; DUP >R IF EXECUTE THEN R> ;\r
+\r
+ $COLON NameENVIRONMENTQuery,ENVIRONMENTQuery\r
+ DW DoLIT,AddrEnvQList,SEARCH_WORDLIST\r
+ DW DUPP,ToR,ZBranch,ENVRN1\r
+ DW EXECUTE\r
+ENVRN1 DW RFrom,EXIT\r
+\r
+; EVALUATE ( i*x c-addr u -- j*x ) \ CORE\r
+; Evaluate the string. Save the input source specification.\r
+; Store -1 in SOURCE-ID.\r
+;\r
+; : EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R\r
+; -1 TO SOURCE-ID\r
+; sourceVar 2! 0 >IN ! interpret\r
+; R> TO SOURCE-ID\r
+; R> >IN ! R> R> sourceVar 2! ;\r
+\r
+ $COLON NameEVALUATE,EVALUATE\r
+ DW SOURCE,ToR,ToR,DoLIT,AddrToIN,Fetch,ToR,SOURCE_ID,ToR\r
+ DW DoLIT,-1,DoTO,AddrSOURCE_ID\r
+ DW DoLIT,AddrSourceVar,TwoStore,DoLIT,0,DoLIT,AddrToIN,Store,Interpret\r
+ DW RFrom,DoTO,AddrSOURCE_ID\r
+ DW RFrom,DoLIT,AddrToIN,Store,RFrom,RFrom,DoLIT,AddrSourceVar,TwoStore,EXIT\r
+\r
+; FILL ( c-addr u char -- ) \ CORE\r
+; Store char in each of u consecutive characters of memory\r
+; beginning at c-addr.\r
+;\r
+; : FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;\r
+;\r
+; $COLON NameFILL,FILL\r
+; DW ROT,ROT,QuestionDUP,ZBranch,FILL2\r
+; DW DoLIT,0,DoDO\r
+; FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1\r
+; FILL2 DW TwoDROP,EXIT\r
+\r
+ $CODE NameFILL,FILL\r
+ POP CX\r
+ MOV DX,SI\r
+ POP SI\r
+ OR CX,CX\r
+ JZ FILL1\r
+ MOV [SI],BL\r
+ MOV AX,DS\r
+ MOV ES,AX\r
+ MOV DI,SI\r
+ DEC CX\r
+ INC DI\r
+ REP MOVSB\r
+FILL1: MOV SI,DX\r
+ POP BX\r
+ $NEXT\r
+\r
+; FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH\r
+; Search dictionary for a match with the given counted name.\r
+; Return execution token and -1 or 1 ( IMMEDIATE) if found;\r
+; c-addr 0 if not found.\r
+;\r
+; : FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN\r
+; 2DROP 0 ;\r
+\r
+ $COLON NameFIND,FIND\r
+ DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1\r
+ DW NIP,ROT,DROP,EXIT\r
+FIND1 DW TwoDROP,DoLIT,0,EXIT\r
+\r
+; IMMEDIATE ( -- ) \ CORE\r
+; Make the most recent definition an immediate word.\r
+;\r
+; : IMMEDIATE lastName [ =immed ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON NameIMMEDIATE,IMMEDIATE\r
+ DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+; Push the index of next outer loop.\r
+;\r
+; : J rp@ [ 3 CELLS ] LITERAL + @\r
+; rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+;\r
+; $COLON NameJ,J\r
+; DW RPFetch,DoLIT,3*CELLL,Plus,Fetch\r
+; DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+ $CODE NameJ,J\r
+ PUSH BX\r
+ MOV BX,[BP+2*CELLL]\r
+ ADD BX,[BP+3*CELLL]\r
+ $NEXT\r
+\r
+; LEAVE ( -- ) ( R: loop-sys -- ) \ CORE\r
+; Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.\r
+;\r
+; : LEAVE POSTPONE UNLOOP POSTPONE branch\r
+; xhere rakeVar DUP @ code, ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameLEAVEE,LEAVEE\r
+ DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma\r
+ DW XHere,DoLIT,AddrRakeVar,DUPP,Fetch,CodeComma,Store,EXIT\r
+\r
+; LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+; Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )\r
+; Terminate a DO|?DO ... LOOP structure. Resolve the destination\r
+; of all unresolved occurences of LEAVE.\r
+;\r
+; : LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameLOOPP,LOOPP\r
+ DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT\r
+\r
+; LSHIFT ( x1 u -- x2 ) \ CORE\r
+; Perform a logical left shift of u bit-places on x1, giving x2.\r
+; Put 0 into the least significant bits vacated by the shift.\r
+;\r
+; : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;\r
+;\r
+; $COLON NameLSHIFT,LSHIFT\r
+; DW QuestionDUP,ZBranch,LSHIFT2\r
+; DW DoLIT,0,DoDO\r
+; LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1\r
+; LSHIFT2 DW EXIT\r
+\r
+ $CODE NameLSHIFT,LSHIFT\r
+ MOV CX,BX\r
+ POP BX\r
+ OR CX,CX\r
+ JZ LSHIFT2\r
+ SHL BX,CL\r
+LSHIFT2: $NEXT\r
+\r
+; M* ( n1 n2 -- d ) \ CORE\r
+; Signed multiply. Return double product.\r
+;\r
+; : M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;\r
+;\r
+; $COLON NameMStar,MStar\r
+; DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS\r
+; DW UMStar,RFrom,ZBranch,MSTAR1\r
+; DW DNEGATE\r
+; MSTAR1 DW EXIT\r
+\r
+ $CODE NameMStar,MStar\r
+ POP AX\r
+ IMUL BX\r
+ PUSH AX\r
+ MOV BX,DX\r
+ $NEXT\r
+\r
+; MAX ( n1 n2 -- n3 ) \ CORE\r
+; Return the greater of two top stack items.\r
+;\r
+; : MAX 2DUP < IF SWAP THEN DROP ;\r
+;\r
+; $COLON NameMAX,MAX\r
+; DW TwoDUP,LessThan,ZBranch,MAX1\r
+; DW SWAP\r
+; MAX1 DW DROP,EXIT\r
+\r
+ $CODE NameMAX,MAX\r
+ POP AX\r
+ CMP AX,BX\r
+ JLE MAX1\r
+ MOV BX,AX\r
+MAX1: $NEXT\r
+\r
+; MIN ( n1 n2 -- n3 ) \ CORE\r
+; Return the smaller of top two stack items.\r
+;\r
+; : MIN 2DUP > IF SWAP THEN DROP ;\r
+;\r
+; $COLON NameMIN,MIN\r
+; DW TwoDUP,GreaterThan,ZBranch,MIN1\r
+; DW SWAP\r
+; MIN1 DW DROP,EXIT\r
+\r
+ $CODE NameMIN,MIN\r
+ POP AX\r
+ CMP AX,BX\r
+ JGE MIN1\r
+ MOV BX,AX\r
+MIN1: $NEXT\r
+\r
+; MOD ( n1 n2 -- n3 ) \ CORE\r
+; Divide n1 by n2, giving the single cell remainder n3.\r
+; Returns modulo of floored division in this implementation.\r
+;\r
+; : MOD /MOD DROP ;\r
+\r
+ $COLON NameMODD,MODD\r
+ DW SlashMOD,DROP,EXIT\r
+\r
+; PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT\r
+; Remove u and copy the uth stack item to top of the stack. An\r
+; ambiguous condition exists if there are less than u+2 items\r
+; on the stack before PICK is executed.\r
+;\r
+; : PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow\r
+; 2 - OVER U< IF -4 THROW THEN\r
+; 1+ CELLS sp@ + @ ;\r
+;\r
+; $COLON NamePICK,PICK\r
+; DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1\r
+; DW DoLIT,-4,THROW\r
+; PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2\r
+; DW DoLIT,-4,THROW\r
+; PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT\r
+\r
+ $CODE NamePICK,PICK\r
+ MOV DI,AddrUserP\r
+ MOV DI,[DI+CELLL] ; sp0\r
+ SUB DI,SP\r
+ SAR DI,1 ; depth-1 in DI\r
+ DEC DI\r
+ JS PICK1\r
+ CMP DI,BX\r
+ JB PICK1\r
+ SHL BX,1\r
+ ADD BX,SP\r
+ MOV BX,[BX]\r
+ $NEXT\r
+PICK1: MOV BX,-4\r
+ JMP THROW\r
+ $ALIGN\r
+\r
+; POSTPONE ( "<spaces>name" -- ) \ CORE\r
+; Parse name and find it. Append compilation semantics of name\r
+; to current definition.\r
+; Structure of words with special compilation action\r
+; for default compilation behavior\r
+; |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
+;\r
+; : POSTPONE (') 0< IF\r
+; specialComp? OVER = IF \ special compilation action\r
+; DUP POSTPONE LITERAL\r
+; cell- cell- code@\r
+; POSTPONE LITERAL\r
+; POSTPONE EXECUTE EXIT THEN\r
+; POSTPONE LITERAL \ non-IMMEDIATE\r
+; POSTPONE code, EXIT THEN\r
+; code, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE\r
+\r
+ $COLON NamePOSTPONE,POSTPONE\r
+ DW ParenTick,ZeroLess,ZBranch,POSTP1\r
+ DW SpecialCompQ,OVER,Equals,ZBranch,POSTP2\r
+ DW DUPP,LITERAL,CellMinus,CellMinus,CodeFetch\r
+ DW LITERAL,DoLIT,EXECUTE,CodeComma,EXIT\r
+POSTP2 DW LITERAL,DoLIT,CodeComma\r
+POSTP1 DW CodeComma,EXIT\r
+\r
+; RECURSE ( -- ) \ CORE\r
+; Append the execution semactics of the current definition to\r
+; the current definition.\r
+;\r
+; : RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN\r
+; \ control structure mismatch; colon-sys type is -1\r
+; bal 1- 2* 1+ PICK \ xt of current definition\r
+; COMPILE, ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameRECURSE,RECURSE\r
+ DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1\r
+ DW DoLIT,-22,THROW\r
+RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK\r
+ DW COMPILEComma,EXIT\r
+\r
+; REPEAT ( C: orig dest -- ) \ CORE\r
+; Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve\r
+; backward reference dest and forward reference orig.\r
+;\r
+; : REPEAT AGAIN THEN ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameREPEAT,REPEATT\r
+ DW AGAIN,THENN,EXIT\r
+\r
+; RSHIFT ( x1 u -- x2 ) \ CORE\r
+; Perform a logical right shift of u bit-places on x1, giving x2.\r
+; Put 0 into the most significant bits vacated by the shift.\r
+;\r
+; : RSHIFT ?DUP IF\r
+; 0 SWAP cell-size-in-bits SWAP -\r
+; 0 DO 2DUP D+ LOOP\r
+; NIP\r
+; THEN ;\r
+;\r
+; $COLON NameRSHIFT,RSHIFT\r
+; DW QuestionDUP,ZBranch,RSHIFT2\r
+; DW DoLIT,0,SWAP,DoLIT,CELLL*8,SWAP,Minus,DoLIT,0,DoDO\r
+; RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1\r
+; DW NIP\r
+; RSHIFT2 DW EXIT\r
+\r
+ $CODE NameRSHIFT,RSHIFT\r
+ MOV CX,BX\r
+ POP BX\r
+ OR CX,CX\r
+ JZ RSHIFT2\r
+ SHR BX,CL\r
+RSHIFT2: $NEXT\r
+\r
+; SLITERAL ( c-addr1 u -- ) \ STRING\r
+; Run-time ( -- c-addr2 u )\r
+; Compile a string literal. Return the string on execution.\r
+;\r
+; : SLITERAL ALIGN HERE LITERAL DUP LITERAL\r
+; CHARS HERE 2DUP + ALIGNED TO HERE\r
+; SWAP MOVE ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameSLITERAL,SLITERAL\r
+ DW ALIGNN,HERE,LITERAL,DUPP,LITERAL\r
+ DW CHARS,HERE,TwoDUP,Plus,ALIGNED,DoTO,AddrHERE\r
+ DW SWAP,MOVE,EXIT\r
+\r
+; S" Compilation: ( "ccc<">" -- ) \ CORE\r
+; Run-time: ( -- c-addr u )\r
+; Parse ccc delimetered by " . Return the string specification\r
+; c-addr u on execution.\r
+;\r
+; : S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameSQuote,SQuote\r
+ DW DoLIT,'"',PARSE,SLITERAL,EXIT\r
+\r
+; SM/REM ( d n1 -- n2 n3 ) \ CORE\r
+; Symmetric divide of double by single. Return remainder n2\r
+; and quotient n3.\r
+;\r
+; : SM/REM OVER >R >R DUP 0< IF DNEGATE THEN\r
+; R@ ABS UM/MOD DUP 0<\r
+; IF DUP 08000h XOR IF -11 THROW THEN THEN \ result out of range\r
+; R> R@ XOR 0< IF NEGATE THEN\r
+; R> 0< IF SWAP NEGATE SWAP THEN ;\r
+;\r
+; $COLON 6,'SM/REM',SMSlashREM,_FLINK\r
+; DW OVER,ToR,ToR,DUPP,ZeroLess,ZBranch,SMREM1\r
+; DW DNEGATE\r
+; SMREM1 DW RFetch,ABSS,UMSlashMOD,DUPP,ZeroLess,ZBranch,SMREM4\r
+; DW DUPP,DoLIT,08000h,XORR,ZBranch,SMREM4\r
+; DW DoLIT,-11,THROW\r
+; SMREM4 DW RFrom,RFetch,XORR,ZeroLess,ZBranch,SMREM2\r
+; DW NEGATE\r
+; SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3\r
+; DW SWAP,NEGATE,SWAP\r
+; SMREM3 DW EXIT\r
+\r
+ $CODE NameSMSlashREM,SMSlashREM\r
+ POP DX\r
+ POP AX\r
+ OR DX,DX\r
+ JS SMREM2\r
+ OR BX,BX\r
+ JZ SMREM1\r
+ JS SMREM3\r
+ CMP DX,BX\r
+ JAE SMREM6\r
+ DIV BX ;positive dividend, positive divisor\r
+ CMP AX,08000h\r
+ JA SMREM6\r
+ PUSH DX\r
+ MOV BX,AX\r
+ $NEXT\r
+SMREM3: NEG BX ;positive dividend, negative divisor\r
+ CMP DX,BX\r
+ JAE SMREM6\r
+ DIV BX\r
+ CMP AX,08000h\r
+ JA SMREM6\r
+ MOV BX,AX\r
+ PUSH DX\r
+ NEG BX\r
+ $NEXT\r
+SMREM2: NEG AX ;DNEGATE\r
+ ADC DX,0\r
+ NEG DX\r
+ OR BX,BX\r
+ JZ SMREM1\r
+ JS SMREM4\r
+ CMP DX,BX ;negative dividend, positive divisor\r
+ JAE SMREM6\r
+ DIV BX\r
+ CMP AX,08000h\r
+ JA SMREM6\r
+ NEG DX\r
+ MOV BX,AX\r
+ PUSH DX\r
+ NEG BX\r
+ $NEXT\r
+SMREM4: NEG BX ;negative dividend, negative divisor\r
+ CMP DX,BX\r
+ JAE SMREM6\r
+ DIV BX\r
+ CMP AX,08000h\r
+ JA SMREM6\r
+ NEG DX\r
+ MOV BX,AX\r
+ PUSH DX\r
+ $NEXT\r
+SMREM6: MOV BX,-11 ;result out of range\r
+ JMP THROW\r
+SMREM1: MOV BX,-10 ;divide by zero\r
+ JMP THROW\r
+ $ALIGN\r
+\r
+; SPACES ( n -- ) \ CORE\r
+; Send n spaces to the output device if n is greater than zero.\r
+;\r
+; : SPACES ?DUP IF 0 DO SPACE LOOP THEN ;\r
+;\r
+; $COLON NameSPACES,SPACES\r
+; DW QuestionDUP,ZBranch,SPACES2\r
+; DW DoLIT,0,DoDO\r
+; SPACES1 DW SPACE,DoLOOP,SPACES1\r
+; SPACES2 DW EXIT\r
+\r
+ $CODE NameSPACES,SPACES\r
+ OR BX,BX\r
+ JZ SPACES2\r
+ PUSH SI\r
+ SUB BP,CELLL\r
+ MOV [BP],BX\r
+ MOV BX,' '\r
+SPACES4: PUSH BX\r
+ MOV SI,OFFSET SPACES3\r
+ MOV AX,AddrTickEMIT\r
+ JMP AX\r
+SPACES1: DEC WORD PTR [BP]\r
+ JNZ SPACES4\r
+ POP SI\r
+ ADD BP,CELLL\r
+SPACES2: POP BX\r
+ $NEXT\r
+SPACES3 DW SPACES1\r
+\r
+; TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT\r
+; Compilation: ( "<spaces>name" -- )\r
+; Run-time: ( x -- )\r
+; Store x in name.\r
+;\r
+; : TO ' ?call ?DUP IF \ should be CALL\r
+; ['] doVALUE = \ verify VALUE marker\r
+; IF code@ STATE @\r
+; IF POSTPONE doTO code, EXIT THEN\r
+; ! EXIT\r
+; THEN THEN\r
+; -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)\r
+\r
+ $COLON NameTO,TO\r
+ DW Tick,QCall,QuestionDUP,ZBranch,TO1\r
+ DW DoLIT,DoVALUE,Equals,ZBranch,TO1\r
+ DW CodeFetch,DoLIT,AddrSTATE,Fetch,ZBranch,TO2\r
+ DW DoLIT,DoTO,COMPILEComma,CodeComma,EXIT\r
+TO2 DW Store,EXIT\r
+TO1 DW DoLIT,-32,THROW\r
+\r
+; U. ( u -- ) \ CORE\r
+; Display u in free field format followed by space.\r
+;\r
+; : U. 0 D. ;\r
+\r
+ $COLON NameUDot,UDot\r
+ DW DoLIT,0,DDot,EXIT\r
+\r
+; UNTIL ( C: dest -- ) \ CORE\r
+; Terminate a BEGIN-UNTIL indefinite loop structure.\r
+;\r
+; : UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+; POSTPONE 0branch code, bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameUNTIL,UNTIL\r
+ DW ZBranch,UNTIL1\r
+ DW DoLIT,-22,THROW\r
+UNTIL1 DW DoLIT,ZBranch,COMPILEComma,CodeComma,BalMinus,EXIT\r
+\r
+; VALUE ( x "<spaces>name" -- ) \ CORE EXT\r
+; name Execution: ( -- x )\r
+; Create a value object with initial value x.\r
+;\r
+; : VALUE bal IF -29 THROW THEN \ compiler nesting\r
+; xhere ALIGNED CELL+ TO xhere\r
+; ['] doVALUE xt, head,\r
+; ALIGN HERE code,\r
+; , linkLast ; \ store x and link CREATEd word to current wordlist\r
+\r
+ $COLON NameVALUE,VALUE\r
+ DW Bal,ZBranch,VALUE1\r
+ DW DoLIT,-29,THROW\r
+VALUE1 DW XHere,ALIGNED,CELLPlus,DoTO,AddrXHere\r
+ DW DoLIT,DoVALUE,xtComma,HeadComma\r
+ DW ALIGNN,HERE,CodeComma\r
+ DW Comma,LinkLast,EXIT\r
+\r
+; VARIABLE ( "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- a-addr )\r
+; Parse a name and create a variable with the name.\r
+; Resolve one cell of data space at an aligned address.\r
+; Return the address on execution.\r
+;\r
+; : VARIABLE bal IF -29 THROW THEN \ compiler nesting\r
+; xhere ALIGNED TO xhere\r
+; ['] compileCONST code,\r
+; xhere CELL+ TO xhere\r
+; ['] doCONST xt, head,\r
+; ALIGN HERE\r
+; 1 CELLS ALLOT \ allocate one cell in data space\r
+; code, linkLast\r
+; lastName [ =seman ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON NameVARIABLE,VARIABLE\r
+ DW Bal,ZBranch,VARIA1\r
+ DW DoLIT,-29,THROW\r
+VARIA1 DW XHere,ALIGNED,DoTO,AddrXHere\r
+ DW DoLIT,CompileCONST,CodeComma\r
+ DW XHere,CELLPlus,DoTO,AddrXHere\r
+ DW DoLIT,DoCONST,xtComma,HeadComma\r
+ DW ALIGNN,HERE,DoLIT,1*CELLL,ALLOT\r
+ DW CodeComma,LinkLast\r
+ DW LastName,DoLIT,SEMAN,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; WHILE ( C: dest -- orig dest ) \ CORE\r
+; Put the location of a new unresolved forward reference orig\r
+; onto the control flow stack under the existing dest. Typically\r
+; used in BEGIN ... WHILE ... REPEAT structure.\r
+;\r
+; : WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameWHILE,WHILEE\r
+ DW IFF,TwoSWAP,EXIT\r
+\r
+; WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE\r
+; Skip leading delimeters and parse a word. Return the address\r
+; of a transient region containing the word as counted string.\r
+;\r
+; : WORD skipPARSE HERE pack" DROP HERE ;\r
+\r
+ $COLON NameWORDD,WORDD\r
+ DW SkipPARSE,HERE,PackQuote,DROP,HERE,EXIT\r
+\r
+; ['] Compilation: ( "<spaces>name" -- ) \ CORE\r
+; Run-time: ( -- xt )\r
+; Parse name. Return the execution token of name on execution.\r
+;\r
+; : ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameBracketTick,BracketTick\r
+ DW Tick,LITERAL,EXIT\r
+\r
+; [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE\r
+; Run-time: ( -- char )\r
+; Parse name. Return the value of the first character of name\r
+; on execution.\r
+;\r
+; : [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON NameBracketCHAR,BracketCHAR\r
+ DW CHAR,LITERAL,EXIT\r
+\r
+; \ ( "ccc<eol>" -- ) \ CORE EXT\r
+; Parse and discard the remainder of the parse area.\r
+;\r
+; : \ SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+ $COLON NameBackslash,Backslash\r
+ DW SOURCE,DoLIT,AddrToIN,Store,DROP,EXIT\r
+\r
+; Optional Facility words\r
+\r
+; EKEY? ( -- flag ) \ FACILITY EXT\r
+; If a keyboard event is available, return true.\r
+;\r
+; : EKEY? 'ekey? EXECUTE ;\r
+;\r
+; $COLON NameEKEYQuestion,EKEYQuestion\r
+; DW TickEKEYQ,EXECUTE,EXIT\r
+\r
+ $CODE NameEKEYQuestion,EKEYQuestion\r
+ MOV AX,AddrTickEKEYQ\r
+ JMP AX\r
+ $ALIGN\r
+\r
+; EMIT? ( -- flag ) \ FACILITY EXT\r
+; flag is true if the user output device is ready to accept data\r
+; and the execution of EMIT in place of EMIT? would not have\r
+; suffered an indefinite delay. If device state is indeterminate,\r
+; flag is true.\r
+;\r
+; : EMIT? 'emit? EXECUTE ;\r
+;\r
+; $COLON NameEMITQuestion,EMITQuestion\r
+; DW TickEMITQ,EXECUTE,EXIT\r
+\r
+ $CODE NameEMITQuestion,EMITQuestion\r
+ MOV AX,AddrTickEMITQ\r
+ JMP AX\r
+ $ALIGN\r
+\r
+;===============================================================\r
+\r
+CTOP DB (0FFFEh-($-XSysStatus)) DUP (?)\r
+ ;code segment occupies 64KB\r
+\r
+CODE ENDS\r
+END ORIG\r
+;===============================================================\r
--- /dev/null
+TITLE hForth 8086 RAM Model\r
+\r
+PAGE 62,132 ;62 lines per page, 132 characters per line\r
+\r
+;===============================================================\r
+;\r
+; hForth 8086 RAM model v0.9.9 by Wonyong Koh, 1997\r
+;\r
+;\r
+; 1997. 2. 19.\r
+; Split environmental variable systemID into CPU and Model.\r
+; 1997. 2. 6.\r
+; Add Neal Crook's microdebugger and comments on assembly definitions.\r
+; 1997. 1. 25.\r
+; Add $THROWMSG macro and revise accordingly.\r
+; 1997. 1. 18.\r
+; Remove 'NullString' from assembly source.\r
+; 1996. 12. 18.\r
+; Revise 'head,'.\r
+; 1996. 12. 3.\r
+; Revise PICK to catch stack underflow.\r
+; 1996. 12. 1.\r
+; Port from ROM Model v0.9.9.\r
+;\r
+; Changes from 0.9.7\r
+;\r
+;; hForth RAM ¡¡\95I·e RAM e·i ³a\93e ¯¡¯aÉQµA xÂ\81´á hForth ROM ¡¡\95I·i\r
+;; \89¡Áa¬á e\97i´ö¯s\93¡\94a.\r
+;;\r
+;; hForth ROM ¡¡\95I\89Á \94a\9fe ¸ñ\97i·i ´a\9c\81µA ¸â´ö¯s\93¡\94a. ¡A¡¡\9f¡\9fi\r
+;; ¸é´¢Ða\89¡ ¢\95¡\9fi ¨a\9fa\89A Ða\9da\89¡ \8b¡\89\81´á ¸÷·\81\9fi ¡y \88\81 \94áÐa\89¡\r
+;; \89¡Áv¯s\93¡\94a. ´áQ§i\9f¡ ¤aÈw¥¥µA¬á aÇa\9d¡µÁ °w¸ñ ¸÷·\81\9fi ¡y \88\81\r
+;; ¤a\8e\81´ö¯s\93¡\94a.\r
+;;\r
+;; 1. ¬a¸å·\81 \8a\81¹¡\9fi ¤a\8e\81´ö¯s\93¡\94a. hForth ROM ¡¡\95IµA¬á\93e Å¡\97aµÁ ·¡\9fq\r
+;; ¸a\9f¡\88a ´a\9c\81Àá\9cñ \90a\92á´á ·¶´ö»¡ e\r
+;;\r
+;; ||Å¡\97a> ... <¯¡Ç±Îa|·µ\8b¡|·¡\9fq||\r
+;;\r
+;; hForth RAM ¡¡\95IµA¬á\93e Å¡\97a, ·¡\9fq, ¸a\9ea ¸a\9f¡\88a ´a\9c\81Àá\9cñ ¡¡\96\81\r
+;; ¬ãµa ·¶¯s\93¡\94a.\r
+;;\r
+;; ||·µ\8b¡|·¡\9fq|·¡\9fq\88a\9f¡Ç±|Å¡\97a>\r
+;;\r
+;; µa\8b¡¬á '¯¡Ç±Îa(xt)'\93e Å¡\97a·\81 ¯¡¸b º\81¡·³\93¡\94a. $STRµÁ $CODEµÁ\r
+;; $ENVIRµÁ $VALUE aÇa\9d¡\9fi ¤a\8e\81´ö¯s\93¡\94a.\r
+;;\r
+;; 2. xt>name\89Á name>xt\9fi ¤a\8e\81´ö¯s\93¡\94a. hForth ROM ¡¡\95IµA¬á\93e ·¡\9fq\r
+;; ¸a\9f¡µA xt\9fi \88i¢\81\9f¡Ð\81 \96\81´á¬á name>xt\88a ·¡ \88t·i \94ᣡµA\r
+;; µ©\9dv¯s\93¡\94a. \8ba\9cá\90a Å¡\97a ¸a\9f¡\9fi ¸b¹A Ða\9da\89¡ Å¡\97a ¸a\9f¡µA\93e ·¡\9fq\r
+;; ¸a\9f¡ \88a\9f¡Ç±\88t·i \90q\89a \91½»¡ ´g´a¬á xt>name·¡ ·©Ã¡Ða\93e xt\9fi Àx·i\r
+;; \98\81\8ca»¡ ·¡\9fq ¸a\9f¡\9fi \94á\97q·i ®\81¤cµA ´ô´ö¯s\93¡\94a. hForth RAM\r
+;; ¡¡\95IµA\93e ·¡\9fq·\81 \8f{µA¬á Å¡\97a\88a ¯¡¸bÐa\8b¡ \98\81¢\85µA 'name>xt'\9fi\r
+;; ¶áÐ\81 \98a\9d¡ \88a\9f¡Ç±\88t·i \90q\89a \91½·i Ï©¶a\88a ´ô¯s\93¡\94a. Ða»¡ e\r
+;; xt>name\9fi ¶áÐ\81¬á xt ¤a\9d¡ ´|µA ·¡\9fq º\81¡\9fi \88a\9f¡Ç¡\93e \88t·i \90q\8b©\r
+;; Ï©¶a\88a ·¶¯s\93¡\94a. name>xt\88a ¤a\8eá´ö\8b¡ \98\81¢\85µA\r
+;; (search-wordlist)·\81 \8b¡\89\81´á ¸÷·\81\9fi ¤a\8e\81´ö¯s\93¡\94a (°w¸ñ ¸÷·\81\93e\r
+;; ¤a\8e\89 Ï©¶a\88a ´ô¯s\93¡\94a).\r
+;;\r
+;; 3. Å¡\97a, ·¡\9fq, ¸a\9ea ¸a\9f¡·\81 §¥ ¸a\9f¡\9fi \90aÈa\90\81\93e \88t\97i·¡ hForth RAM\r
+;; ¡¡\95IµA¬á\93e ROM\89Á RAM ¸a\9f¡\9fi \88a\9f¡Ç¡\93e \88a\9f¡Ç±\88t\97i´á´¡ Ði Ï©¶a\88a\r
+;; ´ô¯s\93¡\94a. ROMB, ROMT, RAMB, RAMT\9fi ¨\96¯s\93¡\94a. xhere\9fi ¡¡\96\81\r
+; HERE\9d¡ ¤a\8e\81´ö¯s\93¡\94a. 'code,'\9fi ¡¡\96\81 ','\9d¡ ¤a\8e\81´ö¯s\93¡\94a.\r
+;;\r
+;; 4. head,\88a ¤a\8eá´ö\8b¡ \98\81¢\85µA :µÁ CONSTANTµÁ CREATEµÁ VARIABLEµÁ\r
+;; VALUE\9fi \89¡Áv¯s\93¡\94a. hForth ROM ¡¡\95IµA¬á\93e ·¡\9fq ¸a\9f¡\88a Å¡\97a\r
+;; ¸a\9f¡µÁ \98é´á¹a ·¶´ö\8b¡ \98\81¢\85µA \90{ i·\81 ·¡\9fq·i ·¡\9fq ¸a\9f¡µA °á\r
+;; \90ý\8b¡ ¸åµA head,\88a xt\9fi ´i ®\81 ·¶´ö¯s\93¡\94a. \8ba\9cá\90a hForth RAM\r
+;; ¡¡\95IµA¬á\93e Å¡\97a ¸a\9f¡µÁ ·¡\9fq ¸a\9f¡\88a ÐsÁa¹v\8b¡ \98\81¢\85µA ·¡\9fq·i\r
+;; °á \90ý\8b¡ ¸åµA head,\88a xt\9fi £¡\9f¡ ´i ®\81 ´ô¯s\93¡\94a.\r
+;;\r
+;; 5. Á¡\8b¡\88t·¡ Ï©¶aÐe ¯¡¯aÉQ ¢\81\9fe\88t\97i\89Á \94e®\85Ðe ¯¡¯aÉQ ¢\81\9fe\88t·i\r
+;; \8a\81¦\85Ð\96¯s\93¡\94a. Á¡\8b¡\88t·¡ Ï©¶aÐe ¢\81\9fe\88t\97i·e doCONST\9fi °á¬á\r
+;; \94ᣡµA \88t·\81 º\81¡\9fi µ©\9f¡\89A Ða\89¡ Á¡\8b¡\88t·¡ Ï©¶a´ô\93e ¢\81\9fe\88t\97i·e\r
+;; $VAR aÇa\9d¡\9d¡ ¸÷·\81Ð\81¬á doVAR\9d¡ \88t·\81 º\81¡\9fi \94ᣡµA µ©\9f¡\89A\r
+;; Ð\96¯s\93¡\94a. VARIABLE·¡ ³a\93e \8b¡\89\81´á ¸÷·\81 doVAR\9fi \94áÐ\96¯s\93¡\94a.\r
+;;\r
+;; 6. CREATEµÁ doCREATEµÁ >BODY·\81 ¸÷·\81\9fi ¤a\8e\81´ö¯s\93¡\94a.\r
+;;\r
+;; 7. RESET-SYSTEM·i ´ô´\96¯s\93¡\94a. COLDµÁ set-i/o\9fi \89¡Áv¯s\93¡\94a.\r
+;;\r
+;; 8. PADSize\9fi \96\81 ¤\81\9d¡ \93i\9dv¯s\93¡\94a.\r
+;;\r
+;; 9. ¡A¡¡\9f¡ e \90â\90âÐa\94a¡e wordlist·\81 ®\81µA ¹AÐe·¡ ´ô¯s\93¡\94a.\r
+;;\r
+;; 10. ¬a¶w \88a\93wÐe ¡A¡¡\9f¡·\81 \85 ¶á\9fi \88a\9f¡Ç¡\93e ¢\81\9fe\88t memTop·i\r
+;; \94áÐ\96¯s\93¡\94a.\r
+;;\r
+;;\r
+; hForth RAM model is derived from hForth ROM model and adapted\r
+; to RAM only system.\r
+;\r
+; Differences from hForth ROM model are described below. One low\r
+; level CODE definition is changed and only one is added for\r
+; efficiency. Some macros in the assembler source and high level\r
+; colon definitions are redefined.\r
+;\r
+; 1. The structure of the dictionary is changed. Code and name\r
+; spaces are intermingled in hForth RAM model as below\r
+;\r
+; ||link|name|pointer_to_name|code>\r
+;\r
+; while they are separated in hForth ROM model as below.\r
+;\r
+; ||code> ... <xt|link|name||\r
+;\r
+; where xt is the starting address of code. $STR, $CODE, $ENVIR,\r
+; and $VALUE macros are redefined in assembly source.\r
+;\r
+; 2. 'xt>name' and 'name>xt' are redefined. In hForth ROM model the\r
+; xt of a definition is stored in name space which is used by\r
+; 'name>xt', however, the pointer to the name of a definition is\r
+; not stored in code space to keep the code space as tight as\r
+; possible. So 'xt>name' of hForth ROM model need to search the\r
+; whole name space until it finds the matched xt. In hForth RAM\r
+; model no pointer for 'name>xt' is necessary since code space\r
+; starts at the end of the name, however, a pointer to the name\r
+; of a definition is stored before the code of a definition for\r
+; 'xt>name'. CODE definition of '(search-wordlist)' is changed\r
+; since 'name>xt' is redefined (although colon definition need\r
+; not be changed at all).\r
+;\r
+; 3. Code, name and data pointers need not be vectored since the\r
+; memory space is not split into separated ROM and RAM spaces.\r
+; 'ROMB', 'ROMT', 'RAMB' and 'RAMT' are deleted. Every 'xhere'\r
+; was replaced with HERE. Every 'code,' was replaced with ','.\r
+;\r
+; 4. ':', 'CONSTANT', 'CREATE', 'VARIABLE', and 'VALUE' are\r
+; redefined since 'head,' is redefined. In hForth ROM model\r
+; name spaces are separated from code space and xt is given to\r
+; 'head,' before the name of a definition is compiled into the\r
+; name space. However, in hForth RAM model code and name spaces\r
+; are combined and xt can not be known to 'head,' until the\r
+; name of a definition is compiled into the name space.\r
+;\r
+; 5. System variables are devided into initializable variables\r
+; defined by $CONST which use doCONST to put a-addr on the\r
+; stack and non-initialized ones defined by $VAR which use\r
+; doVAR. CODE definition 'doVAR' is added and used by VARIABLE.\r
+;\r
+; 6. 'CREATE', 'doCREATE', and '>BODY' are redefined.\r
+;\r
+; 7. RESET-SYSTEM is deleted. COLD and 'set-i/o' are revised.\r
+;\r
+; 8. Increase PADSize twice.\r
+;\r
+; 9. Number of wordlists are only limited by available memory.\r
+;\r
+; 10. Variable 'memTop' is added, which points top of available\r
+; memory.\r
+;\r
+;===============================================================\r
+;\r
+; 8086/8 register usages\r
+; Single segment model. CS, DS and SS must be same.\r
+; The direction bit must be cleared before returning to Forth\r
+; interpreter(CLD).\r
+; SP: data stack pointer\r
+; BP: return stack pointer\r
+; SI: Forth virtual machine instruction pointer\r
+; BX: top of data stack item\r
+; All other registers are free.\r
+;\r
+; Structure of a task\r
+; userP points follower.\r
+; //userP//<return_stack//<data_stack//\r
+; //user_area/user1/taskName/throwFrame/stackTop/status/follower/sp0/rp0\r
+;\r
+;===============================================================\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Assembly Constants\r
+;;;;;;;;;;;;;;;;\r
+\r
+TRUEE EQU -1\r
+FALSEE EQU 0\r
+\r
+CHARR EQU 1 ;byte size of a character\r
+CELLL EQU 2 ;byte size of a cell\r
+MaxChar EQU 0FFh ;Extended character set\r
+ ; Use 07Fh for ASCII only\r
+MaxSigned EQU 07FFFh ;max value of signed integer\r
+MaxUnsigned EQU 0FFFFh ;max value of unsigned integer\r
+MaxNegative EQU 8000h ;max value of negative integer\r
+ ; Used in doDO\r
+\r
+PADSize EQU 258 ;PAD area size\r
+RTCells EQU 64 ;return stack size\r
+DTCells EQU 256 ;data stack size\r
+\r
+BASEE EQU 10 ;default radix\r
+OrderDepth EQU 10 ;depth of search order stack\r
+\r
+COMPO EQU 020h ;lexicon compile only bit\r
+IMMED EQU 040h ;lexicon immediate bit\r
+MASKK EQU 1Fh ;lexicon bit mask\r
+ ;extended character set\r
+ ;maximum name length = 1Fh\r
+\r
+BKSPP EQU 8 ;backspace\r
+TABB EQU 9 ;tab\r
+LFF EQU 10 ;line feed\r
+CRR EQU 13 ;carriage return\r
+DEL EQU 127 ;delete\r
+\r
+CALLL EQU 0E890h ;NOP CALL opcodes\r
+\r
+; Memory allocation\r
+; RAMbottom||code/name/data>WORDworkarea|--//--|PAD|TIB||MemTop\r
+\r
+COLDD EQU 00100h ;cold start vector\r
+\r
+; Initialize assembly variables\r
+\r
+_SLINK = 0 ;force a null link\r
+_FLINK = 0 ;force a null link\r
+_ENVLINK = 0 ;farce a null link\r
+_THROW = 0 ;current throw str addr offset\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Assembly macros\r
+;;;;;;;;;;;;;;;;\r
+\r
+; Adjust an address to the next cell boundary.\r
+\r
+$ALIGN MACRO\r
+ EVEN ;for 16 bit systems\r
+ ENDM\r
+\r
+; Add a name to name space of dictionary.\r
+\r
+$STR MACRO LABEL,STRING\r
+LABEL:\r
+ _LEN = $\r
+ DB 0,STRING\r
+ _CODE = $\r
+ORG _LEN\r
+ DB _CODE-_LEN-1\r
+ORG _CODE\r
+ $ALIGN\r
+ ENDM\r
+\r
+; Add a THROW message in name space. THROW messages won't be\r
+; needed if target system do not need names of Forth words.\r
+\r
+$THROWMSG MACRO STRING\r
+ _LEN = $\r
+ DB 0,STRING\r
+ _CODE = $\r
+ORG _LEN\r
+ DB _CODE-_LEN-1\r
+ _THROW = _THROW + CELLL\r
+ORG AddrTHROWMsgTbl - _THROW\r
+ DW _LEN\r
+ORG _CODE\r
+ ENDM\r
+\r
+; Compile a code definition header.\r
+\r
+$CODE MACRO LEX,NAME,LABEL,LINK\r
+ $ALIGN ;force to cell boundary\r
+ DW LINK\r
+ _NAME = $\r
+ LINK = $ ;link points to a name string\r
+ DB LEX,NAME ;name string\r
+ $ALIGN\r
+ DW _NAME\r
+LABEL: ;assembly label\r
+ ENDM\r
+\r
+; Compile a colon definition header.\r
+\r
+$COLON MACRO LEX,NAME,LABEL,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP ;align to cell boundary\r
+ CALL DoLIST ;include CALL doLIST\r
+ ENDM\r
+\r
+; Compile a system CONSTANT header.\r
+\r
+$CONST MACRO LEX,NAME,LABEL,VALUE,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoCONST\r
+ DW VALUE\r
+ ENDM\r
+\r
+; Compile a system VALUE header.\r
+\r
+$VALUE MACRO LEX,NAME,LABEL,VALUE,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoVALUE\r
+ DW VALUE\r
+ ENDM\r
+\r
+; Compile a non-initialized system VARIABLE header.\r
+\r
+$VAR MACRO LEX,NAME,LABEL,N_CELLS,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoVAR\r
+ DW N_CELLS DUP (?)\r
+ ENDM\r
+\r
+; Compile a system USER header.\r
+\r
+$USER MACRO LEX,NAME,LABEL,OFFSET,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoUSER\r
+ DW OFFSET\r
+ ENDM\r
+\r
+; Compile an inline string.\r
+\r
+$INSTR MACRO STRNG\r
+ DW DoLIT\r
+ _LEN = $ ;save address of count\r
+ DW 0 ;count\r
+ DW DoSQuote ;doS"\r
+ DB STRNG ;store string\r
+ _CODE = $ ;save code pointer\r
+ORG _LEN ;point to count byte\r
+ DW _CODE-_LEN-2*CELLL ;set count\r
+ORG _CODE ;restore code pointer\r
+ $ALIGN\r
+ ENDM\r
+\r
+; Compile a environment query string header.\r
+\r
+$ENVIR MACRO LEX,NAME\r
+ $ALIGN ;force to cell boundary\r
+ DW _ENVLINK ;link\r
+ _ENVLINK = $ ;link points to a name string\r
+ DB LEX,NAME ;name string\r
+ $ALIGN\r
+ DW _ENVLINK\r
+ NOP\r
+ CALL DoLIST\r
+ ENDM\r
+\r
+; Assemble inline direct threaded code ending.\r
+\r
+$NEXT MACRO\r
+; JMP uDebug ;activate to use microdebugger\r
+ LODSW ;next code address into AX\r
+ JMP AX ;jump directly to code address\r
+ $ALIGN\r
+ ENDM\r
+\r
+;===============================================================\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Main entry points and COLD start data\r
+;;;;;;;;;;;;;;;;\r
+\r
+MAIN SEGMENT\r
+ASSUME CS:MAIN,DS:MAIN,SS:MAIN\r
+\r
+ORG COLDD ;beginning of cold boot\r
+\r
+ORIG: CLD ;direction flag, increment\r
+ MOV WORD PTR AddrMemTop,SP ;top of memory at 'memTop'\r
+ MOV AX,CS\r
+ MOV DS,AX ;DS is same as CS\r
+ CLI ;disable interrupts, old 808x CPU bug\r
+ MOV SS,AX ;SS is same as CS\r
+ MOV SP,offset SPP ;initialize SP\r
+ STI ;enable interrupts\r
+ MOV BP,offset RPP ;initialize RP\r
+\r
+ XOR AX,AX ;MS-DOS only\r
+ MOV Redirect1stQ,AX ;MS-DOS only\r
+\r
+ JMP COLD ;to high level cold start\r
+\r
+ $ALIGN\r
+ $STR CPUStr,'8086'\r
+ $STR ModelStr,'RAM Model'\r
+ $STR VersionStr,'0.9.9'\r
+\r
+; system variables.\r
+\r
+ $ALIGN ;align to cell boundary\r
+ValueTickEKEYQ EQU RXQ ;'ekey?\r
+ValueTickEKEY EQU RXFetch ;'ekey\r
+ValueTickEMITQ EQU TXQ ;'emit?\r
+ValueTickEMIT EQU TXStore ;'emit\r
+ValueTickINIT_IO EQU Set_IO ;'init-i/o\r
+ValueTickPrompt EQU DotOK ;'prompt\r
+ValueTickBoot EQU HI ;'boot\r
+ValueSOURCE_ID EQU 0 ;SOURCE-ID\r
+ValueHERE EQU CTOP ;data space pointer\r
+AddrTickDoWord DW OptiCOMPILEComma ;nonimmediate word - compilation\r
+ DW EXECUTE ;nonimmediate word - interpretation\r
+ DW DoubleAlsoComma ;not found word - compilateion\r
+ DW DoubleAlso ;not found word - interpretation\r
+ DW EXECUTE ;immediate word - compilation\r
+ DW EXECUTE ;immediate word - interpretation\r
+AddrBASE DW 10 ;BASE\r
+AddrRakeVar DW 0 ;rakeVar\r
+AddrNumberOrder DW 2 ;#order\r
+ DW AddrFORTH_WORDLIST ;search order stack\r
+ DW AddrNONSTANDARD_WORDLIST\r
+ DW (OrderDepth-2) DUP (0)\r
+AddrCurrent DW AddrFORTH_WORDLIST ;current pointer\r
+AddrFORTH_WORDLIST DW LASTFORTH ;FORTH-WORDLIST\r
+ DW AddrNONSTANDARD_WORDLIST;wordlist link\r
+ DW FORTH_WORDLISTName ;name of the WORDLIST\r
+AddrNONSTANDARD_WORDLIST DW LASTSYSTEM ;NONSTANDARD-WORDLIST\r
+ DW 0 ;wordlist link\r
+ DW NONSTANDARD_WORDLISTName;name of the WORDLIST\r
+AddrEnvQList DW LASTENV ;envQList\r
+AddrUserP DW SysUserP ;user pointer\r
+SysTask DW SysUserP ;system task's tid\r
+SysUser1 DW ? ;user1\r
+SysTaskName DW SystemTaskName ;taskName\r
+SysThrowFrame DW ? ;throwFrame\r
+SysStackTop DW ? ;stackTop\r
+SysStatus DW Wake ;status\r
+SysUserP:\r
+SysFollower DW SysStatus ;follower\r
+ DW SPP ;system task's sp0\r
+ DW RPP ;system task's rp0\r
+\r
+AddrNumberOrder0 DW 2 ;#order\r
+ DW AddrFORTH_WORDLIST ;search order stack\r
+ DW AddrNONSTANDARD_WORDLIST\r
+ DW (OrderDepth-2) DUP (0)\r
+\r
+RStack DW RTCells DUP (0AAAAh) ;to see how deep stack grows\r
+RPP EQU $-CELLL\r
+DStack DW DTCells DUP (05555h) ;to see how deep stack grows\r
+SPP EQU $-CELLL\r
+\r
+; THROW code messages\r
+\r
+ DW 58 DUP (?) ;number of throw messages = 58\r
+AddrTHROWMsgTbl:\r
+ ;THROW code\r
+ $THROWMSG 'ABORT' ;-01\r
+ $THROWMSG 'ABORT"' ;-02\r
+ $THROWMSG 'stack overflow' ;-03\r
+ $THROWMSG 'stack underflow' ;-04\r
+ $THROWMSG 'return stack overflow' ;-05\r
+ $THROWMSG 'return stack underflow' ;-06\r
+ $THROWMSG 'do-loops nested too deeply during execution' ;-07\r
+ $THROWMSG 'dictionary overflow' ;-08\r
+ $THROWMSG 'invalid memory address' ;-09\r
+ $THROWMSG 'division by zero' ;-10\r
+ $THROWMSG 'result out of range' ;-11\r
+ $THROWMSG 'argument type mismatch' ;-12\r
+ $THROWMSG 'undefined word' ;-13\r
+ $THROWMSG 'interpreting a compile-only word' ;-14\r
+ $THROWMSG 'invalid FORGET' ;-15\r
+ $THROWMSG 'attempt to use zero-length string as a name' ;-16\r
+ $THROWMSG 'pictured numeric output string overflow' ;-17\r
+ $THROWMSG 'parsed string overflow' ;-18\r
+ $THROWMSG 'definition name too long' ;-19\r
+ $THROWMSG 'write to a read-only location' ;-20\r
+ $THROWMSG 'unsupported operation (e.g., AT-XY on a too-dumb terminal)' ;-21\r
+ $THROWMSG 'control structure mismatch' ;-22\r
+ $THROWMSG 'address alignment exception' ;-23\r
+ $THROWMSG 'invalid numeric argument' ;-24\r
+ $THROWMSG 'return stack imbalance' ;-25\r
+ $THROWMSG 'loop parameters unavailable' ;-26\r
+ $THROWMSG 'invalid recursion' ;-27\r
+ $THROWMSG 'user interrupt' ;-28\r
+ $THROWMSG 'compiler nesting' ;-29\r
+ $THROWMSG 'obsolescent feature' ;-30\r
+ $THROWMSG '>BODY used on non-CREATEd definition' ;-31\r
+ $THROWMSG 'invalid name argument (e.g., TO xxx)' ;-32\r
+ $THROWMSG 'block read exception' ;-33\r
+ $THROWMSG 'block write exception' ;-34\r
+ $THROWMSG 'invalid block number' ;-35\r
+ $THROWMSG 'invalid file position' ;-36\r
+ $THROWMSG 'file I/O exception' ;-37\r
+ $THROWMSG 'non-existent file' ;-38\r
+ $THROWMSG 'unexpected end of file' ;-39\r
+ $THROWMSG 'invalid BASE for floating point conversion' ;-40\r
+ $THROWMSG 'loss of precision' ;-41\r
+ $THROWMSG 'floating-point divide by zero' ;-42\r
+ $THROWMSG 'floating-point result out of range' ;-43\r
+ $THROWMSG 'floating-point stack overflow' ;-44\r
+ $THROWMSG 'floating-point stack underflow' ;-45\r
+ $THROWMSG 'floating-point invalid argument' ;-46\r
+ $THROWMSG 'compilation word list deleted' ;-47\r
+ $THROWMSG 'invalid POSTPONE' ;-48\r
+ $THROWMSG 'search-order overflow' ;-49\r
+ $THROWMSG 'search-order underflow' ;-50\r
+ $THROWMSG 'compilation word list changed' ;-51\r
+ $THROWMSG 'control-flow stack overflow' ;-52\r
+ $THROWMSG 'exception stack overflow' ;-53\r
+ $THROWMSG 'floating-point underflow' ;-54\r
+ $THROWMSG 'floating-point unidentified fault' ;-55\r
+ $THROWMSG 'QUIT' ;-56\r
+ $THROWMSG 'exception in sending or receiving a character' ;-57\r
+ $THROWMSG '[IF], [ELSE], or [THEN] exception' ;-58\r
+\r
+;;;;;;;;;;;;;;;;\r
+; System dependent words -- Must be re-definded for each system.\r
+;;;;;;;;;;;;;;;;\r
+; I/O words must be redefined if serial communication is used instead of\r
+; keyboard. Following words are for MS-DOS system.\r
+\r
+; RX? ( -- flag )\r
+; Return true if key is pressed.\r
+\r
+ $CODE 3,'RX?',RXQ,_SLINK\r
+ PUSH BX\r
+ MOV AH,0Bh ;get input status of STDIN\r
+ INT 021h\r
+ CBW\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; RX@ ( -- u )\r
+; Receive one keyboard event u.\r
+\r
+ $CODE 3,'RX@',RXFetch,_SLINK\r
+ PUSH BX\r
+ XOR BX,BX\r
+ MOV AH,08h ;MS-DOS Read Keyboard\r
+ INT 021h\r
+ ADD BL,AL ;MOV BL,AL and OR AL,AL\r
+ JNZ RXFET1 ;extended character code?\r
+ INT 021h\r
+ MOV BH,AL\r
+RXFET1: $NEXT\r
+\r
+; TX? ( -- flag )\r
+; Return true if output device is ready or device state is\r
+; indeterminate.\r
+\r
+ $CONST 3,'TX?',TXQ,TRUEE,_SLINK ;always true for MS-DOS\r
+\r
+; TX! ( u -- )\r
+; Send char to the output device.\r
+\r
+ $CODE 3,'TX!',TXStore,_SLINK\r
+ MOV DX,BX ;char in DL\r
+ MOV AH,02h ;MS-DOS Display output\r
+ INT 021H ;display character\r
+ POP BX\r
+ $NEXT\r
+\r
+; CR ( -- ) \ CORE\r
+; Carriage return and linefeed.\r
+;\r
+; : CR carriage-return-char EMIT linefeed-char EMIT ;\r
+\r
+ $COLON 2,'CR',CR,_FLINK\r
+ DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT\r
+\r
+; BYE ( -- ) \ TOOLS EXT\r
+; Return control to the host operation system, if any.\r
+\r
+ $CODE 3,'BYE',BYE,_FLINK\r
+ MOV AX,04C00h ;close all files and\r
+ INT 021h ; return to MS-DOS\r
+ $ALIGN\r
+\r
+; hi ( -- )\r
+;\r
+; : hi CR ." hForth "\r
+; S" CPU" ENVIRONMENT? DROP TYPE SPACE\r
+; S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT\r
+; S" version" ENVIRONMENT? DROP TYPE\r
+; ." by Wonyong Koh, 1997" CR\r
+; ." ALL noncommercial and commercial uses are granted." CR\r
+; ." Please send comment, bug report and suggestions to:" CR\r
+; ." wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;\r
+\r
+ $COLON 2,'hi',HI,_SLINK\r
+ DW CR\r
+ $INSTR 'hForth '\r
+ DW TYPEE\r
+ $INSTR 'CPU'\r
+ DW ENVIRONMENTQuery,DROP,TYPEE,SPACE\r
+ $INSTR 'model'\r
+ DW ENVIRONMENTQuery,DROP,TYPEE,SPACE,DoLIT,'v',EMIT\r
+ $INSTR 'version'\r
+ DW ENVIRONMENTQuery,DROP,TYPEE\r
+ $INSTR ' by Wonyong Koh, 1997'\r
+ DW TYPEE,CR\r
+ $INSTR 'All noncommercial and commercial uses are granted.'\r
+ DW TYPEE,CR\r
+ $INSTR 'Please send comment, bug report and suggestions to:'\r
+ DW TYPEE,CR\r
+ $INSTR ' wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr'\r
+ DW TYPEE,CR,EXIT\r
+\r
+; COLD ( -- )\r
+; The cold start sequence execution word.\r
+;\r
+; : COLD sp0 sp! rp0 rp! \ initialize stack\r
+; 'init-i/o EXECUTE\r
+; 'boot EXECUTE\r
+; QUIT ; \ start interpretation\r
+\r
+ $COLON 4,'COLD',COLD,_SLINK\r
+ DW SPZero,SPStore,RPZero,RPStore\r
+ DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE\r
+ DW QUIT\r
+\r
+; set-i/o ( -- )\r
+; Set input/output device.\r
+;\r
+; : set-i/o S" CON" stdin ; \ MS-DOS only\r
+\r
+ $COLON 7,'set-i/o',Set_IO,_SLINK\r
+ $INSTR 'CON' ;MS-DOS only\r
+ DW STDIN ;MS-DOS only\r
+ DW EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; MS-DOS only words -- not necessary for other systems.\r
+;;;;;;;;;;;;;;;;\r
+; File input using MS-DOS redirection function without using FILE words.\r
+\r
+; redirect ( c-addr -- flag )\r
+; Redirect standard input from the device identified by ASCIIZ\r
+; string stored at c-addr. Return error code.\r
+\r
+ $CODE 8,'redirect',Redirect,_SLINK\r
+ MOV DX,BX\r
+ MOV AX,Redirect1stQ\r
+ OR AX,AX\r
+ JZ REDIRECT2\r
+ MOV AH,03Eh\r
+ MOV BX,RedirHandle\r
+ INT 021h ; close previously opend file\r
+REDIRECT2: MOV AX,03D00h ; open file read-only\r
+ MOV Redirect1stQ,AX ; set Redirect1stQ true\r
+ INT 021h\r
+ JC REDIRECT1 ; if error\r
+ MOV RedirHandle,AX\r
+ XOR CX,CX\r
+ MOV BX,AX\r
+ MOV AX,04600H\r
+ INT 021H\r
+ JC REDIRECT1\r
+ XOR AX,AX\r
+REDIRECT1: MOV BX,AX\r
+ $NEXT\r
+Redirect1stQ DW 0 ; true after the first redirection\r
+RedirHandle DW ? ; redirect file handle\r
+\r
+; asciiz ( ca1 u -- ca2 )\r
+; Return ASCIIZ string.\r
+;\r
+; : asciiz HERE SWAP 2DUP + 0 SWAP C! CHARS MOVE HERE ;\r
+\r
+ $COLON 6,'asciiz',ASCIIZ,_SLINK\r
+ DW HERE,SWAP,TwoDUP,Plus,Zero\r
+ DW SWAP,CStore,CHARS,MOVE,HERE,EXIT\r
+\r
+; stdin ( ca u -- )\r
+;\r
+; : stdin asciiz redirect ?DUP\r
+; IF -38 THROW THEN ; COMPILE-ONLY\r
+\r
+ $COLON 5,'stdin',STDIN,_SLINK\r
+ DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1\r
+ DW DoLIT,-38,THROW\r
+STDIN1 DW EXIT\r
+\r
+; << ( "<spaces>ccc" -- )\r
+; Redirect input from the file 'ccc'. Should be used only in\r
+; interpretation state.\r
+;\r
+; : << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN\r
+; PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+ $COLON IMMED+2,'<<',FROM,_SLINK\r
+ DW STATE,Fetch,ZBranch,FROM1\r
+ DW CR\r
+ $INSTR 'Do not use << in a definition.'\r
+ DW TYPEE,ABORT\r
+FROM1 DW PARSE_WORD,STDIN,SOURCE,ToIN,Store,DROP,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Non-Standard words - Processor-dependent definitions\r
+; 16 bit Forth for 8086/8\r
+;;;;;;;;;;;;;;;;\r
+\r
+; microdebugger for debugging new hForth ports by NAC.\r
+;\r
+; The major problem with debugging Forth code at the assembler level is that\r
+; most of the definitions are lists of execution tokens that get interpreted\r
+; (using doLIST) rather than executed directly. As far as the native processor\r
+; is concerned, these xt are data, and a debugger cannot be set to trap on\r
+; them.\r
+;\r
+; The solution to that problem would seem to be to trap on the native-machine\r
+; 'call' instruction at the start of each definition. However, the threaded\r
+; nature of the code makes it very difficult to follow a particular definition\r
+; through: many definitions are used repeatedly through the code. Simply\r
+; trapping on the 'call' leads to multiple unwanted traps.\r
+;\r
+; Consider, for example, the code for doS" --\r
+;\r
+; DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT\r
+;\r
+; It would be useful to run each word in turn; at the end of each word the\r
+; effect upon the stacks could be checked until the faulty word is found.\r
+;\r
+; This technique allows you to do exactly that.\r
+;\r
+; All definitions end with $NEXT -- either directly (code definitions) or\r
+; indirectly (colon definitions terminating in EXIT, which is itself a code\r
+; definition). The action of $NEXT is to use the fpc for the next word to\r
+; fetch the xt and jumps to it.\r
+;\r
+; To use the udebug routine, replace the $NEXT expansion with a jump (not a\r
+; call) to the routine udebug (this requires you to reassemble the code)\r
+;\r
+; When you want to debug a word, trap at the CALL doLIST at the start of the\r
+; word and then load the location trapfpc with the address of the first xt\r
+; of the word. Make your debugger trap when you execute the final instruction\r
+; in the udebug routine. Now execute your code and your debugger will trap\r
+; after the completion of the first xt in the definition. To stop debugging,\r
+; simply set trapfpc to 0.\r
+;\r
+; This technique has a number of limitations:\r
+; - It is an assumption that an xt of 0 is illegal\r
+; - You cannot automatically debug a code stream that includes inline string\r
+; definitions, or any other kind of inline literal. You must step into the\r
+; word that includes the definition then hand-edit the appropriate new value\r
+; into trapfpc\r
+; Clearly, you could overcome these limitations by making udebug more\r
+; complex -- but then you run the risk of introducing bugs in that code.\r
+\r
+uDebug: MOV AX,trapfpc\r
+ CMP AX,SI ; compare the stored address with\r
+ ; the address we're about to get the\r
+ ; next xt from\r
+ JNE uDebug1 ; not the trap address, so we're done\r
+ ADD AX,CELLL ; next time trap on the next xt\r
+ MOV trapfpc,AX\r
+ NOP ; make debugger TRAP at this address\r
+uDebug1: LODSW\r
+ JMP AX\r
+ $ALIGN\r
+\r
+trapfpc DW 0\r
+\r
+; same? ( c-addr1 c-addr2 u -- -1|0|1 )\r
+; Return 0 if two strings, ca1 u and ca2 u, are same; -1 if\r
+; string, ca1 u is smaller than ca2 u; 1 otherwise. Used by\r
+; '(search-wordlist)'. Code definition is preferred to speed up\r
+; interpretation. Colon definition is shown below.\r
+;\r
+; : same? ?DUP IF \ null strings are always same\r
+; 0 DO OVER C@ OVER C@ XOR\r
+; IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN\r
+; CHAR+ SWAP CHAR+ SWAP\r
+; LOOP\r
+; THEN 2DROP 0 ;\r
+;\r
+; $COLON 5,'same?',SameQ,_SLINK\r
+; DW QuestionDUP,ZBranch,SAMEQ4\r
+; DW Zero,DoDO\r
+; SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2\r
+; DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan\r
+; DW TwoStar,OnePlus,EXIT\r
+; SAMEQ2 DW CHARPlus,SWAP,CHARPlus\r
+; DW DoLOOP,SAMEQ3\r
+; SAMEQ4 DW TwoDROP,Zero,EXIT\r
+\r
+ $CODE 5,'same?',SameQ,_SLINK\r
+ MOV CX,BX\r
+ MOV AX,DS\r
+ MOV ES,AX\r
+ MOV DX,SI ;save SI\r
+ MOV BX,-1\r
+ POP DI\r
+ POP SI\r
+ OR CX,CX\r
+ JZ SAMEQ5\r
+ REPE CMPSB\r
+ JL SAMEQ1\r
+ JZ SAMEQ5\r
+ INC BX\r
+SAMEQ5: INC BX\r
+SAMEQ1: MOV SI,DX\r
+ $NEXT\r
+\r
+; (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)\r
+; Search word list for a match with the given name.\r
+; Return execution token and not-compile-only flag and\r
+; -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.\r
+;\r
+; format is: wid---->[ a ]\r
+; |\r
+; +---------+\r
+; V\r
+; [ a' ][ccbbaann][ggffeedd]...\r
+; |\r
+; +--------+\r
+; V\r
+; [ a'' ][ccbbaann][ggffeedd]...\r
+;\r
+; a, a' etc. point to the cell that contains the name of the\r
+; word. The length is in the low byte of the cell (little byte\r
+; for little-endian, big byte for big-endian).\r
+; Eventually, a''' contains 0 to indicate the end of the wordlist\r
+; (oldest entry). a=0 indicates an empty wordlist.\r
+; xt is the xt of the word. aabbccddeedd etc. is the name of\r
+; the word, packed into cells.\r
+;\r
+; : (search-wordlist)\r
+; ROT >R SWAP DUP 0= IF -16 THROW THEN\r
+; \ attempt to use zero-length string as a name\r
+; >R \ wid R: ca1 u\r
+; BEGIN @ \ ca2 R: ca1 u\r
+; DUP 0= IF R> R> 2DROP EXIT THEN \ not found\r
+; DUP COUNT [ =MASK ] LITERAL AND R@ = \ ca2 ca2+char f\r
+; IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u\r
+; same? \ ca2 flag\r
+; \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.\r
+; THEN\r
+; WHILE cell- \ pointer to next word in wordlist\r
+; REPEAT\r
+; R> R> 2DROP DUP name>xt SWAP \ xt ca2\r
+; C@ DUP [ =COMP ] LITERAL AND 0= SWAP\r
+; [ =IMED ] LITERAL AND 0= 2* 1+ ;\r
+;\r
+; $COLON 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK\r
+; DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6\r
+; DW ToR\r
+; PSRCH1 DW Fetch\r
+; DW DUPP,ZBranch,PSRCH9\r
+; DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals\r
+; DW ZBranch,PSRCH5\r
+; DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ\r
+; PSRCH5 DW ZBranch,PSRCH3\r
+; DW CellMinus,Branch,PSRCH1\r
+; PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP\r
+; DW CFetch,DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP\r
+; DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT\r
+; PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT\r
+; PSRCH6 DW DoLIT,-16,THROW\r
+\r
+ $CODE 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK\r
+ POP AX ;u\r
+ POP DX ;c-addr\r
+ OR AX,AX\r
+ JZ PSRCH1\r
+ PUSH SI\r
+ MOV CX,DS\r
+ MOV ES,CX\r
+ SUB CX,CX\r
+PSRCH2: MOV BX,[BX]\r
+ OR BX,BX\r
+ JZ PSRCH4 ; end of wordlist?\r
+ MOV CL,[BX]\r
+ SUB BX,CELLL ;pointer to nextword\r
+ AND CL,MASKK ;max name length = MASKK\r
+ CMP CL,AL\r
+ JNZ PSRCH2\r
+ MOV SI,DX\r
+ MOV DI,BX\r
+ ADD DI,CELLL+CHARR\r
+ REPE CMPSB\r
+ JNZ PSRCH2\r
+ POP SI\r
+ ADD DI,3 ;add 1 CELLS + 1\r
+ AND DI,0FFFEh ;align\r
+ PUSH DI\r
+ MOV CL,[BX+CELLL]\r
+ XOR DX,DX\r
+ TEST CL,COMPO\r
+ JNZ PSRCH5\r
+ DEC DX\r
+PSRCH5: PUSH DX\r
+ TEST CL,IMMED\r
+ MOV BX,-1\r
+ JZ PSRCH3\r
+ NEG BX\r
+PSRCH3: $NEXT\r
+PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name\r
+ JMP THROW\r
+PSRCH4: POP SI\r
+ $NEXT\r
+\r
+; ?call ( xt1 -- xt1 0 | a-addr xt2 )\r
+; Return xt of the CALLed run-time word if xt starts with machine\r
+; CALL instruction and leaves the next cell address after the\r
+; CALL instruction. Otherwise leaves the original xt1 and zero.\r
+;\r
+; : ?call DUP @ call-code =\r
+; IF CELL+ DUP @ SWAP CELL+ DUP ROT + EXIT THEN\r
+; \ Direct Threaded Code 8086 relative call\r
+; 0 ;\r
+\r
+ $COLON 5,'?call',QCall,_SLINK\r
+ DW DUPP,Fetch,DoLIT,CALLL,Equals,ZBranch,QCALL1\r
+ DW CELLPlus,DUPP,Fetch,SWAP,CELLPlus,DUPP,ROT,Plus,EXIT\r
+QCALL1 DW Zero,EXIT\r
+\r
+; xt, ( xt1 -- xt2 )\r
+; Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and\r
+; CREATE . Return xt2 of current definition.\r
+;\r
+; : xt, HERE ALIGNED DUP TO HERE SWAP\r
+; call-code , \ Direct Threaded Code\r
+; HERE CELL+ - , ; \ 8086 relative call\r
+\r
+ $COLON 3,'xt,',xtComma,_SLINK\r
+ DW HERE,ALIGNED,DUPP,DoTO,AddrHERE,SWAP\r
+ DW DoLIT,CALLL,Comma,HERE,CELLPlus,Minus,Comma,EXIT\r
+\r
+; doLIT ( -- x )\r
+; Push an inline literal. The inline literal is at the current\r
+; value of the fpc, so put it onto the stack and point past it.\r
+\r
+ $CODE COMPO+5,'doLIT',DoLIT,_SLINK\r
+ PUSH BX\r
+ LODSW\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; doCONST ( -- x )\r
+; Run-time routine of CONSTANT. When you quote a constant you\r
+; execute its code, which consists of a call to here, followed\r
+; by an inline literal. Although you come here as the result of\r
+; a native machine call, you never go back to the return address\r
+; -- you jump back up a level by continuing at the new fpc\r
+; value. For 8086, Z80 the inline literal is at the return\r
+; address stored on the top of the hardware stack.\r
+\r
+ $CODE COMPO+7,'doCONST',DoCONST,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; doVALUE ( -- x )\r
+; Run-time routine of VALUE. Same as doCONSTANT. Used as a\r
+; marker for TO.\r
+\r
+ $CODE COMPO+7,'doVALUE',DoVALUE,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; doVAR ( -- x )\r
+; Run-time routine of VARIABLE. When you quote a variable you\r
+; execute its code, which consists of a call to here, followed\r
+; by an inline literal. The literal is the address at which a\r
+; VARIABLE's value is stored. Although you come here as the\r
+; result of a native machine call, you never go back to the\r
+; return address -- you jump back up a level by continuing at\r
+; the new fpc value. For 8086, Z80 the inline literal is at\r
+; the return address stored on the top of the hardware stack.\r
+\r
+ $CODE COMPO+5,'doVAR',DoVAR,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ $NEXT\r
+\r
+; doCREATE ( -- a-addr )\r
+; Run-time routine of CREATE. For CREATEd words with an\r
+; associated DOES>, get the address of the CREATEd word's data\r
+; space and execute the DOES> actions. For CREATEd word without\r
+; an associated DOES>, return the address of the CREATE'd word's\r
+; data space. A CREATEd word starts its execution through this\r
+; routine in exactly the same way as a colon definition uses\r
+; doLIST. In other words, we come here through a native machine\r
+; branch.\r
+;\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | >BODY points here\r
+;\r
+; The DOES> address holds a native call to doLIST. This routine\r
+; doesn't alter the fpc. We never come back *here* so we never\r
+; need to preserve an address that would bring us back *here*.\r
+;\r
+; Example : myVARIABLE CREATE , DOES> ;\r
+; 56 myVARIABLE JIM\r
+; JIM \ stacks the address of the data cell that contains 56\r
+;\r
+; : doCREATE SWAP \ switch BX and top of 8086 stack item\r
+; DUP CELL+ SWAP @ ?DUP IF EXECUTE THEN ; COMPILE-ONLY\r
+;\r
+; $COLON COMPO+8,'doCREATE',DoCREATE,_SLINK\r
+; DW SWAP,DUPP,CELLPlus,SWAP,Fetch,QuestionDUP\r
+; DW ZBranch,DOCREAT1\r
+; DW EXECUTE\r
+; DOCREAT1 DW EXIT\r
+\r
+ $CODE COMPO+8,'doCREATE',DoCREATE,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV AX,[BX]\r
+ ADD BX,CELLL\r
+ OR AX,AX\r
+ JNZ DOCREAT1\r
+ $NEXT\r
+DOCREAT1: JMP AX\r
+ $ALIGN\r
+\r
+; doTO ( x -- )\r
+; Run-time routine of TO. Store x at the address in the\r
+; following cell. The inline literal holds the address\r
+; to be modified.\r
+\r
+ $CODE COMPO+4,'doTO',DoTO,_SLINK\r
+ LODSW\r
+ XCHG BX,AX\r
+ MOV [BX],AX\r
+ POP BX\r
+ $NEXT\r
+\r
+; doUSER ( -- a-addr )\r
+; Run-time routine of USER. Return address of data space.\r
+; This is like doCONST but a variable offset is added to the\r
+; result. By changing the value at AddrUserP (which happens\r
+; on a taskswap) the whole set of user variables is switched\r
+; to the set for the new task.\r
+\r
+ $CODE COMPO+6,'doUSER',DoUSER,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,[BX]\r
+ ADD BX,AddrUserP\r
+ $NEXT\r
+\r
+; doLIST ( -- ) ( R: -- nest-sys )\r
+; Process colon list.\r
+; The first word of a definition (the xt for the word) is a\r
+; native machine-code instruction for the target machine. For\r
+; high-level definitions, that code is emitted by xt, and\r
+; performs a call to doLIST. doLIST executes the list of xt that\r
+; make up the definition. The final xt in the definition is EXIT.\r
+; The address of the first xt to be executed is passed to doLIST\r
+; in a target-specific way. Two examples:\r
+; Z80, 8086: native machine call, leaves the return address on\r
+; the hardware stack pointer, which is used for the data stack.\r
+\r
+ $CODE COMPO+6,'doLIST',DoLIST,_SLINK\r
+ SUB BP,2\r
+ MOV [BP],SI ;push return stack\r
+ POP SI ;new list address\r
+ $NEXT\r
+\r
+; doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Run time routine for LOOP.\r
+\r
+ $CODE COMPO+6,'doLOOP',DoLOOP,_SLINK\r
+ INC WORD PTR [BP] ;increase loop count\r
+ JO DoLOOP1 ;?loop end\r
+ MOV SI,[SI] ;no, go back\r
+ $NEXT\r
+DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+ ADD BP,2*CELLL ;clear return stack\r
+ $NEXT\r
+\r
+; do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Run time routine for +LOOP.\r
+\r
+ $CODE COMPO+7,'do+LOOP',DoPLOOP,_SLINK\r
+ ADD WORD PTR [BP],BX ;increase loop count\r
+ JO DoPLOOP1 ;?loop end\r
+ MOV SI,[SI] ;no, go back\r
+ POP BX\r
+ $NEXT\r
+DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+ ADD BP,2*CELLL ;clear return stack\r
+ POP BX\r
+ $NEXT\r
+\r
+; 0branch ( flag -- )\r
+; Branch if flag is zero.\r
+\r
+ $CODE COMPO+7,'0branch',ZBranch,_SLINK\r
+ OR BX,BX ;?flag=0\r
+ JZ ZBRAN1 ;yes, so branch\r
+ ADD SI,CELLL ;point IP to next cell\r
+ POP BX\r
+ $NEXT\r
+ZBRAN1: MOV SI,[SI] ;IP:=(IP)\r
+ POP BX\r
+ $NEXT\r
+\r
+; branch ( -- )\r
+; Branch to an inline address.\r
+\r
+ $CODE COMPO+6,'branch',Branch,_SLINK\r
+ MOV SI,[SI] ;IP:=(IP)\r
+ $NEXT\r
+\r
+; rp@ ( -- a-addr )\r
+; Push the current RP to the data stack.\r
+\r
+ $CODE COMPO+3,'rp@',RPFetch,_SLINK\r
+ PUSH BX\r
+ MOV BX,BP\r
+ $NEXT\r
+\r
+; rp! ( a-addr -- )\r
+; Set the return stack pointer.\r
+\r
+ $CODE COMPO+3,'rp!',RPStore,_SLINK\r
+ MOV BP,BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; sp@ ( -- a-addr )\r
+; Push the current data stack pointer.\r
+\r
+ $CODE 3,'sp@',SPFetch,_SLINK\r
+ PUSH BX\r
+ MOV BX,SP\r
+ $NEXT\r
+\r
+; sp! ( a-addr -- )\r
+; Set the data stack pointer.\r
+\r
+ $CODE 3,'sp!',SPStore,_SLINK\r
+ MOV SP,BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; um+ ( u1 u2 -- u3 1|0 )\r
+; Add two unsigned numbers, return the sum and carry.\r
+\r
+ $CODE 3,'um+',UMPlus,_SLINK\r
+ XOR CX,CX\r
+ POP AX\r
+ ADD BX,AX\r
+ PUSH BX ;push sum\r
+ RCL CX,1 ;get carry\r
+ MOV BX,CX\r
+ $NEXT\r
+\r
+; 1chars/ ( n1 -- n2 )\r
+; Calculate number of chars for n1 address units.\r
+;\r
+; : 1chars/ 1 CHARS / ; \ slow, very portable\r
+; : 1chars/ ; \ fast, must be redefined for each system\r
+\r
+ $COLON 7,'1chars/',OneCharsSlash,_SLINK\r
+ DW EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Standard words - Processor-dependent definitions\r
+; 16 bit Forth for 8086/8\r
+;;;;;;;;;;;;;;;;\r
+\r
+; ALIGN ( -- ) \ CORE\r
+; Align the data space pointer.\r
+;\r
+; : ALIGN HERE ALIGNED TO HERE ;\r
+\r
+ $COLON 5,'ALIGN',ALIGNN,_FLINK\r
+ DW HERE,ALIGNED,DoTO,AddrHERE,EXIT\r
+\r
+; ALIGNED ( addr -- a-addr ) \ CORE\r
+; Align address to the cell boundary.\r
+;\r
+; : ALIGNED DUP 0 cell-size UM/MOD DROP DUP\r
+; IF cell-size SWAP - THEN + ; \ slow, very portable\r
+;\r
+; $COLON 7,'ALIGNED',ALIGNED,_FLINK\r
+; DW DUPP,Zero,DoLIT,CELLL\r
+; DW UMSlashMOD,DROP,DUPP\r
+; DW ZBranch,ALGN1\r
+; DW DoLIT,CELLL,SWAP,Minus\r
+; ALGN1 DW Plus,EXIT\r
+\r
+ $CODE 7,'ALIGNED',ALIGNED,_FLINK\r
+ INC BX\r
+ AND BX,0FFFEh\r
+ $NEXT\r
+\r
+; pack" is dependent of cell alignment.\r
+;\r
+; pack" ( c-addr u a-addr -- a-addr2 )\r
+; Place a string c-addr u at a-addr and gives the next\r
+; cell-aligned address. Fill the rest of the last cell with\r
+; null character.\r
+;\r
+; : pack" 2DUP SWAP CHARS + CHAR+ DUP >R \ ca u aa aa+u+1\r
+; 1 CHARS - 0 SWAP ! \ fill 0 at the end of string\r
+; 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u\r
+; CHARS MOVE R> ; COMPILE-ONLY\r
+\r
+ $COLON 5,'pack"',PackQuote,_SLINK\r
+ DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR\r
+ DW DoLIT,CHARR,Minus,Zero,SWAP,Store\r
+ DW TwoDUP,CStore,CHARPlus,SWAP\r
+ DW CHARS,MOVE,RFrom,EXIT\r
+\r
+; CELLS ( n1 -- n2 ) \ CORE\r
+; Calculate number of address units for n1 cells.\r
+;\r
+; : CELLS cell-size * ; \ slow, very portable\r
+; : CELLS 2* ; \ fast, must be redefined for each system\r
+\r
+ $COLON 5,'CELLS',CELLS,_FLINK\r
+ DW TwoStar,EXIT\r
+\r
+; CHARS ( n1 -- n2 ) \ CORE\r
+; Calculate number of address units for n1 characters.\r
+;\r
+; : CHARS char-size * ; \ slow, very portable\r
+; : CHARS ; \ fast, must be redefined for each system\r
+\r
+ $COLON 5,'CHARS',CHARS,_FLINK\r
+ DW EXIT\r
+\r
+; ! ( x a-addr -- ) \ CORE\r
+; Store x at a aligned address.\r
+\r
+ $CODE 1,'!',Store,_FLINK\r
+ POP [BX]\r
+ POP BX\r
+ $NEXT\r
+\r
+; 0< ( n -- flag ) \ CORE\r
+; Return true if n is negative.\r
+\r
+ $CODE 2,'0<',ZeroLess,_FLINK\r
+ MOV AX,BX\r
+ CWD ;sign extend\r
+ MOV BX,DX\r
+ $NEXT\r
+\r
+; 0= ( x -- flag ) \ CORE\r
+; Return true if x is zero.\r
+\r
+ $CODE 2,'0=',ZeroEquals,_FLINK\r
+ OR BX,BX\r
+ MOV BX,TRUEE\r
+ JZ ZEQUAL1\r
+ INC BX\r
+ZEQUAL1: $NEXT\r
+\r
+; 2* ( x1 -- x2 ) \ CORE\r
+; Bit-shift left, filling the least significant bit with 0.\r
+\r
+ $CODE 2,'2*',TwoStar,_FLINK\r
+ SHL BX,1\r
+ $NEXT\r
+\r
+; 2/ ( x1 -- x2 ) \ CORE\r
+; Bit-shift right, leaving the most significant bit unchanged.\r
+\r
+ $CODE 2,'2/',TwoSlash,_FLINK\r
+ SAR BX,1\r
+ $NEXT\r
+\r
+; >R ( x -- ) ( R: -- x ) \ CORE\r
+; Move top of the data stack item to the return stack.\r
+\r
+ $CODE COMPO+2,'>R',ToR,_FLINK\r
+ SUB BP,CELLL ;adjust RP\r
+ MOV [BP],BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; @ ( a-addr -- x ) \ CORE\r
+; Push the contents at a-addr to the data stack.\r
+\r
+ $CODE 1,'@',Fetch,_FLINK\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; AND ( x1 x2 -- x3 ) \ CORE\r
+; Bitwise AND.\r
+\r
+ $CODE 3,'AND',ANDD,_FLINK\r
+ POP AX\r
+ AND BX,AX\r
+ $NEXT\r
+\r
+; C! ( char c-addr -- ) \ CORE\r
+; Store char at c-addr.\r
+\r
+ $CODE 2,'C!',CStore,_FLINK\r
+ POP AX\r
+ MOV [BX],AL\r
+ POP BX\r
+ $NEXT\r
+\r
+; C@ ( c-addr -- char ) \ CORE\r
+; Fetch the character stored at c-addr.\r
+\r
+ $CODE 2,'C@',CFetch,_FLINK\r
+ MOV BL,[BX]\r
+ XOR BH,BH\r
+ $NEXT\r
+\r
+; DROP ( x -- ) \ CORE\r
+; Discard top stack item.\r
+\r
+ $CODE 4,'DROP',DROP,_FLINK\r
+ POP BX\r
+ $NEXT\r
+\r
+; DUP ( x -- x x ) \ CORE\r
+; Duplicate the top stack item.\r
+\r
+ $CODE 3,'DUP',DUPP,_FLINK\r
+ PUSH BX\r
+ $NEXT\r
+\r
+; EXECUTE ( i*x xt -- j*x ) \ CORE\r
+; Perform the semantics indentified by execution token, xt.\r
+\r
+ $CODE 7,'EXECUTE',EXECUTE,_FLINK\r
+ MOV AX,BX\r
+ POP BX\r
+ JMP AX ;jump to the code address\r
+ $ALIGN\r
+\r
+; EXIT ( -- ) ( R: nest-sys -- ) \ CORE\r
+; Return control to the calling definition.\r
+\r
+ $CODE COMPO+4,'EXIT',EXIT,_FLINK\r
+ XCHG BP,SP ;exchange pointers\r
+ POP SI ;pop return stack\r
+ XCHG BP,SP ;restore the pointers\r
+ $NEXT\r
+\r
+; MOVE ( addr1 addr2 u -- ) \ CORE\r
+; Copy u address units from addr1 to addr2 if u is greater\r
+; than zero. This word is CODE defined since no other Standard\r
+; words can handle address unit directly.\r
+\r
+ $CODE 4,'MOVE',MOVE,_FLINK\r
+ POP DI\r
+ POP DX\r
+ OR BX,BX\r
+ JZ MOVE2\r
+ MOV CX,BX\r
+ XCHG DX,SI ;save SI\r
+ MOV AX,DS\r
+ MOV ES,AX ;set ES same as DS\r
+ CMP SI,DI\r
+ JC MOVE1\r
+ REP MOVSB\r
+ MOV SI,DX\r
+MOVE2: POP BX\r
+ $NEXT\r
+MOVE1: STD\r
+ ADD DI,CX\r
+ DEC DI\r
+ ADD SI,CX\r
+ DEC SI\r
+ REP MOVSB\r
+ CLD\r
+ MOV SI,DX\r
+ POP BX\r
+ $NEXT\r
+\r
+; OR ( x1 x2 -- x3 ) \ CORE\r
+; Return bitwise inclusive-or of x1 with x2.\r
+\r
+ $CODE 2,'OR',ORR,_FLINK\r
+ POP AX\r
+ OR BX,AX\r
+ $NEXT\r
+\r
+; OVER ( x1 x2 -- x1 x2 x1 ) \ CORE\r
+; Copy second stack item to top of the stack.\r
+\r
+ $CODE 4,'OVER',OVER,_FLINK\r
+ MOV DI,SP\r
+ PUSH BX\r
+ MOV BX,[DI]\r
+ $NEXT\r
+\r
+; R> ( -- x ) ( R: x -- ) \ CORE\r
+; Move x from the return stack to the data stack.\r
+\r
+ $CODE COMPO+2,'R>',RFrom,_FLINK\r
+ PUSH BX\r
+ MOV BX,[BP]\r
+ ADD BP,CELLL ;adjust RP\r
+ $NEXT\r
+\r
+; R@ ( -- x ) ( R: x -- x ) \ CORE\r
+; Copy top of return stack to the data stack.\r
+\r
+ $CODE COMPO+2,'R@',RFetch,_FLINK\r
+ PUSH BX\r
+ MOV BX,[BP]\r
+ $NEXT\r
+\r
+; SWAP ( x1 x2 -- x2 x1 ) \ CORE\r
+; Exchange top two stack items.\r
+\r
+ $CODE 4,'SWAP',SWAP,_FLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ $NEXT\r
+\r
+; XOR ( x1 x2 -- x3 ) \ CORE\r
+; Bitwise exclusive OR.\r
+\r
+ $CODE 3,'XOR',XORR,_FLINK\r
+ POP AX\r
+ XOR BX,AX\r
+ $NEXT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; System constants and variables\r
+;;;;;;;;;;;;;;;;\r
+\r
+; #order0 ( -- a-addr )\r
+; Start address of default search order.\r
+\r
+ $CONST 7,'#order0',NumberOrder0,AddrNumberOrder0,_SLINK\r
+\r
+; 'ekey? ( -- a-addr )\r
+; Execution vector of EKEY?.\r
+\r
+ $VALUE 6,"'ekey?",TickEKEYQ,ValueTickEKEYQ,_SLINK\r
+\r
+; 'ekey ( -- a-addr )\r
+; Execution vector of EKEY.\r
+\r
+ $VALUE 5,"'ekey",TickEKEY,ValueTickEKEY,_SLINK\r
+\r
+; 'emit? ( -- a-addr )\r
+; Execution vector of EMIT?.\r
+\r
+ $VALUE 6,"'emit?",TickEMITQ,ValueTickEMITQ,_SLINK\r
+\r
+; 'emit ( -- a-addr )\r
+; Execution vector of EMIT.\r
+\r
+ $VALUE 5,"'emit",TickEMIT,ValueTickEMIT,_SLINK\r
+\r
+; 'init-i/o ( -- a-addr )\r
+; Execution vector to initialize input/output devices.\r
+\r
+ $VALUE 9,"'init-i/o",TickINIT_IO,ValueTickINIT_IO,_SLINK\r
+\r
+; 'prompt ( -- a-addr )\r
+; Execution vector of '.prompt'.\r
+\r
+ $VALUE 7,"'prompt",TickPrompt,ValueTickPrompt,_SLINK\r
+\r
+; 'boot ( -- a-addr )\r
+; Execution vector of COLD.\r
+\r
+ $VALUE 5,"'boot",TickBoot,ValueTickBoot,_SLINK\r
+\r
+; SOURCE-ID ( -- 0 | -1 ) \ CORE EXT\r
+; Identify the input source. -1 for string (via EVALUATE) and\r
+; 0 for user input device.\r
+\r
+ $VALUE 9,'SOURCE-ID',SOURCE_ID,ValueSOURCE_ID,_FLINK\r
+AddrSOURCE_ID EQU $-CELLL\r
+\r
+; HERE ( -- addr ) \ CORE\r
+; Return data space pointer.\r
+\r
+ $VALUE 4,'HERE',HERE,ValueHERE,_FLINK\r
+AddrHERE EQU $-CELLL\r
+\r
+; 'doWord ( -- a-addr )\r
+; Execution vectors for 'interpret'.\r
+\r
+ $CONST 7,"'doWord",TickDoWord,AddrTickDoWord,_SLINK\r
+\r
+; BASE ( -- a-addr ) \ CORE\r
+; Return the address of the radix base for numeric I/O.\r
+\r
+ $CONST 4,'BASE',BASE,AddrBASE,_FLINK\r
+\r
+; THROWMsgTbl ( -- a-addr ) \ CORE\r
+; Return the address of the THROW message table.\r
+\r
+ $CONST 11,'THROWMsgTbl',THROWMsgTbl,AddrTHROWMsgTbl,_SLINK\r
+\r
+; memTop ( -- a-addr )\r
+; Top of free RAM area.\r
+\r
+ $VALUE 6,'memTop',MemTop,?,_SLINK\r
+AddrMemTop EQU $-CELLL\r
+\r
+; bal ( -- n )\r
+; Return the depth of control-flow stack.\r
+\r
+ $VALUE 3,'bal',Bal,?,_SLINK\r
+AddrBal EQU $-CELLL\r
+\r
+; notNONAME? ( -- f )\r
+; Used by ';' whether to do 'linkLast' or not\r
+\r
+ $VALUE 10,'notNONAME?',NotNONAMEQ,?,_SLINK\r
+AddrNotNONAMEQ EQU $-CELLL\r
+\r
+; rakeVar ( -- a-addr )\r
+; Used by 'rake' to gather LEAVE.\r
+\r
+ $CONST 7,'rakeVar',RakeVar,AddrRakeVar,_SLINK\r
+\r
+; #order ( -- a-addr )\r
+; Hold the search order stack depth.\r
+\r
+ $CONST 6,'#order',NumberOrder,AddrNumberOrder,_SLINK\r
+\r
+; current ( -- a-addr )\r
+; Point to the wordlist to be extended.\r
+\r
+ $CONST 7,'current',Current,AddrCurrent,_SLINK\r
+\r
+; FORTH-WORDLIST ( -- wid ) \ SEARCH\r
+; Return wid of Forth wordlist.\r
+\r
+ $CONST 14,'FORTH-WORDLIST',FORTH_WORDLIST,AddrFORTH_WORDLIST,_FLINK\r
+FORTH_WORDLISTName EQU _NAME-0\r
+\r
+; NONSTANDARD-WORDLIST ( -- wid )\r
+; Return wid of non-standard wordlist.\r
+\r
+ $CONST 20,'NONSTANDARD-WORDLIST',NONSTANDARD_WORDLIST,AddrNONSTANDARD_WORDLIST,_FLINK\r
+NONSTANDARD_WORDLISTName EQU _NAME-0\r
+\r
+; envQList ( -- wid )\r
+; Return wid of ENVIRONMENT? string list. Never put this wid in\r
+; search-order. It should be used only by SET-CURRENT to add new\r
+; environment query string after addition of a complete wordset.\r
+\r
+ $CONST 8,'envQList',EnvQList,AddrEnvQList,_SLINK\r
+\r
+; userP ( -- a-addr )\r
+; Return address of USER variable area of current task.\r
+\r
+ $CONST 5,'userP',UserP,AddrUserP,_SLINK\r
+\r
+; SystemTask ( -- a-addr )\r
+; Return system task's tid.\r
+\r
+ $CONST 10,'SystemTask',SystemTask,SysTask,_SLINK\r
+SystemTaskName EQU _NAME-0\r
+\r
+; follower ( -- a-addr )\r
+; Point next task's 'status' USER variable.\r
+\r
+ $USER 8,'follower',Follower,SysFollower-SysUserP,_SLINK\r
+\r
+; status ( -- a-addr )\r
+; Status of current task. Point 'pass' or 'wake'.\r
+\r
+ $USER 6,'status',Status,SysStatus-SysUserP,_SLINK\r
+\r
+; stackTop ( -- a-addr )\r
+; Store current task's top of stack position.\r
+\r
+ $USER 8,'stackTop',StackTop,SysStackTop-SysUserP,_SLINK\r
+\r
+; throwFrame ( -- a-addr )\r
+; THROW frame for CATCH and THROW need to be saved for eack task.\r
+\r
+ $USER 10,'throwFrame',ThrowFrame,SysThrowFrame-SysUserP,_SLINK\r
+\r
+; taskName ( -- a-addr )\r
+; Current task's task ID.\r
+\r
+ $USER 8,'taskName',TaskName,SysTaskName-SysUserP,_SLINK\r
+\r
+; user1 ( -- a-addr )\r
+; One free USER variable for each task.\r
+\r
+ $USER 5,'user1',User1,SysUser1-SysUserP,_SLINK\r
+\r
+; ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be\r
+; EXECUTEd. This wordlist is completely hidden to Forth system except\r
+; ENVIRONMENT? .\r
+\r
+ $ENVIR 3,'CPU'\r
+ DW DoLIT,CPUStr,COUNT,EXIT\r
+\r
+ $ENVIR 5,'model'\r
+ DW DoLIT,ModelStr,COUNT,EXIT\r
+\r
+ $ENVIR 7,'version'\r
+ DW DoLIT,VersionStr,COUNT,EXIT\r
+\r
+ $ENVIR 15,'/COUNTED-STRING'\r
+ DW DoLIT,MaxChar,EXIT\r
+\r
+ $ENVIR 5,'/HOLD'\r
+ DW DoLIT,PADSize,EXIT\r
+\r
+ $ENVIR 4,'/PAD'\r
+ DW DoLIT,PADSize,EXIT\r
+\r
+ $ENVIR 17,'ADDRESS-UNIT-BITS'\r
+ DW DoLIT,8,EXIT\r
+\r
+ $ENVIR 4,'CORE'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 7,'FLOORED'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 8,'MAX-CHAR'\r
+ DW DoLIT,MaxChar,EXIT ;max value of character set\r
+\r
+ $ENVIR 5,'MAX-D'\r
+ DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT\r
+\r
+ $ENVIR 5,'MAX-N'\r
+ DW DoLIT,MaxSigned,EXIT\r
+\r
+ $ENVIR 5,'MAX-U'\r
+ DW DoLIT,MaxUnsigned,EXIT\r
+\r
+ $ENVIR 6,'MAX-UD'\r
+ DW DoLIT,MaxUnsigned,DoLIT,MaxUnsigned,EXIT\r
+\r
+ $ENVIR 18,'RETURN-STACK-CELLS'\r
+ DW DoLIT,RTCells,EXIT\r
+\r
+ $ENVIR 11,'STACK-CELLS'\r
+ DW DoLIT,DTCells,EXIT\r
+\r
+ $ENVIR 9,'EXCEPTION'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 13,'EXCEPTION-EXT'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 9,'WORDLISTS'\r
+ DW DoLIT,OrderDepth,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Non-Standard words - Colon definitions\r
+;;;;;;;;;;;;;;;;\r
+\r
+; (') ( "<spaces>name" -- xt 1 | xt -1 )\r
+; Parse a name, find it and return execution token and\r
+; -1 or 1 ( IMMEDIATE) if found\r
+;\r
+; : (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN\r
+; errWord 2! \ if not found error\r
+; -13 THROW ; \ undefined word\r
+\r
+ $COLON 3,"(')",ParenTick,_SLINK\r
+ DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1\r
+ DW NIP,EXIT\r
+PTICK1 DW ErrWord,TwoStore,DoLIT,-13,THROW\r
+\r
+; (d.) ( d -- c-addr u )\r
+; Convert a double number to a string.\r
+;\r
+; : (d.) SWAP OVER DUP 0< IF DNEGATE THEN\r
+; <# #S ROT SIGN #> ;\r
+\r
+ $COLON 4,'(d.)',ParenDDot,_SLINK\r
+ DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1\r
+ DW DNEGATE\r
+PARDD1 DW LessNumberSign,NumberSignS,ROT\r
+ DW SIGN,NumberSignGreater,EXIT\r
+\r
+; .ok ( -- )\r
+; Display 'ok'.\r
+;\r
+; : .ok ." ok" ;\r
+\r
+ $COLON 3,'.ok',DotOK,_SLINK\r
+ $INSTR 'ok'\r
+ DW TYPEE,EXIT\r
+\r
+; .prompt ( -- )\r
+; Disply Forth prompt. This word is vectored.\r
+;\r
+; : .prompt 'prompt EXECUTE ;\r
+\r
+ $COLON 7,'.prompt',DotPrompt,_SLINK\r
+ DW TickPrompt,EXECUTE,EXIT\r
+\r
+; 0 ( -- 0 )\r
+; Return zero.\r
+\r
+ $CONST 1,'0',Zero,0,_SLINK\r
+\r
+; 1 ( -- 1 )\r
+; Return one.\r
+\r
+ $CONST 1,'1',One,1,_SLINK\r
+\r
+; -1 ( -- -1 )\r
+; Return -1.\r
+\r
+ $CONST 2,'-1',MinusOne,-1,_SLINK\r
+\r
+; abort"msg ( -- a-addr )\r
+; Abort" error message string address.\r
+\r
+ $VAR 9,'abort"msg',AbortQMsg,2,_SLINK\r
+\r
+; bal+ ( -- )\r
+; Increase bal by 1.\r
+;\r
+; : bal+ bal 1+ TO bal ;\r
+\r
+ $COLON 4,'bal+',BalPlus,_SLINK\r
+ DW Bal,OnePlus,DoTO,AddrBal,EXIT\r
+\r
+; bal- ( -- )\r
+; Decrease bal by 1.\r
+;\r
+; : bal- bal 1- TO bal ;\r
+\r
+ $COLON 4,'bal-',BalMinus,_SLINK\r
+ DW Bal,OneMinus,DoTO,AddrBal,EXIT\r
+\r
+; cell- ( a-addr1 -- a-addr2 )\r
+; Return previous aligned cell address.\r
+;\r
+; : cell- -(cell-size) + ;\r
+\r
+ $COLON 5,'cell-',CellMinus,_SLINK\r
+ DW DoLIT,0-CELLL,Plus,EXIT\r
+\r
+; COMPILE-ONLY ( -- )\r
+; Make the most recent definition an compile-only word.\r
+;\r
+; : COMPILE-ONLY lastName [ =comp ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON 12,'COMPILE-ONLY',COMPILE_ONLY,_SLINK\r
+ DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; doS" ( u -- c-addr u )\r
+; Run-time function of S" .\r
+;\r
+; : doS" R> SWAP 2DUP + ALIGNED >R ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+4,'doS"',DoSQuote,_SLINK\r
+ DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT\r
+\r
+; doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )\r
+; Run-time funtion of DO.\r
+;\r
+; : doDO >R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;\r
+\r
+ $COLON COMPO+4,'doDO',DoDO,_SLINK\r
+ DW ToR,DoLIT,MaxNegative,Plus,RFrom\r
+ DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT\r
+\r
+; errWord ( -- a-addr )\r
+; Last found word. To be used to display the word causing error.\r
+\r
+ $VAR 7,'errWord',ErrWord,2,_SLINK\r
+\r
+; head, ( "<spaces>name" -- )\r
+; Parse a word and build a dictionary entry using a name.\r
+;\r
+; : head, PARSE-WORD DUP 0=\r
+; IF errWord 2! -16 THROW THEN\r
+; \ attempt to use zero-length string as a name\r
+; DUP =mask > IF -19 THROW THEN \ definition name too long\r
+; 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?\r
+; IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined\r
+; HERE ALIGNED TO HERE \ align\r
+; GET-CURRENT @ , \ build wordlist link\r
+; HERE DUP >R pack" TO HERE R> \ pack the name in dictionary\r
+; DUP , TO lastName ;\r
+\r
+ $COLON 5,'head,',HeadComma,_SLINK\r
+ DW PARSE_WORD,DUPP,ZBranch,HEADC1\r
+ DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3\r
+ DW DoLIT,-19,THROW\r
+HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2\r
+ DW DROP\r
+ $INSTR 'redefine '\r
+ DW TYPEE,TwoDUP,TYPEE,SPACE\r
+HEADC2 DW HERE,ALIGNED,DoTO,AddrHERE\r
+ DW GET_CURRENT,Fetch,Comma\r
+ DW HERE,DUPP,ToR,PackQuote,DoTO,AddrHERE,RFrom\r
+ DW DUPP,Comma,DoTO,AddrLastName,EXIT\r
+HEADC1 DW ErrWord,TwoStore,DoLIT,-16,THROW\r
+\r
+; hld ( -- a-addr )\r
+; Hold a pointer in building a numeric output string.\r
+\r
+ $VAR 3,'hld',HLD,1,_SLINK\r
+\r
+; interpret ( i*x -- j*x )\r
+; Intrepret input string.\r
+;\r
+; : interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow\r
+; PARSE-WORD DUP\r
+; WHILE 2DUP errWord 2!\r
+; search-word \ ca u 0 | xt f -1 | xt f 1\r
+; DUP IF\r
+; SWAP STATE @ OR 0= \ compile-only in interpretation\r
+; IF -14 THROW THEN \ interpreting a compile-only word\r
+; THEN\r
+; 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE\r
+; REPEAT 2DROP ;\r
+\r
+ $COLON 9,'interpret',Interpret,_SLINK\r
+INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2\r
+ DW DoLIT,-4,THROW\r
+INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3\r
+ DW TwoDUP,ErrWord,TwoStore\r
+ DW Search_word,DUPP,ZBranch,INTERP5\r
+ DW SWAP,STATE,Fetch,ORR,ZBranch,INTERP4\r
+INTERP5 DW OnePlus,TwoStar,STATE,Fetch,OnePlus,Plus,CELLS\r
+ DW TickDoWord,Plus,Fetch,EXECUTE\r
+ DW Branch,INTERP1\r
+INTERP3 DW TwoDROP,EXIT\r
+INTERP4 DW DoLIT,-14,THROW\r
+\r
+; optiCOMPILE, ( xt -- )\r
+; Optimized COMPILE, . Reduce doLIST ... EXIT sequence if\r
+; xt is COLON definition which contains less than two words.\r
+;\r
+; : optiCOMPILE,\r
+; DUP ?call ['] doLIST = IF\r
+; DUP @ ['] EXIT = IF \ if first word is EXIT\r
+; 2DROP EXIT THEN\r
+; DUP CELL+ @ ['] EXIT = IF \ if second word is EXIT\r
+; @ DUP ['] doLIT XOR \ make sure it is not literal value\r
+; IF SWAP THEN THEN\r
+; THEN THEN DROP COMPILE, ;\r
+\r
+ $COLON 12,'optiCOMPILE,',OptiCOMPILEComma,_SLINK\r
+ DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2\r
+ DW DUPP,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC1\r
+ DW TwoDROP,EXIT\r
+OPTC1 DW DUPP,CELLPlus,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC2\r
+ DW Fetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2\r
+ DW SWAP\r
+OPTC2 DW DROP,COMPILEComma,EXIT\r
+\r
+; singleOnly ( c-addr u -- x )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, leave a single cell number in interpretation state.\r
+;\r
+; : singleOnly\r
+; 0 DUP 2SWAP OVER C@ [CHAR] -\r
+; = DUP >R IF 1 /STRING THEN\r
+; >NUMBER IF -13 THROW THEN \ undefined word\r
+; 2DROP R> IF NEGATE THEN ;\r
+\r
+ $COLON 10,'singleOnly',SingleOnly,_SLINK\r
+ DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+ DW Equals,DUPP,ToR,ZBranch,SINGLEO4\r
+ DW One,SlashSTRING\r
+SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1\r
+ DW DoLIT,-13,THROW\r
+SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2\r
+ DW NEGATE\r
+SINGLEO2 DW EXIT\r
+\r
+; singleOnly, ( c-addr u -- )\r
+; Handle the word not found in the search-order. Compile a\r
+; single cell number in compilation state.\r
+;\r
+; : singleOnly,\r
+; singleOnly LITERAL ;\r
+\r
+ $COLON 11,'singleOnly,',SingleOnlyComma,_SLINK\r
+ DW SingleOnly,LITERAL,EXIT\r
+\r
+; (doubleAlso) ( c-addr u -- x 1 | x x 2 )\r
+; If the string is legal, leave a single or double cell number\r
+; and size of the number.\r
+;\r
+; : (doubleAlso)\r
+; 0 DUP 2SWAP OVER C@ [CHAR] -\r
+; = DUP >R IF 1 /STRING THEN\r
+; >NUMBER ?DUP\r
+; IF 1- IF -13 THROW THEN \ more than one char is remained\r
+; DUP C@ [CHAR] . XOR \ last char is not '.'\r
+; IF -13 THROW THEN \ undefined word\r
+; R> IF DNEGATE THEN\r
+; 2 EXIT THEN\r
+; 2DROP R> IF NEGATE THEN \ single number\r
+; 1 ;\r
+\r
+ $COLON 12,'(doubleAlso)',ParenDoubleAlso,_SLINK\r
+ DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+ DW Equals,DUPP,ToR,ZBranch,DOUBLEA1\r
+ DW One,SlashSTRING\r
+DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4\r
+ DW OneMinus,ZBranch,DOUBLEA3\r
+DOUBLEA2 DW DoLIT,-13,THROW\r
+DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2\r
+ DW RFrom,ZBranch,DOUBLEA5\r
+ DW DNEGATE\r
+DOUBLEA5 DW DoLIT,2,EXIT\r
+DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6\r
+ DW NEGATE\r
+DOUBLEA6 DW One,EXIT\r
+\r
+; doubleAlso ( c-addr u -- x | x x )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, leave a single or double cell number in\r
+; interpretation state.\r
+;\r
+; : doubleAlso\r
+; (doubleAlso) DROP ;\r
+\r
+ $COLON 10,'doubleAlso',DoubleAlso,_SLINK\r
+ DW ParenDoubleAlso,DROP,EXIT\r
+\r
+; doubleAlso, ( c-addr u -- )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, compile a single or double cell number in\r
+; compilation state.\r
+;\r
+; : doubleAlso,\r
+; (doubleAlso) 1- IF SWAP LITERAL THEN LITERAL ;\r
+\r
+ $COLON 11,'doubleAlso,',DoubleAlsoComma,_SLINK\r
+ DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1\r
+ DW SWAP,LITERAL\r
+DOUBC1 DW LITERAL,EXIT\r
+\r
+; -. ( -- )\r
+; You don't need this word unless you care that '-.' returns\r
+; double cell number 0. Catching illegal number '-.' in this way\r
+; is easier than make 'interpret' catch this exception.\r
+;\r
+; : -. -13 THROW ; IMMEDIATE \ undefined word\r
+\r
+ $COLON IMMED+2,'-.',MinusDot,_SLINK\r
+ DW DoLIT,-13,THROW\r
+\r
+; lastName ( -- c-addr )\r
+; Return the address of the last definition name.\r
+\r
+ $VALUE 8,'lastName',LastName,?,_SLINK\r
+AddrLastName EQU $-CELLL\r
+\r
+; linkLast ( -- )\r
+; Link the word being defined to the current wordlist.\r
+; Do nothing if the last definition is made by :NONAME .\r
+;\r
+; : linkLast lastName GET-CURRENT ! ;\r
+\r
+ $COLON 8,'linkLast',LinkLast,_SLINK\r
+ DW LastName,GET_CURRENT,Store,EXIT\r
+\r
+; name>xt ( c-addr -- xt )\r
+; Return execution token using counted string at c-addr.\r
+;\r
+; : name>xt COUNT [ =MASK ] LITERAL AND + ALIGNED CELL+ ;\r
+\r
+ $COLON 7,'name>xt',NameToXT,_SLINK\r
+ DW COUNT,DoLIT,MASKK,ANDD,Plus,ALIGNED,CELLPlus,EXIT\r
+\r
+; PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )\r
+; Skip leading spaces and parse a word. Return the name.\r
+;\r
+; : PARSE-WORD BL skipPARSE ;\r
+\r
+ $COLON 10,'PARSE-WORD',PARSE_WORD,_SLINK\r
+ DW BLank,SkipPARSE,EXIT\r
+\r
+; pipe ( -- ) ( R: xt -- )\r
+; Connect most recently defined word to code following DOES>.\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | >BODY points here\r
+;\r
+; : pipe lastName name>xt ?call DUP IF \ code-addr xt2\r
+; ['] doCREATE = IF\r
+; R> SWAP ! \ change DOES> code of CREATEd word\r
+; EXIT\r
+; THEN THEN\r
+; -32 THROW \ invalid name argument, no-CREATEd last name\r
+; ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+4,'pipe',Pipe,_SLINK\r
+ DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1\r
+ DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1\r
+ DW RFrom,SWAP,Store,EXIT\r
+PIPE1 DW DoLIT,-32,THROW\r
+\r
+; skipPARSE ( char "<chars>ccc<char>" -- c-addr u )\r
+; Skip leading chars and parse a word using char as a\r
+; delimeter. Return the name.\r
+;\r
+; : skipPARSE\r
+; >R SOURCE >IN @ /STRING \ c_addr u R: char\r
+; DUP IF\r
+; BEGIN OVER C@ R@ =\r
+; WHILE 1- SWAP CHAR+ SWAP DUP 0=\r
+; UNTIL R> DROP EXIT\r
+; ELSE THEN\r
+; DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT\r
+; THEN R> DROP ;\r
+\r
+ $COLON 9,'skipPARSE',SkipPARSE,_SLINK\r
+ DW ToR,SOURCE,ToIN,Fetch,SlashSTRING\r
+ DW DUPP,ZBranch,SKPAR1\r
+SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3\r
+ DW OneMinus,SWAP,CHARPlus,SWAP\r
+ DW DUPP,ZeroEquals,ZBranch,SKPAR2\r
+ DW RFrom,DROP,EXIT\r
+SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash\r
+ DW ToIN,Store,RFrom,PARSE,EXIT\r
+SKPAR1 DW RFrom,DROP,EXIT\r
+\r
+; rake ( C: do-sys -- )\r
+; Gathers LEAVEs.\r
+;\r
+; : rake DUP , rakeVar @\r
+; BEGIN 2DUP U<\r
+; WHILE DUP @ HERE ROT !\r
+; REPEAT rakeVar ! DROP\r
+; ?DUP IF \ check for ?DO\r
+; 1 bal+ POSTPONE THEN \ orig type is 1\r
+; THEN bal- ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+4,'rake',rake,_SLINK\r
+ DW DUPP,Comma,RakeVar,Fetch\r
+RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2\r
+ DW DUPP,Fetch,HERE,ROT,Store,Branch,RAKE1\r
+RAKE2 DW RakeVar,Store,DROP\r
+ DW QuestionDUP,ZBranch,RAKE3\r
+ DW One,BalPlus,THENN\r
+RAKE3 DW BalMinus,EXIT\r
+\r
+; rp0 ( -- a-addr )\r
+; Pointer to bottom of the return stack.\r
+;\r
+; : rp0 userP @ CELL+ CELL+ @ ;\r
+\r
+ $COLON 3,'rp0',RPZero,_SLINK\r
+ DW UserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT\r
+\r
+; search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)\r
+; Search dictionary for a match with the given name. Return\r
+; execution token, not-compile-only flag and -1 or 1\r
+; ( IMMEDIATE) if found; c-addr u 0 if not.\r
+;\r
+; : search-word\r
+; #order @ DUP \ not found if #order is 0\r
+; IF 0\r
+; DO 2DUP \ ca u ca u\r
+; I CELLS #order CELL+ + @ \ ca u ca u wid\r
+; (search-wordlist) \ ca u; 0 | w f 1 | w f -1\r
+; ?DUP IF \ ca u; 0 | w f 1 | w f -1\r
+; >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1\r
+; THEN \ ca u\r
+; LOOP 0 \ ca u 0\r
+; THEN ;\r
+\r
+ $COLON 11,'search-word',Search_word,_SLINK\r
+ DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1\r
+ DW Zero,DoDO\r
+SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch\r
+ DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3\r
+ DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT\r
+SEARCH3 DW DoLOOP,SEARCH2\r
+ DW Zero\r
+SEARCH1 DW EXIT\r
+\r
+; sourceVar ( -- a-addr )\r
+; Hold the current count and address of the terminal input buffer.\r
+\r
+ $VAR 9,'sourceVar',SourceVar,2,_SLINK\r
+\r
+; sp0 ( -- a-addr )\r
+; Pointer to bottom of the data stack.\r
+;\r
+; : sp0 userP @ CELL+ @ ;\r
+\r
+ $COLON 3,'sp0',SPZero,_SLINK\r
+ DW UserP,Fetch,CELLPlus,Fetch,EXIT\r
+\r
+;\r
+; Words for multitasking\r
+;\r
+\r
+; PAUSE ( -- )\r
+; Stop current task and transfer control to the task of which\r
+; 'status' USER variable is stored in 'follower' USER variable\r
+; of current task.\r
+;\r
+; : PAUSE rp@ sp@ stackTop ! follower @ >R ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+5,'PAUSE',PAUSE,_SLINK\r
+ DW RPFetch,SPFetch,StackTop,Store,Follower,Fetch,ToR,EXIT\r
+\r
+; wake ( -- )\r
+; Wake current task.\r
+;\r
+; : wake R> userP ! \ userP points 'follower' of current task\r
+; stackTop @ sp! \ set data stack\r
+; rp! ; COMPILE-ONLY \ set return stack\r
+\r
+ $COLON COMPO+4,'wake',Wake,_SLINK\r
+ DW RFrom,UserP,Store,StackTop,Fetch,SPStore,RPStore,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Essential Standard words - Colon definitions\r
+;;;;;;;;;;;;;;;;\r
+\r
+; # ( ud1 -- ud2 ) \ CORE\r
+; Extract one digit from ud1 and append the digit to\r
+; pictured numeric output string. ( ud2 = ud1 / BASE )\r
+;\r
+; : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP\r
+; 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +\r
+; [ CHAR 0 ] LITERAL + HOLD R> ;\r
+\r
+ $COLON 1,'#',NumberSign,_FLINK\r
+ DW Zero,BASE,Fetch,UMSlashMOD,ToR,BASE,Fetch,UMSlashMOD\r
+ DW SWAP,DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus\r
+ DW DoLIT,'0',Plus,HOLD,RFrom,EXIT\r
+\r
+; #> ( xd -- c-addr u ) \ CORE\r
+; Prepare the output string to be TYPE'd.\r
+; ||HERE>WORD/#-work-area|\r
+;\r
+; : #> 2DROP hld @ HERE size-of-PAD + OVER - 1chars/ ;\r
+\r
+ $COLON 2,'#>',NumberSignGreater,_FLINK\r
+ DW TwoDROP,HLD,Fetch,HERE,DoLIT,PADSize*CHARR,Plus\r
+ DW OVER,Minus,OneCharsSlash,EXIT\r
+\r
+; #S ( ud -- 0 0 ) \ CORE\r
+; Convert ud until all digits are added to the output string.\r
+;\r
+; : #S BEGIN # 2DUP OR 0= UNTIL ;\r
+\r
+ $COLON 2,'#S',NumberSignS,_FLINK\r
+NUMSS1 DW NumberSign,TwoDUP,ORR\r
+ DW ZeroEquals,ZBranch,NUMSS1\r
+ DW EXIT\r
+\r
+; ' ( "<spaces>name" -- xt ) \ CORE\r
+; Parse a name, find it and return xt.\r
+;\r
+; : ' (') DROP ;\r
+\r
+ $COLON 1,"'",Tick,_FLINK\r
+ DW ParenTick,DROP,EXIT\r
+\r
+; + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Add top two items and gives the sum.\r
+;\r
+; : + um+ DROP ;\r
+\r
+ $COLON 1,'+',Plus,_FLINK\r
+ DW UMPlus,DROP,EXIT\r
+\r
+; +! ( n|u a-addr -- ) \ CORE\r
+; Add n|u to the contents at a-addr.\r
+;\r
+; : +! SWAP OVER @ + SWAP ! ;\r
+\r
+ $COLON 2,'+!',PlusStore,_FLINK\r
+ DW SWAP,OVER,Fetch,Plus\r
+ DW SWAP,Store,EXIT\r
+\r
+; , ( x -- ) \ CORE\r
+; Reserve one cell in data space and store x in it.\r
+;\r
+; : , HERE DUP CELL+ TO HERE ! ;\r
+\r
+ $COLON 1,',',Comma,_FLINK\r
+ DW HERE,DUPP,CELLPlus,DoTO,AddrHERE,Store,EXIT\r
+\r
+; - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Subtract n2|u2 from n1|u1, giving the difference n3|u3.\r
+;\r
+; : - NEGATE + ;\r
+\r
+ $COLON 1,'-',Minus,_FLINK\r
+ DW NEGATE,Plus,EXIT\r
+\r
+; . ( n -- ) \ CORE\r
+; Display a signed number followed by a space.\r
+;\r
+; : . S>D D. ;\r
+\r
+ $COLON 1,'.',Dot,_FLINK\r
+ DW SToD,DDot,EXIT\r
+\r
+; / ( n1 n2 -- n3 ) \ CORE\r
+; Divide n1 by n2, giving single-cell quotient n3.\r
+;\r
+; : / /MOD NIP ;\r
+\r
+ $COLON 1,'/',Slash,_FLINK\r
+ DW SlashMOD,NIP,EXIT\r
+\r
+; /MOD ( n1 n2 -- n3 n4 ) \ CORE\r
+; Divide n1 by n2, giving single-cell remainder n3 and\r
+; single-cell quotient n4.\r
+;\r
+; : /MOD >R S>D R> FM/MOD ;\r
+\r
+ $COLON 4,'/MOD',SlashMOD,_FLINK\r
+ DW ToR,SToD,RFrom,FMSlashMOD,EXIT\r
+\r
+; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING\r
+; Adjust the char string at c-addr1 by n chars.\r
+;\r
+; : /STRING DUP >R - SWAP R> CHARS + SWAP ;\r
+\r
+ $COLON 7,'/STRING',SlashSTRING,_FLINK\r
+ DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT\r
+\r
+; 1+ ( n1|u1 -- n2|u2 ) \ CORE\r
+; Increase top of the stack item by 1.\r
+;\r
+; : 1+ 1 + ;\r
+\r
+ $COLON 2,'1+',OnePlus,_FLINK\r
+ DW One,Plus,EXIT\r
+\r
+; 1- ( n1|u1 -- n2|u2 ) \ CORE\r
+; Decrease top of the stack item by 1.\r
+;\r
+; : 1- -1 + ;\r
+\r
+ $COLON 2,'1-',OneMinus,_FLINK\r
+ DW MinusOne,Plus,EXIT\r
+\r
+; 2! ( x1 x2 a-addr -- ) \ CORE\r
+; Store the cell pare x1 x2 at a-addr, with x2 at a-addr and\r
+; x1 at the next consecutive cell.\r
+;\r
+; : 2! SWAP OVER ! CELL+ ! ;\r
+\r
+ $COLON 2,'2!',TwoStore,_FLINK\r
+ DW SWAP,OVER,Store,CELLPlus,Store,EXIT\r
+\r
+; 2@ ( a-addr -- x1 x2 ) \ CORE\r
+; Fetch the cell pair stored at a-addr. x2 is stored at a-addr\r
+; and x1 at the next consecutive cell.\r
+;\r
+; : 2@ DUP CELL+ @ SWAP @ ;\r
+\r
+ $COLON 2,'2@',TwoFetch,_FLINK\r
+ DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT\r
+\r
+; 2DROP ( x1 x2 -- ) \ CORE\r
+; Drop cell pair x1 x2 from the stack.\r
+\r
+ $COLON 5,'2DROP',TwoDROP,_FLINK\r
+ DW DROP,DROP,EXIT\r
+\r
+; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE\r
+; Duplicate cell pair x1 x2.\r
+\r
+ $COLON 4,'2DUP',TwoDUP,_FLINK\r
+ DW OVER,OVER,EXIT\r
+\r
+; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE\r
+; Exchange the top two cell pairs.\r
+;\r
+; : 2SWAP ROT >R ROT R> ;\r
+\r
+ $COLON 5,'2SWAP',TwoSWAP,_FLINK\r
+ DW ROT,ToR,ROT,RFrom,EXIT\r
+\r
+; : ( "<spaces>name" -- colon-sys ) \ CORE\r
+; Start a new colon definition using next word as its name.\r
+;\r
+; : : head, :NONAME ROT DROP -1 TO notNONAME? ;\r
+\r
+ $COLON 1,':',COLON,_FLINK\r
+ DW HeadComma,ColonNONAME,ROT,DROP\r
+ DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT\r
+\r
+; :NONAME ( -- xt colon-sys ) \ CORE EXT\r
+; Create an execution token xt, enter compilation state and\r
+; start the current definition.\r
+;\r
+; : :NONAME bal IF -29 THROW THEN \ compiler nesting\r
+; ['] doLIST xt, DUP -1\r
+; 0 TO notNONAME? 1 TO bal ] ;\r
+\r
+ $COLON 7,':NONAME',ColonNONAME,_FLINK\r
+ DW Bal,ZBranch,NONAME1\r
+ DW DoLIT,-29,THROW\r
+NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1\r
+ DW Zero,DoTO,AddrNotNONAMEQ\r
+ DW One,DoTO,AddrBal,RightBracket,EXIT\r
+\r
+; ; ( colon-sys -- ) \ CORE\r
+; Terminate a colon definition.\r
+;\r
+; : ; bal 1- IF -22 THROW THEN \ control structure mismatch\r
+; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+; notNONAME? IF \ if the last definition is not created by ':'\r
+; linkLast 0 TO notNONAME? \ link the word to wordlist\r
+; THEN POSTPONE EXIT \ add EXIT at the end of the definition\r
+; 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+1,';',Semicolon,_FLINK\r
+ DW Bal,OneMinus,ZBranch,SEMI1\r
+ DW DoLIT,-22,THROW\r
+SEMI1 DW NIP,OnePlus,ZBranch,SEMI2\r
+ DW DoLIT,-22,THROW\r
+SEMI2 DW NotNONAMEQ,ZBranch,SEMI3\r
+ DW LinkLast,Zero,DoTO,AddrNotNONAMEQ\r
+SEMI3 DW DoLIT,EXIT,COMPILEComma\r
+ DW Zero,DoTO,AddrBal,LeftBracket,EXIT\r
+\r
+; < ( n1 n2 -- flag ) \ CORE\r
+; Returns true if n1 is less than n2.\r
+;\r
+; : < 2DUP XOR 0< \ same sign?\r
+; IF DROP 0< EXIT THEN \ different signs, true if n1 <0\r
+; - 0< ; \ same signs, true if n1-n2 <0\r
+\r
+ $COLON 1,'<',LessThan,_FLINK\r
+ DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1\r
+ DW DROP,ZeroLess,EXIT\r
+LESS1 DW Minus,ZeroLess,EXIT\r
+\r
+; <# ( -- ) \ CORE\r
+; Initiate the numeric output conversion process.\r
+; ||HERE>WORD/#-work-area|\r
+;\r
+; : <# HERE size-of-PAD + hld ! ;\r
+\r
+ $COLON 2,'<#',LessNumberSign,_FLINK\r
+ DW HERE,DoLIT,PADSize*CHARR,Plus,HLD,Store,EXIT\r
+\r
+; = ( x1 x2 -- flag ) \ CORE\r
+; Return true if top two are equal.\r
+;\r
+; : = XORR 0= ;\r
+\r
+ $COLON 1,'=',Equals,_FLINK\r
+ DW XORR,ZeroEquals,EXIT\r
+\r
+; > ( n1 n2 -- flag ) \ CORE\r
+; Returns true if n1 is greater than n2.\r
+;\r
+; : > SWAP < ;\r
+\r
+ $COLON 1,'>',GreaterThan,_FLINK\r
+ DW SWAP,LessThan,EXIT\r
+\r
+; >IN ( -- a-addr )\r
+; Hold the character pointer while parsing input stream.\r
+\r
+ $VAR 3,'>IN',ToIN,1,_FLINK\r
+\r
+; >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE\r
+; Add number string's value to ud1. Leaves string of any\r
+; unconverted chars.\r
+;\r
+; : >NUMBER BEGIN DUP\r
+; WHILE >R DUP >R C@ \ ud char R: u c-addr\r
+; DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN\r
+; IF DROP R> R> EXIT THEN\r
+; [ CHAR 0 ] LITERAL - 9 OVER <\r
+; [ CHAR A CHAR 9 1 + - ] LITERAL AND -\r
+; DUP 0 BASE @ WITHIN\r
+; WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING\r
+; REPEAT DROP R> R>\r
+; THEN ;\r
+\r
+ $COLON 7,'>NUMBER',ToNUMBER,_FLINK\r
+TONUM1 DW DUPP,ZBranch,TONUM3\r
+ DW ToR,DUPP,ToR,CFetch,DUPP\r
+ DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2\r
+ DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan\r
+ DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP\r
+ DW Zero,BASE,Fetch,WITHIN,ZBranch,TONUM2\r
+ DW SWAP,BASE,Fetch,UMStar,DROP,ROT,BASE,Fetch\r
+ DW UMStar,DPlus,RFrom,RFrom,One,SlashSTRING\r
+ DW Branch,TONUM1\r
+TONUM2 DW DROP,RFrom,RFrom\r
+TONUM3 DW EXIT\r
+\r
+; ?DUP ( x -- x x | 0 ) \ CORE\r
+; Duplicate top of the stack if it is not zero.\r
+;\r
+; : ?DUP DUP IF DUP THEN ;\r
+\r
+ $COLON 4,'?DUP',QuestionDUP,_FLINK\r
+ DW DUPP,ZBranch,QDUP1\r
+ DW DUPP\r
+QDUP1 DW EXIT\r
+\r
+; ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT\r
+; Reset data stack and jump to QUIT.\r
+;\r
+; : ABORT -1 THROW ;\r
+\r
+ $COLON 5,'ABORT',ABORT,_FLINK\r
+ DW MinusOne,THROW\r
+\r
+; ACCEPT ( c-addr +n1 -- +n2 ) \ CORE\r
+; Accept a string of up to +n1 chars. Return with actual count.\r
+; Implementation-defined editing. Stops at EOL# .\r
+; Supports backspace and delete editing.\r
+;\r
+; : ACCEPT >R 0\r
+; BEGIN DUP R@ < \ ca n2 f R: n1\r
+; WHILE EKEY max-char AND\r
+; DUP BL <\r
+; IF DUP cr# = IF ROT 2DROP R> DROP EXIT THEN\r
+; DUP tab# =\r
+; IF DROP 2DUP + BL DUP EMIT SWAP C! 1+\r
+; ELSE DUP bsp# =\r
+; SWAP del# = OR\r
+; IF DROP DUP\r
+; \ discard the last char if not 1st char\r
+; IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN\r
+; THEN\r
+; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ THEN\r
+; THEN\r
+; REPEAT SWAP R> 2DROP ;\r
+\r
+ $COLON 6,'ACCEPT',ACCEPT,_FLINK\r
+ DW ToR,Zero\r
+ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5\r
+ DW EKEY,DoLIT,MaxChar,ANDD\r
+ DW DUPP,BLank,LessThan,ZBranch,ACCPT3\r
+ DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4\r
+ DW ROT,TwoDROP,RFrom,DROP,EXIT\r
+ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6\r
+ DW DROP,TwoDUP,Plus,BLank,DUPP,EMIT,SWAP,CStore,OnePlus\r
+ DW Branch,ACCPT1\r
+ACCPT6 DW DUPP,DoLIT,BKSPP,Equals\r
+ DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1\r
+ DW DUPP,ZBranch,ACCPT1\r
+ DW OneMinus,DoLIT,BKSPP,EMIT,BLank,EMIT,DoLIT,BKSPP,EMIT\r
+ DW Branch,ACCPT1\r
+ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore\r
+ DW OnePlus,Branch,ACCPT1\r
+ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT\r
+\r
+; AGAIN ( C: dest -- ) \ CORE EXT\r
+; Resolve backward reference dest. Typically used as\r
+; BEGIN ... AGAIN . Move control to the location specified by\r
+; dest on execution.\r
+;\r
+; : AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+; POSTPONE branch , bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'AGAIN',AGAIN,_FLINK\r
+ DW ZBranch,AGAIN1\r
+ DW DoLIT,-22,THROW\r
+AGAIN1 DW DoLIT,Branch,COMPILEComma,Comma,BalMinus,EXIT\r
+\r
+; AHEAD ( C: -- orig ) \ TOOLS EXT\r
+; Put the location of a new unresolved forward reference onto\r
+; control-flow stack.\r
+;\r
+; : AHEAD POSTPONE branch HERE 0 ,\r
+; 1 bal+ \ orig type is 1\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'AHEAD',AHEAD,_FLINK\r
+ DW DoLIT,Branch,COMPILEComma,HERE,Zero,Comma\r
+ DW One,BalPlus,EXIT\r
+\r
+; BL ( -- char ) \ CORE\r
+; Return the value of the blank character.\r
+;\r
+; : BL blank-char-value EXIT ;\r
+\r
+ $CONST 2,'BL',BLank,' ',_FLINK\r
+\r
+; CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION\r
+; Push an exception frame on the exception stack and then execute\r
+; the execution token xt in such a way that control can be\r
+; transferred to a point just after CATCH if THROW is executed\r
+; during the execution of xt.\r
+;\r
+; : CATCH sp@ >R throwFrame @ >R \ save error frame\r
+; rp@ throwFrame ! EXECUTE \ execute\r
+; R> throwFrame ! \ restore error frame\r
+; R> DROP 0 ; \ no error\r
+\r
+ $COLON 5,'CATCH',CATCH,_FLINK\r
+ DW SPFetch,ToR,ThrowFrame,Fetch,ToR\r
+ DW RPFetch,ThrowFrame,Store,EXECUTE\r
+ DW RFrom,ThrowFrame,Store\r
+ DW RFrom,DROP,Zero,EXIT\r
+\r
+; CELL+ ( a-addr1 -- a-addr2 ) \ CORE\r
+; Return next aligned cell address.\r
+;\r
+; : CELL+ cell-size + ;\r
+\r
+ $COLON 5,'CELL+',CELLPlus,_FLINK\r
+ DW DoLIT,CELLL,Plus,EXIT\r
+\r
+; CHAR+ ( c-addr1 -- c-addr2 ) \ CORE\r
+; Returns next character-aligned address.\r
+;\r
+; : CHAR+ char-size + ;\r
+\r
+ $COLON 5,'CHAR+',CHARPlus,_FLINK\r
+ DW DoLIT,CHARR,Plus,EXIT\r
+\r
+; COMPILE, ( xt -- ) \ CORE EXT\r
+; Compile the execution token on data stack into current\r
+; colon definition.\r
+;\r
+; : COMPILE, , ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+8,'COMPILE,',COMPILEComma,_FLINK\r
+ DW Comma,EXIT\r
+\r
+; CONSTANT ( x "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- x )\r
+; Create a definition for name which pushes x on the stack on\r
+; execution.\r
+;\r
+; : CONSTANT bal IF -29 THROW THEN \ compiler nesting\r
+; head, ['] doCONST xt, DROP , linkLast ;\r
+\r
+ $COLON 8,'CONSTANT',CONSTANT,_FLINK\r
+ DW Bal,ZBranch,CONST1\r
+ DW DoLIT,-29,THROW\r
+CONST1 DW HeadComma,DoLIT,DoCONST,xtComma,DROP,Comma\r
+ DW LinkLast,EXIT\r
+\r
+; COUNT ( c-addr1 -- c-addr2 u ) \ CORE\r
+; Convert counted string to string specification. c-addr2 is\r
+; the next char-aligned address after c-addr1 and u is the\r
+; contents at c-addr1.\r
+;\r
+; : COUNT DUP CHAR+ SWAP C@ ;\r
+\r
+ $COLON 5,'COUNT',COUNT,_FLINK\r
+ DW DUPP,CHARPlus,SWAP,CFetch,EXIT\r
+\r
+; CREATE ( "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- a-addr )\r
+; Create a data object in data space, which return data\r
+; object address on execution\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | >BODY points here\r
+;\r
+; : CREATE bal IF -29 THROW THEN \ compiler nesting\r
+; head, ['] doCREATE xt, DROP\r
+; HERE DUP CELL+ TO HERE \ reserve a cell\r
+; 0 SWAP ! \ no DOES> code yet\r
+; linkLast ; \ link CREATEd word to current wordlist\r
+\r
+ $COLON 6,'CREATE',CREATE,_FLINK\r
+ DW Bal,ZBranch,CREAT1\r
+ DW DoLIT,-29,THROW\r
+CREAT1 DW HeadComma,DoLIT,DoCREATE,xtComma,DROP\r
+ DW HERE,DUPP,CELLPlus,DoTO,AddrHERE\r
+ DW Zero,SWAP,Store,LinkLast,EXIT\r
+\r
+; D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE\r
+; Add double-cell numbers.\r
+;\r
+; : D+ >R SWAP >R um+ R> R> + + ;\r
+\r
+ $COLON 2,'D+',DPlus,_FLINK\r
+ DW ToR,SWAP,ToR,UMPlus\r
+ DW RFrom,RFrom,Plus,Plus,EXIT\r
+\r
+; D. ( d -- ) \ DOUBLE\r
+; Display d in free field format followed by a space.\r
+;\r
+; : D. (d.) TYPE SPACE ;\r
+\r
+ $COLON 2,'D.',DDot,_FLINK\r
+ DW ParenDDot,TYPEE,SPACE,EXIT\r
+\r
+; DECIMAL ( -- ) \ CORE\r
+; Set the numeric conversion radix to decimal 10.\r
+;\r
+; : DECIMAL 10 BASE ! ;\r
+\r
+ $COLON 7,'DECIMAL',DECIMAL,_FLINK\r
+ DW DoLIT,10,BASE,Store,EXIT\r
+\r
+; DEPTH ( -- +n ) \ CORE\r
+; Return the depth of the data stack.\r
+;\r
+; : DEPTH sp@ sp0 SWAP - cell-size / ;\r
+\r
+ $COLON 5,'DEPTH',DEPTH,_FLINK\r
+ DW SPFetch,SPZero,SWAP,Minus\r
+ DW DoLIT,CELLL,Slash,EXIT\r
+\r
+; DNEGATE ( d1 -- d2 ) \ DOUBLE\r
+; Two's complement of double-cell number.\r
+;\r
+; : DNEGATE INVERT >R INVERT 1 um+ R> + ;\r
+\r
+ $COLON 7,'DNEGATE',DNEGATE,_FLINK\r
+ DW INVERT,ToR,INVERT\r
+ DW One,UMPlus\r
+ DW RFrom,Plus,EXIT\r
+\r
+; EKEY ( -- u ) \ FACILITY EXT\r
+; Receive one keyboard event u.\r
+;\r
+; : EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;\r
+\r
+ $COLON 4,'EKEY',EKEY,_FLINK\r
+EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1\r
+ DW TickEKEY,EXECUTE,EXIT\r
+\r
+; EMIT ( x -- ) \ CORE\r
+; Send a character to the output device.\r
+;\r
+; : EMIT 'emit EXECUTE ;\r
+\r
+ $COLON 4,'EMIT',EMIT,_FLINK\r
+ DW TickEMIT,EXECUTE,EXIT\r
+\r
+; FM/MOD ( d n1 -- n2 n3 ) \ CORE\r
+; Signed floored divide of double by single. Return mod n2\r
+; and quotient n3.\r
+;\r
+; : FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN\r
+; R@ ABS UM/MOD\r
+; R> 0< IF SWAP NEGATE SWAP THEN\r
+; R> 0< IF NEGATE \ negative quotient\r
+; OVER IF R@ ROT - SWAP 1- THEN\r
+; R> DROP\r
+; 0 OVER < IF -11 THROW THEN \ result out of range\r
+; EXIT THEN\r
+; R> DROP DUP 0< IF -11 THROW THEN ; \ result out of range\r
+\r
+ $COLON 6,'FM/MOD',FMSlashMOD,_FLINK\r
+ DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess\r
+ DW ZBranch,FMMOD1\r
+ DW DNEGATE\r
+FMMOD1 DW RFetch,ABSS,UMSlashMOD\r
+ DW RFrom,ZeroLess,ZBranch,FMMOD2\r
+ DW SWAP,NEGATE,SWAP\r
+FMMOD2 DW RFrom,ZeroLess,ZBranch,FMMOD3\r
+ DW NEGATE,OVER,ZBranch,FMMOD4\r
+ DW RFetch,ROT,Minus,SWAP,OneMinus\r
+FMMOD4 DW RFrom,DROP\r
+ DW DoLIT,0,OVER,LessThan,ZBranch,FMMOD6\r
+ DW DoLIT,-11,THROW\r
+FMMOD6 DW EXIT\r
+FMMOD3 DW RFrom,DROP,DUPP,ZeroLess,ZBranch,FMMOD6\r
+ DW DoLIT,-11,THROW\r
+\r
+; GET-CURRENT ( -- wid ) \ SEARCH\r
+; Return the indentifier of the compilation wordlist.\r
+;\r
+; : GET-CURRENT current @ ;\r
+\r
+ $COLON 11,'GET-CURRENT',GET_CURRENT,_FLINK\r
+ DW Current,Fetch,EXIT\r
+\r
+; HOLD ( char -- ) \ CORE\r
+; Add char to the beginning of pictured numeric output string.\r
+;\r
+; : HOLD hld @ 1 CHARS - DUP hld ! C! ;\r
+\r
+ $COLON 4,'HOLD',HOLD,_FLINK\r
+ DW HLD,Fetch,DoLIT,0-CHARR,Plus\r
+ DW DUPP,HLD,Store,CStore,EXIT\r
+\r
+; I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+; Push the innermost loop index.\r
+;\r
+; : I rp@ [ 1 CELLS ] LITERAL + @\r
+; rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+1,'I',I,_FLINK\r
+ DW RPFetch,DoLIT,CELLL,Plus,Fetch\r
+ DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+; IF Compilation: ( C: -- orig ) \ CORE\r
+; Run-time: ( x -- )\r
+; Put the location of a new unresolved forward reference orig\r
+; onto the control flow stack. On execution jump to location\r
+; specified by the resolution of orig if x is zero.\r
+;\r
+; : IF POSTPONE 0branch HERE 0 ,\r
+; 1 bal+ \ orig type is 1\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'IF',IFF,_FLINK\r
+ DW DoLIT,ZBranch,COMPILEComma,HERE,Zero,Comma\r
+ DW One,BalPlus,EXIT\r
+\r
+; INVERT ( x1 -- x2 ) \ CORE\r
+; Return one's complement of x1.\r
+;\r
+; : INVERT -1 XOR ;\r
+\r
+ $COLON 6,'INVERT',INVERT,_FLINK\r
+ DW MinusOne,XORR,EXIT\r
+\r
+; KEY ( -- char ) \ CORE\r
+; Receive a character. Do not display char.\r
+;\r
+; : KEY EKEY max-char AND ;\r
+\r
+ $COLON 3,'KEY',KEY,_FLINK\r
+ DW EKEY,DoLIT,MaxChar,ANDD,EXIT\r
+\r
+; LITERAL Compilation: ( x -- ) \ CORE\r
+; Run-time: ( -- x )\r
+; Append following run-time semantics. Put x on the stack on\r
+; execution\r
+;\r
+; : LITERAL POSTPONE doLIT , ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+7,'LITERAL',LITERAL,_FLINK\r
+ DW DoLIT,DoLIT,COMPILEComma,Comma,EXIT\r
+\r
+; NEGATE ( n1 -- n2 ) \ CORE\r
+; Return two's complement of n1.\r
+;\r
+; : NEGATE INVERT 1+ ;\r
+\r
+ $COLON 6,'NEGATE',NEGATE,_FLINK\r
+ DW INVERT,OnePlus,EXIT\r
+\r
+; NIP ( n1 n2 -- n2 ) \ CORE EXT\r
+; Discard the second stack item.\r
+;\r
+; : NIP SWAP DROP ;\r
+\r
+ $COLON 3,'NIP',NIP,_FLINK\r
+ DW SWAP,DROP,EXIT\r
+\r
+; PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT\r
+; Scan input stream and return counted string delimited by char.\r
+;\r
+; : PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char\r
+; DUP IF\r
+; OVER CHARS + OVER \ c-addr c-addr+u c-addr R: char\r
+; BEGIN DUP C@ R@ XOR\r
+; WHILE CHAR+ 2DUP =\r
+; UNTIL DROP OVER - 1chars/ DUP\r
+; ELSE NIP OVER - 1chars/ DUP CHAR+\r
+; THEN >IN +!\r
+; THEN R> DROP EXIT ;\r
+\r
+ $COLON 5,'PARSE',PARSE,_FLINK\r
+ DW ToR,SOURCE,ToIN,Fetch,SlashSTRING\r
+ DW DUPP,ZBranch,PARSE4\r
+ DW OVER,CHARS,Plus,OVER\r
+PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3\r
+ DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1\r
+PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5\r
+PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus\r
+PARSE5 DW ToIN,PlusStore\r
+PARSE4 DW RFrom,DROP,EXIT\r
+\r
+; QUIT ( -- ) ( R: i*x -- ) \ CORE\r
+; Empty the return stack, store zero in SOURCE-ID, make the user\r
+; input device the input source, and start text interpreter.\r
+;\r
+; : QUIT BEGIN\r
+; rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [\r
+; BEGIN CR REFILL DROP SPACE \ REFILL returns always true\r
+; ['] interpret CATCH ?DUP 0=\r
+; WHILE STATE @ 0= IF .prompt THEN\r
+; REPEAT\r
+; DUP -1 XOR IF \ ABORT\r
+; DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"\r
+; SPACE errWord 2@ TYPE\r
+; SPACE [CHAR] ? EMIT SPACE\r
+; DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception\r
+; CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN\r
+; sp0 sp!\r
+; AGAIN ;\r
+\r
+ $COLON 4,'QUIT',QUIT,_FLINK\r
+QUIT1 DW RPZero,RPStore,Zero,DoTO,AddrSOURCE_ID\r
+ DW Zero,DoTO,AddrBal,LeftBracket\r
+QUIT2 DW CR,REFILL,DROP,SPACE\r
+ DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals\r
+ DW ZBranch,QUIT3\r
+ DW STATE,Fetch,ZeroEquals,ZBranch,QUIT2\r
+ DW DotPrompt,Branch,QUIT2\r
+QUIT3 DW DUPP,MinusOne,XORR,ZBranch,QUIT5\r
+ DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4\r
+ DW SPACE,AbortQMsg,TwoFetch,TYPEE,Branch,QUIT5\r
+QUIT4 DW SPACE,ErrWord,TwoFetch,TYPEE\r
+ DW SPACE,DoLIT,'?',EMIT,SPACE\r
+ DW DUPP,MinusOne,DoLIT,-58,WITHIN,ZBranch,QUIT7\r
+ $INSTR ' Exception # '\r
+ DW TYPEE,Dot,Branch,QUIT5\r
+QUIT7 DW CELLS,THROWMsgTbl,Plus,Fetch,COUNT,TYPEE\r
+QUIT5 DW SPZero,SPStore,Branch,QUIT1\r
+\r
+; REFILL ( -- flag ) \ CORE EXT\r
+; Attempt to fill the input buffer from the input source. Make\r
+; the result the input buffer, set >IN to zero, and return true\r
+; if successful. Return false if the input source is a string\r
+; from EVALUATE.\r
+;\r
+; : REFILL SOURCE-ID IF 0 EXIT THEN\r
+; memTop [ size-of-PAD CHARS ] LITERAL - DUP\r
+; size-of-PAD ACCEPT sourceVar 2!\r
+; 0 >IN ! -1 ;\r
+\r
+ $COLON 6,'REFILL',REFILL,_FLINK\r
+ DW SOURCE_ID,ZBranch,REFIL1\r
+ DW Zero,EXIT\r
+REFIL1 DW MemTop,DoLIT,0-PADSize*CHARR,Plus,DUPP\r
+ DW DoLIT,PADSize*CHARR,ACCEPT,SourceVar,TwoStore\r
+ DW Zero,ToIN,Store,MinusOne,EXIT\r
+\r
+; ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE\r
+; Rotate the top three data stack items.\r
+;\r
+; : ROT >R SWAP R> SWAP ;\r
+\r
+ $COLON 3,'ROT',ROT,_FLINK\r
+ DW ToR,SWAP,RFrom,SWAP,EXIT\r
+\r
+; S>D ( n -- d ) \ CORE\r
+; Convert a single-cell number n to double-cell number.\r
+;\r
+; : S>D DUP 0< ;\r
+\r
+ $COLON 3,'S>D',SToD,_FLINK\r
+ DW DUPP,ZeroLess,EXIT\r
+\r
+; SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH\r
+; Search word list for a match with the given name.\r
+; Return execution token and -1 or 1 ( IMMEDIATE) if found.\r
+; Return 0 if not found.\r
+;\r
+; : SEARCH-WORDLIST\r
+; (search-wordlist) DUP IF NIP THEN ;\r
+\r
+ $COLON 15,'SEARCH-WORDLIST',SEARCH_WORDLIST,_FLINK\r
+ DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1\r
+ DW NIP\r
+SRCHW1 DW EXIT\r
+\r
+; SIGN ( n -- ) \ CORE\r
+; Add a minus sign to the numeric output string if n is negative.\r
+;\r
+; : SIGN 0< IF [CHAR] - HOLD THEN ;\r
+\r
+ $COLON 4,'SIGN',SIGN,_FLINK\r
+ DW ZeroLess,ZBranch,SIGN1\r
+ DW DoLIT,'-',HOLD\r
+SIGN1 DW EXIT\r
+\r
+; SOURCE ( -- c-addr u ) \ CORE\r
+; Return input buffer string.\r
+;\r
+; : SOURCE sourceVar 2@ ;\r
+\r
+ $COLON 6,'SOURCE',SOURCE,_FLINK\r
+ DW SourceVar,TwoFetch,EXIT\r
+\r
+; SPACE ( -- ) \ CORE\r
+; Send the blank character to the output device.\r
+;\r
+; : SPACE 32 EMIT ;\r
+\r
+ $COLON 5,'SPACE',SPACE,_FLINK\r
+ DW BLank,EMIT,EXIT\r
+\r
+; STATE ( -- a-addr ) \ CORE\r
+; Return the address of a cell containing compilation-state flag\r
+; which is true in compilation state or false otherwise.\r
+\r
+ $VAR 5,'STATE',STATE,1,_FLINK\r
+\r
+; THEN Compilation: ( C: orig -- ) \ CORE\r
+; Run-time: ( -- )\r
+; Resolve the forward reference orig.\r
+;\r
+; : THEN 1- IF -22 THROW THEN \ control structure mismatch\r
+; \ orig type is 1\r
+; HERE SWAP ! bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+4,'THEN',THENN,_FLINK\r
+ DW OneMinus,ZBranch,THEN1\r
+ DW DoLIT,-22,THROW\r
+THEN1 DW HERE,SWAP,Store,BalMinus,EXIT\r
+\r
+; THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION\r
+; If n is not zero, pop the topmost exception frame from the\r
+; exception stack, along with everything on the return stack\r
+; above the frame. Then restore the condition before CATCH and\r
+; transfer control just after the CATCH that pushed that\r
+; exception frame.\r
+;\r
+; : THROW ?DUP\r
+; IF throwFrame @ rp! \ restore return stack\r
+; R> throwFrame ! \ restore THROW frame\r
+; R> SWAP >R sp! \ restore data stack\r
+; DROP R>\r
+; 'init-i/o EXECUTE\r
+; THEN ;\r
+\r
+ $COLON 5,'THROW',THROW,_FLINK\r
+ DW QuestionDUP,ZBranch,THROW1\r
+ DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store\r
+ DW RFrom,SWAP,ToR,SPStore,DROP,RFrom\r
+ DW TickINIT_IO,EXECUTE\r
+THROW1 DW EXIT\r
+\r
+; TYPE ( c-addr u -- ) \ CORE\r
+; Display the character string if u is greater than zero.\r
+;\r
+; : TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;\r
+\r
+ $COLON 4,'TYPE',TYPEE,_FLINK\r
+ DW QuestionDUP,ZBranch,TYPE2\r
+ DW Zero,DoDO\r
+TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1\r
+TYPE2 DW DROP,EXIT\r
+\r
+; U< ( u1 u2 -- flag ) \ CORE\r
+; Unsigned compare of top two items. True if u1 < u2.\r
+;\r
+; : U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;\r
+\r
+ $COLON 2,'U<',ULess,_FLINK\r
+ DW TwoDUP,XORR,ZeroLess\r
+ DW ZBranch,ULES1\r
+ DW NIP,ZeroLess,EXIT\r
+ULES1 DW Minus,ZeroLess,EXIT\r
+\r
+; UM* ( u1 u2 -- ud ) \ CORE\r
+; Unsigned multiply. Return double-cell product.\r
+;\r
+; : UM* 0 SWAP cell-size-in-bits 0 DO\r
+; DUP um+ >R >R DUP um+ R> +\r
+; R> IF >R OVER um+ R> + THEN \ if carry\r
+; LOOP ROT DROP ;\r
+\r
+ $COLON 3,'UM*',UMStar,_FLINK\r
+ DW Zero,SWAP,DoLIT,CELLL*8,Zero,DoDO\r
+UMST1 DW DUPP,UMPlus,ToR,ToR\r
+ DW DUPP,UMPlus,RFrom,Plus,RFrom\r
+ DW ZBranch,UMST2\r
+ DW ToR,OVER,UMPlus,RFrom,Plus\r
+UMST2 DW DoLOOP,UMST1\r
+ DW ROT,DROP,EXIT\r
+\r
+; UM/MOD ( ud u1 -- u2 u3 ) \ CORE\r
+; Unsigned division of a double-cell number ud by a single-cell\r
+; number u1. Return remainder u2 and quotient u3.\r
+;\r
+; : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero\r
+; 2DUP U< IF\r
+; NEGATE cell-size-in-bits 0\r
+; DO >R DUP um+ >R >R DUP um+ R> + DUP\r
+; R> R@ SWAP >R um+ R> OR\r
+; IF >R DROP 1+ R> THEN\r
+; ELSE DROP THEN\r
+; R>\r
+; LOOP DROP SWAP EXIT\r
+; ELSE -11 THROW \ result out of range\r
+; THEN ;\r
+\r
+ $COLON 6,'UM/MOD',UMSlashMOD,_FLINK\r
+ DW DUPP,ZBranch,UMM5\r
+ DW TwoDUP,ULess,ZBranch,UMM4\r
+ DW NEGATE,DoLIT,CELLL*8,Zero,DoDO\r
+UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP\r
+ DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2\r
+ DW ToR,DROP,OnePlus,RFrom,Branch,UMM3\r
+UMM2 DW DROP\r
+UMM3 DW RFrom,DoLOOP,UMM1\r
+ DW DROP,SWAP,EXIT\r
+UMM5 DW DoLIT,-10,THROW\r
+UMM4 DW DoLIT,-11,THROW\r
+\r
+; UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE\r
+; Discard loop-control parameters for the current nesting level.\r
+; An UNLOOP is required for each nesting level before the\r
+; definition may be EXITed.\r
+;\r
+; : UNLOOP R> R> R> 2DROP >R ;\r
+\r
+ $COLON COMPO+6,'UNLOOP',UNLOOP,_FLINK\r
+ DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT\r
+\r
+; WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT\r
+; Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or\r
+; (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).\r
+;\r
+; : WITHIN OVER - >R - R> U< ;\r
+\r
+ $COLON 6,'WITHIN',WITHIN,_FLINK\r
+ DW OVER,Minus,ToR ;ul <= u < uh\r
+ DW Minus,RFrom,ULess,EXIT\r
+\r
+; [ ( -- ) \ CORE\r
+; Enter interpretation state.\r
+;\r
+; : [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+1,'[',LeftBracket,_FLINK\r
+ DW Zero,STATE,Store,EXIT\r
+\r
+; ] ( -- ) \ CORE\r
+; Enter compilation state.\r
+;\r
+; : ] -1 STATE ! ;\r
+\r
+ $COLON 1,']',RightBracket,_FLINK\r
+ DW MinusOne,STATE,Store,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Rest of CORE words and two facility words, EKEY? and EMIT?\r
+;;;;;;;;;;;;;;;;\r
+; Following definitions can be removed from assembler source and\r
+; can be colon-defined later.\r
+\r
+; ( ( "ccc<)>" -- ) \ CORE\r
+; Ignore following string up to next ) . A comment.\r
+;\r
+; : ( [CHAR] ) PARSE 2DROP ;\r
+\r
+ $COLON IMMED+1,'(',Paren,_FLINK\r
+ DW DoLIT,')',PARSE,TwoDROP,EXIT\r
+\r
+; * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Multiply n1|u1 by n2|u2 giving a single product.\r
+;\r
+; : * UM* DROP ;\r
+\r
+ $COLON 1,'*',Star,_FLINK\r
+ DW UMStar,DROP,EXIT\r
+\r
+; */ ( n1 n2 n3 -- n4 ) \ CORE\r
+; Multiply n1 by n2 producing double-cell intermediate,\r
+; then divide it by n3. Return single-cell quotient.\r
+;\r
+; : */ */MOD NIP ;\r
+\r
+ $COLON 2,'*/',StarSlash,_FLINK\r
+ DW StarSlashMOD,NIP,EXIT\r
+\r
+; */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE\r
+; Multiply n1 by n2 producing double-cell intermediate,\r
+; then divide it by n3. Return single-cell remainder and\r
+; single-cell quotient.\r
+;\r
+; : */MOD >R M* R> FM/MOD ;\r
+\r
+ $COLON 5,'*/MOD',StarSlashMOD,_FLINK\r
+ DW ToR,MStar,RFrom,FMSlashMOD,EXIT\r
+\r
+; +LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+; Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Terminate a DO-+LOOP structure. Resolve the destination of all\r
+; unresolved occurences of LEAVE.\r
+; On execution add n to the loop index. If loop index did not\r
+; cross the boundary between loop_limit-1 and loop_limit,\r
+; continue execution at the beginning of the loop. Otherwise,\r
+; finish the loop.\r
+;\r
+; : +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'+LOOP',PlusLOOP,_FLINK\r
+ DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT\r
+\r
+; ." ( "ccc<">" -- ) \ CORE\r
+; Run-time ( -- )\r
+; Compile an inline string literal to be typed out at run time.\r
+;\r
+; : ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'."',DotQuote,_FLINK\r
+ DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT\r
+\r
+; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE\r
+; Copy cell pair x1 x2 to the top of the stack.\r
+;\r
+; : 2OVER >R >R 2DUP R> R> 2SWAP ;\r
+\r
+ $COLON 5,'2OVER',TwoOVER,_FLINK\r
+ DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT\r
+\r
+; >BODY ( xt -- a-addr ) \ CORE\r
+; Push data field address of CREATEd word.\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | >BODY points here\r
+;\r
+; : >BODY ?call DUP IF \ code-addr xt2\r
+; ['] doCREATE = IF \ should be call-doCREATE\r
+; CELL+ EXIT\r
+; THEN THEN\r
+; -31 THROW ; \ >BODY used on non-CREATEd definition\r
+\r
+ $COLON 5,'>BODY',ToBODY,_FLINK\r
+ DW QCall,DUPP,ZBranch,TBODY1\r
+ DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1\r
+ DW CELLPlus,EXIT\r
+TBODY1 DW DoLIT,-31,THROW\r
+\r
+; ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT\r
+; Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )\r
+; Conditional abort with an error message.\r
+;\r
+; : ABORT" S" POSTPONE ROT\r
+; POSTPONE IF POSTPONE abort"msg POSTPONE 2!\r
+; -2 POSTPONE LITERAL POSTPONE THROW\r
+; POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+6,'ABORT"',ABORTQuote,_FLINK\r
+ DW SQuote,DoLIT,ROT,COMPILEComma\r
+ DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate\r
+ DW DoLIT,TwoStore,COMPILEComma\r
+ DW DoLIT,-2,LITERAL ; LITERAL is immediate\r
+ DW DoLIT,THROW,COMPILEComma\r
+ DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are\r
+ DW THENN,EXIT ; immediate\r
+\r
+; ABS ( n -- u ) \ CORE\r
+; Return the absolute value of n.\r
+;\r
+; : ABS DUP 0< IF NEGATE THEN ;\r
+\r
+ $COLON 3,'ABS',ABSS,_FLINK\r
+ DW DUPP,ZeroLess,ZBranch,ABS1\r
+ DW NEGATE\r
+ABS1 DW EXIT\r
+\r
+; ALLOT ( n -- ) \ CORE\r
+; Allocate n address units in data space.\r
+;\r
+; : ALLOT HERE + TO HERE ;\r
+\r
+ $COLON 5,'ALLOT',ALLOT,_FLINK\r
+ DW HERE,Plus,DoTO,AddrHERE,EXIT\r
+\r
+; BEGIN ( C: -- dest ) \ CORE\r
+; Start an infinite or indefinite loop structure. Put the next\r
+; location for a transfer of control, dest, onto the data\r
+; control stack.\r
+;\r
+; : BEGIN HERE 0 bal+ \ dest type is 0\r
+; ; COMPILE-ONLY IMMDEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'BEGIN',BEGIN,_FLINK\r
+ DW HERE,Zero,BalPlus,EXIT\r
+\r
+; C, ( char -- ) \ CORE\r
+; Compile a character into data space.\r
+;\r
+; : C, HERE C! HERE CHAR+ TO HERE ;\r
+\r
+ $COLON 2,'C,',CComma,_FLINK\r
+ DW HERE,CStore,HERE,CHARPlus,DoTO,AddrHERE,EXIT\r
+\r
+; CHAR ( "<spaces>ccc" -- char ) \ CORE\r
+; Parse next word and return the value of first character.\r
+;\r
+; : CHAR PARSE-WORD DROP C@ ;\r
+\r
+ $COLON 4,'CHAR',CHAR,_FLINK\r
+ DW PARSE_WORD,DROP,CFetch,EXIT\r
+\r
+; DO Compilation: ( C: -- do-sys ) \ CORE\r
+; Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )\r
+; Start a DO-LOOP structure in a colon definition. Place do-sys\r
+; on control-flow stack, which will be resolved by LOOP or +LOOP.\r
+;\r
+; : DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO\r
+; POSTPONE doDO HERE bal+ \ DO-dest\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'DO',DO,_FLINK\r
+ DW Zero,RakeVar,Store,Zero\r
+ DW DoLIT,DoDO,COMPILEComma,HERE,BalPlus,EXIT\r
+\r
+; DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE\r
+; Build run time code of the data object CREATEd.\r
+;\r
+; : DOES> bal 1- IF -22 THROW THEN \ control structure mismatch\r
+; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+; POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'DOES>',DOESGreater,_FLINK\r
+ DW Bal,OneMinus,ZBranch,DOES1\r
+ DW DoLIT,-22,THROW\r
+DOES1 DW NIP,OnePlus,ZBranch,DOES2\r
+ DW DoLIT,-22,THROW\r
+DOES2 DW DoLIT,Pipe,COMPILEComma\r
+ DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT\r
+\r
+; ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE\r
+; Run-time: ( -- )\r
+; Start the false clause in an IF-ELSE-THEN structure.\r
+; Put the location of new unresolved forward reference orig2\r
+; onto control-flow stack.\r
+;\r
+; : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMDEDIATE\r
+\r
+ $COLON IMMED+COMPO+4,'ELSE',ELSEE,_FLINK\r
+ DW AHEAD,TwoSWAP,THENN,EXIT\r
+\r
+; ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE\r
+; Environment query.\r
+;\r
+; : ENVIRONMENT?\r
+; envQList SEARCH-WORDLIST\r
+; DUP >R IF EXECUTE THEN R> ;\r
+\r
+ $COLON 12,'ENVIRONMENT?',ENVIRONMENTQuery,_FLINK\r
+ DW EnvQList,SEARCH_WORDLIST\r
+ DW DUPP,ToR,ZBranch,ENVRN1\r
+ DW EXECUTE\r
+ENVRN1 DW RFrom,EXIT\r
+\r
+; EVALUATE ( i*x c-addr u -- j*x ) \ CORE\r
+; Evaluate the string. Save the input source specification.\r
+; Store -1 in SOURCE-ID.\r
+;\r
+; : EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R\r
+; -1 TO SOURCE-ID\r
+; sourceVar 2! 0 >IN ! interpret\r
+; R> TO SOURCE-ID\r
+; R> >IN ! R> R> sourceVar 2! ;\r
+\r
+ $COLON 8,'EVALUATE',EVALUATE,_FLINK\r
+ DW SOURCE,ToR,ToR,ToIN,Fetch,ToR,SOURCE_ID,ToR\r
+ DW MinusOne,DoTO,AddrSOURCE_ID\r
+ DW SourceVar,TwoStore,Zero,ToIN,Store,Interpret\r
+ DW RFrom,DoTO,AddrSOURCE_ID\r
+ DW RFrom,ToIN,Store,RFrom,RFrom,SourceVar,TwoStore,EXIT\r
+\r
+; FILL ( c-addr u char -- ) \ CORE\r
+; Store char in each of u consecutive characters of memory\r
+; beginning at c-addr.\r
+;\r
+; : FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;\r
+\r
+ $COLON 4,'FILL',FILL,_FLINK\r
+ DW ROT,ROT,QuestionDUP,ZBranch,FILL2\r
+ DW Zero,DoDO\r
+FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1\r
+FILL2 DW TwoDROP,EXIT\r
+\r
+; FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH\r
+; Search dictionary for a match with the given counted name.\r
+; Return execution token and -1 or 1 ( IMMEDIATE) if found;\r
+; c-addr 0 if not found.\r
+;\r
+; : FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN\r
+; 2DROP 0 ;\r
+\r
+ $COLON 4,'FIND',FIND,_FLINK\r
+ DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1\r
+ DW NIP,ROT,DROP,EXIT\r
+FIND1 DW TwoDROP,Zero,EXIT\r
+\r
+; IMMEDIATE ( -- ) \ CORE\r
+; Make the most recent definition an immediate word.\r
+;\r
+; : IMMEDIATE lastName [ =imed ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON 9,'IMMEDIATE',IMMEDIATE,_FLINK\r
+ DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+; Push the index of next outer loop.\r
+;\r
+; : J rp@ [ 3 CELLS ] LITERAL + @\r
+; rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+1,'J',J,_FLINK\r
+ DW RPFetch,DoLIT,3*CELLL,Plus,Fetch\r
+ DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+; LEAVE ( -- ) ( R: loop-sys -- ) \ CORE\r
+; Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.\r
+;\r
+; : LEAVE POSTPONE UNLOOP POSTPONE branch\r
+; HERE rakeVar DUP @ , ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'LEAVE',LEAVEE,_FLINK\r
+ DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma\r
+ DW HERE,RakeVar,DUPP,Fetch,Comma,Store,EXIT\r
+\r
+; LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+; Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )\r
+; Terminate a DO|?DO ... LOOP structure. Resolve the destination\r
+; of all unresolved occurences of LEAVE.\r
+;\r
+; : LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+4,'LOOP',LOOPP,_FLINK\r
+ DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT\r
+\r
+; LSHIFT ( x1 u -- x2 ) \ CORE\r
+; Perform a logical left shift of u bit-places on x1, giving x2.\r
+; Put 0 into the least significant bits vacated by the shift.\r
+;\r
+; : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;\r
+\r
+ $COLON 6,'LSHIFT',LSHIFT,_FLINK\r
+ DW QuestionDUP,ZBranch,LSHIFT2\r
+ DW Zero,DoDO\r
+LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1\r
+LSHIFT2 DW EXIT\r
+\r
+; M* ( n1 n2 -- d ) \ CORE\r
+; Signed multiply. Return double product.\r
+;\r
+; : M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;\r
+\r
+ $COLON 2,'M*',MStar,_FLINK\r
+ DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS\r
+ DW UMStar,RFrom,ZBranch,MSTAR1\r
+ DW DNEGATE\r
+MSTAR1 DW EXIT\r
+\r
+; MAX ( n1 n2 -- n3 ) \ CORE\r
+; Return the greater of two top stack items.\r
+;\r
+; : MAX 2DUP < IF SWAP THEN DROP ;\r
+\r
+ $COLON 3,'MAX',MAX,_FLINK\r
+ DW TwoDUP,LessThan,ZBranch,MAX1\r
+ DW SWAP\r
+MAX1 DW DROP,EXIT\r
+\r
+; MIN ( n1 n2 -- n3 ) \ CORE\r
+; Return the smaller of top two stack items.\r
+;\r
+; : MIN 2DUP > IF SWAP THEN DROP ;\r
+\r
+ $COLON 3,'MIN',MIN,_FLINK\r
+ DW TwoDUP,GreaterThan,ZBranch,MIN1\r
+ DW SWAP\r
+MIN1 DW DROP,EXIT\r
+\r
+; MOD ( n1 n2 -- n3 ) \ CORE\r
+; Divide n1 by n2, giving the single cell remainder n3.\r
+; Returns modulo of floored division in this implementation.\r
+;\r
+; : MOD /MOD DROP ;\r
+\r
+ $COLON 3,'MOD',MODD,_FLINK\r
+ DW SlashMOD,DROP,EXIT\r
+\r
+; PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT\r
+; Remove u and copy the uth stack item to top of the stack. An\r
+; ambiguous condition exists if there are less than u+2 items\r
+; on the stack before PICK is executed.\r
+;\r
+; : PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow\r
+; 2 - OVER U< IF -4 THROW THEN\r
+; 1+ CELLS sp@ + @ ;\r
+\r
+ $COLON 4,'PICK',PICK,_FLINK\r
+ DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1\r
+ DW DoLIT,-4,THROW\r
+PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2\r
+ DW DoLIT,-4,THROW\r
+PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT\r
+\r
+; POSTPONE ( "<spaces>name" -- ) \ CORE\r
+; Parse name and find it. Append compilation semantics of name\r
+; to current definition.\r
+;\r
+; : POSTPONE (') 0< IF POSTPONE LITERAL\r
+; POSTPONE COMPILE, EXIT THEN \ non-IMMEDIATE\r
+; COMPILE, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+8,'POSTPONE',POSTPONE,_FLINK\r
+ DW ParenTick,ZeroLess,ZBranch,POSTP1\r
+ DW LITERAL,DoLIT,COMPILEComma\r
+POSTP1 DW COMPILEComma,EXIT\r
+\r
+; RECURSE ( -- ) \ CORE\r
+; Append the execution semactics of the current definition to\r
+; the current definition.\r
+;\r
+; : RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN\r
+; \ control structure mismatch; colon-sys type is -1\r
+; bal 1- 2* 1+ PICK \ xt of current definition\r
+; COMPILE, ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+7,'RECURSE',RECURSE,_FLINK\r
+ DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1\r
+ DW DoLIT,-22,THROW\r
+RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK\r
+ DW COMPILEComma,EXIT\r
+\r
+; REPEAT ( C: orig dest -- ) \ CORE\r
+; Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve\r
+; backward reference dest and forward reference orig.\r
+;\r
+; : REPEAT AGAIN THEN ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+6,'REPEAT',REPEATT,_FLINK\r
+ DW AGAIN,THENN,EXIT\r
+\r
+; RSHIFT ( x1 u -- x2 ) \ CORE\r
+; Perform a logical right shift of u bit-places on x1, giving x2.\r
+; Put 0 into the most significant bits vacated by the shift.\r
+;\r
+; : RSHIFT ?DUP IF\r
+; 0 SWAP cell-size-in-bits SWAP -\r
+; 0 DO 2DUP D+ LOOP\r
+; NIP\r
+; THEN ;\r
+\r
+ $COLON 6,'RSHIFT',RSHIFT,_FLINK\r
+ DW QuestionDUP,ZBranch,RSHIFT2\r
+ DW Zero,SWAP,DoLIT,CELLL*8,SWAP,Minus,Zero,DoDO\r
+RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1\r
+ DW NIP\r
+RSHIFT2 DW EXIT\r
+\r
+; SLITERAL ( c-addr1 u -- ) \ STRING\r
+; Run-time ( -- c-addr2 u )\r
+; Compile a string literal. Return the string on execution.\r
+;\r
+; : SLITERAL DUP LITERAL POSTPONE doS"\r
+; CHARS HERE 2DUP + ALIGNED TO HERE\r
+; SWAP MOVE ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+8,'SLITERAL',SLITERAL,_FLINK\r
+ DW DUPP,LITERAL,DoLIT,DoSQuote,COMPILEComma\r
+ DW CHARS,HERE,TwoDUP,Plus,ALIGNED,DoTO,AddrHERE\r
+ DW SWAP,MOVE,EXIT\r
+\r
+; S" Compilation: ( "ccc<">" -- ) \ CORE\r
+; Run-time: ( -- c-addr u )\r
+; Parse ccc delimetered by " . Return the string specification\r
+; c-addr u on execution.\r
+;\r
+; : S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'S"',SQuote,_FLINK\r
+ DW DoLIT,'"',PARSE,SLITERAL,EXIT\r
+\r
+; SM/REM ( d n1 -- n2 n3 ) \ CORE\r
+; Symmetric divide of double by single. Return remainder n2\r
+; and quotient n3.\r
+;\r
+; : SM/REM 2DUP XOR >R OVER >R >R DUP 0< IF DNEGATE THEN\r
+; R> ABS UM/MOD\r
+; R> 0< IF SWAP NEGATE SWAP THEN\r
+; R> 0< IF \ negative quotient\r
+; NEGATE 0 OVER < 0= IF EXIT THEN\r
+; -11 THROW THEN \ result out of range\r
+; DUP 0< IF -11 THROW THEN ; \ result out of range\r
+\r
+ $COLON 6,'SM/REM',SMSlashREM,_FLINK\r
+ DW TwoDUP,XORR,ToR,OVER,ToR,ToR,DUPP,ZeroLess\r
+ DW ZBranch,SMREM1\r
+ DW DNEGATE\r
+SMREM1 DW RFrom,ABSS,UMSlashMOD\r
+ DW RFrom,ZeroLess,ZBranch,SMREM2\r
+ DW SWAP,NEGATE,SWAP\r
+SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3\r
+ DW NEGATE,DoLIT,0,OVER,LessThan,ZeroEquals,ZBranch,SMREM4\r
+SMREM5 DW EXIT\r
+SMREM3 DW DUPP,ZeroLess,ZBranch,SMREM5\r
+SMREM4 DW DoLIT,-11,THROW\r
+\r
+; SPACES ( n -- ) \ CORE\r
+; Send n spaces to the output device if n is greater than zero.\r
+;\r
+; : SPACES ?DUP IF 0 DO SPACE LOOP THEN ;\r
+\r
+ $COLON 6,'SPACES',SPACES,_FLINK\r
+ DW QuestionDUP,ZBranch,SPACES2\r
+ DW Zero,DoDO\r
+SPACES1 DW SPACE,DoLOOP,SPACES1\r
+SPACES2 DW EXIT\r
+\r
+; TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT\r
+; Compilation: ( "<spaces>name" -- )\r
+; Run-time: ( x -- )\r
+; Store x in name.\r
+;\r
+; : TO ' ?call DUP IF \ should be call-doCONST\r
+; ['] doVALUE = \ verify VALUE marker\r
+; IF STATE @\r
+; IF POSTPONE doTO , EXIT THEN\r
+; ! EXIT\r
+; THEN THEN\r
+; -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)\r
+\r
+ $COLON IMMED+2,'TO',TO,_FLINK\r
+ DW Tick,QCall,DUPP,ZBranch,TO1\r
+ DW DoLIT,DoVALUE,Equals,ZBranch,TO1\r
+ DW STATE,Fetch,ZBranch,TO2\r
+ DW DoLIT,DoTO,COMPILEComma,Comma,EXIT\r
+TO2 DW Store,EXIT\r
+TO1 DW DoLIT,-32,THROW\r
+\r
+; U. ( u -- ) \ CORE\r
+; Display u in free field format followed by space.\r
+;\r
+; : U. 0 D. ;\r
+\r
+ $COLON 2,'U.',UDot,_FLINK\r
+ DW Zero,DDot,EXIT\r
+\r
+; UNTIL ( C: dest -- ) \ CORE\r
+; Terminate a BEGIN-UNTIL indefinite loop structure.\r
+;\r
+; : UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+; POSTPONE 0branch , bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'UNTIL',UNTIL,_FLINK\r
+ DW ZBranch,UNTIL1\r
+ DW DoLIT,-22,THROW\r
+UNTIL1 DW DoLIT,ZBranch,COMPILEComma,Comma,BalMinus,EXIT\r
+\r
+; VALUE ( x "<spaces>name" -- ) \ CORE EXT\r
+; name Execution: ( -- x )\r
+; Create a value object with initial value x.\r
+;\r
+; : VALUE bal IF -29 THROW THEN \ compiler nesting\r
+; head, ['] doVALUE xt, DROP\r
+; , linkLast ; \ store x and link VALUE word to current wordlist\r
+\r
+ $COLON 5,'VALUE',VALUE,_FLINK\r
+ DW Bal,ZBranch,VALUE1\r
+ DW DoLIT,-29,THROW\r
+VALUE1 DW HeadComma,DoLIT,DoVALUE,xtComma,DROP\r
+ DW Comma,LinkLast,EXIT\r
+\r
+; VARIABLE ( "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- a-addr )\r
+; Parse a name and create a variable with the name.\r
+; Resolve one cell of data space at an aligned address.\r
+; Return the address on execution.\r
+;\r
+; : VARIABLE bal IF -29 THROW THEN \ compiler nesting\r
+; head, ['] doVAR xt, DROP\r
+; HERE CELL+ TO HERE linkLast ;\r
+\r
+ $COLON 8,'VARIABLE',VARIABLE,_FLINK\r
+ DW Bal,ZBranch,VARIA1\r
+ DW DoLIT,-29,THROW\r
+VARIA1 DW HeadComma,DoLIT,DoVAR,xtComma,DROP\r
+ DW HERE,CELLPlus,DoTO,AddrHERE,LinkLast,EXIT\r
+\r
+; WHILE ( C: dest -- orig dest ) \ CORE\r
+; Put the location of a new unresolved forward reference orig\r
+; onto the control flow stack under the existing dest. Typically\r
+; used in BEGIN ... WHILE ... REPEAT structure.\r
+;\r
+; : WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'WHILE',WHILEE,_FLINK\r
+ DW IFF,TwoSWAP,EXIT\r
+\r
+; WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE\r
+; Skip leading delimeters and parse a word. Return the address\r
+; of a transient region containing the word as counted string.\r
+;\r
+; : WORD skipPARSE HERE pack" DROP HERE ;\r
+\r
+ $COLON 4,'WORD',WORDD,_FLINK\r
+ DW SkipPARSE,HERE,PackQuote,DROP,HERE,EXIT\r
+\r
+; ['] Compilation: ( "<spaces>name" -- ) \ CORE\r
+; Run-time: ( -- xt )\r
+; Parse name. Return the execution token of name on execution.\r
+;\r
+; : ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+3,"[']",BracketTick,_FLINK\r
+ DW Tick,LITERAL,EXIT\r
+\r
+; [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE\r
+; Run-time: ( -- char )\r
+; Parse name. Return the value of the first character of name\r
+; on execution.\r
+;\r
+; : [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+6,'[CHAR]',BracketCHAR,_FLINK\r
+ DW CHAR,LITERAL,EXIT\r
+\r
+; \ ( "ccc<eol>" -- ) \ CORE EXT\r
+; Parse and discard the remainder of the parse area.\r
+;\r
+; : \ SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+ $COLON IMMED+1,'\',Backslash,_FLINK\r
+ DW SOURCE,ToIN,Store,DROP,EXIT\r
+\r
+; Optional Facility words\r
+\r
+; EKEY? ( -- flag ) \ FACILITY EXT\r
+; If a keyboard event is available, return true.\r
+;\r
+; : EKEY? 'ekey? EXECUTE ;\r
+\r
+ $COLON 5,'EKEY?',EKEYQuestion,_FLINK\r
+ DW TickEKEYQ,EXECUTE,EXIT\r
+\r
+; EMIT? ( -- flag ) \ FACILITY EXT\r
+; flag is true if the user output device is ready to accept data\r
+; and the execution of EMIT in place of EMIT? would not have\r
+; suffered an indefinite delay. If device state is indeterminate,\r
+; flag is true.\r
+;\r
+; : EMIT? 'emit? EXECUTE ;\r
+\r
+ $COLON 5,'EMIT?',EMITQuestion,_FLINK\r
+ DW TickEMITQ,EXECUTE,EXIT\r
+\r
+;===============================================================\r
+\r
+LASTENV EQU _ENVLINK-0\r
+LASTSYSTEM EQU _SLINK-0 ;last SYSTEM word name address\r
+LASTFORTH EQU _FLINK-0 ;last FORTH word name address\r
+\r
+CTOP EQU $-0 ;next available memory in dictionary\r
+\r
+MAIN ENDS\r
+END ORIG\r
+\r
+;===============================================================\r
--- /dev/null
+TITLE hForth 8086 ROM Model\r
+\r
+PAGE 62,132 ;62 lines per page, 132 characters per line\r
+\r
+;===============================================================\r
+;\r
+; hForth 8086 ROM model v0.9.9 by Wonyong Koh, 1997\r
+;\r
+;\r
+; 1997. 2. 19.\r
+; Split environmental variable systemID into CPU and Model.\r
+; 1997. 2. 6.\r
+; Add Neal Crook's microdebugger and comments on assembly definitions.\r
+; 1997. 1. 25.\r
+; Add $THROWMSG macro and revise accordingly.\r
+; 1997. 1. 18.\r
+; Remove 'NullString' from assembly source.\r
+; 1996. 12. 18.\r
+; Revise 'head,'.\r
+; 1996. 12. 3.\r
+; Revise PICK to catch stack underflow.\r
+; 1996. 11. 29.\r
+; Implement control-flow stack on data stack. Control-flow stack\r
+; item consists of two data stack items, one for value\r
+; and one for the type of control-flow stack item.\r
+;\r
+; control-flow stack item data stack representation\r
+; dest control-flow_destination 0\r
+; orig control-flow_origin 1\r
+; of-sys OF_origin 2\r
+; case-sys x (any value) 3\r
+; do-sys ?DO_origin DO_destination\r
+; colon-sys xt_of_current_definition -1\r
+;\r
+; Add PICK.\r
+; 'bal' is now the depth of control-flow stack.\r
+; Drop 'lastXT'.\r
+; Introduce 'notNONAME?'\r
+; Add 'bal+' and 'bal-'. Drop 'orig+', 'orig-', 'dest+', 'dest-',\r
+; 'dosys+', and 'dosys-'.\r
+; Revise ':NONAME', ':', ';', 'linkLast', 'head,', RECURSE, 'DOES>',\r
+; CONSTANT, CREATE, VALUE, VARIABLE, and QUIT.\r
+; This change makes RECURSE work properly in ':NONAME ... ;'\r
+; and '... DOES> ... ;'.\r
+; Revise 'rake', AGAIN, AHEAD, IF, THEN, +LOOP, BEGIN, DO, ELSE, LOOP,\r
+; UNTIL, and WHILE.\r
+;\r
+; 1996. 11. 29.\r
+; Revise SLITERAL, '."', 'doS"' to allow a string larger than\r
+; max char size.\r
+; Revise $INSTR and remove 'do."'.\r
+; Revise 'pack"'.\r
+; 1996. 6. 19.\r
+; Fix '/STRING'.\r
+;\r
+; Changes from 0.9.7\r
+;\r
+; 1996. 2. 10.\r
+; Revise FM/MOD and SM/REM to catch result-out-of-range error in\r
+; '80000. 2 FM/MOD'.\r
+; 1996. 1. 19.\r
+; Rename 'x,' to 'code,'.\r
+; 1996. 1. 7.\r
+; Rename non-Standard 'parse-word' to PARSE-WORD.\r
+; 1995. 12. 2.\r
+; Drop '?doLIST' and revise 'optiCOMPILE,'.\r
+;\r
+; Changes from 0.9.6\r
+;\r
+; 1995. 11. 25.\r
+; Make 'lastXT' VALUE word.\r
+; 1995. 11. 23.\r
+; Revise doCREATE, CREATE, pipe, DOES>, and >BODY.\r
+; 'pipe' is no longer processor-dependent.\r
+; 1995. 11. 17.\r
+; Move ERASE to ASM8086.F.\r
+;\r
+; Changes from 0.9.5\r
+;\r
+; 1995. 11. 15.\r
+; Fix MOVE to check whether 'u' is 0.\r
+; Add ERASE.\r
+; 1995. 11. 5.\r
+; Revise 'orig+', 'dosys+', etc to catch 'DO IF LOOP' mismatch.\r
+;\r
+; Changes from 0.9.2\r
+;\r
+; 1995. 9. 6.\r
+; Move terminal input buffer (TIB) below the name space to\r
+; prevent accidental overwriting it. It was too close\r
+; to HERE and might be overwritten by ALLOT or , .\r
+; TIB address is only known to REFILL . Revise REFILL .\r
+; Move PAD also with TIB.\r
+; 1995. 9. 5.\r
+; Revise EVALUATE for FILE words.\r
+; 1995. 8. 21\r
+; Chris Jakeman kindly report several bugs and made suggestions.\r
+; CHARS is added in the definition of /STRING .\r
+; '1chars/' is introduced to convert # address units to # chars.\r
+; 'skipPARSE' is introduced. 'parse-word' and 'WORD' are\r
+; redefined using it.\r
+;\r
+; Changes from 0.9.0\r
+;\r
+; 1995. 7. 21.\r
+; Make 'cpVar', 'npVar' and 'hereVar' VALUE type.\r
+; Make SOURCE-ID VALUE type, replace TOsource-id with\r
+; "TO SOURCE-ID" and remove TOsource-id .\r
+; 1995. 7. 20.\r
+; Make 'ekey? , 'ekey , 'emit? , 'emit , 'init-i/o , 'prompt\r
+; and 'boot VALUE type and replace "'emit @ EXECUTE"\r
+; with "'emit EXECUTE".\r
+; 1995. 7. 19.\r
+; Add doVALUE , doTO , VALUE and TO .\r
+; Replace 'DUP' with '?DUP' in the definition of "(')".\r
+; Replace 'CREATEd' with 'doCREATE' and remove CREATEd .\r
+; 1995. 7. 6.\r
+; Move "'init-i/o @ EXECUTE" from QUIT to THROW according\r
+; to the suggestion from Chris Jakeman.\r
+; 1995. 6. 14.\r
+; Revise $ENVIR for portability.\r
+; 'CR' is a system dependent definition.\r
+; 1995. 6. 9.\r
+; Rename '.ok' and '.OKay' as '.prompt' and '.ok' respectively.\r
+; 1995. 6. 5.\r
+; Fix SOURCE-ID .\r
+;\r
+;; hForth ROM ¡¡\95I·e ¸b·e \90\81¸w ¯¡¯aÉQµA xÂ\81´á ¬é\89\81\96A´ö¯s\93¡\94a. ËbÓ¡\r
+;; ·¡\88õ·e ROM \94\81¯¥ \90i´a\88a»¡ ´g\93e RAM(non-volatile RAM, NVRAM)·¡\90a\r
+;; ROM µA£I\9dA·¡Èá\9fi ³a\93e ÂA¡Ðe·\81 \88\81¤i ¯¡¯aÉQµA x\89A\r
+;; ¬é\89\81\96A´ö¯s\93¡\94a. \88\81¤iÐa\93e \95·´eµA\93e "ROM"·\81 \90\81¶w·i \89¡Ã© ®\81 ·¶\89¡\r
+;; \88\81¤i·¡ \8f{\90a¡e ·¡ "ROM"·\81 \90\81¶w·i ¯©¹A ¬a¶w\96I ¯¡¯aÉQ·\81 »¥¼a ROMµA\r
+;; µ«\8b© ®\81 ·¶¯s\93¡\94a. µÅ¬÷\96E ¯¡¯aÉQµA Í¡¯a ÉB¯aËa É·µb\8b¡\88a\r
+;; Ï©¶a´ô\94a¡e ·¡\9fq ¸a\9f¡\93e µÅ¬÷\96E ¯¡¯aÉQµA Í¡Ðq\96I Ï©¶a\88a ´ô¯s\93¡\94a.\r
+;; ANS Í¡¯a Îaº\85·\81 ³¡´u \90{ i(Core wordset)·i ¡¡\96\81 Í¡ÐqÐe Å¡\97a\r
+;; ¸a\9f¡·\81 Ça\8b¡\93e 6 K¤a·¡Ëa·¡\89¡ µa\8b¡µA OPTIONAL.FµA \97i´á ·¶\93e\r
+;; WORDSµÁ HEXµÁ SEE \97w·\81 \90{ i(Optional wordset)·i \94áÐa¡e Å¡\97a\r
+;; ¸a\9f¡\93e 8 K¤a·¡Ëa·³\93¡\94a. hForth RAM ¡¡\95IµA\93e ÂA¡ 1 KB·\81 RAM·¡\r
+;; Ï©¶aÐs\93¡\94a.\r
+;;\r
+;; ANS Í¡¯a Îaº\85·e Í¡¯a ¬a¸å·i Å¡\97a ¸a\9f¡µÁ ·¡\9fq ¸a\9f¡µÁ ¸a\9ea ¸a\9f¡\9d¡\r
+;; \90a\92\81´ö¯s\93¡\94a. hForth ROM ¡¡\95I·¡ ¯¡¸bÐa¡e Å¡\97a ¸a\9f¡\93e ROM·\81 ´a\9c\81\r
+;; ¦\81¦\85µA, ·¡\9fq ¸a\9f¡\93e ROM·\81 ¶á ¦\81¦\85µA, ¸a\9ea ¸a\9f¡\93e RAMµA ¸a\9f¡¸s\89¡\r
+;; ·¶¯s\93¡\94a. "ROM"µA ³i ®\81 ·¶\94a¡e ¬\81 \90{ i\97i·\81 Å¡\97aµÁ ·¡\9fq·e ROM·\81\r
+;; ´a\9c\81µÁ ¶áµA \98a\9d¡\98a\9d¡ \97i´á\88s\93¡\94a. "ROM"µA ³i ®\81 ´ô\94a¡e ¬\81 \90{ i·\81\r
+;; Å¡\97aµÁ ¸a\9ea\93e RAM·\81 ´a\9c\81 ¦\81¦\85µA ·¡\9fq·e RAM·\81 ¶á ¦\81¦\85·i Àa»¡Ða\89A\r
+;; \96S\93¡\94a.\r
+;;\r
+;; RAM\89Á ROM \90{ i·i °á¬á ¸a\9ea \89·\88e·¡ RAMµA ·¶\89A Ða\88á\90a ROMµA ·¶\89A\r
+;; Ði ®\81 ·¶¯s\93¡\94a.\r
+;;\r
+;; ROM CREATE TTABLE 1 , 2 , 3 ,\r
+;;\r
+;; ·e ROM ¸a\9f¡µA £¡\9f¡ \88t·¡ ¸÷Ð\81»¥ Îa TTABLE·i e\97i\89¡\r
+;;\r
+;; RAM CREATE AARRAY 10 CELLS ALLOT\r
+;;\r
+;; ·e RAM ¸a\9f¡µA \88t·i °á \90ý·i ®\81 ·¶\93e 10 Äe ¤\81µi·i e\97s\93¡\94a.\r
+;;\r
+;; hForth\93e 1990 \91eµA Bill MuenchµÁ Dr. C. H. Ting·¡ ¤iÎaÐe eForth\9fi\r
+;; ¤aÈw·a\9d¡ e\97i´á¬á ¥¥\9c\81·\81 eForth·\81 Ëb»·\97i·i \8ba\94\81\9d¡ ¬i\9dv¯s\93¡\94a.\r
+;; ´a\9c\81\93e 8086 eForth ¤aÈw¥¥µA¬á \98a µ¥ \88õ·³\93¡\94a.\r
+;;\r
+;; > \88b\88b·\81 a·¡Ça\9d¡Ïa\9d¡A¬áµA xÂ\85 ¡y ´e\96A\93e CODE \90{ i\97i\89Á ¡¡\97e\r
+;; > a·¡Ça\9d¡Ïa\9d¡A¬áµA \89·É··¥ \89¡\8bs (high level) \90{ i\97i\9d¡\r
+;; > ·¡\9e\81´á¹a ·¶¯s\93¡\94a.\r
+;; > ¶¥¯¡Å¡\97a\93e MASM ´áQ§i\9cá¶w·³\93¡\94a.\r
+;; > »¢¸ó \8eÅ (direct threaded) ¤w¤ó·i ³s\93¡\94a.\r
+;; > ¬a¸å·\81 Å¡\97aµÁ ·¡\9fq·¡ ¡A¡¡\9f¡µA \98a\9d¡ ¸a\9f¡Ðs\93¡\94a.\r
+;; > ·³Â\89\9db·e \88a\9f¡Ç± \90{ i·i É·Ða\89¡ º\81 ÄñÏAÈá(host computer)\9fi\r
+;; > \94e i\8b¡µÁ Ìa·© ·³Â\89\9dbµA ·¡¶wÐs\93¡\94a.\r
+;; > ¹A´e\96E £¡\8a\82 Îaº\85 Í¡¯a(ANS Forth)·\81 ¤wз·i \98a\9cv¯s\93¡\94a.\r
+;; > Ëb¸÷Ðe a·¡Ça\9d¡Ïa\9d¡A¬áµA xÂ\81´á ÂA¸âÑÁÐa\8b¡\88a ®ó¯s\93¡\94a.\r
+;;\r
+;; ·¡\88õ\97i·e \8ba\94\81\9d¡ hForth·\81 ¬÷»©·³\93¡\94a. \8ba\9f¡\89¡ hForth \93e ANS Forth\r
+;; Îaº\85·\81 ¤wз e·i \98a\9fa\93e \88õ·¡ ´a\93¡\9ca ANS Í¡¯a Îaº\85·\81 ¶a\8a\81\r
+;; ¹¡\88å·i ¡¡\96\81 e¹¢Ða\93e ANS Îaº\85 Í¡¯a ¯¡¯aÉQ·³\93¡\94a.\r
+;;\r
+;;\r
+; hForth ROM model is designed for small embedded system.\r
+; Especially it is designed for a minimal development system which\r
+; uses non-volatile RAM(NVRAM) or ROM emulator in place of ROM so\r
+; that the content of ROM can be changed during development phase\r
+; and can be copied to real ROM later for production system. Name\r
+; space does not need to be included in final system if the system\r
+; does not require Forth text interpreter. hForth occupies little\r
+; more than 6 KB of code space for CORE words only and about 8 KB\r
+; with additional words in OPTIONAL.F such as WORDS, HEX, SEE,\r
+; etc. hForth ROM model requires at lease 1 KB of RAM.\r
+;\r
+; ANS Forth Standard divide Forth dictionary into code, name, and\r
+; data space. When hForth ROM model starts, the code space resides\r
+; at bottom of ROM, name space at top of ROM, and data space in\r
+; RAM address space. Code and name parts of new definitions will\r
+; split into proper spaces if "ROM" is writable. If "ROM" is not\r
+; writable, code and data part of new definitions goes into bottom\r
+; of RAM and name part of new definitions goes into top of RAM.\r
+;\r
+; You can use the words 'RAM' and 'ROM' to switch data space\r
+; between RAM and ROM address space.\r
+;\r
+; ROM CREATE TTABLE 1 , 2 , 3 ,\r
+;\r
+; will make a preset table in ROM address space while\r
+;\r
+; RAM CREATE AARRAY 10 CELLS ALLOT\r
+;\r
+; will make an array of 10 cells where you write values into.\r
+;\r
+; hForth is based on eForth model published by Mr. Bill Muench and\r
+; Dr. C. H. Ting in 1990. The key features of the original eForth\r
+; model is preserved. Following is quoted from the orginal 8086\r
+; eForth source.\r
+;\r
+; > small machine dependent kernel and portable high level code\r
+; > source code in the MASM format\r
+; > direct threaded code\r
+; > separated code and name dictionaries\r
+; > simple vectored terminal and file interface to host computer\r
+; > aligned with the proposed ANS Forth Standard\r
+; > easy upgrade path to optimize for specific CPU\r
+;\r
+; These are also the characteristics of hForth. For better, hForth\r
+; is ANS Forth system which complies the Standard, not just\r
+; alignes with the Standard. Colon definitions for all high level\r
+; words are also given as comments in TASM source code. The source\r
+; code would be a working example for a Forth student.\r
+;\r
+;===============================================================\r
+;\r
+; 8086/8 register usages\r
+; Single segment model. CS, DS and SS must be same.\r
+; The direction bit must be cleared before returning to Forth\r
+; interpreter(CLD).\r
+; SP: data stack pointer\r
+; BP: return stack pointer\r
+; SI: Forth virtual machine instruction pointer\r
+; BX: top of data stack item\r
+; All other registers are free.\r
+;\r
+; Structure of a task\r
+; userP points follower.\r
+; //userP//<return_stack//<data_stack//\r
+; //user_area/user1/taskName/throwFrame/stackTop/status/follower/sp0/rp0\r
+;\r
+;===============================================================\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Assembly Constants\r
+;;;;;;;;;;;;;;;;\r
+\r
+TRUEE EQU -1\r
+FALSEE EQU 0\r
+\r
+CHARR EQU 1 ;byte size of a character\r
+CELLL EQU 2 ;byte size of a cell\r
+MaxChar EQU 0FFh ;Extended character set\r
+ ; Use 07Fh for ASCII only\r
+MaxSigned EQU 07FFFh ;max value of signed integer\r
+MaxUnsigned EQU 0FFFFh ;max value of unsigned integer\r
+MaxNegative EQU 8000h ;max value of negative integer\r
+ ; Used in doDO\r
+\r
+PADSize EQU 134 ;PAD area size\r
+RTCells EQU 64 ;return stack size\r
+DTCells EQU 256 ;data stack size\r
+\r
+BASEE EQU 10 ;default radix\r
+OrderDepth EQU 10 ;depth of search order stack\r
+MaxWLISTS EQU 20 ;maximum number of wordlists\r
+ ; 2 is used by the system\r
+ ; 18 is available to Forth programs\r
+\r
+COMPO EQU 020h ;lexicon compile only bit\r
+IMMED EQU 040h ;lexicon immediate bit\r
+MASKK EQU 1Fh ;lexicon bit mask\r
+ ;extended character set\r
+ ;maximum name length = 1Fh\r
+\r
+BKSPP EQU 8 ;backspace\r
+TABB EQU 9 ;tab\r
+LFF EQU 10 ;line feed\r
+CRR EQU 13 ;carriage return\r
+DEL EQU 127 ;delete\r
+\r
+CALLL EQU 0E890h ;NOP CALL opcodes\r
+\r
+; Memory allocation for writable ROM\r
+; ROMbottom||code>WORDworkarea|--//--|PAD|TIB|reserved<name||ROMtop\r
+; RAMbottom||variable>--//--<sp|rp||RAMtop\r
+; Memory allocation for unwritable ROM\r
+; ROMbottom||initial-code>--//--<initial-name||ROMtop\r
+; RAMbottom||code/data>WORDworkarea|--//--|PAD|TIB|reserved<name|sp|rp||RAMtop\r
+\r
+RAM0 EQU 0C000h ;bottom of RAM memory ******\r
+RAMEnd EQU 0FFFEh ;top of RAM memory ******\r
+ ;RAM size = 16KB\r
+ROM0 EQU 0 ;bottom of ROM memory ******\r
+ROMEnd EQU 08000h ;end of ROM memory ******\r
+ ;ROM size = 32KB\r
+COLDD EQU ROM0+00100h ;cold start vector ******\r
+\r
+Trapfpc EQU RAMEnd ;reserve a cell for microdebugger\r
+RPP EQU RAMEnd-CELLL ;start of return stack (RP0)\r
+SPP EQU RPP-RTCells*CELLL ;start of data stack (SP0)\r
+RAMT0 EQU SPP-DTCells*CELLL ;top of free RAM area\r
+\r
+; Initialize assembly variables\r
+\r
+_SLINK = 0 ;force a null link\r
+_FLINK = 0 ;force a null link\r
+_ENVLINK = 0 ;farce a null link\r
+_NAME = ROMEnd ;initialize name pointer\r
+_VAR = RAM0 ;variable space pointer\r
+_THROW = 0 ;current throw str addr offset\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Assembly macros\r
+;;;;;;;;;;;;;;;;\r
+\r
+; Adjust an address to the next cell boundary.\r
+\r
+$ALIGN MACRO\r
+ EVEN ;for 16 bit systems\r
+ ENDM\r
+\r
+; Add a name to name space of dictionary.\r
+\r
+$STR MACRO LABEL,STRING\r
+ _CODE = $\r
+ DB STRING\r
+ _LEN = $ - _CODE\r
+ _NAME = _NAME-(_LEN/CELLL+1)*CELLL\r
+ORG _NAME\r
+LABEL:\r
+ DB _LEN,STRING\r
+ORG _CODE ;restore code pointer\r
+ ENDM\r
+\r
+; Add a THROW message in name space. THROW messages won't be\r
+; needed if target system do not need names of Forth words.\r
+\r
+$THROWMSG MACRO STRING\r
+ _CODE = $\r
+ DB STRING\r
+ _LEN = $ - _CODE\r
+ _NAME = _NAME-(_LEN/CELLL+1)*CELLL\r
+ORG _NAME\r
+ DB _LEN,STRING\r
+ _THROW = _THROW + CELLL\r
+ORG AddrTHROWMsgTbl - _THROW\r
+ DW _NAME\r
+ORG _CODE\r
+ ENDM\r
+\r
+; Compile a code definition header.\r
+\r
+$CODE MACRO LEX,NAME,LABEL,LINK\r
+ $ALIGN ;force to cell boundary\r
+LABEL: ;assembly label\r
+ _CODE = $ ;save code pointer\r
+ _LEN = (LEX AND MASKK)/CELLL ;string cell count, round down\r
+ _NAME = _NAME-((_LEN+3)*CELLL) ;new header on cell boundary\r
+ORG _NAME ;set name pointer\r
+ DW _CODE,LINK ;token pointer and link\r
+ LINK = $ ;link points to a name string\r
+ DB LEX,NAME ;name string\r
+ORG _CODE ;restore code pointer\r
+ ENDM\r
+\r
+; Compile a colon definition header.\r
+\r
+$COLON MACRO LEX,NAME,LABEL,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP ;align to cell boundary\r
+ CALL DoLIST ;include CALL doLIST\r
+ ENDM\r
+\r
+; Compile a system CONSTANT header.\r
+\r
+$CONST MACRO LEX,NAME,LABEL,VALUE,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoCONST\r
+ DW VALUE\r
+ ENDM\r
+\r
+; Compile a system VALUE header.\r
+\r
+$VALUE MACRO LEX,NAME,LABEL,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoVALUE\r
+ DW _VAR\r
+ _VAR = _VAR +CELLL\r
+ ENDM\r
+\r
+; Compile a system VARIABLE header.\r
+\r
+$VAR MACRO LEX,NAME,LABEL,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoCONST\r
+ DW _VAR\r
+ _VAR = _VAR +CELLL ;update variable area offset\r
+ ENDM\r
+\r
+; Compile a system USER header.\r
+\r
+$USER MACRO LEX,NAME,LABEL,OFFSET,LINK\r
+ $CODE LEX,NAME,LABEL,LINK\r
+ NOP\r
+ CALL DoUSER\r
+ DW OFFSET\r
+ ENDM\r
+\r
+; Compile an inline string.\r
+\r
+$INSTR MACRO STRNG\r
+ DW DoLIT\r
+ _LEN = $ ;save address of count\r
+ DW 0 ;count\r
+ DW DoSQuote ;doS"\r
+ DB STRNG ;store string\r
+ _CODE = $ ;save code pointer\r
+ORG _LEN ;point to count byte\r
+ DW _CODE-_LEN-2*CELLL ;set count\r
+ORG _CODE ;restore code pointer\r
+ $ALIGN\r
+ ENDM\r
+\r
+; Compile a environment query string header.\r
+\r
+$ENVIR MACRO LEX,NAME\r
+ $ALIGN ;force to cell boundary\r
+ _CODE = $ ;save code pointer\r
+ _LEN = (LEX AND MASKK)/CELLL ;string cell count, round down\r
+ _NAME = _NAME-((_LEN+3)*CELLL) ;new header on cell boundary\r
+ORG _NAME ;set name pointer\r
+ DW _CODE,_ENVLINK ;token pointer and link\r
+ _ENVLINK = $ ;link points to a name string\r
+ DB LEX,NAME ;name string\r
+ORG _CODE\r
+ NOP\r
+ CALL DoLIST\r
+ ENDM\r
+\r
+; Assemble inline direct threaded code ending.\r
+\r
+$NEXT MACRO\r
+; JMP uDebug ;activate to use microdebugger\r
+ LODSW ;next code address into AX\r
+ JMP AX ;jump directly to code address\r
+ $ALIGN\r
+ ENDM\r
+\r
+;===============================================================\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Main entry points and COLD start data\r
+;;;;;;;;;;;;;;;;\r
+\r
+MAIN SEGMENT\r
+ASSUME CS:MAIN,DS:MAIN,SS:MAIN\r
+\r
+ORG COLDD ;beginning of cold boot\r
+\r
+ORIG: CLD ;direction flag, increment\r
+ MOV AX,CS\r
+ MOV DS,AX ;DS is same as CS\r
+ CLI ;disable interrupts, old 808x CPU bug\r
+ MOV SS,AX ;SS is same as CS\r
+ MOV SP,SPP ;initialize SP\r
+ STI ;enable interrupts\r
+ MOV BP,RPP ;initialize RP\r
+ XOR AX,AX\r
+ MOV DI,Trapfpc\r
+ MOV [DI],AX ;initialize for microdebugger\r
+\r
+ MOV Redirect1stQ,AX ;MS-DOS only\r
+\r
+ JMP COLD ;to high level cold start\r
+\r
+ $ALIGN\r
+ $STR CPUStr,'8086'\r
+ $STR ModelStr,'ROM Model'\r
+ $STR VersionStr,'0.9.9'\r
+\r
+; COLD start moves the following to system variables.\r
+; MUST BE IN SAME ORDER AS SYSTEM VARIABLES.\r
+\r
+ $ALIGN ;align to cell boundary\r
+UZERO DW RXQ ;'ekey?\r
+ DW RXFetch ;'ekey\r
+ DW TXQ ;'emit?\r
+ DW TXStore ;'emit\r
+ DW Set_IO ;'init-i/o\r
+ DW DotOK ;'prompt\r
+ DW HI ;'boot\r
+ DW 0 ;SOURCE-ID\r
+ DW AddrROMB ;CPVar\r
+ DW AddrROMT ;NPVar\r
+ DW AddrRAMB ;HereVar points RAM space.\r
+ DW OptiCOMPILEComma ;'doWord nonimmediate word - compilation\r
+ DW EXECUTE ;nonimmediate word - interpretation\r
+ DW DoubleAlsoComma ;not found word - compilateion\r
+ DW DoubleAlso ;not found word - interpretation\r
+ DW EXECUTE ;immediate word - compilation\r
+ DW EXECUTE ;immediate word - interpretation\r
+ DW 10 ;BASE\r
+ DW CTOP ;ROMB\r
+ DW NTOP ;ROMT\r
+ DW VTOP ;RAMB\r
+ DW RAMT0 ;RAMT\r
+ DW 0 ;bal\r
+ DW 0 ;notNONAME?\r
+ DW 0 ;rakeVar\r
+NOrder0 DW 2 ;#order\r
+ DW FORTH_WORDLISTAddr ;search order stack\r
+ DW NONSTANDARD_WORDLISTAddr\r
+ DW (OrderDepth-2) DUP (0)\r
+ DW FORTH_WORDLISTAddr ;current pointer\r
+ DW LASTFORTH ;FORTH-WORDLIST\r
+ DW NONSTANDARD_WORDLISTAddr ;wordlist link\r
+ DW FORTH_WORDLISTName ;name of the WORDLIST\r
+ DW LASTSYSTEM ;NONSTANDARD-WORDLIST\r
+ DW 0 ;wordlist link\r
+ DW NONSTANDARD_WORDLISTName ;name of the WORDLIST\r
+ DW 3*(MaxWLISTS-2) DUP (0) ;wordlist area\r
+ DW LASTENV ;envQList\r
+ DW SysUserP ;user pointer\r
+ DW SysUserP ;system task's tid\r
+ DW ? ;user1\r
+ DW SystemTaskName ;taskName\r
+ DW ? ;throwFrame\r
+ DW ? ;stackTop\r
+ DW Wake ;status\r
+ DW SysStatus ;follower\r
+ DW SPP ;system task's sp0\r
+ DW RPP ;system task's rp0\r
+ULAST:\r
+\r
+; THROW code messages resides in top of name space. Messages must be\r
+; placed before any Forth words were defined.\r
+\r
+_CODE = $\r
+ORG _NAME\r
+AddrTHROWMsgTbl:\r
+ _NAME = _NAME - 58*CELLL ;number of throw messages = 58\r
+ORG _CODE\r
+ ;THROW code\r
+ $THROWMSG 'ABORT' ;-01\r
+ $THROWMSG 'ABORT"' ;-02\r
+ $THROWMSG 'stack overflow' ;-03\r
+ $THROWMSG 'stack underflow' ;-04\r
+ $THROWMSG 'return stack overflow' ;-05\r
+ $THROWMSG 'return stack underflow' ;-06\r
+ $THROWMSG 'do-loops nested too deeply during execution' ;-07\r
+ $THROWMSG 'dictionary overflow' ;-08\r
+ $THROWMSG 'invalid memory address' ;-09\r
+ $THROWMSG 'division by zero' ;-10\r
+ $THROWMSG 'result out of range' ;-11\r
+ $THROWMSG 'argument type mismatch' ;-12\r
+ $THROWMSG 'undefined word' ;-13\r
+ $THROWMSG 'interpreting a compile-only word' ;-14\r
+ $THROWMSG 'invalid FORGET' ;-15\r
+ $THROWMSG 'attempt to use zero-length string as a name' ;-16\r
+ $THROWMSG 'pictured numeric output string overflow' ;-17\r
+ $THROWMSG 'parsed string overflow' ;-18\r
+ $THROWMSG 'definition name too long' ;-19\r
+ $THROWMSG 'write to a read-only location' ;-20\r
+ $THROWMSG 'unsupported operation (e.g., AT-XY on a too-dumb terminal)' ;-21\r
+ $THROWMSG 'control structure mismatch' ;-22\r
+ $THROWMSG 'address alignment exception' ;-23\r
+ $THROWMSG 'invalid numeric argument' ;-24\r
+ $THROWMSG 'return stack imbalance' ;-25\r
+ $THROWMSG 'loop parameters unavailable' ;-26\r
+ $THROWMSG 'invalid recursion' ;-27\r
+ $THROWMSG 'user interrupt' ;-28\r
+ $THROWMSG 'compiler nesting' ;-29\r
+ $THROWMSG 'obsolescent feature' ;-30\r
+ $THROWMSG '>BODY used on non-CREATEd definition' ;-31\r
+ $THROWMSG 'invalid name argument (e.g., TO xxx)' ;-32\r
+ $THROWMSG 'block read exception' ;-33\r
+ $THROWMSG 'block write exception' ;-34\r
+ $THROWMSG 'invalid block number' ;-35\r
+ $THROWMSG 'invalid file position' ;-36\r
+ $THROWMSG 'file I/O exception' ;-37\r
+ $THROWMSG 'non-existent file' ;-38\r
+ $THROWMSG 'unexpected end of file' ;-39\r
+ $THROWMSG 'invalid BASE for floating point conversion' ;-40\r
+ $THROWMSG 'loss of precision' ;-41\r
+ $THROWMSG 'floating-point divide by zero' ;-42\r
+ $THROWMSG 'floating-point result out of range' ;-43\r
+ $THROWMSG 'floating-point stack overflow' ;-44\r
+ $THROWMSG 'floating-point stack underflow' ;-45\r
+ $THROWMSG 'floating-point invalid argument' ;-46\r
+ $THROWMSG 'compilation word list deleted' ;-47\r
+ $THROWMSG 'invalid POSTPONE' ;-48\r
+ $THROWMSG 'search-order overflow' ;-49\r
+ $THROWMSG 'search-order underflow' ;-50\r
+ $THROWMSG 'compilation word list changed' ;-51\r
+ $THROWMSG 'control-flow stack overflow' ;-52\r
+ $THROWMSG 'exception stack overflow' ;-53\r
+ $THROWMSG 'floating-point underflow' ;-54\r
+ $THROWMSG 'floating-point unidentified fault' ;-55\r
+ $THROWMSG 'QUIT' ;-56\r
+ $THROWMSG 'exception in sending or receiving a character' ;-57\r
+ $THROWMSG '[IF], [ELSE], or [THEN] exception' ;-58\r
+\r
+;;;;;;;;;;;;;;;;\r
+; System dependent words -- Must be re-definded for each system.\r
+;;;;;;;;;;;;;;;;\r
+; I/O words must be redefined if serial communication is used instead of\r
+; keyboard. Following words are for MS-DOS system.\r
+\r
+; RX? ( -- flag )\r
+; Return true if key is pressed.\r
+\r
+ $CODE 3,'RX?',RXQ,_SLINK\r
+ PUSH BX\r
+ MOV AH,0Bh ;get input status of STDIN\r
+ INT 021h\r
+ CBW\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; RX@ ( -- u )\r
+; Receive one keyboard event u.\r
+\r
+ $CODE 3,'RX@',RXFetch,_SLINK\r
+ PUSH BX\r
+ XOR BX,BX\r
+ MOV AH,08h ;MS-DOS Read Keyboard\r
+ INT 021h\r
+ ADD BL,AL ;MOV BL,AL and OR AL,AL\r
+ JNZ RXFET1 ;extended character code?\r
+ INT 021h\r
+ MOV BH,AL\r
+RXFET1: $NEXT\r
+\r
+; TX? ( -- flag )\r
+; Return true if output device is ready or device state is\r
+; indeterminate.\r
+\r
+ $CONST 3,'TX?',TXQ,TRUEE,_SLINK ;always true for MS-DOS\r
+\r
+; TX! ( u -- )\r
+; Send char to the output device.\r
+\r
+ $CODE 3,'TX!',TXStore,_SLINK\r
+ MOV DX,BX ;char in DL\r
+ MOV AH,02h ;MS-DOS Display output\r
+ INT 021H ;display character\r
+ POP BX\r
+ $NEXT\r
+\r
+; CR ( -- ) \ CORE\r
+; Carriage return and linefeed.\r
+;\r
+; : CR carriage-return-char EMIT linefeed-char EMIT ;\r
+\r
+ $COLON 2,'CR',CR,_FLINK\r
+ DW DoLIT,CRR,EMIT,DoLIT,LFF,EMIT,EXIT\r
+\r
+; BYE ( -- ) \ TOOLS EXT\r
+; Return control to the host operation system, if any.\r
+\r
+ $CODE 3,'BYE',BYE,_FLINK\r
+ MOV AX,04C00h ;close all files and\r
+ INT 021h ; return to MS-DOS\r
+ $ALIGN\r
+\r
+; hi ( -- )\r
+;\r
+; : hi CR ." hForth "\r
+; S" CPU" ENVIRONMENT? DROP TYPE SPACE\r
+; S" model" ENVIRONMENT? DROP TYPE SPACE [CHAR] v EMIT\r
+; S" version" ENVIRONMENT? DROP TYPE\r
+; ." by Wonyong Koh, 1997" CR\r
+; ." ALL noncommercial and commercial uses are granted." CR\r
+; ." Please send comment, bug report and suggestions to:" CR\r
+; ." wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr" CR ;\r
+\r
+ $COLON 2,'hi',HI,_SLINK\r
+ DW CR\r
+ $INSTR 'hForth '\r
+ DW TYPEE\r
+ $INSTR 'CPU'\r
+ DW ENVIRONMENTQuery,DROP,TYPEE,SPACE\r
+ $INSTR 'model'\r
+ DW ENVIRONMENTQuery,DROP,TYPEE,SPACE,DoLIT,'v',EMIT\r
+ $INSTR 'version'\r
+ DW ENVIRONMENTQuery,DROP,TYPEE\r
+ $INSTR ' by Wonyong Koh, 1997'\r
+ DW TYPEE,CR\r
+ $INSTR 'All noncommercial and commercial uses are granted.'\r
+ DW TYPEE,CR\r
+ $INSTR 'Please send comment, bug report and suggestions to:'\r
+ DW TYPEE,CR\r
+ $INSTR ' wykoh@pado.krict.re.kr or wykoh@hitel.kol.co.kr'\r
+ DW TYPEE,CR,EXIT\r
+\r
+; COLD ( -- )\r
+; The cold start sequence execution word.\r
+;\r
+; : COLD sysVar0 var0 [ sysVar0End sysVar0 - ] LITERAL\r
+; MOVE \ initialize system variable\r
+; xhere DUP @ \ free-ROM [free-ROM]\r
+; INVERT SWAP 2DUP ! @ XOR \ writable ROM?\r
+; IF RAMB TO cpVar RAMT TO npVar THEN\r
+; sp0 sp! rp0 rp! \ initialize stack\r
+; 'init-i/o EXECUTE\r
+; 'boot EXECUTE\r
+; QUIT ; \ start interpretation\r
+\r
+ $COLON 4,'COLD',COLD,_SLINK\r
+ DW SysVar0,VarZero,DoLIT,ULAST-UZERO,MOVE\r
+ DW XHere,DUPP,Fetch,INVERT,SWAP,TwoDUP,Store,Fetch,XORR\r
+ DW ZBranch,COLD1\r
+ DW RAMB,DoTO,AddrCPVar,RAMT,DoTO,AddrNPVar\r
+COLD1 DW SPZero,SPStore,RPZero,RPStore\r
+ DW TickINIT_IO,EXECUTE,TickBoot,EXECUTE\r
+ DW QUIT\r
+\r
+; set-i/o ( -- )\r
+; Set input/output device.\r
+;\r
+; : set-i/o sysVar0 var0 4 CELLS MOVE \ set i/o vectors\r
+; S" CON" stdin ; \ MS-DOS only\r
+\r
+ $COLON 7,'set-i/o',Set_IO,_SLINK\r
+ DW SysVar0,VarZero,DoLIT,4*CELLL,MOVE\r
+ $INSTR 'CON' ;MS-DOS only\r
+ DW STDIN ;MS-DOS only\r
+ DW EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; MS-DOS only words -- not necessary for other systems.\r
+;;;;;;;;;;;;;;;;\r
+; File input using MS-DOS redirection function without using FILE words.\r
+\r
+; redirect ( c-addr -- flag )\r
+; Redirect standard input from the device identified by ASCIIZ\r
+; string stored at c-addr. Return error code.\r
+\r
+ $CODE 8,'redirect',Redirect,_SLINK\r
+ MOV DX,BX\r
+ MOV AX,Redirect1stQ\r
+ OR AX,AX\r
+ JZ REDIRECT2\r
+ MOV AH,03Eh\r
+ MOV BX,RedirHandle\r
+ INT 021h ; close previously opend file\r
+REDIRECT2: MOV AX,03D00h ; open file read-only\r
+ MOV Redirect1stQ,AX ; set Redirect1stQ true\r
+ INT 021h\r
+ JC REDIRECT1 ; if error\r
+ MOV RedirHandle,AX\r
+ XOR CX,CX\r
+ MOV BX,AX\r
+ MOV AX,04600H\r
+ INT 021H\r
+ JC REDIRECT1\r
+ XOR AX,AX\r
+REDIRECT1: MOV BX,AX\r
+ $NEXT\r
+Redirect1stQ DW 0 ; true after the first redirection\r
+RedirHandle DW ? ; redirect file handle\r
+\r
+; asciiz ( ca1 u -- ca2 )\r
+; Return ASCIIZ string.\r
+;\r
+; : asciiz xhere SWAP 2DUP + 0 SWAP C! CHARS MOVE xhere ;\r
+\r
+ $COLON 6,'asciiz',ASCIIZ,_SLINK\r
+ DW XHere,SWAP,TwoDUP,Plus,Zero\r
+ DW SWAP,CStore,CHARS,MOVE,XHere,EXIT\r
+\r
+; stdin ( ca u -- )\r
+;\r
+; : stdin asciiz redirect ?DUP\r
+; IF -38 THROW THEN ; COMPILE-ONLY\r
+\r
+ $COLON 5,'stdin',STDIN,_SLINK\r
+ DW ASCIIZ,Redirect,QuestionDUP,ZBranch,STDIN1\r
+ DW DoLIT,-38,THROW\r
+STDIN1 DW EXIT\r
+\r
+; << ( "<spaces>ccc" -- )\r
+; Redirect input from the file 'ccc'. Should be used only in\r
+; interpretation state.\r
+;\r
+; : << STATE @ IF ." Do not use '<<' in a definition." ABORT THEN\r
+; PARSE-WORD stdin SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+ $COLON IMMED+2,'<<',FROM,_SLINK\r
+ DW STATE,Fetch,ZBranch,FROM1\r
+ DW CR\r
+ $INSTR 'Do not use << in a definition.'\r
+ DW TYPEE,ABORT\r
+FROM1 DW PARSE_WORD,STDIN,SOURCE,ToIN,Store,DROP,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Non-Standard words - Processor-dependent definitions\r
+; 16 bit Forth for 8086/8\r
+;;;;;;;;;;;;;;;;\r
+\r
+; microdebugger for debugging new hForth ports by NAC.\r
+;\r
+; The major problem with debugging Forth code at the assembler level is that\r
+; most of the definitions are lists of execution tokens that get interpreted\r
+; (using doLIST) rather than executed directly. As far as the native processor\r
+; is concerned, these xt are data, and a debugger cannot be set to trap on\r
+; them.\r
+;\r
+; The solution to that problem would seem to be to trap on the native-machine\r
+; 'call' instruction at the start of each definition. However, the threaded\r
+; nature of the code makes it very difficult to follow a particular definition\r
+; through: many definitions are used repeatedly through the code. Simply\r
+; trapping on the 'call' leads to multiple unwanted traps.\r
+;\r
+; Consider, for example, the code for doS" --\r
+;\r
+; DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT\r
+;\r
+; It would be useful to run each word in turn; at the end of each word the\r
+; effect upon the stacks could be checked until the faulty word is found.\r
+;\r
+; This technique allows you to do exactly that.\r
+;\r
+; All definitions end with $NEXT -- either directly (code definitions) or\r
+; indirectly (colon definitions terminating in EXIT, which is itself a code\r
+; definition). The action of $NEXT is to use the fpc for the next word to\r
+; fetch the xt and jumps to it.\r
+;\r
+; To use the udebug routine, replace the $NEXT expansion with a jump (not a\r
+; call) to the routine udebug (this requires you to reassemble the code)\r
+;\r
+; When you want to debug a word, trap at the CALL doLIST at the start of the\r
+; word and then load the location trapfpc with the address of the first xt\r
+; of the word. Make your debugger trap when you execute the final instruction\r
+; in the udebug routine. Now execute your code and your debugger will trap\r
+; after the completion of the first xt in the definition. To stop debugging,\r
+; simply set trapfpc to 0.\r
+;\r
+; This technique has a number of limitations:\r
+; - It is an assumption that an xt of 0 is illegal\r
+; - You cannot automatically debug a code stream that includes inline string\r
+; definitions, or any other kind of inline literal. You must step into the\r
+; word that includes the definition then hand-edit the appropriate new value\r
+; into trapfpc\r
+; Clearly, you could overcome these limitations by making udebug more\r
+; complex -- but then you run the risk of introducing bugs in that code.\r
+\r
+uDebug: MOV DI,Trapfpc\r
+ MOV AX,[DI]\r
+ CMP AX,SI ; compare the stored address with\r
+ ; the address we're about to get the\r
+ ; next xt from\r
+ JNE uDebug1 ; not the trap address, so we're done\r
+ ADD AX,CELLL ; next time trap on the next xt\r
+ MOV [DI],AX\r
+ NOP ; make debugger TRAP at this address\r
+uDebug1: LODSW\r
+ JMP AX\r
+ $ALIGN\r
+\r
+; same? ( c-addr1 c-addr2 u -- -1|0|1 )\r
+; Return 0 if two strings, ca1 u and ca2 u, are same; -1 if\r
+; string, ca1 u is smaller than ca2 u; 1 otherwise. Used by\r
+; '(search-wordlist)'. Code definition is preferred to speed up\r
+; interpretation. Colon definition is shown below.\r
+;\r
+; : same? ?DUP IF \ null strings are always same\r
+; 0 DO OVER C@ OVER C@ XOR\r
+; IF UNLOOP C@ SWAP C@ > 2* 1+ EXIT THEN\r
+; CHAR+ SWAP CHAR+ SWAP\r
+; LOOP\r
+; THEN 2DROP 0 ;\r
+;\r
+; $COLON 5,'same?',SameQ,_SLINK\r
+; DW QuestionDUP,ZBranch,SAMEQ4\r
+; DW Zero,DoDO\r
+; SAMEQ3 DW OVER,CFetch,OVER,CFetch,XORR,ZBranch,SAMEQ2\r
+; DW UNLOOP,CFetch,SWAP,CFetch,GreaterThan\r
+; DW TwoStar,OnePlus,EXIT\r
+; SAMEQ2 DW CHARPlus,SWAP,CHARPlus\r
+; DW DoLOOP,SAMEQ3\r
+; SAMEQ4 DW TwoDROP,Zero,EXIT\r
+\r
+ $CODE 5,'same?',SameQ,_SLINK\r
+ MOV CX,BX\r
+ MOV AX,DS\r
+ MOV ES,AX\r
+ MOV DX,SI ;save SI\r
+ MOV BX,-1\r
+ POP DI\r
+ POP SI\r
+ OR CX,CX\r
+ JZ SAMEQ5\r
+ REPE CMPSB\r
+ JL SAMEQ1\r
+ JZ SAMEQ5\r
+ INC BX\r
+SAMEQ5: INC BX\r
+SAMEQ1: MOV SI,DX\r
+ $NEXT\r
+\r
+; (search-wordlist) ( c-addr u wid -- 0 | xt f 1 | xt f -1)\r
+; Search word list for a match with the given name.\r
+; Return execution token and not-compile-only flag and\r
+; -1 or 1 ( IMMEDIATE) if found. Return 0 if not found.\r
+;\r
+; format is: wid---->[ a ]\r
+; |\r
+; V\r
+; [ xt' ][ a' ][ccbbaann][ggffeedd]...\r
+; |\r
+; +--------+\r
+; V\r
+; [ xt'' ][ a'' ][ccbbaann][ggffeedd]...\r
+;\r
+; a, a' etc. point to the cell that contains the name of the\r
+; word. The length is in the low byte of the cell (little byte\r
+; for little-endian, big byte for big-endian).\r
+; Eventually, a''' contains 0 to indicate the end of the wordlist\r
+; (oldest entry). a=0 indicates an empty wordlist.\r
+; xt is the xt of the word. aabbccddeedd etc. is the name of\r
+; the word, packed into cells.\r
+;\r
+; : (search-wordlist)\r
+; ROT >R SWAP DUP 0= IF -16 THROW THEN\r
+; \ attempt to use zero-length string as a name\r
+; >R \ wid R: ca1 u\r
+; BEGIN @ \ ca2 R: ca1 u\r
+; DUP 0= IF R> R> 2DROP EXIT THEN \ not found\r
+; DUP COUNT [ =MASK ] LITERAL AND R@ = \ ca2 ca2+char f\r
+; IF R> R@ SWAP DUP >R \ ca2 ca2+char ca1 u\r
+; same? \ ca2 flag\r
+; \ ELSE DROP -1 \ unnecessary since ca2+char is not 0.\r
+; THEN\r
+; WHILE cell- \ pointer to next word in wordlist\r
+; REPEAT\r
+; R> R> 2DROP DUP name>xt SWAP \ xt ca2\r
+; C@ DUP [ =COMP ] LITERAL AND 0= SWAP\r
+; [ =IMED ] LITERAL AND 0= 2* 1+ ;\r
+;\r
+; $COLON 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK\r
+; DW ROT,ToR,SWAP,DUPP,ZBranch,PSRCH6\r
+; DW ToR\r
+; PSRCH1 DW Fetch\r
+; DW DUPP,ZBranch,PSRCH9\r
+; DW DUPP,COUNT,DoLIT,MASKK,ANDD,RFetch,Equals\r
+; DW ZBranch,PSRCH5\r
+; DW RFrom,RFetch,SWAP,DUPP,ToR,SameQ\r
+; PSRCH5 DW ZBranch,PSRCH3\r
+; DW CellMinus,Branch,PSRCH1\r
+; PSRCH3 DW RFrom,RFrom,TwoDROP,DUPP,NameToXT,SWAP\r
+; DW CFetch,DUPP,DoLIT,COMPO,ANDD,ZeroEquals,SWAP\r
+; DW DoLIT,IMMED,ANDD,ZeroEquals,TwoStar,OnePlus,EXIT\r
+; PSRCH9 DW RFrom,RFrom,TwoDROP,EXIT\r
+; PSRCH6 DW DoLIT,-16,THROW\r
+\r
+ $CODE 17,'(search-wordlist)',ParenSearch_Wordlist,_SLINK\r
+ POP AX ;u\r
+ POP DX ;c-addr\r
+ OR AX,AX\r
+ JZ PSRCH1\r
+ PUSH SI\r
+ MOV CX,DS\r
+ MOV ES,CX\r
+ SUB CX,CX\r
+PSRCH2: MOV BX,[BX]\r
+ OR BX,BX\r
+ JZ PSRCH4 ; end of wordlist?\r
+ MOV CL,[BX]\r
+ SUB BX,CELLL ;pointer to nextword\r
+ AND CL,MASKK ;max name length = MASKK\r
+ CMP CL,AL\r
+ JNZ PSRCH2\r
+ MOV SI,DX\r
+ MOV DI,BX\r
+ ADD DI,CELLL+CHARR\r
+ REPE CMPSB\r
+ JNZ PSRCH2\r
+ POP SI\r
+ PUSH [BX-CELLL] ;xt\r
+ MOV CL,[BX+CELLL]\r
+ XOR DX,DX\r
+ TEST CL,COMPO\r
+ JNZ PSRCH5\r
+ DEC DX\r
+PSRCH5: PUSH DX\r
+ TEST CL,IMMED\r
+ MOV BX,-1\r
+ JZ PSRCH3\r
+ NEG BX\r
+PSRCH3: $NEXT\r
+PSRCH1: MOV BX,-16 ;attempt to use zero-length string as a name\r
+ JMP THROW\r
+PSRCH4: POP SI\r
+ $NEXT\r
+\r
+; ?call ( xt1 -- xt1 0 | a-addr xt2 )\r
+; Return xt of the CALLed run-time word if xt starts with machine\r
+; CALL instruction and leaves the next cell address after the\r
+; CALL instruction. Otherwise leaves the original xt1 and zero.\r
+;\r
+; : ?call DUP @ call-code =\r
+; IF CELL+ DUP @ SWAP CELL+ DUP ROT + EXIT THEN\r
+; \ Direct Threaded Code 8086 relative call\r
+; 0 ;\r
+\r
+ $COLON 5,'?call',QCall,_SLINK\r
+ DW DUPP,Fetch,DoLIT,CALLL,Equals,ZBranch,QCALL1\r
+ DW CELLPlus,DUPP,Fetch,SWAP,CELLPlus,DUPP,ROT,Plus,EXIT\r
+QCALL1 DW Zero,EXIT\r
+\r
+; xt, ( xt1 -- xt2 )\r
+; Take a run-time word xt1 for :NONAME , CONSTANT , VARIABLE and\r
+; CREATE . Return xt2 of current definition.\r
+;\r
+; : xt, xhere ALIGNED DUP TOxhere SWAP\r
+; call-code code, \ Direct Threaded Code\r
+; xhere CELL+ - code, ; \ 8086 relative call\r
+\r
+ $COLON 3,'xt,',xtComma,_SLINK\r
+ DW XHere,ALIGNED,DUPP,TOXHere,SWAP\r
+ DW DoLIT,CALLL,CodeComma\r
+ DW XHere,CELLPlus,Minus,CodeComma,EXIT\r
+\r
+; doLIT ( -- x )\r
+; Push an inline literal. The inline literal is at the current\r
+; value of the fpc, so put it onto the stack and point past it.\r
+\r
+ $CODE COMPO+5,'doLIT',DoLIT,_SLINK\r
+ PUSH BX\r
+ LODSW\r
+ MOV BX,AX\r
+ $NEXT\r
+\r
+; doCONST ( -- x )\r
+; Run-time routine of CONSTANT and VARIABLE. When you quote a\r
+; constant or variable you execute its code, which consists of a\r
+; call to here, followed by an inline literal. The literal is a\r
+; constant (for a CONSTANT) or the address at which a VARIABLE's\r
+; value is stored. Although you come here as the result of a\r
+; native machine call, you never go back to the return address\r
+; -- you jump back up a level by continuing at the new fpc value.\r
+; For 8086, Z80 the inline literal is at the return address\r
+; stored on the top of the hardware stack.\r
+\r
+ $CODE COMPO+7,'doCONST',DoCONST,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; doVALUE ( -- x )\r
+; Run-time routine of VALUE. Return the value of VALUE word.\r
+; This is like an invocation of doCONST for a VARIABLE but\r
+; instead of returning the address of the variable, we return\r
+; the value of the variable -- in other words, there is another\r
+; level of indirection.\r
+\r
+ $CODE COMPO+7,'doVALUE',DoVALUE,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,[BX]\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; doCREATE ( -- a-addr )\r
+; Run-time routine of CREATE. For CREATEd words with an\r
+; associated DOES>, get the address of the CREATEd word's data\r
+; space and execute the DOES> actions. For CREATEd word without\r
+; an associated DOES>, return the address of the CREATE'd word's\r
+; data space. A CREATEd word starts its execution through this\r
+; routine in exactly the same way as a colon definition uses\r
+; doLIST. In other words, we come here through a native machine\r
+; branch.\r
+;\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | a-addr |\r
+;\r
+; The DOES> address holds a native call to doLIST. This routine\r
+; doesn't alter the fpc. We never come back *here* so we never\r
+; need to preserve an address that would bring us back *here*.\r
+;\r
+; Example : myVARIABLE CREATE , DOES> ;\r
+; 56 myVARIABLE JIM\r
+; JIM \ stacks the address of the data cell that contains 56\r
+;\r
+; : doCREATE SWAP \ switch BX and top of 8086 stack item\r
+; DUP CELL+ @ SWAP @ ?DUP IF EXECUTE THEN ; COMPILE-ONLY\r
+;\r
+; $COLON COMPO+8,'doCREATE',DoCREATE,_SLINK\r
+; DW SWAP,DUPP,CELLPlus,Fetch,SWAP,Fetch,QuestionDUP\r
+; DW ZBranch,DOCREAT1\r
+; DW EXECUTE\r
+; DOCREAT1: DW EXIT\r
+\r
+ $CODE COMPO+8,'doCREATE',DoCREATE,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV AX,[BX]\r
+ MOV BX,[BX+CELLL]\r
+ OR AX,AX\r
+ JNZ DOCREAT1\r
+ $NEXT\r
+DOCREAT1: JMP AX\r
+ $ALIGN\r
+\r
+; doTO ( x -- )\r
+; Run-time routine of TO. Store x at the address in the\r
+; following cell. The inline literal holds the address\r
+; to be modified.\r
+\r
+ $CODE COMPO+4,'doTO',DoTO,_SLINK\r
+ LODSW\r
+ XCHG BX,AX\r
+ MOV [BX],AX\r
+ POP BX\r
+ $NEXT\r
+\r
+; doUSER ( -- a-addr )\r
+; Run-time routine of USER. Return address of data space.\r
+; This is like doCONST but a variable offset is added to the\r
+; result. By changing the value at AddrUserP (which happens\r
+; on a taskswap) the whole set of user variables is switched\r
+; to the set for the new task.\r
+\r
+ $CODE COMPO+6,'doUSER',DoUSER,_SLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ MOV BX,[BX]\r
+ ADD BX,AddrUserP\r
+ $NEXT\r
+\r
+; doLIST ( -- ) ( R: -- nest-sys )\r
+; Process colon list.\r
+; The first word of a definition (the xt for the word) is a\r
+; native machine-code instruction for the target machine. For\r
+; high-level definitions, that code is emitted by xt, and\r
+; performs a call to doLIST. doLIST executes the list of xt that\r
+; make up the definition. The final xt in the definition is EXIT.\r
+; The address of the first xt to be executed is passed to doLIST\r
+; in a target-specific way. Two examples:\r
+; Z80, 8086: native machine call, leaves the return address on\r
+; the hardware stack pointer, which is used for the data stack.\r
+\r
+ $CODE COMPO+6,'doLIST',DoLIST,_SLINK\r
+ SUB BP,2\r
+ MOV [BP],SI ;push return stack\r
+ POP SI ;new list address\r
+ $NEXT\r
+\r
+; doLOOP ( -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Run time routine for LOOP.\r
+\r
+ $CODE COMPO+6,'doLOOP',DoLOOP,_SLINK\r
+ INC WORD PTR [BP] ;increase loop count\r
+ JO DoLOOP1 ;?loop end\r
+ MOV SI,[SI] ;no, go back\r
+ $NEXT\r
+DoLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+ ADD BP,2*CELLL ;clear return stack\r
+ $NEXT\r
+\r
+; do+LOOP ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Run time routine for +LOOP.\r
+\r
+ $CODE COMPO+7,'do+LOOP',DoPLOOP,_SLINK\r
+ ADD WORD PTR [BP],BX ;increase loop count\r
+ JO DoPLOOP1 ;?loop end\r
+ MOV SI,[SI] ;no, go back\r
+ POP BX\r
+ $NEXT\r
+DoPLOOP1: ADD SI,CELLL ;yes, continue past the branch offset\r
+ ADD BP,2*CELLL ;clear return stack\r
+ POP BX\r
+ $NEXT\r
+\r
+; 0branch ( flag -- )\r
+; Branch if flag is zero.\r
+\r
+ $CODE COMPO+7,'0branch',ZBranch,_SLINK\r
+ OR BX,BX ;?flag=0\r
+ JZ ZBRAN1 ;yes, so branch\r
+ ADD SI,CELLL ;point IP to next cell\r
+ POP BX\r
+ $NEXT\r
+ZBRAN1: MOV SI,[SI] ;IP:=(IP)\r
+ POP BX\r
+ $NEXT\r
+\r
+; branch ( -- )\r
+; Branch to an inline address.\r
+\r
+ $CODE COMPO+6,'branch',Branch,_SLINK\r
+ MOV SI,[SI] ;IP:=(IP)\r
+ $NEXT\r
+\r
+; rp@ ( -- a-addr )\r
+; Push the current RP to the data stack.\r
+\r
+ $CODE COMPO+3,'rp@',RPFetch,_SLINK\r
+ PUSH BX\r
+ MOV BX,BP\r
+ $NEXT\r
+\r
+; rp! ( a-addr -- )\r
+; Set the return stack pointer.\r
+\r
+ $CODE COMPO+3,'rp!',RPStore,_SLINK\r
+ MOV BP,BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; sp@ ( -- a-addr )\r
+; Push the current data stack pointer.\r
+\r
+ $CODE 3,'sp@',SPFetch,_SLINK\r
+ PUSH BX\r
+ MOV BX,SP\r
+ $NEXT\r
+\r
+; sp! ( a-addr -- )\r
+; Set the data stack pointer.\r
+\r
+ $CODE 3,'sp!',SPStore,_SLINK\r
+ MOV SP,BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; um+ ( u1 u2 -- u3 1|0 )\r
+; Add two unsigned numbers, return the sum and carry.\r
+\r
+ $CODE 3,'um+',UMPlus,_SLINK\r
+ XOR CX,CX\r
+ POP AX\r
+ ADD BX,AX\r
+ PUSH BX ;push sum\r
+ RCL CX,1 ;get carry\r
+ MOV BX,CX\r
+ $NEXT\r
+\r
+; 1chars/ ( n1 -- n2 )\r
+; Calculate number of chars for n1 address units.\r
+;\r
+; : 1chars/ 1 CHARS / ; \ slow, very portable\r
+; : 1chars/ ; \ fast, must be redefined for each system\r
+\r
+ $COLON 7,'1chars/',OneCharsSlash,_SLINK\r
+ DW EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Standard words - Processor-dependent definitions\r
+; 16 bit Forth for 8086/8\r
+;;;;;;;;;;;;;;;;\r
+\r
+; ALIGN ( -- ) \ CORE\r
+; Align the data space pointer.\r
+;\r
+; : ALIGN hereVar DUP @ ALIGNED SWAP ! ;\r
+\r
+ $COLON 5,'ALIGN',ALIGNN,_FLINK\r
+ DW HereVar,DUPP,Fetch,ALIGNED,SWAP,Store,EXIT\r
+\r
+; ALIGNED ( addr -- a-addr ) \ CORE\r
+; Align address to the cell boundary.\r
+;\r
+; : ALIGNED DUP 0 cell-size UM/MOD DROP DUP\r
+; IF cell-size SWAP - THEN + ; \ slow, very portable\r
+;\r
+; $COLON 7,'ALIGNED',ALIGNED,_FLINK\r
+; DW DUPP,Zero,DoLIT,CELLL\r
+; DW UMSlashMOD,DROP,DUPP\r
+; DW ZBranch,ALGN1\r
+; DW DoLIT,CELLL,SWAP,Minus\r
+; ALGN1 DW Plus,EXIT\r
+\r
+ $CODE 7,'ALIGNED',ALIGNED,_FLINK\r
+ INC BX\r
+ AND BX,0FFFEh\r
+ $NEXT\r
+\r
+; pack" is dependent of cell alignment.\r
+;\r
+; pack" ( c-addr u a-addr -- a-addr2 )\r
+; Place a string c-addr u at a-addr and gives the next\r
+; cell-aligned address. Fill the rest of the last cell with\r
+; null character.\r
+;\r
+; : pack" 2DUP SWAP CHARS + CHAR+ DUP >R \ ca u aa aa+u+1\r
+; 1 CHARS - 0 SWAP ! \ fill 0 at the end of string\r
+; 2DUP C! CHAR+ SWAP \ c-addr a-addr+1 u\r
+; CHARS MOVE R> ; COMPILE-ONLY\r
+\r
+ $COLON 5,'pack"',PackQuote,_SLINK\r
+ DW TwoDUP,SWAP,CHARS,Plus,CHARPlus,DUPP,ToR\r
+ DW DoLIT,CHARR,Minus,Zero,SWAP,Store\r
+ DW TwoDUP,CStore,CHARPlus,SWAP\r
+ DW CHARS,MOVE,RFrom,EXIT\r
+\r
+; CELLS ( n1 -- n2 ) \ CORE\r
+; Calculate number of address units for n1 cells.\r
+;\r
+; : CELLS cell-size * ; \ slow, very portable\r
+; : CELLS 2* ; \ fast, must be redefined for each system\r
+\r
+ $COLON 5,'CELLS',CELLS,_FLINK\r
+ DW TwoStar,EXIT\r
+\r
+; CHARS ( n1 -- n2 ) \ CORE\r
+; Calculate number of address units for n1 characters.\r
+;\r
+; : CHARS char-size * ; \ slow, very portable\r
+; : CHARS ; \ fast, must be redefined for each system\r
+\r
+ $COLON 5,'CHARS',CHARS,_FLINK\r
+ DW EXIT\r
+\r
+; ! ( x a-addr -- ) \ CORE\r
+; Store x at a aligned address.\r
+\r
+ $CODE 1,'!',Store,_FLINK\r
+ POP [BX]\r
+ POP BX\r
+ $NEXT\r
+\r
+; 0< ( n -- flag ) \ CORE\r
+; Return true if n is negative.\r
+\r
+ $CODE 2,'0<',ZeroLess,_FLINK\r
+ MOV AX,BX\r
+ CWD ;sign extend\r
+ MOV BX,DX\r
+ $NEXT\r
+\r
+; 0= ( x -- flag ) \ CORE\r
+; Return true if x is zero.\r
+\r
+ $CODE 2,'0=',ZeroEquals,_FLINK\r
+ OR BX,BX\r
+ MOV BX,TRUEE\r
+ JZ ZEQUAL1\r
+ INC BX\r
+ZEQUAL1: $NEXT\r
+\r
+; 2* ( x1 -- x2 ) \ CORE\r
+; Bit-shift left, filling the least significant bit with 0.\r
+\r
+ $CODE 2,'2*',TwoStar,_FLINK\r
+ SHL BX,1\r
+ $NEXT\r
+\r
+; 2/ ( x1 -- x2 ) \ CORE\r
+; Bit-shift right, leaving the most significant bit unchanged.\r
+\r
+ $CODE 2,'2/',TwoSlash,_FLINK\r
+ SAR BX,1\r
+ $NEXT\r
+\r
+; >R ( x -- ) ( R: -- x ) \ CORE\r
+; Move top of the data stack item to the return stack.\r
+\r
+ $CODE COMPO+2,'>R',ToR,_FLINK\r
+ SUB BP,CELLL ;adjust RP\r
+ MOV [BP],BX\r
+ POP BX\r
+ $NEXT\r
+\r
+; @ ( a-addr -- x ) \ CORE\r
+; Push the contents at a-addr to the data stack.\r
+\r
+ $CODE 1,'@',Fetch,_FLINK\r
+ MOV BX,[BX]\r
+ $NEXT\r
+\r
+; AND ( x1 x2 -- x3 ) \ CORE\r
+; Bitwise AND.\r
+\r
+ $CODE 3,'AND',ANDD,_FLINK\r
+ POP AX\r
+ AND BX,AX\r
+ $NEXT\r
+\r
+; C! ( char c-addr -- ) \ CORE\r
+; Store char at c-addr.\r
+\r
+ $CODE 2,'C!',CStore,_FLINK\r
+ POP AX\r
+ MOV [BX],AL\r
+ POP BX\r
+ $NEXT\r
+\r
+; C@ ( c-addr -- char ) \ CORE\r
+; Fetch the character stored at c-addr.\r
+\r
+ $CODE 2,'C@',CFetch,_FLINK\r
+ MOV BL,[BX]\r
+ XOR BH,BH\r
+ $NEXT\r
+\r
+; DROP ( x -- ) \ CORE\r
+; Discard top stack item.\r
+\r
+ $CODE 4,'DROP',DROP,_FLINK\r
+ POP BX\r
+ $NEXT\r
+\r
+; DUP ( x -- x x ) \ CORE\r
+; Duplicate the top stack item.\r
+\r
+ $CODE 3,'DUP',DUPP,_FLINK\r
+ PUSH BX\r
+ $NEXT\r
+\r
+; EXECUTE ( i*x xt -- j*x ) \ CORE\r
+; Perform the semantics indentified by execution token, xt.\r
+\r
+ $CODE 7,'EXECUTE',EXECUTE,_FLINK\r
+ MOV AX,BX\r
+ POP BX\r
+ JMP AX ;jump to the code address\r
+ $ALIGN\r
+\r
+; EXIT ( -- ) ( R: nest-sys -- ) \ CORE\r
+; Return control to the calling definition.\r
+\r
+ $CODE COMPO+4,'EXIT',EXIT,_FLINK\r
+ XCHG BP,SP ;exchange pointers\r
+ POP SI ;pop return stack\r
+ XCHG BP,SP ;restore the pointers\r
+ $NEXT\r
+\r
+; MOVE ( addr1 addr2 u -- ) \ CORE\r
+; Copy u address units from addr1 to addr2 if u is greater\r
+; than zero. This word is CODE defined since no other Standard\r
+; words can handle address unit directly.\r
+\r
+ $CODE 4,'MOVE',MOVE,_FLINK\r
+ POP DI\r
+ POP DX\r
+ OR BX,BX\r
+ JZ MOVE2\r
+ MOV CX,BX\r
+ XCHG DX,SI ;save SI\r
+ MOV AX,DS\r
+ MOV ES,AX ;set ES same as DS\r
+ CMP SI,DI\r
+ JC MOVE1\r
+ REP MOVSB\r
+ MOV SI,DX\r
+MOVE2: POP BX\r
+ $NEXT\r
+MOVE1: STD\r
+ ADD DI,CX\r
+ DEC DI\r
+ ADD SI,CX\r
+ DEC SI\r
+ REP MOVSB\r
+ CLD\r
+ MOV SI,DX\r
+ POP BX\r
+ $NEXT\r
+\r
+; OR ( x1 x2 -- x3 ) \ CORE\r
+; Return bitwise inclusive-or of x1 with x2.\r
+\r
+ $CODE 2,'OR',ORR,_FLINK\r
+ POP AX\r
+ OR BX,AX\r
+ $NEXT\r
+\r
+; OVER ( x1 x2 -- x1 x2 x1 ) \ CORE\r
+; Copy second stack item to top of the stack.\r
+\r
+ $CODE 4,'OVER',OVER,_FLINK\r
+ MOV DI,SP\r
+ PUSH BX\r
+ MOV BX,[DI]\r
+ $NEXT\r
+\r
+; R> ( -- x ) ( R: x -- ) \ CORE\r
+; Move x from the return stack to the data stack.\r
+\r
+ $CODE COMPO+2,'R>',RFrom,_FLINK\r
+ PUSH BX\r
+ MOV BX,[BP]\r
+ ADD BP,CELLL ;adjust RP\r
+ $NEXT\r
+\r
+; R@ ( -- x ) ( R: x -- x ) \ CORE\r
+; Copy top of return stack to the data stack.\r
+\r
+ $CODE COMPO+2,'R@',RFetch,_FLINK\r
+ PUSH BX\r
+ MOV BX,[BP]\r
+ $NEXT\r
+\r
+; SWAP ( x1 x2 -- x2 x1 ) \ CORE\r
+; Exchange top two stack items.\r
+\r
+ $CODE 4,'SWAP',SWAP,_FLINK\r
+ MOV DI,SP\r
+ XCHG BX,[DI]\r
+ $NEXT\r
+\r
+; XOR ( x1 x2 -- x3 ) \ CORE\r
+; Bitwise exclusive OR.\r
+\r
+ $CODE 3,'XOR',XORR,_FLINK\r
+ POP AX\r
+ XOR BX,AX\r
+ $NEXT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; System constants and variables\r
+;;;;;;;;;;;;;;;;\r
+\r
+; var0 ( -- a-addr )\r
+; Start of system variable area.\r
+\r
+ $CONST 4,'var0',VarZero,RAM0,_SLINK\r
+\r
+; sysVar0 ( -- a-addr )\r
+; Start of initial value table of system variables.\r
+\r
+ $CONST 7,'sysVar0',SysVar0,UZERO,_SLINK\r
+\r
+; sysVar0End ( -- a-addr )\r
+; End of initial value table of system variables.\r
+\r
+ $CONST 10,'sysVar0End',SysVar0End,ULAST,_SLINK\r
+\r
+; 'ekey? ( -- a-addr )\r
+; Execution vector of EKEY?.\r
+\r
+ $VALUE 6,"'ekey?",TickEKEYQ,_SLINK\r
+\r
+; 'ekey ( -- a-addr )\r
+; Execution vector of EKEY.\r
+\r
+ $VALUE 5,"'ekey",TickEKEY,_SLINK\r
+\r
+; 'emit? ( -- a-addr )\r
+; Execution vector of EMIT?.\r
+\r
+ $VALUE 6,"'emit?",TickEMITQ,_SLINK\r
+\r
+; 'emit ( -- a-addr )\r
+; Execution vector of EMIT.\r
+\r
+ $VALUE 5,"'emit",TickEMIT,_SLINK\r
+\r
+; 'init-i/o ( -- a-addr )\r
+; Execution vector to initialize input/output devices.\r
+\r
+ $VALUE 9,"'init-i/o",TickINIT_IO,_SLINK\r
+\r
+; 'prompt ( -- a-addr )\r
+; Execution vector of '.prompt'.\r
+\r
+ $VALUE 7,"'prompt",TickPrompt,_SLINK\r
+\r
+; 'boot ( -- a-addr )\r
+; Execution vector of COLD.\r
+\r
+ $VALUE 5,"'boot",TickBoot,_SLINK\r
+\r
+; SOURCE-ID ( -- 0 | -1 ) \ CORE EXT\r
+; Identify the input source. -1 for string (via EVALUATE) and\r
+; 0 for user input device.\r
+\r
+ $VALUE 9,'SOURCE-ID',SOURCE_ID,_FLINK\r
+AddrSOURCE_ID EQU _VAR -CELLL\r
+\r
+; cpVar ( -- a-addr )\r
+; Point to the top of the code dictionary.\r
+\r
+ $VALUE 5,'cpVar',CPVar,_SLINK\r
+AddrCPVar EQU _VAR -CELLL\r
+\r
+; npVar ( -- a-addr )\r
+; Point to the bottom of the name dictionary.\r
+\r
+ $VALUE 5,'npVar',NPVar,_SLINK\r
+AddrNPVar EQU _VAR -CELLL\r
+\r
+; hereVar ( -- a-addr )\r
+; Point to the RAM/ROM data space pointer. Used by , or ALLOT.\r
+\r
+ $VALUE 7,'hereVar',HereVar,_SLINK\r
+AddrHereVar EQU _VAR -CELLL\r
+\r
+; 'doWord ( -- a-addr )\r
+; Execution vectors for 'interpret'.\r
+\r
+ $VAR 7,"'doWord",TickDoWord,_SLINK\r
+ _VAR = _VAR +5*CELLL\r
+\r
+; BASE ( -- a-addr ) \ CORE\r
+; Return the address of the radix base for numeric I/O.\r
+\r
+ $VAR 4,'BASE',BASE,_FLINK\r
+\r
+; THROWMsgTbl ( -- a-addr ) \ CORE\r
+; Return the address of the THROW message table.\r
+\r
+ $CONST 11,'THROWMsgTbl',THROWMsgTbl,AddrTHROWMsgTbl,_SLINK\r
+\r
+; ROMB ( -- a-addr )\r
+; Bottom of free ROM area.\r
+\r
+ $VAR 4,'ROMB',ROMB,_SLINK\r
+AddrROMB EQU _VAR -CELLL\r
+\r
+; ROMT ( -- a-addr )\r
+; Top of free ROM area.\r
+\r
+ $VAR 4,'ROMT',ROMT,_SLINK\r
+AddrROMT EQU _VAR -CELLL\r
+\r
+; RAMB ( -- a-addr )\r
+; Bottom of free RAM area.\r
+\r
+ $VAR 4,'RAMB',RAMB,_SLINK\r
+AddrRAMB EQU _VAR -CELLL\r
+\r
+; RAMT ( -- a-addr )\r
+; Top of free RAM area.\r
+\r
+ $VAR 4,'RAMT',RAMT,_SLINK\r
+AddrRAMT EQU _VAR -CELLL\r
+\r
+; bal ( -- n )\r
+; Return the depth of control-flow stack.\r
+\r
+ $VALUE 3,'bal',Bal,_SLINK\r
+AddrBal EQU _VAR -CELLL\r
+\r
+; notNONAME? ( -- f )\r
+; Used by ';' whether to do 'linkLast' or not\r
+\r
+ $VALUE 10,'notNONAME?',NotNONAMEQ,_SLINK\r
+AddrNotNONAMEQ EQU _VAR -CELLL\r
+\r
+; rakeVar ( -- a-addr )\r
+; Used by 'rake' to gather LEAVE.\r
+\r
+ $VAR 7,'rakeVar',RakeVar,_SLINK\r
+\r
+; #order ( -- a-addr )\r
+; Hold the search order stack depth.\r
+\r
+ $VAR 6,'#order',NumberOrder,_SLINK\r
+ _VAR = _VAR +OrderDepth*CELLL ;search order stack\r
+\r
+; current ( -- a-addr )\r
+; Point to the wordlist to be extended.\r
+\r
+ $VAR 7,'current',Current,_SLINK\r
+\r
+; FORTH-WORDLIST ( -- wid ) \ SEARCH\r
+; Return wid of Forth wordlist.\r
+\r
+ $VAR 14,'FORTH-WORDLIST',FORTH_WORDLIST,_FLINK\r
+FORTH_WORDLISTAddr EQU _VAR -CELLL\r
+FORTH_WORDLISTName EQU _NAME +2*CELLL\r
+\r
+ _VAR = _VAR +2*CELLL\r
+\r
+; NONSTANDARD-WORDLIST ( -- wid )\r
+; Return wid of non-standard wordlist.\r
+\r
+ $VAR 20,'NONSTANDARD-WORDLIST',NONSTANDARD_WORDLIST,_FLINK\r
+NONSTANDARD_WORDLISTAddr EQU _VAR -CELLL\r
+NONSTANDARD_WORDLISTName EQU _NAME +2*CELLL\r
+\r
+ _VAR = _VAR +2*CELLL\r
+ _VAR = _VAR +3*(MaxWLISTS-2)*CELLL\r
+\r
+; envQList ( -- wid )\r
+; Return wid of ENVIRONMENT? string list. Never put this wid in\r
+; search-order. It should be used only by SET-CURRENT to add new\r
+; environment query string after addition of a complete wordset.\r
+\r
+ $VAR 8,'envQList',EnvQList,_SLINK\r
+\r
+; userP ( -- a-addr )\r
+; Return address of USER variable area of current task.\r
+\r
+ $VAR 5,'userP',UserP,_SLINK\r
+_CODE = $\r
+ORG _VAR -CELLL\r
+AddrUserP DW ?\r
+ORG _CODE\r
+\r
+SysTask EQU _VAR-0\r
+ _VAR = _VAR + CELLL\r
+\r
+SysUser1 EQU _VAR-0 ;user1\r
+ _VAR = _VAR + CELLL\r
+SysTaskName EQU _VAR-0 ;taskName\r
+ _VAR = _VAR + CELLL\r
+SysThrowFrame EQU _VAR-0 ;throwFrame\r
+ _VAR = _VAR + CELLL\r
+SysStackTop EQU _VAR-0 ;stackTop\r
+ _VAR = _VAR + CELLL\r
+SysStatus EQU _VAR-0 ;status\r
+ _VAR = _VAR + CELLL\r
+SysUserP EQU _VAR-0\r
+SysFollower EQU _VAR-0 ;follower\r
+ _VAR = _VAR + CELLL\r
+ _VAR = _VAR + CELLL ;SP0 for system task\r
+ _VAR = _VAR + CELLL ;RP0 for system task\r
+\r
+; SystemTask ( -- a-addr )\r
+; Return system task's tid.\r
+\r
+ $CONST 10,'SystemTask',SystemTask,SysTask,_SLINK\r
+SystemTaskName EQU _NAME-0\r
+\r
+; follower ( -- a-addr )\r
+; Point next task's 'status' USER variable.\r
+\r
+ $USER 8,'follower',Follower,SysFollower-SysUserP,_SLINK\r
+\r
+; status ( -- a-addr )\r
+; Status of current task. Point 'pass' or 'wake'.\r
+\r
+ $USER 6,'status',Status,SysStatus-SysUserP,_SLINK\r
+\r
+; stackTop ( -- a-addr )\r
+; Store current task's top of stack position.\r
+\r
+ $USER 8,'stackTop',StackTop,SysStackTop-SysUserP,_SLINK\r
+\r
+; throwFrame ( -- a-addr )\r
+; THROW frame for CATCH and THROW need to be saved for eack task.\r
+\r
+ $USER 10,'throwFrame',ThrowFrame,SysThrowFrame-SysUserP,_SLINK\r
+\r
+; taskName ( -- a-addr )\r
+; Current task's task ID.\r
+\r
+ $USER 8,'taskName',TaskName,SysTaskName-SysUserP,_SLINK\r
+\r
+; user1 ( -- a-addr )\r
+; One free USER variable for each task.\r
+\r
+ $USER 5,'user1',User1,SysUser1-SysUserP,_SLINK\r
+\r
+; ENVIRONMENT? strings can be searched using SEARCH-WORDLIST and can be\r
+; EXECUTEd. This wordlist is completely hidden to Forth system except\r
+; ENVIRONMENT? .\r
+\r
+ $ENVIR 3,'CPU'\r
+ DW DoLIT,CPUStr,COUNT,EXIT\r
+\r
+ $ENVIR 5,'model'\r
+ DW DoLIT,ModelStr,COUNT,EXIT\r
+\r
+ $ENVIR 7,'version'\r
+ DW DoLIT,VersionStr,COUNT,EXIT\r
+\r
+ $ENVIR 15,'/COUNTED-STRING'\r
+ DW DoLIT,MaxChar,EXIT\r
+\r
+ $ENVIR 5,'/HOLD'\r
+ DW DoLIT,PADSize,EXIT\r
+\r
+ $ENVIR 4,'/PAD'\r
+ DW DoLIT,PADSize,EXIT\r
+\r
+ $ENVIR 17,'ADDRESS-UNIT-BITS'\r
+ DW DoLIT,8,EXIT\r
+\r
+ $ENVIR 4,'CORE'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 7,'FLOORED'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 8,'MAX-CHAR'\r
+ DW DoLIT,MaxChar,EXIT ;max value of character set\r
+\r
+ $ENVIR 5,'MAX-D'\r
+ DW DoLIT,MaxUnsigned,DoLIT,MaxSigned,EXIT\r
+\r
+ $ENVIR 5,'MAX-N'\r
+ DW DoLIT,MaxSigned,EXIT\r
+\r
+ $ENVIR 5,'MAX-U'\r
+ DW DoLIT,MaxUnsigned,EXIT\r
+\r
+ $ENVIR 6,'MAX-UD'\r
+ DW DoLIT,MaxUnsigned,DoLIT,MaxUnsigned,EXIT\r
+\r
+ $ENVIR 18,'RETURN-STACK-CELLS'\r
+ DW DoLIT,RTCells,EXIT\r
+\r
+ $ENVIR 11,'STACK-CELLS'\r
+ DW DoLIT,DTCells,EXIT\r
+\r
+ $ENVIR 9,'EXCEPTION'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 13,'EXCEPTION-EXT'\r
+ DW DoLIT,TRUEE,EXIT\r
+\r
+ $ENVIR 9,'WORDLISTS'\r
+ DW DoLIT,OrderDepth,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Non-Standard words - Colon definitions\r
+;;;;;;;;;;;;;;;;\r
+\r
+; (') ( "<spaces>name" -- xt 1 | xt -1 )\r
+; Parse a name, find it and return execution token and\r
+; -1 or 1 ( IMMEDIATE) if found\r
+;\r
+; : (') PARSE-WORD search-word ?DUP IF NIP EXIT THEN\r
+; errWord 2! \ if not found error\r
+; -13 THROW ; \ undefined word\r
+\r
+ $COLON 3,"(')",ParenTick,_SLINK\r
+ DW PARSE_WORD,Search_word,QuestionDUP,ZBranch,PTICK1\r
+ DW NIP,EXIT\r
+PTICK1 DW ErrWord,TwoStore,DoLIT,-13,THROW\r
+\r
+; (d.) ( d -- c-addr u )\r
+; Convert a double number to a string.\r
+;\r
+; : (d.) SWAP OVER DUP 0< IF DNEGATE THEN\r
+; <# #S ROT SIGN #> ;\r
+\r
+ $COLON 4,'(d.)',ParenDDot,_SLINK\r
+ DW SWAP,OVER,DUPP,ZeroLess,ZBranch,PARDD1\r
+ DW DNEGATE\r
+PARDD1 DW LessNumberSign,NumberSignS,ROT\r
+ DW SIGN,NumberSignGreater,EXIT\r
+\r
+; .ok ( -- )\r
+; Display 'ok'.\r
+;\r
+; : .ok ." ok" ;\r
+\r
+ $COLON 3,'.ok',DotOK,_SLINK\r
+ $INSTR 'ok'\r
+ DW TYPEE,EXIT\r
+\r
+; .prompt ( -- )\r
+; Disply Forth prompt. This word is vectored.\r
+;\r
+; : .prompt 'prompt EXECUTE ;\r
+\r
+ $COLON 7,'.prompt',DotPrompt,_SLINK\r
+ DW TickPrompt,EXECUTE,EXIT\r
+\r
+; 0 ( -- 0 )\r
+; Return zero.\r
+\r
+ $CONST 1,'0',Zero,0,_SLINK\r
+\r
+; 1 ( -- 1 )\r
+; Return one.\r
+\r
+ $CONST 1,'1',One,1,_SLINK\r
+\r
+; -1 ( -- -1 )\r
+; Return -1.\r
+\r
+ $CONST 2,'-1',MinusOne,-1,_SLINK\r
+\r
+; abort"msg ( -- a-addr )\r
+; Abort" error message string address.\r
+\r
+ $VAR 9,'abort"msg',AbortQMsg,_SLINK\r
+ _VAR = _VAR +CELLL\r
+\r
+; bal+ ( -- )\r
+; Increase bal by 1.\r
+;\r
+; : bal+ bal 1+ TO bal ;\r
+\r
+ $COLON 4,'bal+',BalPlus,_SLINK\r
+ DW Bal,OnePlus,DoTO,AddrBal,EXIT\r
+\r
+; bal- ( -- )\r
+; Decrease bal by 1.\r
+;\r
+; : bal- bal 1- TO bal ;\r
+\r
+ $COLON 4,'bal-',BalMinus,_SLINK\r
+ DW Bal,OneMinus,DoTO,AddrBal,EXIT\r
+\r
+; cell- ( a-addr1 -- a-addr2 )\r
+; Return previous aligned cell address.\r
+;\r
+; : cell- -(cell-size) + ;\r
+\r
+ $COLON 5,'cell-',CellMinus,_SLINK\r
+ DW DoLIT,0-CELLL,Plus,EXIT\r
+\r
+; COMPILE-ONLY ( -- )\r
+; Make the most recent definition an compile-only word.\r
+;\r
+; : COMPILE-ONLY lastName [ =comp ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON 12,'COMPILE-ONLY',COMPILE_ONLY,_SLINK\r
+ DW LastName,DoLIT,COMPO,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; doS" ( u -- c-addr u )\r
+; Run-time function of S" .\r
+;\r
+; : doS" R> SWAP 2DUP + ALIGNED >R ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+4,'doS"',DoSQuote,_SLINK\r
+ DW RFrom,SWAP,TwoDUP,Plus,ALIGNED,ToR,EXIT\r
+\r
+; doDO ( n1|u1 n2|u2 -- ) ( R: -- n1 n2-n1-max_negative )\r
+; Run-time funtion of DO.\r
+;\r
+; : doDO >R max-negative + R> OVER - SWAP R> SWAP >R SWAP >R >R ;\r
+\r
+ $COLON COMPO+4,'doDO',DoDO,_SLINK\r
+ DW ToR,DoLIT,MaxNegative,Plus,RFrom\r
+ DW OVER,Minus,SWAP,RFrom,SWAP,ToR,SWAP,ToR,ToR,EXIT\r
+\r
+; errWord ( -- a-addr )\r
+; Last found word. To be used to display the word causing error.\r
+\r
+ $VAR 7,'errWord',ErrWord,_SLINK\r
+ _VAR = _VAR +CELLL\r
+\r
+; head, ( xt "<spaces>name" -- )\r
+; Parse a word and build a dictionary entry using xt and name.\r
+;\r
+; : head, PARSE-WORD DUP 0=\r
+; IF errWord 2! -16 THROW THEN\r
+; \ attempt to use zero-length string as a name\r
+; DUP =mask > IF -19 THROW THEN \ definition name too long\r
+; 2DUP GET-CURRENT SEARCH-WORDLIST \ name exist?\r
+; IF DROP ." redefine " 2DUP TYPE SPACE THEN \ warn if redefined\r
+; npVar @ OVER CELL+ - ALIGNED\r
+; DUP >R pack" DROP R> \ pack the name in dictionary\r
+; cell- GET-CURRENT @ OVER ! \ build wordlist link\r
+; cell- DUP npVar ! ! ; \ adjust name space pointer\r
+; \ and store xt at code field\r
+\r
+ $COLON 5,'head,',HeadComma,_SLINK\r
+ DW PARSE_WORD,DUPP,ZBranch,HEADC1\r
+ DW DUPP,DoLIT,MASKK,GreaterThan,ZBranch,HEADC3\r
+ DW DoLIT,-19,THROW\r
+HEADC3 DW TwoDUP,GET_CURRENT,SEARCH_WORDLIST,ZBranch,HEADC2\r
+ DW DROP\r
+ $INSTR 'redefine '\r
+ DW TYPEE,TwoDUP,TYPEE,SPACE\r
+HEADC2 DW NPVar,Fetch,OVER,CELLPlus,Minus,ALIGNED\r
+ DW DUPP,ToR,PackQuote,DROP,RFrom\r
+ DW CellMinus,GET_CURRENT,Fetch,OVER,Store\r
+ DW CellMinus,DUPP,NPVar,Store,Store,EXIT\r
+HEADC1 DW ErrWord,TwoStore,DoLIT,-16,THROW\r
+\r
+; hld ( -- a-addr )\r
+; Hold a pointer in building a numeric output string.\r
+\r
+ $VAR 3,'hld',HLD,_SLINK\r
+\r
+; interpret ( i*x -- j*x )\r
+; Intrepret input string.\r
+;\r
+; : interpret BEGIN DEPTH 0< IF -4 THROW THEN \ stack underflow\r
+; PARSE-WORD DUP\r
+; WHILE 2DUP errWord 2!\r
+; search-word \ ca u 0 | xt f -1 | xt f 1\r
+; DUP IF\r
+; SWAP STATE @ OR 0= \ compile-only in interpretation\r
+; IF -14 THROW THEN \ interpreting a compile-only word\r
+; THEN\r
+; 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE\r
+; REPEAT 2DROP ;\r
+\r
+ $COLON 9,'interpret',Interpret,_SLINK\r
+INTERP1 DW DEPTH,ZeroLess,ZBranch,INTERP2\r
+ DW DoLIT,-4,THROW\r
+INTERP2 DW PARSE_WORD,DUPP,ZBranch,INTERP3\r
+ DW TwoDUP,ErrWord,TwoStore\r
+ DW Search_word,DUPP,ZBranch,INTERP5\r
+ DW SWAP,STATE,Fetch,ORR,ZBranch,INTERP4\r
+INTERP5 DW OnePlus,TwoStar,STATE,Fetch,OnePlus,Plus,CELLS\r
+ DW TickDoWord,Plus,Fetch,EXECUTE\r
+ DW Branch,INTERP1\r
+INTERP3 DW TwoDROP,EXIT\r
+INTERP4 DW DoLIT,-14,THROW\r
+\r
+; optiCOMPILE, ( xt -- )\r
+; Optimized COMPILE, . Reduce doLIST ... EXIT sequence if\r
+; xt is COLON definition which contains less than two words.\r
+;\r
+; : optiCOMPILE,\r
+; DUP ?call ['] doLIST = IF\r
+; DUP @ ['] EXIT = IF \ if first word is EXIT\r
+; 2DROP EXIT THEN\r
+; DUP CELL+ @ ['] EXIT = IF \ if second word is EXIT\r
+; @ DUP ['] doLIT XOR \ make sure it is not literal value\r
+; IF SWAP THEN THEN\r
+; THEN THEN DROP COMPILE, ;\r
+\r
+ $COLON 12,'optiCOMPILE,',OptiCOMPILEComma,_SLINK\r
+ DW DUPP,QCall,DoLIT,DoLIST,Equals,ZBranch,OPTC2\r
+ DW DUPP,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC1\r
+ DW TwoDROP,EXIT\r
+OPTC1 DW DUPP,CELLPlus,Fetch,DoLIT,EXIT,Equals,ZBranch,OPTC2\r
+ DW Fetch,DUPP,DoLIT,DoLIT,XORR,ZBranch,OPTC2\r
+ DW SWAP\r
+OPTC2 DW DROP,COMPILEComma,EXIT\r
+\r
+; singleOnly ( c-addr u -- x )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, leave a single cell number in interpretation state.\r
+;\r
+; : singleOnly\r
+; 0 DUP 2SWAP OVER C@ [CHAR] -\r
+; = DUP >R IF 1 /STRING THEN\r
+; >NUMBER IF -13 THROW THEN \ undefined word\r
+; 2DROP R> IF NEGATE THEN ;\r
+\r
+ $COLON 10,'singleOnly',SingleOnly,_SLINK\r
+ DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+ DW Equals,DUPP,ToR,ZBranch,SINGLEO4\r
+ DW One,SlashSTRING\r
+SINGLEO4 DW ToNUMBER,ZBranch,SINGLEO1\r
+ DW DoLIT,-13,THROW\r
+SINGLEO1 DW TwoDROP,RFrom,ZBranch,SINGLEO2\r
+ DW NEGATE\r
+SINGLEO2 DW EXIT\r
+\r
+; singleOnly, ( c-addr u -- )\r
+; Handle the word not found in the search-order. Compile a\r
+; single cell number in compilation state.\r
+;\r
+; : singleOnly,\r
+; singleOnly LITERAL ;\r
+\r
+ $COLON 11,'singleOnly,',SingleOnlyComma,_SLINK\r
+ DW SingleOnly,LITERAL,EXIT\r
+\r
+; (doubleAlso) ( c-addr u -- x 1 | x x 2 )\r
+; If the string is legal, leave a single or double cell number\r
+; and size of the number.\r
+;\r
+; : (doubleAlso)\r
+; 0 DUP 2SWAP OVER C@ [CHAR] -\r
+; = DUP >R IF 1 /STRING THEN\r
+; >NUMBER ?DUP\r
+; IF 1- IF -13 THROW THEN \ more than one char is remained\r
+; DUP C@ [CHAR] . XOR \ last char is not '.'\r
+; IF -13 THROW THEN \ undefined word\r
+; R> IF DNEGATE THEN\r
+; 2 EXIT THEN\r
+; 2DROP R> IF NEGATE THEN \ single number\r
+; 1 ;\r
+\r
+ $COLON 12,'(doubleAlso)',ParenDoubleAlso,_SLINK\r
+ DW Zero,DUPP,TwoSWAP,OVER,CFetch,DoLIT,'-'\r
+ DW Equals,DUPP,ToR,ZBranch,DOUBLEA1\r
+ DW One,SlashSTRING\r
+DOUBLEA1 DW ToNUMBER,QuestionDUP,ZBranch,DOUBLEA4\r
+ DW OneMinus,ZBranch,DOUBLEA3\r
+DOUBLEA2 DW DoLIT,-13,THROW\r
+DOUBLEA3 DW CFetch,DoLIT,'.',Equals,ZBranch,DOUBLEA2\r
+ DW RFrom,ZBranch,DOUBLEA5\r
+ DW DNEGATE\r
+DOUBLEA5 DW DoLIT,2,EXIT\r
+DOUBLEA4 DW TwoDROP,RFrom,ZBranch,DOUBLEA6\r
+ DW NEGATE\r
+DOUBLEA6 DW One,EXIT\r
+\r
+; doubleAlso ( c-addr u -- x | x x )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, leave a single or double cell number in\r
+; interpretation state.\r
+;\r
+; : doubleAlso\r
+; (doubleAlso) DROP ;\r
+\r
+ $COLON 10,'doubleAlso',DoubleAlso,_SLINK\r
+ DW ParenDoubleAlso,DROP,EXIT\r
+\r
+; doubleAlso, ( c-addr u -- )\r
+; Handle the word not found in the search-order. If the string\r
+; is legal, compile a single or double cell number in\r
+; compilation state.\r
+;\r
+; : doubleAlso,\r
+; (doubleAlso) 1- IF SWAP LITERAL THEN LITERAL ;\r
+\r
+ $COLON 11,'doubleAlso,',DoubleAlsoComma,_SLINK\r
+ DW ParenDoubleAlso,OneMinus,ZBranch,DOUBC1\r
+ DW SWAP,LITERAL\r
+DOUBC1 DW LITERAL,EXIT\r
+\r
+; -. ( -- )\r
+; You don't need this word unless you care that '-.' returns\r
+; double cell number 0. Catching illegal number '-.' in this way\r
+; is easier than make 'interpret' catch this exception.\r
+;\r
+; : -. -13 THROW ; IMMEDIATE \ undefined word\r
+\r
+ $COLON IMMED+2,'-.',MinusDot,_SLINK\r
+ DW DoLIT,-13,THROW\r
+\r
+; lastName ( -- c-addr )\r
+; Return the address of the last definition name.\r
+;\r
+; : lastName npVar @ CELL+ CELL+ ;\r
+\r
+ $COLON 8,'lastName',LastName,_SLINK\r
+ DW NPVar,Fetch,CELLPlus,CELLPlus,EXIT\r
+\r
+; linkLast ( -- )\r
+; Link the word being defined to the current wordlist.\r
+; Do nothing if the last definition is made by :NONAME .\r
+;\r
+; : linkLast lastName GET-CURRENT ! ;\r
+\r
+ $COLON 8,'linkLast',LinkLast,_SLINK\r
+ DW LastName,GET_CURRENT,Store,EXIT\r
+\r
+; name>xt ( c-addr -- xt )\r
+; Return execution token using counted string at c-addr.\r
+;\r
+; : name>xt cell- cell- @ ;\r
+\r
+ $COLON 7,'name>xt',NameToXT,_SLINK\r
+ DW CellMinus,CellMinus,Fetch,EXIT\r
+\r
+; PARSE-WORD ( "<spaces>ccc<space>" -- c-addr u )\r
+; Skip leading spaces and parse a word. Return the name.\r
+;\r
+; : PARSE-WORD BL skipPARSE ;\r
+\r
+ $COLON 10,'PARSE-WORD',PARSE_WORD,_SLINK\r
+ DW BLank,SkipPARSE,EXIT\r
+\r
+; pipe ( -- ) ( R: xt -- )\r
+; Connect most recently defined word to code following DOES>.\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | a-addr |\r
+;\r
+; : pipe lastName name>xt ?call DUP IF \ code-addr xt2\r
+; ['] doCREATE = IF\r
+; R> SWAP ! \ change DOES> code of CREATEd word\r
+; EXIT\r
+; THEN THEN\r
+; -32 THROW \ invalid name argument, no-CREATEd last name\r
+; ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+4,'pipe',Pipe,_SLINK\r
+ DW LastName,NameToXT,QCall,DUPP,ZBranch,PIPE1\r
+ DW DoLIT,DoCREATE,Equals,ZBranch,PIPE1\r
+ DW RFrom,SWAP,Store,EXIT\r
+PIPE1 DW DoLIT,-32,THROW\r
+\r
+; skipPARSE ( char "<chars>ccc<char>" -- c-addr u )\r
+; Skip leading chars and parse a word using char as a\r
+; delimeter. Return the name.\r
+;\r
+; : skipPARSE\r
+; >R SOURCE >IN @ /STRING \ c_addr u R: char\r
+; DUP IF\r
+; BEGIN OVER C@ R@ =\r
+; WHILE 1- SWAP CHAR+ SWAP DUP 0=\r
+; UNTIL R> DROP EXIT\r
+; ELSE THEN\r
+; DROP SOURCE DROP - 1chars/ >IN ! R> PARSE EXIT\r
+; THEN R> DROP ;\r
+\r
+ $COLON 9,'skipPARSE',SkipPARSE,_SLINK\r
+ DW ToR,SOURCE,ToIN,Fetch,SlashSTRING\r
+ DW DUPP,ZBranch,SKPAR1\r
+SKPAR2 DW OVER,CFetch,RFetch,Equals,ZBranch,SKPAR3\r
+ DW OneMinus,SWAP,CHARPlus,SWAP\r
+ DW DUPP,ZeroEquals,ZBranch,SKPAR2\r
+ DW RFrom,DROP,EXIT\r
+SKPAR3 DW DROP,SOURCE,DROP,Minus,OneCharsSlash\r
+ DW ToIN,Store,RFrom,PARSE,EXIT\r
+SKPAR1 DW RFrom,DROP,EXIT\r
+\r
+; rake ( C: do-sys -- )\r
+; Gathers LEAVEs.\r
+;\r
+; : rake DUP code, rakeVar @\r
+; BEGIN 2DUP U<\r
+; WHILE DUP @ xhere ROT !\r
+; REPEAT rakeVar ! DROP\r
+; ?DUP IF \ check for ?DO\r
+; 1 bal+ POSTPONE THEN \ orig type is 1\r
+; THEN bal- ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+4,'rake',rake,_SLINK\r
+ DW DUPP,CodeComma,RakeVar,Fetch\r
+RAKE1 DW TwoDUP,ULess,ZBranch,RAKE2\r
+ DW DUPP,Fetch,XHere,ROT,Store,Branch,RAKE1\r
+RAKE2 DW RakeVar,Store,DROP\r
+ DW QuestionDUP,ZBranch,RAKE3\r
+ DW One,BalPlus,THENN\r
+RAKE3 DW BalMinus,EXIT\r
+\r
+; rp0 ( -- a-addr )\r
+; Pointer to bottom of the return stack.\r
+;\r
+; : rp0 userP @ CELL+ CELL+ @ ;\r
+\r
+ $COLON 3,'rp0',RPZero,_SLINK\r
+ DW UserP,Fetch,CELLPlus,CELLPlus,Fetch,EXIT\r
+\r
+; search-word ( c-addr u -- c-addr u 0 | xt f 1 | xt f -1)\r
+; Search dictionary for a match with the given name. Return\r
+; execution token, not-compile-only flag and -1 or 1\r
+; ( IMMEDIATE) if found; c-addr u 0 if not.\r
+;\r
+; : search-word\r
+; #order @ DUP \ not found if #order is 0\r
+; IF 0\r
+; DO 2DUP \ ca u ca u\r
+; I CELLS #order CELL+ + @ \ ca u ca u wid\r
+; (search-wordlist) \ ca u; 0 | w f 1 | w f -1\r
+; ?DUP IF \ ca u; 0 | w f 1 | w f -1\r
+; >R 2SWAP 2DROP R> UNLOOP EXIT \ xt f 1 | xt f -1\r
+; THEN \ ca u\r
+; LOOP 0 \ ca u 0\r
+; THEN ;\r
+\r
+ $COLON 11,'search-word',Search_word,_SLINK\r
+ DW NumberOrder,Fetch,DUPP,ZBranch,SEARCH1\r
+ DW Zero,DoDO\r
+SEARCH2 DW TwoDUP,I,CELLS,NumberOrder,CELLPlus,Plus,Fetch\r
+ DW ParenSearch_Wordlist,QuestionDUP,ZBranch,SEARCH3\r
+ DW ToR,TwoSWAP,TwoDROP,RFrom,UNLOOP,EXIT\r
+SEARCH3 DW DoLOOP,SEARCH2\r
+ DW Zero\r
+SEARCH1 DW EXIT\r
+\r
+; sourceVar ( -- a-addr )\r
+; Hold the current count and address of the terminal input buffer.\r
+\r
+ $VAR 9,'sourceVar',SourceVar,_SLINK\r
+ _VAR = _VAR +CELLL\r
+\r
+; sp0 ( -- a-addr )\r
+; Pointer to bottom of the data stack.\r
+;\r
+; : sp0 userP @ CELL+ @ ;\r
+\r
+ $COLON 3,'sp0',SPZero,_SLINK\r
+ DW UserP,Fetch,CELLPlus,Fetch,EXIT\r
+\r
+; TOxhere ( a-addr -- )\r
+; Set the next available code space address as a-addr.\r
+;\r
+; : TOxhere cpVar ! ;\r
+\r
+ $COLON 7,'TOxhere',TOXHere,_SLINK\r
+ DW CPVar,Store,EXIT\r
+\r
+; xhere ( -- a-addr )\r
+; Return next available code space address.\r
+;\r
+; : xhere cpVar @ ;\r
+\r
+ $COLON 5,'xhere',XHere,_SLINK\r
+ DW CPVar,Fetch,EXIT\r
+\r
+; code, ( x -- )\r
+; Reserve one cell in code space and store x in it.\r
+;\r
+; : code, xhere DUP CELL+ TOxhere ! ;\r
+\r
+ $COLON 5,'code,',CodeComma,_SLINK\r
+ DW XHere,DUPP,CELLPlus,TOXHere,Store,EXIT\r
+\r
+;\r
+; Words for multitasking\r
+;\r
+\r
+; PAUSE ( -- )\r
+; Stop current task and transfer control to the task of which\r
+; 'status' USER variable is stored in 'follower' USER variable\r
+; of current task.\r
+;\r
+; : PAUSE rp@ sp@ stackTop ! follower @ >R ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+5,'PAUSE',PAUSE,_SLINK\r
+ DW RPFetch,SPFetch,StackTop,Store,Follower,Fetch,ToR,EXIT\r
+\r
+; wake ( -- )\r
+; Wake current task.\r
+;\r
+; : wake R> userP ! \ userP points 'follower' of current task\r
+; stackTop @ sp! \ set data stack\r
+; rp! ; COMPILE-ONLY \ set return stack\r
+\r
+ $COLON COMPO+4,'wake',Wake,_SLINK\r
+ DW RFrom,UserP,Store,StackTop,Fetch,SPStore,RPStore,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Essential Standard words - Colon definitions\r
+;;;;;;;;;;;;;;;;\r
+\r
+; # ( ud1 -- ud2 ) \ CORE\r
+; Extract one digit from ud1 and append the digit to\r
+; pictured numeric output string. ( ud2 = ud1 / BASE )\r
+;\r
+; : # 0 BASE @ UM/MOD >R BASE @ UM/MOD SWAP\r
+; 9 OVER < [ CHAR A CHAR 9 1 + - ] LITERAL AND +\r
+; [ CHAR 0 ] LITERAL + HOLD R> ;\r
+\r
+ $COLON 1,'#',NumberSign,_FLINK\r
+ DW Zero,BASE,Fetch,UMSlashMOD,ToR,BASE,Fetch,UMSlashMOD\r
+ DW SWAP,DoLIT,9,OVER,LessThan,DoLIT,'A'-'9'-1,ANDD,Plus\r
+ DW DoLIT,'0',Plus,HOLD,RFrom,EXIT\r
+\r
+; #> ( xd -- c-addr u ) \ CORE\r
+; Prepare the output string to be TYPE'd.\r
+; ||xhere>WORD/#-work-area|\r
+;\r
+; : #> 2DROP hld @ xhere size-of-PAD + OVER - 1chars/ ;\r
+\r
+ $COLON 2,'#>',NumberSignGreater,_FLINK\r
+ DW TwoDROP,HLD,Fetch,XHere,DoLIT,PADSize*CHARR,Plus\r
+ DW OVER,Minus,OneCharsSlash,EXIT\r
+\r
+; #S ( ud -- 0 0 ) \ CORE\r
+; Convert ud until all digits are added to the output string.\r
+;\r
+; : #S BEGIN # 2DUP OR 0= UNTIL ;\r
+\r
+ $COLON 2,'#S',NumberSignS,_FLINK\r
+NUMSS1 DW NumberSign,TwoDUP,ORR\r
+ DW ZeroEquals,ZBranch,NUMSS1\r
+ DW EXIT\r
+\r
+; ' ( "<spaces>name" -- xt ) \ CORE\r
+; Parse a name, find it and return xt.\r
+;\r
+; : ' (') DROP ;\r
+\r
+ $COLON 1,"'",Tick,_FLINK\r
+ DW ParenTick,DROP,EXIT\r
+\r
+; + ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Add top two items and gives the sum.\r
+;\r
+; : + um+ DROP ;\r
+\r
+ $COLON 1,'+',Plus,_FLINK\r
+ DW UMPlus,DROP,EXIT\r
+\r
+; +! ( n|u a-addr -- ) \ CORE\r
+; Add n|u to the contents at a-addr.\r
+;\r
+; : +! SWAP OVER @ + SWAP ! ;\r
+\r
+ $COLON 2,'+!',PlusStore,_FLINK\r
+ DW SWAP,OVER,Fetch,Plus\r
+ DW SWAP,Store,EXIT\r
+\r
+; , ( x -- ) \ CORE\r
+; Reserve one cell in RAM or ROM data space and store x in it.\r
+;\r
+; : , HERE ! cell-size hereVar +! ;\r
+\r
+ $COLON 1,',',Comma,_FLINK\r
+ DW HERE,Store\r
+ DW DoLIT,CELLL,HereVar,PlusStore,EXIT\r
+\r
+; - ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Subtract n2|u2 from n1|u1, giving the difference n3|u3.\r
+;\r
+; : - NEGATE + ;\r
+\r
+ $COLON 1,'-',Minus,_FLINK\r
+ DW NEGATE,Plus,EXIT\r
+\r
+; . ( n -- ) \ CORE\r
+; Display a signed number followed by a space.\r
+;\r
+; : . S>D D. ;\r
+\r
+ $COLON 1,'.',Dot,_FLINK\r
+ DW SToD,DDot,EXIT\r
+\r
+; / ( n1 n2 -- n3 ) \ CORE\r
+; Divide n1 by n2, giving single-cell quotient n3.\r
+;\r
+; : / /MOD NIP ;\r
+\r
+ $COLON 1,'/',Slash,_FLINK\r
+ DW SlashMOD,NIP,EXIT\r
+\r
+; /MOD ( n1 n2 -- n3 n4 ) \ CORE\r
+; Divide n1 by n2, giving single-cell remainder n3 and\r
+; single-cell quotient n4.\r
+;\r
+; : /MOD >R S>D R> FM/MOD ;\r
+\r
+ $COLON 4,'/MOD',SlashMOD,_FLINK\r
+ DW ToR,SToD,RFrom,FMSlashMOD,EXIT\r
+\r
+; /STRING ( c-addr1 u1 n -- c-addr2 u2 ) \ STRING\r
+; Adjust the char string at c-addr1 by n chars.\r
+;\r
+; : /STRING DUP >R - SWAP R> CHARS + SWAP ;\r
+\r
+ $COLON 7,'/STRING',SlashSTRING,_FLINK\r
+ DW DUPP,ToR,Minus,SWAP,RFrom,CHARS,Plus,SWAP,EXIT\r
+\r
+; 1+ ( n1|u1 -- n2|u2 ) \ CORE\r
+; Increase top of the stack item by 1.\r
+;\r
+; : 1+ 1 + ;\r
+\r
+ $COLON 2,'1+',OnePlus,_FLINK\r
+ DW One,Plus,EXIT\r
+\r
+; 1- ( n1|u1 -- n2|u2 ) \ CORE\r
+; Decrease top of the stack item by 1.\r
+;\r
+; : 1- -1 + ;\r
+\r
+ $COLON 2,'1-',OneMinus,_FLINK\r
+ DW MinusOne,Plus,EXIT\r
+\r
+; 2! ( x1 x2 a-addr -- ) \ CORE\r
+; Store the cell pare x1 x2 at a-addr, with x2 at a-addr and\r
+; x1 at the next consecutive cell.\r
+;\r
+; : 2! SWAP OVER ! CELL+ ! ;\r
+\r
+ $COLON 2,'2!',TwoStore,_FLINK\r
+ DW SWAP,OVER,Store,CELLPlus,Store,EXIT\r
+\r
+; 2@ ( a-addr -- x1 x2 ) \ CORE\r
+; Fetch the cell pair stored at a-addr. x2 is stored at a-addr\r
+; and x1 at the next consecutive cell.\r
+;\r
+; : 2@ DUP CELL+ @ SWAP @ ;\r
+\r
+ $COLON 2,'2@',TwoFetch,_FLINK\r
+ DW DUPP,CELLPlus,Fetch,SWAP,Fetch,EXIT\r
+\r
+; 2DROP ( x1 x2 -- ) \ CORE\r
+; Drop cell pair x1 x2 from the stack.\r
+\r
+ $COLON 5,'2DROP',TwoDROP,_FLINK\r
+ DW DROP,DROP,EXIT\r
+\r
+; 2DUP ( x1 x2 -- x1 x2 x1 x2 ) \ CORE\r
+; Duplicate cell pair x1 x2.\r
+\r
+ $COLON 4,'2DUP',TwoDUP,_FLINK\r
+ DW OVER,OVER,EXIT\r
+\r
+; 2SWAP ( x1 x2 x3 x4 -- x3 x4 x1 x2 ) \ CORE\r
+; Exchange the top two cell pairs.\r
+;\r
+; : 2SWAP ROT >R ROT R> ;\r
+\r
+ $COLON 5,'2SWAP',TwoSWAP,_FLINK\r
+ DW ROT,ToR,ROT,RFrom,EXIT\r
+\r
+; : ( "<spaces>name" -- colon-sys ) \ CORE\r
+; Start a new colon definition using next word as its name.\r
+;\r
+; : : :NONAME ROT head, -1 TO notNONAME? ;\r
+\r
+ $COLON 1,':',COLON,_FLINK\r
+ DW ColonNONAME,ROT,HeadComma\r
+ DW DoLIT,-1,DoTO,AddrNotNONAMEQ,EXIT\r
+\r
+; :NONAME ( -- xt colon-sys ) \ CORE EXT\r
+; Create an execution token xt, enter compilation state and\r
+; start the current definition.\r
+;\r
+; : :NONAME bal IF -29 THROW THEN \ compiler nesting\r
+; ['] doLIST xt, DUP -1\r
+; 0 TO notNONAME? 1 TO bal ] ;\r
+\r
+ $COLON 7,':NONAME',ColonNONAME,_FLINK\r
+ DW Bal,ZBranch,NONAME1\r
+ DW DoLIT,-29,THROW\r
+NONAME1 DW DoLIT,DoLIST,xtComma,DUPP,DoLIT,-1\r
+ DW Zero,DoTO,AddrNotNONAMEQ\r
+ DW One,DoTO,AddrBal,RightBracket,EXIT\r
+\r
+; ; ( colon-sys -- ) \ CORE\r
+; Terminate a colon definition.\r
+;\r
+; : ; bal 1- IF -22 THROW THEN \ control structure mismatch\r
+; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+; notNONAME? IF \ if the last definition is not created by ':'\r
+; linkLast 0 TO notNONAME? \ link the word to wordlist\r
+; THEN POSTPONE EXIT \ add EXIT at the end of the definition\r
+; 0 TO bal POSTPONE [ ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+1,';',Semicolon,_FLINK\r
+ DW Bal,OneMinus,ZBranch,SEMI1\r
+ DW DoLIT,-22,THROW\r
+SEMI1 DW NIP,OnePlus,ZBranch,SEMI2\r
+ DW DoLIT,-22,THROW\r
+SEMI2 DW NotNONAMEQ,ZBranch,SEMI3\r
+ DW LinkLast,Zero,DoTO,AddrNotNONAMEQ\r
+SEMI3 DW DoLIT,EXIT,COMPILEComma\r
+ DW Zero,DoTO,AddrBal,LeftBracket,EXIT\r
+\r
+; < ( n1 n2 -- flag ) \ CORE\r
+; Returns true if n1 is less than n2.\r
+;\r
+; : < 2DUP XOR 0< \ same sign?\r
+; IF DROP 0< EXIT THEN \ different signs, true if n1 <0\r
+; - 0< ; \ same signs, true if n1-n2 <0\r
+\r
+ $COLON 1,'<',LessThan,_FLINK\r
+ DW TwoDUP,XORR,ZeroLess,ZBranch,LESS1\r
+ DW DROP,ZeroLess,EXIT\r
+LESS1 DW Minus,ZeroLess,EXIT\r
+\r
+; <# ( -- ) \ CORE\r
+; Initiate the numeric output conversion process.\r
+; ||xhere>WORD/#-work-area|\r
+;\r
+; : <# xhere size-of-PAD + hld ! ;\r
+\r
+ $COLON 2,'<#',LessNumberSign,_FLINK\r
+ DW XHere,DoLIT,PADSize*CHARR,Plus,HLD,Store,EXIT\r
+\r
+; = ( x1 x2 -- flag ) \ CORE\r
+; Return true if top two are equal.\r
+;\r
+; : = XORR 0= ;\r
+\r
+ $COLON 1,'=',Equals,_FLINK\r
+ DW XORR,ZeroEquals,EXIT\r
+\r
+; > ( n1 n2 -- flag ) \ CORE\r
+; Returns true if n1 is greater than n2.\r
+;\r
+; : > SWAP < ;\r
+\r
+ $COLON 1,'>',GreaterThan,_FLINK\r
+ DW SWAP,LessThan,EXIT\r
+\r
+; >IN ( -- a-addr )\r
+; Hold the character pointer while parsing input stream.\r
+\r
+ $VAR 3,'>IN',ToIN,_FLINK\r
+\r
+; >NUMBER ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) \ CORE\r
+; Add number string's value to ud1. Leaves string of any\r
+; unconverted chars.\r
+;\r
+; : >NUMBER BEGIN DUP\r
+; WHILE >R DUP >R C@ \ ud char R: u c-addr\r
+; DUP [ CHAR 9 1+ ] LITERAL [CHAR] A WITHIN\r
+; IF DROP R> R> EXIT THEN\r
+; [ CHAR 0 ] LITERAL - 9 OVER <\r
+; [ CHAR A CHAR 9 1 + - ] LITERAL AND -\r
+; DUP 0 BASE @ WITHIN\r
+; WHILE SWAP BASE @ UM* DROP ROT BASE @ UM* D+ R> R> 1 /STRING\r
+; REPEAT DROP R> R>\r
+; THEN ;\r
+\r
+ $COLON 7,'>NUMBER',ToNUMBER,_FLINK\r
+TONUM1 DW DUPP,ZBranch,TONUM3\r
+ DW ToR,DUPP,ToR,CFetch,DUPP\r
+ DW DoLIT,'9'+1,DoLIT,'A',WITHIN,ZeroEquals,ZBranch,TONUM2\r
+ DW DoLIT,'0',Minus,DoLIT,9,OVER,LessThan\r
+ DW DoLIT,'A'-'9'-1,ANDD,Minus,DUPP\r
+ DW Zero,BASE,Fetch,WITHIN,ZBranch,TONUM2\r
+ DW SWAP,BASE,Fetch,UMStar,DROP,ROT,BASE,Fetch\r
+ DW UMStar,DPlus,RFrom,RFrom,One,SlashSTRING\r
+ DW Branch,TONUM1\r
+TONUM2 DW DROP,RFrom,RFrom\r
+TONUM3 DW EXIT\r
+\r
+; ?DUP ( x -- x x | 0 ) \ CORE\r
+; Duplicate top of the stack if it is not zero.\r
+;\r
+; : ?DUP DUP IF DUP THEN ;\r
+\r
+ $COLON 4,'?DUP',QuestionDUP,_FLINK\r
+ DW DUPP,ZBranch,QDUP1\r
+ DW DUPP\r
+QDUP1 DW EXIT\r
+\r
+; ABORT ( i*x -- ) ( R: j*x -- ) \ EXCEPTION EXT\r
+; Reset data stack and jump to QUIT.\r
+;\r
+; : ABORT -1 THROW ;\r
+\r
+ $COLON 5,'ABORT',ABORT,_FLINK\r
+ DW MinusOne,THROW\r
+\r
+; ACCEPT ( c-addr +n1 -- +n2 ) \ CORE\r
+; Accept a string of up to +n1 chars. Return with actual count.\r
+; Implementation-defined editing. Stops at EOL# .\r
+; Supports backspace and delete editing.\r
+;\r
+; : ACCEPT >R 0\r
+; BEGIN DUP R@ < \ ca n2 f R: n1\r
+; WHILE EKEY max-char AND\r
+; DUP BL <\r
+; IF DUP cr# = IF ROT 2DROP R> DROP EXIT THEN\r
+; DUP tab# =\r
+; IF DROP 2DUP + BL DUP EMIT SWAP C! 1+\r
+; ELSE DUP bsp# =\r
+; SWAP del# = OR\r
+; IF DROP DUP\r
+; \ discard the last char if not 1st char\r
+; IF 1- bsp# EMIT BL EMIT bsp# EMIT THEN THEN\r
+; THEN\r
+; ELSE >R 2DUP CHARS + R> DUP EMIT SWAP C! 1+ THEN\r
+; THEN\r
+; REPEAT SWAP R> 2DROP ;\r
+\r
+ $COLON 6,'ACCEPT',ACCEPT,_FLINK\r
+ DW ToR,Zero\r
+ACCPT1 DW DUPP,RFetch,LessThan,ZBranch,ACCPT5\r
+ DW EKEY,DoLIT,MaxChar,ANDD\r
+ DW DUPP,BLank,LessThan,ZBranch,ACCPT3\r
+ DW DUPP,DoLIT,CRR,Equals,ZBranch,ACCPT4\r
+ DW ROT,TwoDROP,RFrom,DROP,EXIT\r
+ACCPT4 DW DUPP,DoLIT,TABB,Equals,ZBranch,ACCPT6\r
+ DW DROP,TwoDUP,Plus,BLank,DUPP,EMIT,SWAP,CStore,OnePlus\r
+ DW Branch,ACCPT1\r
+ACCPT6 DW DUPP,DoLIT,BKSPP,Equals\r
+ DW SWAP,DoLIT,DEL,Equals,ORR,ZBranch,ACCPT1\r
+ DW DUPP,ZBranch,ACCPT1\r
+ DW OneMinus,DoLIT,BKSPP,EMIT,BLank,EMIT,DoLIT,BKSPP,EMIT\r
+ DW Branch,ACCPT1\r
+ACCPT3 DW ToR,TwoDUP,CHARS,Plus,RFrom,DUPP,EMIT,SWAP,CStore\r
+ DW OnePlus,Branch,ACCPT1\r
+ACCPT5 DW SWAP,RFrom,TwoDROP,EXIT\r
+\r
+; AGAIN ( C: dest -- ) \ CORE EXT\r
+; Resolve backward reference dest. Typically used as\r
+; BEGIN ... AGAIN . Move control to the location specified by\r
+; dest on execution.\r
+;\r
+; : AGAIN IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+; POSTPONE branch code, bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'AGAIN',AGAIN,_FLINK\r
+ DW ZBranch,AGAIN1\r
+ DW DoLIT,-22,THROW\r
+AGAIN1 DW DoLIT,Branch,COMPILEComma,CodeComma,BalMinus,EXIT\r
+\r
+; AHEAD ( C: -- orig ) \ TOOLS EXT\r
+; Put the location of a new unresolved forward reference onto\r
+; control-flow stack.\r
+;\r
+; : AHEAD POSTPONE branch xhere 0 code,\r
+; 1 bal+ \ orig type is 1\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'AHEAD',AHEAD,_FLINK\r
+ DW DoLIT,Branch,COMPILEComma,XHere,Zero,CodeComma\r
+ DW One,BalPlus,EXIT\r
+\r
+; BL ( -- char ) \ CORE\r
+; Return the value of the blank character.\r
+;\r
+; : BL blank-char-value EXIT ;\r
+\r
+ $CONST 2,'BL',BLank,' ',_FLINK\r
+\r
+; CATCH ( i*x xt -- j*x 0 | i*x n ) \ EXCEPTION\r
+; Push an exception frame on the exception stack and then execute\r
+; the execution token xt in such a way that control can be\r
+; transferred to a point just after CATCH if THROW is executed\r
+; during the execution of xt.\r
+;\r
+; : CATCH sp@ >R throwFrame @ >R \ save error frame\r
+; rp@ throwFrame ! EXECUTE \ execute\r
+; R> throwFrame ! \ restore error frame\r
+; R> DROP 0 ; \ no error\r
+\r
+ $COLON 5,'CATCH',CATCH,_FLINK\r
+ DW SPFetch,ToR,ThrowFrame,Fetch,ToR\r
+ DW RPFetch,ThrowFrame,Store,EXECUTE\r
+ DW RFrom,ThrowFrame,Store\r
+ DW RFrom,DROP,Zero,EXIT\r
+\r
+; CELL+ ( a-addr1 -- a-addr2 ) \ CORE\r
+; Return next aligned cell address.\r
+;\r
+; : CELL+ cell-size + ;\r
+\r
+ $COLON 5,'CELL+',CELLPlus,_FLINK\r
+ DW DoLIT,CELLL,Plus,EXIT\r
+\r
+; CHAR+ ( c-addr1 -- c-addr2 ) \ CORE\r
+; Returns next character-aligned address.\r
+;\r
+; : CHAR+ char-size + ;\r
+\r
+ $COLON 5,'CHAR+',CHARPlus,_FLINK\r
+ DW DoLIT,CHARR,Plus,EXIT\r
+\r
+; COMPILE, ( xt -- ) \ CORE EXT\r
+; Compile the execution token on data stack into current\r
+; colon definition.\r
+;\r
+; : COMPILE, code, ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+8,'COMPILE,',COMPILEComma,_FLINK\r
+ DW CodeComma,EXIT\r
+\r
+; CONSTANT ( x "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- x )\r
+; Create a definition for name which pushes x on the stack on\r
+; execution.\r
+;\r
+; : CONSTANT bal IF -29 THROW THEN \ compiler nesting\r
+; ['] doCONST xt, head, code, linkLast ;\r
+\r
+ $COLON 8,'CONSTANT',CONSTANT,_FLINK\r
+ DW Bal,ZBranch,CONST1\r
+ DW DoLIT,-29,THROW\r
+CONST1 DW DoLIT,DoCONST,xtComma,HeadComma,CodeComma,LinkLast,EXIT\r
+\r
+; COUNT ( c-addr1 -- c-addr2 u ) \ CORE\r
+; Convert counted string to string specification. c-addr2 is\r
+; the next char-aligned address after c-addr1 and u is the\r
+; contents at c-addr1.\r
+;\r
+; : COUNT DUP CHAR+ SWAP C@ ;\r
+\r
+ $COLON 5,'COUNT',COUNT,_FLINK\r
+ DW DUPP,CHARPlus,SWAP,CFetch,EXIT\r
+\r
+; CREATE ( "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- a-addr )\r
+; Create a data object in RAM/ROM data space, which return\r
+; data object address on execution\r
+;\r
+; : CREATE bal IF -29 THROW THEN \ compiler nesting\r
+; ['] doCREATE xt, head,\r
+; xhere DUP CELL+ CELL+ TOxhere \ reserve two cells\r
+; 0 OVER ! \ no DOES> code yet\r
+; ALIGN HERE SWAP CELL+ ! \ >BODY returns this address\r
+; linkLast ; \ link CREATEd word to current wordlist\r
+\r
+ $COLON 6,'CREATE',CREATE,_FLINK\r
+ DW Bal,ZBranch,CREAT1\r
+ DW DoLIT,-29,THROW\r
+CREAT1 DW DoLIT,DoCREATE,xtComma,HeadComma\r
+ DW XHere,DUPP,CELLPlus,CELLPlus,TOXHere\r
+ DW Zero,OVER,Store\r
+ DW ALIGNN,HERE,SWAP,CELLPlus,Store\r
+ DW LinkLast,EXIT\r
+\r
+; D+ ( d1|ud1 d2|ud2 -- d3|ud3 ) \ DOUBLE\r
+; Add double-cell numbers.\r
+;\r
+; : D+ >R SWAP >R um+ R> R> + + ;\r
+\r
+ $COLON 2,'D+',DPlus,_FLINK\r
+ DW ToR,SWAP,ToR,UMPlus\r
+ DW RFrom,RFrom,Plus,Plus,EXIT\r
+\r
+; D. ( d -- ) \ DOUBLE\r
+; Display d in free field format followed by a space.\r
+;\r
+; : D. (d.) TYPE SPACE ;\r
+\r
+ $COLON 2,'D.',DDot,_FLINK\r
+ DW ParenDDot,TYPEE,SPACE,EXIT\r
+\r
+; DECIMAL ( -- ) \ CORE\r
+; Set the numeric conversion radix to decimal 10.\r
+;\r
+; : DECIMAL 10 BASE ! ;\r
+\r
+ $COLON 7,'DECIMAL',DECIMAL,_FLINK\r
+ DW DoLIT,10,BASE,Store,EXIT\r
+\r
+; DEPTH ( -- +n ) \ CORE\r
+; Return the depth of the data stack.\r
+;\r
+; : DEPTH sp@ sp0 SWAP - cell-size / ;\r
+\r
+ $COLON 5,'DEPTH',DEPTH,_FLINK\r
+ DW SPFetch,SPZero,SWAP,Minus\r
+ DW DoLIT,CELLL,Slash,EXIT\r
+\r
+; DNEGATE ( d1 -- d2 ) \ DOUBLE\r
+; Two's complement of double-cell number.\r
+;\r
+; : DNEGATE INVERT >R INVERT 1 um+ R> + ;\r
+\r
+ $COLON 7,'DNEGATE',DNEGATE,_FLINK\r
+ DW INVERT,ToR,INVERT\r
+ DW One,UMPlus\r
+ DW RFrom,Plus,EXIT\r
+\r
+; EKEY ( -- u ) \ FACILITY EXT\r
+; Receive one keyboard event u.\r
+;\r
+; : EKEY BEGIN PAUSE EKEY? UNTIL 'ekey EXECUTE ;\r
+\r
+ $COLON 4,'EKEY',EKEY,_FLINK\r
+EKEY1 DW PAUSE,EKEYQuestion,ZBranch,EKEY1\r
+ DW TickEKEY,EXECUTE,EXIT\r
+\r
+; EMIT ( x -- ) \ CORE\r
+; Send a character to the output device.\r
+;\r
+; : EMIT 'emit EXECUTE ;\r
+\r
+ $COLON 4,'EMIT',EMIT,_FLINK\r
+ DW TickEMIT,EXECUTE,EXIT\r
+\r
+; FM/MOD ( d n1 -- n2 n3 ) \ CORE\r
+; Signed floored divide of double by single. Return mod n2\r
+; and quotient n3.\r
+;\r
+; : FM/MOD DUP >R 2DUP XOR >R >R DUP 0< IF DNEGATE THEN\r
+; R@ ABS UM/MOD\r
+; R> 0< IF SWAP NEGATE SWAP THEN\r
+; R> 0< IF NEGATE \ negative quotient\r
+; OVER IF R@ ROT - SWAP 1- THEN\r
+; R> DROP\r
+; 0 OVER < IF -11 THROW THEN \ result out of range\r
+; EXIT THEN\r
+; R> DROP DUP 0< IF -11 THROW THEN ; \ result out of range\r
+\r
+ $COLON 6,'FM/MOD',FMSlashMOD,_FLINK\r
+ DW DUPP,ToR,TwoDUP,XORR,ToR,ToR,DUPP,ZeroLess\r
+ DW ZBranch,FMMOD1\r
+ DW DNEGATE\r
+FMMOD1 DW RFetch,ABSS,UMSlashMOD\r
+ DW RFrom,ZeroLess,ZBranch,FMMOD2\r
+ DW SWAP,NEGATE,SWAP\r
+FMMOD2 DW RFrom,ZeroLess,ZBranch,FMMOD3\r
+ DW NEGATE,OVER,ZBranch,FMMOD4\r
+ DW RFetch,ROT,Minus,SWAP,OneMinus\r
+FMMOD4 DW RFrom,DROP\r
+ DW DoLIT,0,OVER,LessThan,ZBranch,FMMOD6\r
+ DW DoLIT,-11,THROW\r
+FMMOD6 DW EXIT\r
+FMMOD3 DW RFrom,DROP,DUPP,ZeroLess,ZBranch,FMMOD6\r
+ DW DoLIT,-11,THROW\r
+\r
+; GET-CURRENT ( -- wid ) \ SEARCH\r
+; Return the indentifier of the compilation wordlist.\r
+;\r
+; : GET-CURRENT current @ ;\r
+\r
+ $COLON 11,'GET-CURRENT',GET_CURRENT,_FLINK\r
+ DW Current,Fetch,EXIT\r
+\r
+; HERE ( -- addr ) \ CORE\r
+; Return data space pointer.\r
+;\r
+; : HERE hereVar @ ;\r
+\r
+ $COLON 4,'HERE',HERE,_FLINK\r
+ DW HereVar,Fetch,EXIT\r
+\r
+; HOLD ( char -- ) \ CORE\r
+; Add char to the beginning of pictured numeric output string.\r
+;\r
+; : HOLD hld @ 1 CHARS - DUP hld ! C! ;\r
+\r
+ $COLON 4,'HOLD',HOLD,_FLINK\r
+ DW HLD,Fetch,DoLIT,0-CHARR,Plus\r
+ DW DUPP,HLD,Store,CStore,EXIT\r
+\r
+; I ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+; Push the innermost loop index.\r
+;\r
+; : I rp@ [ 1 CELLS ] LITERAL + @\r
+; rp@ [ 2 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+1,'I',I,_FLINK\r
+ DW RPFetch,DoLIT,CELLL,Plus,Fetch\r
+ DW RPFetch,DoLIT,2*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+; IF Compilation: ( C: -- orig ) \ CORE\r
+; Run-time: ( x -- )\r
+; Put the location of a new unresolved forward reference orig\r
+; onto the control flow stack. On execution jump to location\r
+; specified by the resolution of orig if x is zero.\r
+;\r
+; : IF POSTPONE 0branch xhere 0 code,\r
+; 1 bal+ \ orig type is 1\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'IF',IFF,_FLINK\r
+ DW DoLIT,ZBranch,COMPILEComma,XHere,Zero,CodeComma\r
+ DW One,BalPlus,EXIT\r
+\r
+; INVERT ( x1 -- x2 ) \ CORE\r
+; Return one's complement of x1.\r
+;\r
+; : INVERT -1 XOR ;\r
+\r
+ $COLON 6,'INVERT',INVERT,_FLINK\r
+ DW MinusOne,XORR,EXIT\r
+\r
+; KEY ( -- char ) \ CORE\r
+; Receive a character. Do not display char.\r
+;\r
+; : KEY EKEY max-char AND ;\r
+\r
+ $COLON 3,'KEY',KEY,_FLINK\r
+ DW EKEY,DoLIT,MaxChar,ANDD,EXIT\r
+\r
+; LITERAL Compilation: ( x -- ) \ CORE\r
+; Run-time: ( -- x )\r
+; Append following run-time semantics. Put x on the stack on\r
+; execution\r
+;\r
+; : LITERAL POSTPONE doLIT code, ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+7,'LITERAL',LITERAL,_FLINK\r
+ DW DoLIT,DoLIT,COMPILEComma,CodeComma,EXIT\r
+\r
+; NEGATE ( n1 -- n2 ) \ CORE\r
+; Return two's complement of n1.\r
+;\r
+; : NEGATE INVERT 1+ ;\r
+\r
+ $COLON 6,'NEGATE',NEGATE,_FLINK\r
+ DW INVERT,OnePlus,EXIT\r
+\r
+; NIP ( n1 n2 -- n2 ) \ CORE EXT\r
+; Discard the second stack item.\r
+;\r
+; : NIP SWAP DROP ;\r
+\r
+ $COLON 3,'NIP',NIP,_FLINK\r
+ DW SWAP,DROP,EXIT\r
+\r
+; PARSE ( char "ccc<char>"-- c-addr u ) \ CORE EXT\r
+; Scan input stream and return counted string delimited by char.\r
+;\r
+; : PARSE >R SOURCE >IN @ /STRING \ c-addr u R: char\r
+; DUP IF\r
+; OVER CHARS + OVER \ c-addr c-addr+u c-addr R: char\r
+; BEGIN DUP C@ R@ XOR\r
+; WHILE CHAR+ 2DUP =\r
+; UNTIL DROP OVER - 1chars/ DUP\r
+; ELSE NIP OVER - 1chars/ DUP CHAR+\r
+; THEN >IN +!\r
+; THEN R> DROP EXIT ;\r
+\r
+ $COLON 5,'PARSE',PARSE,_FLINK\r
+ DW ToR,SOURCE,ToIN,Fetch,SlashSTRING\r
+ DW DUPP,ZBranch,PARSE4\r
+ DW OVER,CHARS,Plus,OVER\r
+PARSE1 DW DUPP,CFetch,RFetch,XORR,ZBranch,PARSE3\r
+ DW CHARPlus,TwoDUP,Equals,ZBranch,PARSE1\r
+PARSE2 DW DROP,OVER,Minus,DUPP,OneCharsSlash,Branch,PARSE5\r
+PARSE3 DW NIP,OVER,Minus,DUPP,OneCharsSlash,CHARPlus\r
+PARSE5 DW ToIN,PlusStore\r
+PARSE4 DW RFrom,DROP,EXIT\r
+\r
+; QUIT ( -- ) ( R: i*x -- ) \ CORE\r
+; Empty the return stack, store zero in SOURCE-ID, make the user\r
+; input device the input source, and start text interpreter.\r
+;\r
+; : QUIT BEGIN\r
+; rp0 rp! 0 TO SOURCE-ID 0 TO bal POSTPONE [\r
+; BEGIN CR REFILL DROP SPACE \ REFILL returns always true\r
+; ['] interpret CATCH ?DUP 0=\r
+; WHILE STATE @ 0= IF .prompt THEN\r
+; REPEAT\r
+; DUP -1 XOR IF \ ABORT\r
+; DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"\r
+; SPACE errWord 2@ TYPE\r
+; SPACE [CHAR] ? EMIT SPACE\r
+; DUP -1 -58 WITHIN IF ." Exception # " . ELSE \ undefined exception\r
+; CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN\r
+; sp0 sp!\r
+; AGAIN ;\r
+\r
+ $COLON 4,'QUIT',QUIT,_FLINK\r
+QUIT1 DW RPZero,RPStore,Zero,DoTO,AddrSOURCE_ID\r
+ DW Zero,DoTO,AddrBal,LeftBracket\r
+QUIT2 DW CR,REFILL,DROP,SPACE\r
+ DW DoLIT,Interpret,CATCH,QuestionDUP,ZeroEquals\r
+ DW ZBranch,QUIT3\r
+ DW STATE,Fetch,ZeroEquals,ZBranch,QUIT2\r
+ DW DotPrompt,Branch,QUIT2\r
+QUIT3 DW DUPP,MinusOne,XORR,ZBranch,QUIT5\r
+ DW DUPP,DoLIT,-2,Equals,ZBranch,QUIT4\r
+ DW SPACE,AbortQMsg,TwoFetch,TYPEE,Branch,QUIT5\r
+QUIT4 DW SPACE,ErrWord,TwoFetch,TYPEE\r
+ DW SPACE,DoLIT,'?',EMIT,SPACE\r
+ DW DUPP,MinusOne,DoLIT,-58,WITHIN,ZBranch,QUIT7\r
+ $INSTR ' Exception # '\r
+ DW TYPEE,Dot,Branch,QUIT5\r
+QUIT7 DW CELLS,THROWMsgTbl,Plus,Fetch,COUNT,TYPEE\r
+QUIT5 DW SPZero,SPStore,Branch,QUIT1\r
+\r
+; REFILL ( -- flag ) \ CORE EXT\r
+; Attempt to fill the input buffer from the input source. Make\r
+; the result the input buffer, set >IN to zero, and return true\r
+; if successful. Return false if the input source is a string\r
+; from EVALUATE.\r
+;\r
+; : REFILL SOURCE-ID IF 0 EXIT THEN\r
+; npVar @ [ size-of-PAD CHARS 2* ] LITERAL - DUP\r
+; size-of-PAD ACCEPT sourceVar 2!\r
+; 0 >IN ! -1 ;\r
+\r
+ $COLON 6,'REFILL',REFILL,_FLINK\r
+ DW SOURCE_ID,ZBranch,REFIL1\r
+ DW Zero,EXIT\r
+REFIL1 DW NPVar,DoLIT,0-PADSize*CHARR*2,Plus,DUPP\r
+ DW DoLIT,PADSize*CHARR,ACCEPT,SourceVar,TwoStore\r
+ DW Zero,ToIN,Store,MinusOne,EXIT\r
+\r
+; ROT ( x1 x2 x3 -- x2 x3 x1 ) \ CORE\r
+; Rotate the top three data stack items.\r
+;\r
+; : ROT >R SWAP R> SWAP ;\r
+\r
+ $COLON 3,'ROT',ROT,_FLINK\r
+ DW ToR,SWAP,RFrom,SWAP,EXIT\r
+\r
+; S>D ( n -- d ) \ CORE\r
+; Convert a single-cell number n to double-cell number.\r
+;\r
+; : S>D DUP 0< ;\r
+\r
+ $COLON 3,'S>D',SToD,_FLINK\r
+ DW DUPP,ZeroLess,EXIT\r
+\r
+; SEARCH-WORDLIST ( c-addr u wid -- 0 | xt 1 | xt -1) \ SEARCH\r
+; Search word list for a match with the given name.\r
+; Return execution token and -1 or 1 ( IMMEDIATE) if found.\r
+; Return 0 if not found.\r
+;\r
+; : SEARCH-WORDLIST\r
+; (search-wordlist) DUP IF NIP THEN ;\r
+\r
+ $COLON 15,'SEARCH-WORDLIST',SEARCH_WORDLIST,_FLINK\r
+ DW ParenSearch_Wordlist,DUPP,ZBranch,SRCHW1\r
+ DW NIP\r
+SRCHW1 DW EXIT\r
+\r
+; SIGN ( n -- ) \ CORE\r
+; Add a minus sign to the numeric output string if n is negative.\r
+;\r
+; : SIGN 0< IF [CHAR] - HOLD THEN ;\r
+\r
+ $COLON 4,'SIGN',SIGN,_FLINK\r
+ DW ZeroLess,ZBranch,SIGN1\r
+ DW DoLIT,'-',HOLD\r
+SIGN1 DW EXIT\r
+\r
+; SOURCE ( -- c-addr u ) \ CORE\r
+; Return input buffer string.\r
+;\r
+; : SOURCE sourceVar 2@ ;\r
+\r
+ $COLON 6,'SOURCE',SOURCE,_FLINK\r
+ DW SourceVar,TwoFetch,EXIT\r
+\r
+; SPACE ( -- ) \ CORE\r
+; Send the blank character to the output device.\r
+;\r
+; : SPACE 32 EMIT ;\r
+\r
+ $COLON 5,'SPACE',SPACE,_FLINK\r
+ DW BLank,EMIT,EXIT\r
+\r
+; STATE ( -- a-addr ) \ CORE\r
+; Return the address of a cell containing compilation-state flag\r
+; which is true in compilation state or false otherwise.\r
+\r
+ $VAR 5,'STATE',STATE,_FLINK\r
+\r
+; THEN Compilation: ( C: orig -- ) \ CORE\r
+; Run-time: ( -- )\r
+; Resolve the forward reference orig.\r
+;\r
+; : THEN 1- IF -22 THROW THEN \ control structure mismatch\r
+; \ orig type is 1\r
+; xhere SWAP ! bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+4,'THEN',THENN,_FLINK\r
+ DW OneMinus,ZBranch,THEN1\r
+ DW DoLIT,-22,THROW\r
+THEN1 DW XHere,SWAP,Store,BalMinus,EXIT\r
+\r
+; THROW ( k*x n -- k*x | i*x n ) \ EXCEPTION\r
+; If n is not zero, pop the topmost exception frame from the\r
+; exception stack, along with everything on the return stack\r
+; above the frame. Then restore the condition before CATCH and\r
+; transfer control just after the CATCH that pushed that\r
+; exception frame.\r
+;\r
+; : THROW ?DUP\r
+; IF throwFrame @ rp! \ restore return stack\r
+; R> throwFrame ! \ restore THROW frame\r
+; R> SWAP >R sp! \ restore data stack\r
+; DROP R>\r
+; 'init-i/o EXECUTE\r
+; THEN ;\r
+\r
+ $COLON 5,'THROW',THROW,_FLINK\r
+ DW QuestionDUP,ZBranch,THROW1\r
+ DW ThrowFrame,Fetch,RPStore,RFrom,ThrowFrame,Store\r
+ DW RFrom,SWAP,ToR,SPStore,DROP,RFrom\r
+ DW TickINIT_IO,EXECUTE\r
+THROW1 DW EXIT\r
+\r
+; TYPE ( c-addr u -- ) \ CORE\r
+; Display the character string if u is greater than zero.\r
+;\r
+; : TYPE ?DUP IF 0 DO DUP C@ EMIT CHAR+ LOOP THEN DROP ;\r
+\r
+ $COLON 4,'TYPE',TYPEE,_FLINK\r
+ DW QuestionDUP,ZBranch,TYPE2\r
+ DW Zero,DoDO\r
+TYPE1 DW DUPP,CFetch,EMIT,CHARPlus,DoLOOP,TYPE1\r
+TYPE2 DW DROP,EXIT\r
+\r
+; U< ( u1 u2 -- flag ) \ CORE\r
+; Unsigned compare of top two items. True if u1 < u2.\r
+;\r
+; : U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;\r
+\r
+ $COLON 2,'U<',ULess,_FLINK\r
+ DW TwoDUP,XORR,ZeroLess\r
+ DW ZBranch,ULES1\r
+ DW NIP,ZeroLess,EXIT\r
+ULES1 DW Minus,ZeroLess,EXIT\r
+\r
+; UM* ( u1 u2 -- ud ) \ CORE\r
+; Unsigned multiply. Return double-cell product.\r
+;\r
+; : UM* 0 SWAP cell-size-in-bits 0 DO\r
+; DUP um+ >R >R DUP um+ R> +\r
+; R> IF >R OVER um+ R> + THEN \ if carry\r
+; LOOP ROT DROP ;\r
+\r
+ $COLON 3,'UM*',UMStar,_FLINK\r
+ DW Zero,SWAP,DoLIT,CELLL*8,Zero,DoDO\r
+UMST1 DW DUPP,UMPlus,ToR,ToR\r
+ DW DUPP,UMPlus,RFrom,Plus,RFrom\r
+ DW ZBranch,UMST2\r
+ DW ToR,OVER,UMPlus,RFrom,Plus\r
+UMST2 DW DoLOOP,UMST1\r
+ DW ROT,DROP,EXIT\r
+\r
+; UM/MOD ( ud u1 -- u2 u3 ) \ CORE\r
+; Unsigned division of a double-cell number ud by a single-cell\r
+; number u1. Return remainder u2 and quotient u3.\r
+;\r
+; : UM/MOD DUP 0= IF -10 THROW THEN \ divide by zero\r
+; 2DUP U< IF\r
+; NEGATE cell-size-in-bits 0\r
+; DO >R DUP um+ >R >R DUP um+ R> + DUP\r
+; R> R@ SWAP >R um+ R> OR\r
+; IF >R DROP 1+ R> THEN\r
+; ELSE DROP THEN\r
+; R>\r
+; LOOP DROP SWAP EXIT\r
+; ELSE -11 THROW \ result out of range\r
+; THEN ;\r
+\r
+ $COLON 6,'UM/MOD',UMSlashMOD,_FLINK\r
+ DW DUPP,ZBranch,UMM5\r
+ DW TwoDUP,ULess,ZBranch,UMM4\r
+ DW NEGATE,DoLIT,CELLL*8,Zero,DoDO\r
+UMM1 DW ToR,DUPP,UMPlus,ToR,ToR,DUPP,UMPlus,RFrom,Plus,DUPP\r
+ DW RFrom,RFetch,SWAP,ToR,UMPlus,RFrom,ORR,ZBranch,UMM2\r
+ DW ToR,DROP,OnePlus,RFrom,Branch,UMM3\r
+UMM2 DW DROP\r
+UMM3 DW RFrom,DoLOOP,UMM1\r
+ DW DROP,SWAP,EXIT\r
+UMM5 DW DoLIT,-10,THROW\r
+UMM4 DW DoLIT,-11,THROW\r
+\r
+; UNLOOP ( -- ) ( R: loop-sys -- ) \ CORE\r
+; Discard loop-control parameters for the current nesting level.\r
+; An UNLOOP is required for each nesting level before the\r
+; definition may be EXITed.\r
+;\r
+; : UNLOOP R> R> R> 2DROP >R ;\r
+\r
+ $COLON COMPO+6,'UNLOOP',UNLOOP,_FLINK\r
+ DW RFrom,RFrom,RFrom,TwoDROP,ToR,EXIT\r
+\r
+; WITHIN ( n1|u1 n2|n2 n3|u3 -- flag ) \ CORE EXT\r
+; Return true if (n2|u2<=n1|u1 and n1|u1<n3|u3) or\r
+; (n2|u2>n3|u3 and (n2|u2<=n1|u1 or n1|u1<n3|u3)).\r
+;\r
+; : WITHIN OVER - >R - R> U< ;\r
+\r
+ $COLON 6,'WITHIN',WITHIN,_FLINK\r
+ DW OVER,Minus,ToR ;ul <= u < uh\r
+ DW Minus,RFrom,ULess,EXIT\r
+\r
+; [ ( -- ) \ CORE\r
+; Enter interpretation state.\r
+;\r
+; : [ 0 STATE ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+1,'[',LeftBracket,_FLINK\r
+ DW Zero,STATE,Store,EXIT\r
+\r
+; ] ( -- ) \ CORE\r
+; Enter compilation state.\r
+;\r
+; : ] -1 STATE ! ;\r
+\r
+ $COLON 1,']',RightBracket,_FLINK\r
+ DW MinusOne,STATE,Store,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; Rest of CORE words and two facility words, EKEY? and EMIT?\r
+;;;;;;;;;;;;;;;;\r
+; Following definitions can be removed from assembler source and\r
+; can be colon-defined later.\r
+\r
+; ( ( "ccc<)>" -- ) \ CORE\r
+; Ignore following string up to next ) . A comment.\r
+;\r
+; : ( [CHAR] ) PARSE 2DROP ;\r
+\r
+ $COLON IMMED+1,'(',Paren,_FLINK\r
+ DW DoLIT,')',PARSE,TwoDROP,EXIT\r
+\r
+; * ( n1|u1 n2|u2 -- n3|u3 ) \ CORE\r
+; Multiply n1|u1 by n2|u2 giving a single product.\r
+;\r
+; : * UM* DROP ;\r
+\r
+ $COLON 1,'*',Star,_FLINK\r
+ DW UMStar,DROP,EXIT\r
+\r
+; */ ( n1 n2 n3 -- n4 ) \ CORE\r
+; Multiply n1 by n2 producing double-cell intermediate,\r
+; then divide it by n3. Return single-cell quotient.\r
+;\r
+; : */ */MOD NIP ;\r
+\r
+ $COLON 2,'*/',StarSlash,_FLINK\r
+ DW StarSlashMOD,NIP,EXIT\r
+\r
+; */MOD ( n1 n2 n3 -- n4 n5 ) \ CORE\r
+; Multiply n1 by n2 producing double-cell intermediate,\r
+; then divide it by n3. Return single-cell remainder and\r
+; single-cell quotient.\r
+;\r
+; : */MOD >R M* R> FM/MOD ;\r
+\r
+ $COLON 5,'*/MOD',StarSlashMOD,_FLINK\r
+ DW ToR,MStar,RFrom,FMSlashMOD,EXIT\r
+\r
+; +LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+; Run-time: ( n -- ) ( R: loop-sys1 -- | loop-sys2 )\r
+; Terminate a DO-+LOOP structure. Resolve the destination of all\r
+; unresolved occurences of LEAVE.\r
+; On execution add n to the loop index. If loop index did not\r
+; cross the boundary between loop_limit-1 and loop_limit,\r
+; continue execution at the beginning of the loop. Otherwise,\r
+; finish the loop.\r
+;\r
+; : +LOOP POSTPONE do+LOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'+LOOP',PlusLOOP,_FLINK\r
+ DW DoLIT,DoPLOOP,COMPILEComma,rake,EXIT\r
+\r
+; ." ( "ccc<">" -- ) \ CORE\r
+; Run-time ( -- )\r
+; Compile an inline string literal to be typed out at run time.\r
+;\r
+; : ." POSTPONE S" POSTPONE TYPE ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'."',DotQuote,_FLINK\r
+ DW SQuote,DoLIT,TYPEE,COMPILEComma,EXIT\r
+\r
+; 2OVER ( x1 x2 x3 x4 -- x1 x2 x3 x4 x1 x2 ) \ CORE\r
+; Copy cell pair x1 x2 to the top of the stack.\r
+;\r
+; : 2OVER >R >R 2DUP R> R> 2SWAP ;\r
+\r
+ $COLON 5,'2OVER',TwoOVER,_FLINK\r
+ DW ToR,ToR,TwoDUP,RFrom,RFrom,TwoSWAP,EXIT\r
+\r
+; >BODY ( xt -- a-addr ) \ CORE\r
+; Push data field address of CREATEd word.\r
+; Structure of CREATEd word:\r
+; | call-doCREATE | 0 or DOES> code addr | a-addr |\r
+;\r
+; : >BODY ?call DUP IF \ code-addr xt2\r
+; ['] doCREATE = IF \ should be call-doCREATE\r
+; CELL+ @ EXIT\r
+; THEN THEN\r
+; -31 THROW ; \ >BODY used on non-CREATEd definition\r
+\r
+ $COLON 5,'>BODY',ToBODY,_FLINK\r
+ DW QCall,DUPP,ZBranch,TBODY1\r
+ DW DoLIT,DoCREATE,Equals,ZBranch,TBODY1\r
+ DW CELLPlus,Fetch,EXIT\r
+TBODY1 DW DoLIT,-31,THROW\r
+\r
+; ABORT" ( "ccc<">" -- ) \ EXCEPTION EXT\r
+; Run-time ( i*x x1 -- | i*x ) ( R: j*x -- | j*x )\r
+; Conditional abort with an error message.\r
+;\r
+; : ABORT" S" POSTPONE ROT\r
+; POSTPONE IF POSTPONE abort"msg POSTPONE 2!\r
+; -2 POSTPONE LITERAL POSTPONE THROW\r
+; POSTPONE ELSE POSTPONE 2DROP POSTPONE THEN\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+6,'ABORT"',ABORTQuote,_FLINK\r
+ DW SQuote,DoLIT,ROT,COMPILEComma\r
+ DW IFF,DoLIT,AbortQMsg,COMPILEComma ; IF is immediate\r
+ DW DoLIT,TwoStore,COMPILEComma\r
+ DW DoLIT,-2,LITERAL ; LITERAL is immediate\r
+ DW DoLIT,THROW,COMPILEComma\r
+ DW ELSEE,DoLIT,TwoDROP,COMPILEComma ; ELSE and THEN are\r
+ DW THENN,EXIT ; immediate\r
+\r
+; ABS ( n -- u ) \ CORE\r
+; Return the absolute value of n.\r
+;\r
+; : ABS DUP 0< IF NEGATE THEN ;\r
+\r
+ $COLON 3,'ABS',ABSS,_FLINK\r
+ DW DUPP,ZeroLess,ZBranch,ABS1\r
+ DW NEGATE\r
+ABS1 DW EXIT\r
+\r
+; ALLOT ( n -- ) \ CORE\r
+; Allocate n bytes in RAM or ROM data space.\r
+;\r
+; : ALLOT hereVar +! ;\r
+\r
+ $COLON 5,'ALLOT',ALLOT,_FLINK\r
+ DW HereVar,PlusStore,EXIT\r
+\r
+; BEGIN ( C: -- dest ) \ CORE\r
+; Start an infinite or indefinite loop structure. Put the next\r
+; location for a transfer of control, dest, onto the data\r
+; control stack.\r
+;\r
+; : BEGIN xhere 0 bal+ \ dest type is 0\r
+; ; COMPILE-ONLY IMMDEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'BEGIN',BEGIN,_FLINK\r
+ DW XHere,Zero,BalPlus,EXIT\r
+\r
+; C, ( char -- ) \ CORE\r
+; Compile a character into data space.\r
+;\r
+; : C, HERE C! char-size hereVar +! ;\r
+\r
+ $COLON 2,'C,',CComma,_FLINK\r
+ DW HERE,CStore,DoLIT,CHARR,HereVar,PlusStore,EXIT\r
+\r
+; CHAR ( "<spaces>ccc" -- char ) \ CORE\r
+; Parse next word and return the value of first character.\r
+;\r
+; : CHAR PARSE-WORD DROP C@ ;\r
+\r
+ $COLON 4,'CHAR',CHAR,_FLINK\r
+ DW PARSE_WORD,DROP,CFetch,EXIT\r
+\r
+; DO Compilation: ( C: -- do-sys ) \ CORE\r
+; Run-time: ( n1|u1 n2|u2 -- ) ( R: -- loop-sys )\r
+; Start a DO-LOOP structure in a colon definition. Place do-sys\r
+; on control-flow stack, which will be resolved by LOOP or +LOOP.\r
+;\r
+; : DO 0 rakeVar ! 0 \ ?DO-orig is 0 for DO\r
+; POSTPONE doDO xhere bal+ \ DO-dest\r
+; ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'DO',DO,_FLINK\r
+ DW Zero,RakeVar,Store,Zero\r
+ DW DoLIT,DoDO,COMPILEComma,XHere,BalPlus,EXIT\r
+\r
+; DOES> ( C: colon-sys1 -- colon-sys2 ) \ CORE\r
+; Build run time code of the data object CREATEd.\r
+;\r
+; : DOES> bal 1- IF -22 THROW THEN \ control structure mismatch\r
+; NIP 1+ IF -22 THROW THEN \ colon-sys type is -1\r
+; POSTPONE pipe ['] doLIST xt, -1 ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'DOES>',DOESGreater,_FLINK\r
+ DW Bal,OneMinus,ZBranch,DOES1\r
+ DW DoLIT,-22,THROW\r
+DOES1 DW NIP,OnePlus,ZBranch,DOES2\r
+ DW DoLIT,-22,THROW\r
+DOES2 DW DoLIT,Pipe,COMPILEComma\r
+ DW DoLIT,DoLIST,xtComma,DoLIT,-1,EXIT\r
+\r
+; ELSE Compilation: ( C: orig1 -- orig2 ) \ CORE\r
+; Run-time: ( -- )\r
+; Start the false clause in an IF-ELSE-THEN structure.\r
+; Put the location of new unresolved forward reference orig2\r
+; onto control-flow stack.\r
+;\r
+; : ELSE POSTPONE AHEAD 2SWAP POSTPONE THEN ; COMPILE-ONLY IMMDEDIATE\r
+\r
+ $COLON IMMED+COMPO+4,'ELSE',ELSEE,_FLINK\r
+ DW AHEAD,TwoSWAP,THENN,EXIT\r
+\r
+; ENVIRONMENT? ( c-addr u -- false | i*x true ) \ CORE\r
+; Environment query.\r
+;\r
+; : ENVIRONMENT?\r
+; envQList SEARCH-WORDLIST\r
+; DUP >R IF EXECUTE THEN R> ;\r
+\r
+ $COLON 12,'ENVIRONMENT?',ENVIRONMENTQuery,_FLINK\r
+ DW EnvQList,SEARCH_WORDLIST\r
+ DW DUPP,ToR,ZBranch,ENVRN1\r
+ DW EXECUTE\r
+ENVRN1 DW RFrom,EXIT\r
+\r
+; EVALUATE ( i*x c-addr u -- j*x ) \ CORE\r
+; Evaluate the string. Save the input source specification.\r
+; Store -1 in SOURCE-ID.\r
+;\r
+; : EVALUATE SOURCE >R >R >IN @ >R SOURCE-ID >R\r
+; -1 TO SOURCE-ID\r
+; sourceVar 2! 0 >IN ! interpret\r
+; R> TO SOURCE-ID\r
+; R> >IN ! R> R> sourceVar 2! ;\r
+\r
+ $COLON 8,'EVALUATE',EVALUATE,_FLINK\r
+ DW SOURCE,ToR,ToR,ToIN,Fetch,ToR,SOURCE_ID,ToR\r
+ DW MinusOne,DoTO,AddrSOURCE_ID\r
+ DW SourceVar,TwoStore,Zero,ToIN,Store,Interpret\r
+ DW RFrom,DoTO,AddrSOURCE_ID\r
+ DW RFrom,ToIN,Store,RFrom,RFrom,SourceVar,TwoStore,EXIT\r
+\r
+; FILL ( c-addr u char -- ) \ CORE\r
+; Store char in each of u consecutive characters of memory\r
+; beginning at c-addr.\r
+;\r
+; : FILL ROT ROT ?DUP IF 0 DO 2DUP C! CHAR+ LOOP THEN 2DROP ;\r
+\r
+ $COLON 4,'FILL',FILL,_FLINK\r
+ DW ROT,ROT,QuestionDUP,ZBranch,FILL2\r
+ DW Zero,DoDO\r
+FILL1 DW TwoDUP,CStore,CHARPlus,DoLOOP,FILL1\r
+FILL2 DW TwoDROP,EXIT\r
+\r
+; FIND ( c-addr -- c-addr 0 | xt 1 | xt -1) \ SEARCH\r
+; Search dictionary for a match with the given counted name.\r
+; Return execution token and -1 or 1 ( IMMEDIATE) if found;\r
+; c-addr 0 if not found.\r
+;\r
+; : FIND DUP COUNT search-word ?DUP IF NIP ROT DROP EXIT THEN\r
+; 2DROP 0 ;\r
+\r
+ $COLON 4,'FIND',FIND,_FLINK\r
+ DW DUPP,COUNT,Search_word,QuestionDUP,ZBranch,FIND1\r
+ DW NIP,ROT,DROP,EXIT\r
+FIND1 DW TwoDROP,Zero,EXIT\r
+\r
+; IMMEDIATE ( -- ) \ CORE\r
+; Make the most recent definition an immediate word.\r
+;\r
+; : IMMEDIATE lastName [ =imed ] LITERAL OVER @ OR SWAP ! ;\r
+\r
+ $COLON 9,'IMMEDIATE',IMMEDIATE,_FLINK\r
+ DW LastName,DoLIT,IMMED,OVER,Fetch,ORR,SWAP,Store,EXIT\r
+\r
+; J ( -- n|u ) ( R: loop-sys -- loop-sys ) \ CORE\r
+; Push the index of next outer loop.\r
+;\r
+; : J rp@ [ 3 CELLS ] LITERAL + @\r
+; rp@ [ 4 CELLS ] LITERAL + @ + ; COMPILE-ONLY\r
+\r
+ $COLON COMPO+1,'J',J,_FLINK\r
+ DW RPFetch,DoLIT,3*CELLL,Plus,Fetch\r
+ DW RPFetch,DoLIT,4*CELLL,Plus,Fetch,Plus,EXIT\r
+\r
+; LEAVE ( -- ) ( R: loop-sys -- ) \ CORE\r
+; Terminate definite loop, DO|?DO ... LOOP|+LOOP, immediately.\r
+;\r
+; : LEAVE POSTPONE UNLOOP POSTPONE branch\r
+; xhere rakeVar DUP @ code, ! ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'LEAVE',LEAVEE,_FLINK\r
+ DW DoLIT,UNLOOP,COMPILEComma,DoLIT,Branch,COMPILEComma\r
+ DW XHere,RakeVar,DUPP,Fetch,CodeComma,Store,EXIT\r
+\r
+; LOOP Compilation: ( C: do-sys -- ) \ CORE\r
+; Run-time: ( -- ) ( R: loop-sys1 -- loop-sys2 )\r
+; Terminate a DO|?DO ... LOOP structure. Resolve the destination\r
+; of all unresolved occurences of LEAVE.\r
+;\r
+; : LOOP POSTPONE doLOOP rake ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+4,'LOOP',LOOPP,_FLINK\r
+ DW DoLIT,DoLOOP,COMPILEComma,rake,EXIT\r
+\r
+; LSHIFT ( x1 u -- x2 ) \ CORE\r
+; Perform a logical left shift of u bit-places on x1, giving x2.\r
+; Put 0 into the least significant bits vacated by the shift.\r
+;\r
+; : LSHIFT ?DUP IF 0 DO 2* LOOP THEN ;\r
+\r
+ $COLON 6,'LSHIFT',LSHIFT,_FLINK\r
+ DW QuestionDUP,ZBranch,LSHIFT2\r
+ DW Zero,DoDO\r
+LSHIFT1 DW TwoStar,DoLOOP,LSHIFT1\r
+LSHIFT2 DW EXIT\r
+\r
+; M* ( n1 n2 -- d ) \ CORE\r
+; Signed multiply. Return double product.\r
+;\r
+; : M* 2DUP XOR 0< >R ABS SWAP ABS UM* R> IF DNEGATE THEN ;\r
+\r
+ $COLON 2,'M*',MStar,_FLINK\r
+ DW TwoDUP,XORR,ZeroLess,ToR,ABSS,SWAP,ABSS\r
+ DW UMStar,RFrom,ZBranch,MSTAR1\r
+ DW DNEGATE\r
+MSTAR1 DW EXIT\r
+\r
+; MAX ( n1 n2 -- n3 ) \ CORE\r
+; Return the greater of two top stack items.\r
+;\r
+; : MAX 2DUP < IF SWAP THEN DROP ;\r
+\r
+ $COLON 3,'MAX',MAX,_FLINK\r
+ DW TwoDUP,LessThan,ZBranch,MAX1\r
+ DW SWAP\r
+MAX1 DW DROP,EXIT\r
+\r
+; MIN ( n1 n2 -- n3 ) \ CORE\r
+; Return the smaller of top two stack items.\r
+;\r
+; : MIN 2DUP > IF SWAP THEN DROP ;\r
+\r
+ $COLON 3,'MIN',MIN,_FLINK\r
+ DW TwoDUP,GreaterThan,ZBranch,MIN1\r
+ DW SWAP\r
+MIN1 DW DROP,EXIT\r
+\r
+; MOD ( n1 n2 -- n3 ) \ CORE\r
+; Divide n1 by n2, giving the single cell remainder n3.\r
+; Returns modulo of floored division in this implementation.\r
+;\r
+; : MOD /MOD DROP ;\r
+\r
+ $COLON 3,'MOD',MODD,_FLINK\r
+ DW SlashMOD,DROP,EXIT\r
+\r
+; PICK ( x_u ... x1 x0 u -- x_u ... x1 x0 x_u ) \ CORE EXT\r
+; Remove u and copy the uth stack item to top of the stack. An\r
+; ambiguous condition exists if there are less than u+2 items\r
+; on the stack before PICK is executed.\r
+;\r
+; : PICK DEPTH DUP 2 < IF -4 THROW THEN \ stack underflow\r
+; 2 - OVER U< IF -4 THROW THEN\r
+; 1+ CELLS sp@ + @ ;\r
+\r
+ $COLON 4,'PICK',PICK,_FLINK\r
+ DW DEPTH,DUPP,DoLIT,2,LessThan,ZBranch,PICK1\r
+ DW DoLIT,-4,THROW\r
+PICK1 DW DoLIT,2,Minus,OVER,ULess,ZBranch,PICK2\r
+ DW DoLIT,-4,THROW\r
+PICK2 DW OnePlus,CELLS,SPFetch,Plus,Fetch,EXIT\r
+\r
+; POSTPONE ( "<spaces>name" -- ) \ CORE\r
+; Parse name and find it. Append compilation semantics of name\r
+; to current definition.\r
+;\r
+; : POSTPONE (') 0< IF POSTPONE LITERAL\r
+; POSTPONE COMPILE, EXIT THEN \ non-IMMEDIATE\r
+; COMPILE, ; COMPILE-ONLY IMMEDIATE \ IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+8,'POSTPONE',POSTPONE,_FLINK\r
+ DW ParenTick,ZeroLess,ZBranch,POSTP1\r
+ DW LITERAL,DoLIT,COMPILEComma\r
+POSTP1 DW COMPILEComma,EXIT\r
+\r
+; RECURSE ( -- ) \ CORE\r
+; Append the execution semactics of the current definition to\r
+; the current definition.\r
+;\r
+; : RECURSE bal 1- 2* PICK 1+ IF -22 THROW THEN\r
+; \ control structure mismatch; colon-sys type is -1\r
+; bal 1- 2* 1+ PICK \ xt of current definition\r
+; COMPILE, ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+7,'RECURSE',RECURSE,_FLINK\r
+ DW Bal,OneMinus,TwoStar,PICK,OnePlus,ZBranch,RECUR1\r
+ DW DoLIT,-22,THROW\r
+RECUR1 DW Bal,OneMinus,TwoStar,OnePlus,PICK\r
+ DW COMPILEComma,EXIT\r
+\r
+; REPEAT ( C: orig dest -- ) \ CORE\r
+; Terminate a BEGIN-WHILE-REPEAT indefinite loop. Resolve\r
+; backward reference dest and forward reference orig.\r
+;\r
+; : REPEAT AGAIN THEN ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+6,'REPEAT',REPEATT,_FLINK\r
+ DW AGAIN,THENN,EXIT\r
+\r
+; RSHIFT ( x1 u -- x2 ) \ CORE\r
+; Perform a logical right shift of u bit-places on x1, giving x2.\r
+; Put 0 into the most significant bits vacated by the shift.\r
+;\r
+; : RSHIFT ?DUP IF\r
+; 0 SWAP cell-size-in-bits SWAP -\r
+; 0 DO 2DUP D+ LOOP\r
+; NIP\r
+; THEN ;\r
+\r
+ $COLON 6,'RSHIFT',RSHIFT,_FLINK\r
+ DW QuestionDUP,ZBranch,RSHIFT2\r
+ DW Zero,SWAP,DoLIT,CELLL*8,SWAP,Minus,Zero,DoDO\r
+RSHIFT1 DW TwoDUP,DPlus,DoLOOP,RSHIFT1\r
+ DW NIP\r
+RSHIFT2 DW EXIT\r
+\r
+; SLITERAL ( c-addr1 u -- ) \ STRING\r
+; Run-time ( -- c-addr2 u )\r
+; Compile a string literal. Return the string on execution.\r
+;\r
+; : SLITERAL DUP LITERAL POSTPONE doS"\r
+; CHARS xhere 2DUP + ALIGNED TOxhere\r
+; SWAP MOVE ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+8,'SLITERAL',SLITERAL,_FLINK\r
+ DW DUPP,LITERAL,DoLIT,DoSQuote,COMPILEComma\r
+ DW CHARS,XHere,TwoDUP,Plus,ALIGNED,TOXHere\r
+ DW SWAP,MOVE,EXIT\r
+\r
+; S" Compilation: ( "ccc<">" -- ) \ CORE\r
+; Run-time: ( -- c-addr u )\r
+; Parse ccc delimetered by " . Return the string specification\r
+; c-addr u on execution.\r
+;\r
+; : S" [CHAR] " PARSE POSTPONE SLITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+2,'S"',SQuote,_FLINK\r
+ DW DoLIT,'"',PARSE,SLITERAL,EXIT\r
+\r
+; SM/REM ( d n1 -- n2 n3 ) \ CORE\r
+; Symmetric divide of double by single. Return remainder n2\r
+; and quotient n3.\r
+;\r
+; : SM/REM 2DUP XOR >R OVER >R >R DUP 0< IF DNEGATE THEN\r
+; R> ABS UM/MOD\r
+; R> 0< IF SWAP NEGATE SWAP THEN\r
+; R> 0< IF \ negative quotient\r
+; NEGATE 0 OVER < 0= IF EXIT THEN\r
+; -11 THROW THEN \ result out of range\r
+; DUP 0< IF -11 THROW THEN ; \ result out of range\r
+\r
+ $COLON 6,'SM/REM',SMSlashREM,_FLINK\r
+ DW TwoDUP,XORR,ToR,OVER,ToR,ToR,DUPP,ZeroLess\r
+ DW ZBranch,SMREM1\r
+ DW DNEGATE\r
+SMREM1 DW RFrom,ABSS,UMSlashMOD\r
+ DW RFrom,ZeroLess,ZBranch,SMREM2\r
+ DW SWAP,NEGATE,SWAP\r
+SMREM2 DW RFrom,ZeroLess,ZBranch,SMREM3\r
+ DW NEGATE,DoLIT,0,OVER,LessThan,ZeroEquals,ZBranch,SMREM4\r
+SMREM5 DW EXIT\r
+SMREM3 DW DUPP,ZeroLess,ZBranch,SMREM5\r
+SMREM4 DW DoLIT,-11,THROW\r
+\r
+; SPACES ( n -- ) \ CORE\r
+; Send n spaces to the output device if n is greater than zero.\r
+;\r
+; : SPACES ?DUP IF 0 DO SPACE LOOP THEN ;\r
+\r
+ $COLON 6,'SPACES',SPACES,_FLINK\r
+ DW QuestionDUP,ZBranch,SPACES2\r
+ DW Zero,DoDO\r
+SPACES1 DW SPACE,DoLOOP,SPACES1\r
+SPACES2 DW EXIT\r
+\r
+; TO Interpretation: ( x "<spaces>name" -- ) \ CORE EXT\r
+; Compilation: ( "<spaces>name" -- )\r
+; Run-time: ( x -- )\r
+; Store x in name.\r
+;\r
+; : TO ' ?call DUP IF \ should be call-doVALUE\r
+; ['] doVALUE = \ verify VALUE marker\r
+; IF @ STATE @\r
+; IF POSTPONE doTO code, EXIT THEN\r
+; ! EXIT\r
+; THEN THEN\r
+; -32 THROW ; IMMEDIATE \ invalid name argument (e.g. TO xxx)\r
+\r
+ $COLON IMMED+2,'TO',TO,_FLINK\r
+ DW Tick,QCall,DUPP,ZBranch,TO1\r
+ DW DoLIT,DoVALUE,Equals,ZBranch,TO1\r
+ DW Fetch,STATE,Fetch,ZBranch,TO2\r
+ DW DoLIT,DoTO,COMPILEComma,CodeComma,EXIT\r
+TO2 DW Store,EXIT\r
+TO1 DW DoLIT,-32,THROW\r
+\r
+; U. ( u -- ) \ CORE\r
+; Display u in free field format followed by space.\r
+;\r
+; : U. 0 D. ;\r
+\r
+ $COLON 2,'U.',UDot,_FLINK\r
+ DW Zero,DDot,EXIT\r
+\r
+; UNTIL ( C: dest -- ) \ CORE\r
+; Terminate a BEGIN-UNTIL indefinite loop structure.\r
+;\r
+; : UNTIL IF -22 THROW THEN \ control structure mismatch; dest type is 0\r
+; POSTPONE 0branch code, bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'UNTIL',UNTIL,_FLINK\r
+ DW ZBranch,UNTIL1\r
+ DW DoLIT,-22,THROW\r
+UNTIL1 DW DoLIT,ZBranch,COMPILEComma,CodeComma,BalMinus,EXIT\r
+\r
+; VALUE ( x "<spaces>name" -- ) \ CORE EXT\r
+; name Execution: ( -- x )\r
+; Create a value object with initial value x.\r
+;\r
+; : VALUE bal IF -29 THROW THEN \ compiler nesting\r
+; ['] doVALUE xt, head,\r
+; xhere DUP CELL+ TOxhere\r
+; RAMB @ SWAP !\r
+; , linkLast ; \ store x and link VALUE word to current wordlist\r
+\r
+ $COLON 5,'VALUE',VALUE,_FLINK\r
+ DW Bal,ZBranch,VALUE1\r
+ DW DoLIT,-29,THROW\r
+VALUE1 DW DoLIT,DoVALUE,xtComma,HeadComma\r
+ DW XHere,DUPP,CELLPlus,TOXHere,RAMB,Fetch,SWAP,Store\r
+ DW Comma,LinkLast,EXIT\r
+\r
+; VARIABLE ( "<spaces>name" -- ) \ CORE\r
+; name Execution: ( -- a-addr )\r
+; Parse a name and create a variable with the name.\r
+; Resolve one cell of data space at an aligned address.\r
+; Return the address on execution.\r
+;\r
+; : VARIABLE bal IF -29 THROW THEN \ compiler nesting\r
+; ['] doCONST xt, head,\r
+; xhere DUP CELL+ TOxhere\r
+; RAMB @ DUP CELL+ RAMB ! \ allocate one cell in RAM area\r
+; SWAP ! linkLast ;\r
+\r
+ $COLON 8,'VARIABLE',VARIABLE,_FLINK\r
+ DW Bal,ZBranch,VARIA1\r
+ DW DoLIT,-29,THROW\r
+VARIA1 DW DoLIT,DoCONST,xtComma,HeadComma\r
+ DW XHere,DUPP,CELLPlus,TOXHere\r
+ DW RAMB,Fetch,DUPP,CELLPlus,RAMB,Store\r
+ DW SWAP,Store,LinkLast,EXIT\r
+\r
+; WHILE ( C: dest -- orig dest ) \ CORE\r
+; Put the location of a new unresolved forward reference orig\r
+; onto the control flow stack under the existing dest. Typically\r
+; used in BEGIN ... WHILE ... REPEAT structure.\r
+;\r
+; : WHILE POSTPONE IF 2SWAP ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+5,'WHILE',WHILEE,_FLINK\r
+ DW IFF,TwoSWAP,EXIT\r
+\r
+; WORD ( char "<chars>ccc<char>" -- c-addr ) \ CORE\r
+; Skip leading delimeters and parse a word. Return the address\r
+; of a transient region containing the word as counted string.\r
+;\r
+; : WORD skipPARSE xhere pack" DROP xhere ;\r
+\r
+ $COLON 4,'WORD',WORDD,_FLINK\r
+ DW SkipPARSE,XHere,PackQuote,DROP,XHere,EXIT\r
+\r
+; ['] Compilation: ( "<spaces>name" -- ) \ CORE\r
+; Run-time: ( -- xt )\r
+; Parse name. Return the execution token of name on execution.\r
+;\r
+; : ['] ' POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+3,"[']",BracketTick,_FLINK\r
+ DW Tick,LITERAL,EXIT\r
+\r
+; [CHAR] Compilation: ( "<spaces>name" -- ) \ CORE\r
+; Run-time: ( -- char )\r
+; Parse name. Return the value of the first character of name\r
+; on execution.\r
+;\r
+; : [CHAR] CHAR POSTPONE LITERAL ; COMPILE-ONLY IMMEDIATE\r
+\r
+ $COLON IMMED+COMPO+6,'[CHAR]',BracketCHAR,_FLINK\r
+ DW CHAR,LITERAL,EXIT\r
+\r
+; \ ( "ccc<eol>" -- ) \ CORE EXT\r
+; Parse and discard the remainder of the parse area.\r
+;\r
+; : \ SOURCE >IN ! DROP ; IMMEDIATE\r
+\r
+ $COLON IMMED+1,'\',Backslash,_FLINK\r
+ DW SOURCE,ToIN,Store,DROP,EXIT\r
+\r
+; Optional Facility words\r
+\r
+; EKEY? ( -- flag ) \ FACILITY EXT\r
+; If a keyboard event is available, return true.\r
+;\r
+; : EKEY? 'ekey? EXECUTE ;\r
+\r
+ $COLON 5,'EKEY?',EKEYQuestion,_FLINK\r
+ DW TickEKEYQ,EXECUTE,EXIT\r
+\r
+; EMIT? ( -- flag ) \ FACILITY EXT\r
+; flag is true if the user output device is ready to accept data\r
+; and the execution of EMIT in place of EMIT? would not have\r
+; suffered an indefinite delay. If device state is indeterminate,\r
+; flag is true.\r
+;\r
+; : EMIT? 'emit? EXECUTE ;\r
+\r
+ $COLON 5,'EMIT?',EMITQuestion,_FLINK\r
+ DW TickEMITQ,EXECUTE,EXIT\r
+\r
+;;;;;;;;;;;;;;;;\r
+; RAM/ROM System Only\r
+;;;;;;;;;;;;;;;;\r
+\r
+; RESET-SYSTEM ( -- )\r
+; Reset the system. Restore initialization values of system\r
+; variables.\r
+;\r
+; : RESET-SYSTEM\r
+; sysVar00 sysVar0 [ sysVar0End sysVar0 - ] LITERAL MOVE COLD ;\r
+\r
+ $COLON 12,'RESET-SYSTEM',RESET_SYSTEM,_SLINK\r
+ DW DoLIT,UZERO0,SysVar0,DoLIT,ULAST-UZERO\r
+ DW MOVE,COLD,EXIT\r
+\r
+UZERO0 DW RXQ\r
+ DW RXFetch\r
+ DW TXQ\r
+ DW TXStore\r
+ DW Set_IO\r
+ DW DotOK\r
+ DW HI\r
+ DW 0\r
+ DW AddrROMB\r
+ DW AddrROMT\r
+ DW AddrRAMB\r
+ DW OptiCOMPILEComma\r
+ DW EXECUTE\r
+ DW DoubleAlsoComma\r
+ DW DoubleAlso\r
+ DW EXECUTE\r
+ DW EXECUTE\r
+ DW 10\r
+ DW CTOP\r
+ DW NTOP\r
+ DW VTOP\r
+ DW RAMT0\r
+ DW 0\r
+ DW 0\r
+ DW 0\r
+ DW 2\r
+ DW FORTH_WORDLISTAddr\r
+ DW NONSTANDARD_WORDLISTAddr\r
+ DW (OrderDepth-2) DUP (0)\r
+ DW FORTH_WORDLISTAddr\r
+ DW LASTFORTH\r
+ DW NONSTANDARD_WORDLISTAddr\r
+ DW FORTH_WORDLISTName\r
+ DW LASTSYSTEM\r
+ DW 0\r
+ DW NONSTANDARD_WORDLISTName\r
+ DW 3*(MaxWLISTS-2) DUP (0)\r
+ DW LASTENV\r
+ DW SysUserP\r
+ DW SysUserP\r
+ DW ?\r
+ DW SystemTaskName\r
+ DW ?\r
+ DW ?\r
+ DW Wake\r
+ DW SysStatus\r
+ DW SPP\r
+ DW RPP\r
+\r
+;===============================================================\r
+\r
+LASTENV EQU _ENVLINK-0\r
+LASTSYSTEM EQU _SLINK-0 ;last SYSTEM word name address\r
+LASTFORTH EQU _FLINK-0 ;last FORTH word name address\r
+\r
+NTOP EQU _NAME-0 ;next available memory in name dictionary\r
+CTOP EQU $-0 ;next available memory in code dictionary\r
+VTOP EQU _VAR-0 ;next available memory in variable area\r
+\r
+MAIN ENDS\r
+END ORIG\r
+\r
+;===============================================================\r
--- /dev/null
+<HTML>\r
+<HEAD>\r
+<TITLE>hForth - A Small, Portable ANS Forth</TITLE>\r
+</HEAD>\r
+<BODY>\r
+\r
+<P><I>Originally published in</I>Forth Dimensions XVIII/2, 30</P>\r
+\r
+<H1>hForth - A Small, Portable ANS Forth</H1>\r
+\r
+Wonyong Koh, Ph.D.</BR>\r
+Taejon, Korea</BR>\r
+wykoh@pado.krict.re.kr</BR>\r
+\r
+<H2>Background history</H2> \r
+\r
+<P>I started a personal project two and half years ago, which was in my\r
+mind for quite a long time: Widespread Forth in Korea. Postfix is natural\r
+to Korean people since a verb comes after an object in Korean language.\r
+Also Forth does not restrict a programmer to use only alphanumeric\r
+characters. A Korean Forth programmer can easily express his idea in\r
+comfortable Korean words rather than to be forced to think in English. As\r
+one might expect, there was an effort for Korean Forth. Dr. Chong-Hong\r
+Pyun and Mr. Jin-Mook Park built a Korean version of fig-Forth for Apple\r
+II computer in mid-eighties. Long-time FD readers may remember Dr. Pyun's\r
+letter in <I>Forth Dimensions</I> X/6, 8. Unfortunately, Korean computer\r
+community swiftly moved to IBM PC while Dr. Pyun wrote articles about\r
+their work in popular programming and science magazines. It became\r
+somewhat obsolete before being known widely. Despite of this and other\r
+efforts Forth has been virtually unknown to most Koreans. Two and half\r
+years ago I decided to restart it and looked for a vehicle for the\r
+purpose. I found that there was no small ANS Forth system for IBM PC. I\r
+decided to build one. In the course of ANSifying eForth I have replaced\r
+every line of eForth source and felt that it deserved its own name. I\r
+knew that there were Forth systems named as bForth, cForth, eForth,\r
+gForth, iForth, Jforth and KForth. I picked <I>h</I> since it seemed not\r
+yet used by anyone and also <I>Han</I> means Korean in Korean\r
+language.</P>\r
+\r
+<H2>ROM model came first</H2>\r
+\r
+<P>eForth, which was written by Mr. Bill Muench and Dr. C. H. Ting in\r
+1990, seemed to be a good place to start. I studied eForth source and Dr.\r
+Ting's article in <I>Forth Dimensions</I> XIII/1, 15 and set the\r
+following goals:</P>\r
+\r
+<UL>\r
+<LI>small machine dependent kernel and portable high level code</LI>\r
+<LI>strict compliance to ANS Forth</LI>\r
+<LI>extensive error handling through CATCH/THROW mechanism</LI>\r
+<LI>separated code and name space</LI>\r
+<LI>use of wordlists</LI>\r
+<LI>explicit consideration for separated RAM/ROM address space</LI>\r
+<LI>simple vectored input/output</LI>\r
+<LI>direct threaded code</LI>\r
+<LI>easy upgrade path to optimize for specific CPU</LI>\r
+</UL>\r
+\r
+<P>Most of them are adapted from eForth. I emphasize extensive error\r
+handling since some of well-known Forth systems cannot manage as simple a\r
+situation as divide-by-zero. In hForth almost all ambiguous conditions\r
+specified in the ANS Forth document issue <CODE>THROW</CODE> and are\r
+captured by <CODE>CATCH</CODE> either by user-defined word or by hForth\r
+system.</P>\r
+\r
+<P>hForth ROM model is especially designed for a minimal development\r
+system for embedded applications which uses non-volatile RAM or ROM\r
+emulator in place of ROM. The content of ROM address space can be changed\r
+during development phase and is copied later to real ROM for production\r
+system. hForth ROM model checks whether or not ROM address space is\r
+alterable when it starts. New definitions go into ROM address space if it\r
+is alterable. Otherwise they go into RAM address space.</P>\r
+\r
+<PRE>\r
+ Alterable ROM address space Unalterable ROM address space\r
+=============================== ===============================\r
+ name space of new definitions\r
+ -------------------------------\r
+\r
+ RAM address space RAM address space\r
+\r
+------------------------------- -------------------------------\r
+ data space / code space \r
+ data space of new definitions\r
+=============================== ===============================\r
+ name space of old definitions name space of old definitions\r
+------------------------------- -------------------------------\r
+ name space of new definitions\r
+-------------------------------\r
+\r
+ ROM address space ROM address space\r
+\r
+------------------------------- -------------------------------\r
+ data space / code space \r
+ of new definitions data space\r
+------------------------------- -------------------------------\r
+ code space of old definitions code space of old definitions\r
+=============================== ===============================\r
+</PRE>\r
+\r
+<P>Data space can be allocated either in ROM address space for tables of\r
+constants or in RAM address space for arrays of variables.\r
+<CODE>ROM</CODE> and <CODE>RAM</CODE>, recommended in the Appendix of the\r
+Standard document, are used to switch data space between RAM and ROM\r
+address space. Name space may be excluded in final system if an\r
+application does not require Forth text interpreter. 8086 hForth ROM\r
+model occupies little more than 6 KB of code space for all Core word set\r
+words and requires at least 1 KB of RAM address space for stacks and\r
+system variables.</P>\r
+\r
+<P>The assembly source is arranged so that more implementation-dependent\r
+words come earlier. System-dependent words come first, CPU-dependent\r
+words come after, then come all the other high level words. Colon\r
+definitions of all high level words are given as comments in the assembly\r
+source. One needs to redefine only system-dependent words to port hForth\r
+ROM model to a 8086 single board computer from current one for MS-DOS\r
+machine without changing any CPU-dependent words. Standard words come\r
+after essential non-Standard words in each system-dependent,\r
+CPU-dependent, and portable part. All Standard Core word set words are\r
+included to make hForth an ANS Forth system. High level Standard words in\r
+the last part of the assembly source are not used for the implementation\r
+of hForth and can be omitted to make a minimal system. Current 8086\r
+hForth ROM model for MS-DOS has 59 kernel words: 13 system-dependent\r
+words, 21 CPU-dependent non-Standard words and 25 CPU-dependent Standard\r
+words. System-dependent words include input/output words and other words\r
+for file input through keyboard redirection of MS-DOS. For five of kernel\r
+words, including <CODE>(search-wordlist)</CODE> and <CODE>ALIGNED</CODE>,\r
+CPU-dependent definitions are used instead of high level definitions for\r
+faster execution.</P>\r
+\r
+<P>System initialization and input/output operations are performed\r
+through following execution vectors: <CODE>'boot</CODE>,\r
+<CODE>'init-i/o</CODE>, <CODE>'ekey?</CODE>, <CODE>'ekey</CODE>,\r
+<CODE>'emit?</CODE>, <CODE>'emit</CODE>, and <CODE>'prompt</CODE>.\r
+Appropriate actions can be taken by redirecting these execution vectors.\r
+<CODE>'init-i/o</CODE> is executed in <CODE>THROW</CODE> and when the\r
+system starts while <CODE>'boot</CODE> is executed only once when the\r
+system starts. One has better chance not to loose control by restoring\r
+i/o vectors through <CODE>'init-i/o</CODE> whenever an exception\r
+condition occurs. For example, serial communication link may not be\r
+broken by an accidental change of communication parameters.\r
+<CODE>'boot</CODE> may be redirected to an appropriate application word\r
+instead of default word in a finished application. Traditional\r
+'ok<end-of-line>' prompt (which is actually not) may be replaced by\r
+redirecting <CODE>'prompt</CODE>.</P>\r
+\r
+<P>Control structure matching is rigorously checked for different control\r
+flow stack items. Control-flow stack is implemented on data stack.\r
+Control-flow stack item is represented by two data stack items as\r
+below</P>\r
+\r
+<PRE>\r
+Control-flow stack item Representation (parameter and type)\r
+----------------------- -------------------------------------\r
+ <I>dest</I> control-flow destination 0\r
+ <I>orig</I> control-flow origin 1\r
+ <I>of-sys</I> OF origin 2\r
+ <I>case-sys</I> x (any value) 3\r
+ <I>do-sys</I> ?DO origin DO destination\r
+ <I>colon-sys</I> xt of current definition -1\r
+</PRE>\r
+\r
+<P>hForth can detect the nonsense clause "<CODE>BEGIN IF AGAIN\r
+THEN</CODE>" easily. <CODE>CS-ROLL</CODE> and <CODE>CS-PICK</CODE> can be\r
+applied to the list of <I>dest</I>s and <I>orig</I>s only. This can be\r
+verified by checking whether the ORed type is 1. I can not think of a\r
+control-structure-mismatch that current hForth cannot catch.</P>\r
+\r
+<P>Number of words grows substantially as a Forth system is extended.\r
+Dictionary search can be time-consuming unless hashing or other means are\r
+employed. Currently hForth uses no special search mechanism, however,\r
+maintains reasonable compilation speed by keeping shallow search depth in\r
+addition to using optimized <CODE>(search-wordlist)</CODE>. Initially two\r
+wordlists are in the search order stack: <CODE>FORTH-WORDLIST</CODE> and\r
+<CODE>NONSTANDARD-WORDLIST</CODE>. <CODE>FORTH-WORDLIST</CODE> contains\r
+all the Standard words and <CODE>NONSTANDARD-WORDLIST</CODE> contains all\r
+the other words. Upon extending hForth, optional Standard words will go\r
+in <CODE>FORTH-WORDLIST</CODE> and lower-level non-Standard words to\r
+implement them will be kept in separate wordlists which are usually not\r
+in the search order stack. Only a small number of non-Standard words to\r
+be used by a user will be added in <CODE>NONSTANDARD-WORDLIST</CODE>.</P>\r
+\r
+<H2>RAM and EXE models follow</H2>\r
+\r
+<P>hForth package consists of three models: ROM, RAM and EXE model.\r
+hForth RAM model is for RAM only system where name, code and data spaces\r
+are all combined. hForth EXE model is for a system in which code space is\r
+completely separated from data space and execution token (xt) may not be\r
+a valid address in data space. 8086 hForth EXE model uses two 64 KB full\r
+memory segments: one for code space and the other for name and data\r
+spaces. EXE model might be extended for an embedded system where name\r
+space resides in host computer and code and data space are in target\r
+computer. Few kernel words are added to ROM model to derive RAM and EXE\r
+models and only several high level words such as <CODE>HERE</CODE> and\r
+<CODE>CREATE</CODE> are redefined.</P>\r
+\r
+<P>ROM and RAM models are probably too slow for many practical\r
+applications as original eForth. However, 8086 hForth EXE model is more\r
+competitive. High-level colon definitions of all frequently used words\r
+are replaced with 8086 assembly code definitions in hForth EXE model.\r
+Comparison with other 8086 Forth systems can be found in Mr. Borasky's\r
+article "Forth in the HP100LX" <I>Forth Dimensions</I> XVII/4, 6.</P>\r
+\r
+<P>hForth models are highly extensible. Optional word set words as well\r
+as an assembler can be added on top of basic hForth system. Complete\r
+Tools, Search Order, Search Order Ext word set words and other optional\r
+Standard words are defined in <I>OPTIONAL.F</I> included in 8086 hForth\r
+package. 8086 Forth assembler is provided in <I>ASM8086.F</I>. Many of\r
+Core Ext word set words are provided in <I>OPTIONAL.F</I> and all the\r
+other Core Ext words except obsolescent ones and <CODE>[COMPILE]</CODE>\r
+(for which <CODE>POSTPONE</CODE> should be used) are provided in\r
+<I>COREEXT.F</I>. Complete Double and Double Ext word set words are\r
+provided in <I>DOUBLE.F</I>. High level definitions in these files should\r
+work in hForth for other CPUs. These files are loaded into 8086 hForth\r
+for MS-DOS machines through keyboard redirection function of MS-DOS.\r
+Complete Block, Block Ext, File and File Ext word set words are provided\r
+in <I>MSDOS.F</I> using MS-DOS file handle functions. Other utilities are\r
+also included in 8086 hForth package. <I>LOG.F</I> is to capture screen\r
+output to an MS-DOS text file, which is edited to make Forth text source.\r
+<I>DOSEXEC.F</I> is to call MS-DOS executables within hForth system. A\r
+user can call familiar text editor, edit Forth text source, exit the\r
+editor, load the source and debug without leaving hForth environment.\r
+This process can be repeated without saturating address spaces if a\r
+<CODE>MARKER</CODE> word is defined in the beginning of the Forth text\r
+source and called before reload the source.</P>\r
+\r
+<H2>Multitasker</H2>\r
+\r
+<P>I had a chance to look at Mr. Muench's eForth 2.4.2. The multitasker\r
+is the most elegant one among those that I have seen. It does task\r
+switching through only two high-level words. I immediately adapted it to\r
+hForth. Mr. Muench's multitasker is now included in P21Forth for MuP21\r
+processor.</P>\r
+\r
+<P>In Forth multitasker each task has its own context: data stack, return\r
+stack and its own variables (traditionally called user variables). The\r
+contexts must be stored and restored properly when tasks are suspended\r
+and resumed. In Mr. Muench's multitasker <CODE>PAUSE</CODE> saves current\r
+task's context and <CODE>wake</CODE> restores next task's context.\r
+<CODE>PAUSE</CODE> saves return stack pointer on data stack and data\r
+stack pointer into a user variable <CODE>stackTop</CODE>, then jumps to\r
+next task's <CODE>status</CODE> which is held in current task's user\r
+variable <CODE>follower.</CODE> It is defined as:</P>\r
+\r
+<PRE><CODE> : PAUSE rp@ sp@ stackTop ! follower @ >R ; COMPILE-ONLY\r
+</CODE></PRE>\r
+\r
+<P>Advanced Forth users already know that '<CODE>>R EXIT</CODE>'\r
+causes high level jump for traditional Forth virtual machine. Each task's\r
+user variable <CODE>status</CODE> holds <CODE>wake</CODE> and immediately\r
+followed by user variable <CODE>follower</CODE>. Initially hForth has\r
+only one task <CODE>SystemTask</CODE>. Its user variable\r
+<CODE>status</CODE> and <CODE>follower</CODE> hold:</P>\r
+\r
+<PRE>\r
+SystemTask's status follower\r
+ +------+ +-----------------------------------------+\r
+ | wake | | absolute address of SystemTask's status |\r
+ +------+ +-----------------------------------------+\r
+</PRE>\r
+\r
+<P>If <CODE>FooTask</CODE> is added, <CODE>status</CODE> and\r
+<CODE>follwer</CODE> of the two tasks now hold:</P>\r
+\r
+<PRE>\r
+SystemTask's status follower\r
+ +------+ +-----------------------------------------+\r
+ | wake | | absolute address of FooTask's status |\r
+ +------+ +-----------------------------------------+\r
+\r
+ FooTask's status follower\r
+ +------+ +-----------------------------------------+\r
+ | wake | | absolute address of SystemTask's status |\r
+ +------+ +-----------------------------------------+\r
+</PRE>\r
+\r
+<P>Effectively current task's <CODE>PAUSE</CODE> jumps to next task's\r
+<CODE>wake</CODE>. At this point user variables and stacks are not\r
+switched yet. <CODE>wake</CODE> assigns the return stack item (the next\r
+address of <CODE>status</CODE>, i.e. the address of\r
+<CODE>follower</CODE>) into global variable <CODE>userP</CODE>, which is\r
+used to calculate absolute address of user variables. All user variables\r
+cluster in front of <CODE>follower</CODE>. Now user variables are\r
+switched. Then <CODE>wake</CODE> restores data stack pointer stored in\r
+user variable <CODE>stackTop</CODE> (now data stack is switched) and\r
+restores return stack pointer saved on top of data stack (now return\r
+stack is switched). <CODE>wake</CODE> is defined as:</P>\r
+\r
+<PRE><CODE> : wake R> userP ! stackTop @ sp! rp! ; COMPILE-ONLY\r
+</CODE></PRE>\r
+\r
+<P>What is clever here is that one item on return stack, left by\r
+<CODE>PAUSE</CODE> and consumed by <CODE>wake</CODE>, is used to transfer\r
+control as well as information for context switching. This multitasker is\r
+highly portable. Not a line of multitasker code was touched when hForth\r
+8086 RAM model was moved to Z80 processor. This is also verified by Neal\r
+Crook when porting hForth to ARM processor. I believe that it should be\r
+possible to port this multitasker to subroutine-threaded or native-code\r
+Forth by redefining them in machine codes.</P>\r
+\r
+<P>I used this multitasker to update graphics screen and make cursor\r
+blink in <I>HIOMULTI.F</I>. Console output is redirected to graphics\r
+screen to display Korean and English characters for VGA and Hercules\r
+Graphics Adapters. <CODE>EMIT</CODE> fills characters into a buffer and a\r
+background task displays them on graphics screen when hForth is waiting\r
+for keyboard input. Scrolling text on graphics screen is as fast as on\r
+text screen. I also used the multitasker for serial communication in\r
+<I>SIO.F</I>. Main routine fetches characters from input buffer and\r
+stores characters in output buffer while background task does actual\r
+hardware control.</P>\r
+\r
+<H2>Jump table interpreter</H2>\r
+\r
+<P>I applied all the best ideas and tricks I know to hForth. Most of them\r
+came from other people while I added a few of my own. I believe that some\r
+of them are worth to mention.</P>\r
+\r
+<P>hForth text interpreter uses vector table to determine what to do with\r
+a parsed strings after search it in the Forth dictionary. Dictionary\r
+search results the string and 0 (for an unknown word); xt and -1 (for\r
+non-immediate word); or xt and 1 (for immediate word) on data stack.\r
+hForth text interpreter chooses next action by the following code:</P>\r
+\r
+<PRE><CODE> 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE\r
+</CODE></PRE>\r
+\r
+<P><CODE>'doWord</CODE> table consists of six vectors.</P>\r
+\r
+<PRE>\r
+ compilation state interpretation state\r
+ (STATE returns -1) (STATE returns 0)\r
+ ------------------ --------------------\r
+non-immediate word (TOS = -1) optiCOMPILE, EXECUTE\r
+unknown word (TOS = 0) doubleAlso, doubleAlso\r
+immediate word (TOS = 1) EXECUTE EXECUTE\r
+\r
+TOS = top-of-stack\r
+</PRE>\r
+\r
+<P>The behavior of the hForth text interpreter can be interactively\r
+changed by replacing these vectors. For example, one can make hForth\r
+interpreter accept only single-cell numbers by replacing\r
+<CODE>doubleAlso,</CODE> and <CODE>doubleAlso</CODE> with\r
+<CODE>singleOnly,</CODE> and <CODE>singleOnly</CODE> respectively.\r
+<CODE>optiCOMPILE,</CODE> does the same thing as Standard word\r
+<CODE>COMPILE,</CODE> except that it removes one level of\r
+<CODE>EXIT</CODE> if possible. <CODE>optiCOMPILE, </CODE> does not\r
+compile null definition <CODE>CHARS</CODE> into the current definition.\r
+Also it compiles <CODE>2*</CODE> instead of <CODE>CELLS</CODE> if\r
+<CODE>CELLS</CODE> is defined as "<CODE>: CELLS 2* ;</CODE>".</P>\r
+\r
+<H2>Special compilation action for default compilation semantics</H2>\r
+\r
+<P>Compiling words created by <CODE>CONSTANT</CODE>,\r
+<CODE>VARIABLE</CODE>, and <CODE>CREATE</CODE> as literal values can\r
+increase execution speed, especially for native-code Forth compilers. A\r
+solution is implemented in hForth EXE model to provide special\r
+compilation action for default compilation semantics. Words created by\r
+<CODE>CONSTANT</CODE>, <CODE>VARIABLE</CODE>, and <CODE>CREATE</CODE>\r
+have a special mark and xt for special compilation action. hForth\r
+compiler executes the xt if it sees the mark. (<CODE>POSTPONE</CODE> must\r
+find this special compilation action also and compile it.) A new data\r
+structure with special compilation action can be built by\r
+<CODE>CREATE</CODE> and only two non-Standard words:\r
+implementation-dependent <CODE>doCompiles></CODE> and\r
+implementation-independent <CODE>compiles></CODE>.\r
+<CODE>doCompiles></CODE> verifies whether the last definition is ready\r
+for special compilation action and takes an xt on data stack and assign\r
+it as special compilation action of the last definition.\r
+<CODE>compiles></CODE> is defined as:</P>\r
+\r
+<PRE><CODE> : compiles> ( xt -- )\r
+ POSTPONE LITERAL POSTPONE doCompiles> ; IMMEDIATE\r
+</CODE></PRE>\r
+\r
+<P>For example, <CODE>2CONSTANT</CODE> can be defined as:</P>\r
+\r
+<PRE><CODE> :NONAME EXECUTE POSTPONE 2LITERAL ;\r
+ : 2CONSTANT\r
+ CREATE SWAP , , compiles> DOES> DUP @ SWAP CELL+ @ ;\r
+</CODE></PRE>\r
+\r
+</CODE><P>It is the user's responsibility to match special compilation\r
+action with the default compilation semantics. I believe that this\r
+solution is general enough to be applied to other Forth systems.</P>\r
+\r
+<H2>Turtle Graphics</H2>\r
+\r
+I implemented LOGO's Turtle Graphics in hForth. The turtle moves on VGA\r
+or Hercules graphics screen and follows postfix Forth command '<CODE>100\r
+FORWARD</CODE>' instead of prefix LOGO command '<CODE>FORWARD\r
+100</CODE>'. No floating-point math is used at all. Integers are used\r
+represent angles in degree rather than in radian and look-up table is\r
+used to evaluate trigonometric functions. Only a few words are defined in\r
+machine code for line drawing and trigonometric function evaluation. The\r
+turtle moves swiftly on a 286 machine. The Forth source and MS-DOS\r
+executables, <I>TURTLE.F</I>, <I>ETURTLE.EXE</I> (using English commands)\r
+and <I>HTURTLE.EXE </I>(using Korean commands), are included.</P>\r
+\r
+<H2>Summary</H2>\r
+\r
+<P>hForth is a small ANS Forth system based on eForth. It is especially\r
+designed for small embedded system. The basic ROM and RAM models are\r
+designed for portability, however, can be easily optimized for a specific\r
+CPU to build a competitive system as shown in 8086 EXE model. hForth\r
+packages for 8086 and Z80 can be found at \r
+<A HREF="http://www.taygeta.com/forthcomp.html">\r
+http://www.taygeta.com/forthcomp.html</A> or \r
+<A HREF="ftp://ftp.taygeta.com/pub/Forth/Reviewed/">\r
+ftp://ftp.taygeta.com/pub/Forth/Reviewed/</A>. hForth is also ported to\r
+H8 processor by Mr. Bernie Mentink and to ARM processor by Neal Crook.\r
+I hope that hForth will be useful to many people.</P>\r
+\r
+</BODY>\r
+</HTML>\r
--- /dev/null
+\ IBM-PCµA¬á ³a\93e hForth ¶w Ðe\8bi ·³Â\89\9db Ïa\9d¡\8ba\9c\91·³\93¡\94a. »¡\8bq·e ¹¡ÐsÑw\r
+\ Ðe\8bi e ³i ®\81 ·¶·s\93¡\94a.\r
+\\r
+\ ·¡ Ïa\9d¡\8ba\9c\91·e VGA \8ba\9c\81Ï¢ Äa\97aµÁ ÐáÇI\9dA¯a \8ba\9c\81Ï¢ Äa\97a e·i »¡¶¥Ðs\93¡\94a.\r
+\\r
+\ 'TEXT'\9ca\89¡ ¯¡Åa¡e ÉB¯aËa ÑÁ¡e·a\9d¡ ¤a\8eá\89¡ 'HGRAPHIC'·¡\9ca\89¡ ¯¡Ç¡¡e \8ba\9c\81Ï¢\r
+\ ÑÁ¡e·a\9d¡ ¤a\8eá´á¬á Ðe\8bi·i ÑÁ¡eµA Îa¯¡Ði ®\81 ·¶·s\93¡\94a.\r
+\\r
+\ Àá·qµA\93e \96\81¤é¯¢ ¸aÌe·a\9d¡ ¬é¸÷\96A´á ·¶·s\93¡\94a. 3¤é¯¢ ¸aÌe·a\9d¡ ¤a\8e\81\9da¡e\r
+\ '3BUL'·¡\9ca\89¡ ¯¡Ç¡\89¡ 2¤é¯¢ ¸aÌe·a\9d¡ ¤a\8e\81\9da¡e '2BUL'·¡\9ca\89¡ ¯¡Ç¡¯³¯¡µ¡.\r
+\\r
+\ \8bi\8d©·i ¤a\8e\81\9da¡e ´a\9c\81Àá\9cñ ENGFONT-LOADEDµÁ HANFONT-LOADED\9fi ³a¯³¯¡µ¡.\r
+\\r
+\ BL PARSE ENG.FNT ENGFONT-LOADED\r
+\ BL PARSE HAN.FNT HANFONT-LOADED\r
+\\r
+\ Ça\8b¡\88a 11008·¡\90a 11520 ¤a·¡Ëa·¥ 8¤éX4¤éX4¤é \8bi\8d©·i ³i ®\81 ·¶·s\93¡\94a.\r
+\\r
+\ HF86EXE.EXE\9fi ¯¡¸bÐe Ò\81 \94a·q ®\85¬á\9d¡ ·¡ Ïa\9d¡\8ba\9c\91·i µ©\9f© ®\81 ·¶·s\93¡\94a.\r
+\\r
+\ << OPTIONAL.F\r
+\ << ASM8086.F\r
+\ << COREEXT.F\r
+\ << MSDOS.F\r
+\ BL PARSE MULTI.F INCLUDED\r
+\ BL PARSE HIOMULT2.F INCLUDED\r
+\\r
+\ 1996. 2. 9.\r
+\ Wonyong Koh\r
+\\r
+\ Usage:\r
+\ TEXT ( -- )\r
+\ Set text screen and redirect i/o vectors to DOS functions.\r
+\ HGRAPHIC ( -- )\r
+\ Set graphics screen and redirect i/o vectors to handle Korean\r
+\ character input and graphics screen output.\r
+\ ENGFONT-LOADED ( c-addr u -- )\r
+\ Load English font file 'c-addr u' of which size is 4096 bytes.\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT? 0= [IF] 0 [THEN]\r
+0= [IF]\r
+ CR .( This program needs FILE wordset words.) ABORT\r
+[THEN]\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+WORDLIST WORDLIST-NAME Ðe\8bi·³Â\89\9db-WORDLIST\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+GET-ORDER Ðe\8bi·³Â\89\9db-WORDLIST SWAP 1+ SET-ORDER\r
+\r
+CR .( Loading character font data)\r
+DECIMAL\r
+CREATE ENGFONT \ 8x16, 128 ¸a\r
+16 128 * ALLOT\r
+\r
+CREATE HANFONT \ 16x16, 19 ¸a x 8 ¤é + 21 ¸a X 4 ¤é + 27 ¸a X 4 ¤é\r
+11008 ALLOT\r
+HANFONT CONSTANT Á¡¬÷\8bi\8d©\r
+Á¡¬÷\8bi\8d© 32 19 * 8 * + CONSTANT º\97¬÷\8bi\8d©\r
+º\97¬÷\8bi\8d© 32 21 * 4 * + CONSTANT ¤hñ\8bi\8d©\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+: ENGFONT-LOADED ( c_addr u -- )\r
+ R/O OPEN-FILE THROW \ fileid\r
+ DUP ENGFONT [ 16 128 * ] LITERAL ROT READ-FILE THROW \ fileid n\r
+ [ 16 128 * ] LITERAL <> IF\r
+ ." µw¢\85\8bi\8d© Ìa·©µA \8bi\8d©\88t·¡ ¡¡¸a\9cs\93¡\94a." CR\r
+ ABORT" Not enough font data in English font file." THEN\r
+ CLOSE-FILE THROW ;\r
+\r
+: HANFONT-LOADED ( c_addr u -- )\r
+ R/O OPEN-FILE THROW \ fileid\r
+ DUP FILE-SIZE THROW \ fileid ud\r
+ IF ." ¡¡\9fa\93e Ðe\8bi\8bi\8d© Ìa·©·³\93¡\94a - Ìa·©·¡ \90á¢\81 Çs\93¡\94a." CR\r
+ ABORT" Unknown type of Korean font file - file too big." THEN\r
+ \ fileid u\r
+ CASE\r
+ 11008 OF DUP Á¡¬÷\8bi\8d© 11008 ROT READ-FILE THROW DROP ENDOF\r
+ 11520 OF\r
+ 8 0 DO DUP DUP FILE-POSITION THROW 32 S>D D+ ROT REPOSITION-FILE THROW\r
+ DUP Á¡¬÷\8bi\8d© [ 19 32 * ] LITERAL I * + [ 19 32 * ] LITERAL\r
+ ROT READ-FILE THROW DROP LOOP\r
+ 4 0 DO DUP DUP FILE-POSITION THROW 32 S>D D+ ROT REPOSITION-FILE THROW\r
+ DUP º\97¬÷\8bi\8d© [ 21 32 * ] LITERAL I * + [ 21 32 * ] LITERAL\r
+ ROT READ-FILE THROW DROP LOOP\r
+ 4 0 DO DUP DUP FILE-POSITION THROW 32 S>D D+ ROT REPOSITION-FILE THROW\r
+ DUP ¤hñ\8bi\8d© [ 27 32 * ] LITERAL I * + [ 27 32 * ] LITERAL\r
+ ROT READ-FILE THROW DROP LOOP\r
+ ENDOF\r
+ DROP ." ¡¡\9fa\93e Ðe\8bi\8bi\8d© Ìa·©·³\93¡\94a." CR\r
+ ABORT" Unknown type of Korean font file."\r
+ ENDCASE\r
+ CLOSE-FILE THROW ;\r
+\r
+BL PARSE ENG.FNT ENGFONT-LOADED\r
+BL PARSE HAN.FNT HANFONT-LOADED\r
+\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+\\r
+\ Ðe\8bi Â\89\9db \90{ i\r
+\\r
+CR .( Loading character output words)\r
+\r
+DECIMAL 80 CONSTANT MAX-X\r
+VARIABLE VIR_X\r
+VARIABLE VIR_Y\r
+\r
+HEX\r
+: BINARY 2 BASE ! ;\r
+: 16* ( n -- 16*n ) 2* 2* 2* 2* ;\r
+: \96õ®A= ( char -- 0|-1 ) DUP 08 = OVER 07F = OR SWAP 0FF = OR ;\r
+\r
+CODE INT10 ( AX -- AX )\r
+ BX AX MOV, \ BX\88a \94ᣡ·\81 \85 ¶á \88t·³\93¡\94a.\r
+ 10 INT, \ AH = 0\r
+ AX BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+: GET-MODE ( -- mode )\r
+ 0F00 INT10 0FF AND ;\r
+\r
+3 VALUE OldMode#\r
+\r
+: SET-MODE ( mode -- ) INT10 DROP ;\r
+\r
+: VGA? ( -- flag ) 1A00 INT10 0FF AND 1A = ;\r
+\r
+0 VALUE GRAPHIC?\r
+3 VALUE textmode#\r
+\r
+\ for VGA graphics card\r
+DECIMAL 30 VALUE MAX-Y \ 640X480 Ð\81¬w\95¡; 480 / 16 = 30 º\89\r
+HEX\r
+\r
+: VGA-SET-GRAPHIC ( -- ) 11 SET-MODE -1 TO GRAPHIC? ;\r
+\r
+\ VGA §¡\97¡µ¡ ¡A¡¡\9f¡·\81 \88b º\89µA \94\81Ðe A\8ba åËa º\81¡·\81 Îa\9fi e\97k\r
+\ Y ¹ÁÎa\9d¡ ·¡ A\8ba åËa \88t·i ´è·a¡e X ¹ÁÎa\9fi ¤a\9d¡\r
+\ µ¡ÏaU º\81¡\9d¡ ³i ®\81 ·¶·s\93¡\94a.\r
+CREATE VGA-Y>SegTable MAX-Y 16* CELLS ALLOT\r
+\r
+MARKER ~TEMP\r
+:NONAME\r
+ MAX-Y 16* 0 DO 0A000 I 5 * + VGA-Y>SegTable I CELLS + ! LOOP ;\r
+EXECUTE\r
+~TEMP \ Îa\9fi À\81¶\81\89¡ ¶á \90{ i·i »¡¶\91\r
+\r
+\ for Hercules monochrome grahics card\r
+DECIMAL 25 TO MAX-Y \ 640X400 Ð\81¬w\95¡; 400 / 16 = 25 º\89\r
+HEX\r
+\r
+CREATE 6854REGS \ 640X400 Ð\81¬w\95¡µA Ï©¶aÐe 6845 \9dA»¡¯aÈá Á¡\8b¡\88t\r
+31 C, 28 C, 29 C, 08 C, 68 C, 02 C, 64 C, 65 C, 02 C, 03 C,\r
+\r
+: HERC? ( -- flag )\r
+ 03B5 PC@ 4F DUP 03B5 PC! 100 0 DO LOOP\r
+ 03B5 PC@ ROT 03B5 PC! = IF\r
+ 03BA PC@ 80 AND\r
+ 8000 0 DO 03BA PC@ 80 AND OVER <> IF UNLOOP DROP TRUE EXIT THEN LOOP\r
+ THEN FALSE ;\r
+\r
+: HERC-SET-GRAPHIC ( -- )\r
+ 0A 0 DO I 03B4 PC! 6854REGS I + C@ 03B5 PC! LOOP\r
+ 1 03BF PC! \ \8ba\9c\81Ï¢ ¡¡\97a\9fi Ðá¶w, \8ba\9c\81Ï¢ ÍA·¡»¡ 1 ·e ¬a¶w ¦\89\88a\93w\r
+ [ BINARY ] 00001010 [ HEX ]\r
+ 03B8 PC! \ \8ba\9c\81Ï¢ ÍA·¡»¡ 0 ·i \8ba\9c\81Ï¢ ¡¡\97a\9d¡ Îa¯¡\r
+ -1 TO GRAPHIC? ;\r
+\r
+\ ÐáÇI\9dA¯a §¡\97¡µ¡ ¡A¡¡\9f¡·\81 \88b º\89µA \94\81Ðe A\8ba åËa º\81¡·\81 Îa\9fi e\97k\r
+\ \8ba\9c\81Ï¢ ÍA·¡»¡ 1·e 0B000:0hµA¬á ¯¡¸b\r
+\ Y ¹ÁÎa\9d¡ ·¡ A\8ba åËa \88t·i ´è·a¡e X ¹ÁÎa\9fi ¤a\9d¡\r
+\ µ¡ÏaU º\81¡\9d¡ ³i ®\81 ·¶·s\93¡\94a.\r
+CREATE HERC-Y>SegTable MAX-Y 16* CELLS ALLOT\r
+\r
+MARKER ~TEMP\r
+:NONAME\r
+ MAX-Y 16* 0 DO 0B000 I 4 MOD 200 * + I 4 / 5 * +\r
+ HERC-Y>SegTable I CELLS + ! LOOP ;\r
+EXECUTE\r
+~TEMP \ Îa\9fi À\81¶\81\89¡ ¶á \90{ i·i »¡¶\91\r
+\r
+VARIABLE Y>SegTable\r
+: Y>SEG ( y -- segment_addr )\r
+ CELLS Y>SegTable @ + @ ;\r
+\r
+' VGA-SET-GRAPHIC VALUE 'SET-GRAPHIC\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+: SET-GRAPHIC ( -- ) 'SET-GRAPHIC EXECUTE ;\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+DECIMAL\r
+\r
+\ ÉB¯aËa Y ¹ÁÎa·\81 ÑÁ¡eµA Îa¯¡\96E ¢\85¸a\97i·i ¤a\9d¡ ¶á º\89\9d¡ µ«\8b±\r
+\ \8ba\9c\81Ï¢ ¹ÁÎa\9d¡\93e 16y ¦\81Èá 16 \88a\9d¡º\89·i \88b\88b 16 º\89 ¶á\9d¡ µ«\8b±\r
+\ : UP-LINE\r
+\ 16* DUP 16 - DO\r
+\ I 16 + Y>SEG I Y>SEG\r
+\ 40 0 DO OVER I 2* L@ OVER I 2* L! LOOP 2DROP\r
+\ LOOP ;\r
+\r
+CODE UP-LINE ( y -- )\r
+ SI PUSH,\r
+ BX DEC,\r
+ 5 # CL MOV,\r
+ BX CL SHL, \ BX = (VIR_Y@-1)@ * 32\r
+ Y>SegTable ) BX ADD,\r
+ 16 # DX MOV,\r
+1 L:\r
+ SI SI XOR,\r
+ DI DI XOR,\r
+ SS: 0 [BX] ES MOV,\r
+ SS: 32 [BX] DS MOV,\r
+ 40 # CX MOV,\r
+ REPE, WORD MOVS,\r
+ 2 # BX ADD,\r
+ DX DEC,\r
+ 1 L# JNE,\r
+ SS AX MOV,\r
+ AX DS MOV,\r
+ SI POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ ÉB¯aËa Y ¹ÁÎa·\81 º\89·i »¡¶\91\r
+\ : CLEAR-LINE\r
+\ 16* DUP 16 + SWAP\r
+\ DO I Y>SEG\r
+\ 40 0 DO 0 OVER I 2* L! LOOP DROP\r
+\ LOOP ;\r
+\r
+CODE CLEAR-LINE ( y -- )\r
+ 5 # CL MOV,\r
+ BX CL SHL, \ BX = VIR_Y@ * 32\r
+ Y>SegTable ) BX ADD,\r
+ AX AX XOR,\r
+ 16 # DX MOV,\r
+1 L:\r
+ 0 [BX] ES MOV,\r
+ DI DI XOR,\r
+ 40 # CX MOV,\r
+ REPE,\r
+ WORD STOS,\r
+ 2 # BX ADD,\r
+ DX DEC,\r
+ 1 L# JNE,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+HEX\r
+VARIABLE VSCR0\r
+VARIABLE YY\r
+VARIABLE XX\r
+1000 CONSTANT VSCREEN-SIZE\r
+0FFF CONSTANT VSCR-MASK\r
+CREATE VSCREEN VSCREEN-SIZE CHARS ALLOT\r
+: >VSCR-ADDR ( offset -- c_addr )\r
+ VSCR0 @ + VSCR-MASK AND VSCREEN + ;\r
+\r
+DECIMAL\r
+\r
+\ : EFONT! ( x y char -- )\r
+\ 16* ENGFONT + \ x y font-addr\r
+\ SWAP 16* \ x font-addr 16y\r
+\ 16 0 DO OVER I + C@ OVER I + Y>SEG 4 PICK LC! LOOP DROP 2DROP ;\r
+\r
+CODE EFONT! ( x y char -- )\r
+ SI DX MOV, \ MOV DX,SI\r
+ BX SI MOV, \ MOV SI,BX\r
+ BX POP, \ POP BX\r
+ DI POP, \ POP DI\r
+ 4 # CL MOV, \ MOV CL,#4\r
+ SI CL SHL, \ SHL SI,CL\r
+ ENGFONT # SI ADD, \ ADD SI,ENGFONT ; SI = font-addr\r
+ CL INC, \ INC CL ; CL = 5\r
+ BX CL SHL, \ SHL BX,CL ; BX = VIR_Y@ * 32\r
+ Y>SegTable ) BX ADD,\r
+ 2 # CX MOV,\r
+ 15\r
+ 0 [BX] ES MOV, BYTE LODS, ES: AL 0 [DI] MOV, CX BX ADD, 1- ?DUP [IF] 0 >IN ! [THEN]\r
+ 0 [BX] ES MOV, BYTE LODS, ES: AL 0 [DI] MOV,\r
+ DX SI MOV,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+HEX\r
+CREATE À\81¶\91\8bi\8d©\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ À\81¶\91\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+\r
+CREATE \8ba\9f±¸a\8bi\8d©\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+\r
+BINARY\r
+00001 CONSTANT À\81¶\91Á¡¬÷\r
+00010 CONSTANT À\81¶\91º\97¬÷\r
+00001 CONSTANT À\81¶\91¤hñ\r
+1000010001000001 CONSTANT À\81¶\91¸a \ Á¡¬÷, º\97¬÷, ¤hñ ¡¡\96\81 À\81¶\91¸a\r
+0111110000000000 CONSTANT Á¡¬÷¥¥\r
+0000001111100000 CONSTANT º\97¬÷¥¥\r
+0000000000011111 CONSTANT ¤hñ¥¥\r
+1000001111111111 CONSTANT Á¡¬÷»¡¶\91¥¥\r
+1111110000011111 CONSTANT º\97¬÷»¡¶\91¥¥\r
+1111111111100000 CONSTANT ¤hñ»¡¶\91¥¥\r
+DECIMAL\r
+\r
+VARIABLE HCHAR\r
+\r
+\ VARIABLE H1FONT\r
+\ VARIABLE H2FONT\r
+\ VARIABLE H3FONT\r
+\ : Y>SEG ( y -- segment ) CELLS Y>SegTable @ + @ ;\r
+\ : H2FONT! ( x y Á¡¬÷\8bi\8d©\88t º\97¬÷\8bi\8d©\88t -- )\r
+\ H2FONT !\r
+\ H1FONT !\r
+\ 16*\r
+\ 16 0 DO H1FONT @ @\r
+\ H2FONT @ @ OR\r
+\ OVER I + Y>SEG 3 PICK L!\r
+\ 2 H1FONT +! 2 H2FONT +!\r
+\ LOOP 2DROP ;\r
+\\r
+\ : H3FONT! ( x y Á¡¬÷\8bi\8d©\88t º\97¬÷\8bi\8d©\88t ¤hñ\8bi\8d©\88t -- )\r
+\ H3FONT !\r
+\ H2FONT !\r
+\ H1FONT !\r
+\ 16*\r
+\ 16 0 DO H1FONT @ @\r
+\ H2FONT @ @ OR\r
+\ H3FONT @ @ OR\r
+\ OVER I + Y>SEG 3 PICK L!\r
+\ 2 H1FONT +! 2 H2FONT +! 2 H3FONT +!\r
+\ LOOP 2DROP ;\r
+\r
+\ ¹¡ÐsÑwÅ¡\97a\9fi §¥ ¸a\9f¡ ´ô\93e \8bi\8d© Å¡\97a\88t·a\9d¡ ¤a\8e\91\r
+\ 'ÄñÏAÈá ¢·\81 Ðe\8bi' ·¡º\85Ó\81, ¸÷\90\81\8a¥ »¡·q, ¸÷¥¡¯¡\94\81 (1991) 122-134½¢ Àq¹¡\r
+\ À\81¶\91¸a\93e 32\9fi, ·AÒaÐa»¡ ´g·e Å¡\97a\93e 96(=32+64)·i \94ᣡµA µ©\9f±\r
+\r
+CREATE Á¡¬÷\8bi\8d©Å¡\97aÎa ( ¹¡ÐsÑwÁ¡¬÷Å¡\97a -- Á¡¬÷\8bi\8d©Å¡\97a )\r
+ 96 C, 32 C, 0 C, 1 C, 2 C, 3 C, 4 C, 5 C,\r
+ 6 C, 7 C, 8 C, 9 C, 10 C, 11 C, 12 C, 13 C,\r
+ 14 C, 15 C, 16 C, 17 C, 18 C, 96 C, 96 C, 96 C,\r
+ 96 C, 96 C, 96 C, 96 C, 96 C, 96 C, 96 C, 96 C, ALIGN\r
+\r
+CREATE º\97¬÷\8bi\8d©Å¡\97aÎa ( ¹¡ÐsÑwº\97¬÷Å¡\97a -- º\97¬÷\8bi\8d©Å¡\97a )\r
+ 96 C, 96 C, 32 C, 0 C, 1 C, 2 C, 3 C, 4 C,\r
+ 96 C, 96 C, 5 C, 6 C, 7 C, 8 C, 9 C, 10 C,\r
+ 96 C, 96 C, 11 C, 12 C, 13 C, 14 C, 15 C, 16 C,\r
+ 96 C, 96 C, 17 C, 18 C, 19 C, 20 C, 96 C, 96 C, ALIGN\r
+\r
+CREATE ¤hñ\8bi\8d©Å¡\97aÎa ( ¹¡ÐsÑw¤hñš\97a -- ¤hñ\8bi\8d©Å¡\97a )\r
+ 96 C, 32 C, 0 C, 1 C, 2 C, 3 C, 4 C, 5 C,\r
+ 6 C, 7 C, 8 C, 9 C, 10 C, 11 C, 12 C, 13 C,\r
+ 14 C, 15 C, 96 C, 16 C, 17 C, 18 C, 19 C, 20 C,\r
+ 21 C, 22 C, 23 C, 24 C, 25 C, 26 C, 96 C, 96 C, ALIGN\r
+\r
+19 VALUE Å¡\97a®\81\r
+: *, Å¡\97a®\81 * , ;\r
+\r
+CREATE ¤hñ´ô\93eÁ¡¬÷\8bi\8d©¤é£» ( º\97¬÷\8bi\8d©Å¡\97a -- Á¡¬÷\8bi\8d©¤é )\r
+ \ \84a \84\81 \84¡ \84Á \84á \85A \85a \85\81 \85¡ \85Á \85á\r
+ 0 *, 0 *, 0 *, 0 *, 0 *, 0 *, 0 *, 0 *, 1 *, 3 *, 3 *,\r
+ \ \86A \86a \86\81 \86¡ \86Á \86á \87A \87a \87\81 \87¡\r
+ 3 *, 1 *, 2 *, 4 *, 4 *, 4 *, 2 *, 1 *, 3 *, 0 *,\r
+\r
+21 TO Å¡\97a®\81\r
+CREATE ¤hñ´ô\93eº\97¬÷\8bi\8d©¤é£» ( Á¡¬÷\8bi\8d©Å¡\97a -- º\97¬÷\8bi\8d©¤é )\r
+ \ \88A \8cA \90A \94A \98A \9cA A ¤A ¨A ¬A\r
+ 0 *, 1 *, 1 *, 1 *, 1 *, 1 *, 1 *, 1 *, 1 *, 1 *,\r
+ \ °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 1 *, 1 *, 1 *, 1 *, 1 *, 0 *, 1 *, 1 *, 1 *,\r
+\r
+19 TO Å¡\97a®\81\r
+CREATE ¤hñ·¶\93eÁ¡¬÷\8bi\8d©¤é£» ( º\97¬÷\8bi\8d©Å¡\97a -- Á¡¬÷\8bi\8d©¤é )\r
+ \ \84a \84\81 \84¡ \84Á \84á \85A \85a \85\81 \85¡ \85Á \85á\r
+ 5 *, 5 *, 5 *, 5 *, 5 *, 5 *, 5 *, 5 *, 6 *, 7 *, 7 *,\r
+ \ \86A \86a \86\81 \86¡ \86Á \86á \87A \87a \87\81 \87¡\r
+ 7 *, 6 *, 6 *, 7 *, 7 *, 7 *, 6 *, 6 *, 7 *, 5 *,\r
+\r
+21 TO Å¡\97a®\81\r
+CREATE ¤hñ·¶\93eº\97¬÷\8bi\8d©¤é£» ( Á¡¬÷\8bi\8d©Å¡\97a -- º\97¬÷\8bi\8d©¤é )\r
+ \ \88A \8cA \90A \94A \98A \9cA A ¤A ¨A ¬A\r
+ 2 *, 3 *, 3 *, 3 *, 3 *, 3 *, 3 *, 3 *, 3 *, 3 *,\r
+ \ °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 3 *, 3 *, 3 *, 3 *, 3 *, 2 *, 3 *, 3 *, 3 *,\r
+\r
+27 TO Å¡\97a®\81\r
+CREATE ¤hñ\8bi\8d©¤é£» ( º\97¬÷\8bi\8d©Å¡\97a -- ¤hñ\8bi\8d©¤é )\r
+ \ \84a \84\81 \84¡ \84Á \84á \85A \85a \85\81 \85¡ \85Á \85á\r
+ 0 *, 2 *, 0 *, 2 *, 1 *, 2 *, 1 *, 2 *, 3 *, 0 *, 2 *,\r
+ \ \86A \86a \86\81 \86¡ \86Á \86á \87A \87a \87\81 \87¡\r
+ 1 *, 3 *, 3 *, 1 *, 2 *, 1 *, 3 *, 3 *, 1 *, 1 *,\r
+\r
+\ : CCFONT! ( x y ¤hñ´ô\93e16§¡ËaÐe\8biÅ¡\97a -- )\r
+\ DUP Á¡¬÷¥¥ AND 10 RSHIFT CHARS\r
+\ Á¡¬÷\8bi\8d©Å¡\97aÎa + C@ SWAP \ x y Á¡¬÷\8bi\8d©Å¡\97a Ðe\8biÅ¡\97a\r
+\ º\97¬÷¥¥ AND 5 RSHIFT CHARS\r
+\ º\97¬÷\8bi\8d©Å¡\97aÎa + C@ \ x y Á¡¬÷\8bi\8d©Å¡\97a º\97¬÷\8bi\8d©Å¡\97a\r
+\ 2DUP OVER 31 > IF\r
+\ DROP 63 > IF \8ba\9f±¸a\8bi\8d© ELSE À\81¶\91\8bi\8d© THEN\r
+\ ELSE DUP 31 > IF DROP 0 THEN\r
+\ CELLS ¤hñ´ô\93eÁ¡¬÷\8bi\8d©¤é£» + @ + 5 LSHIFT Á¡¬÷\8bi\8d© + THEN\r
+\ ROT ROT DUP 31 > IF NIP 63 > IF \8ba\9f±¸a\8bi\8d© ELSE À\81¶\91\8bi\8d© THEN\r
+\ ELSE SWAP DUP 31 > IF DROP 0 THEN\r
+\ CELLS ¤hñ´ô\93eº\97¬÷\8bi\8d©¤é£» + @ + 5 LSHIFT º\97¬÷\8bi\8d© + THEN\r
+\ H2FONT! ;\r
+\r
+CODE CCFONT! ( x y ¤hñ´ô\93e16§¡ËaÐe\8biÅ¡\97a -- )\r
+ CX POP,\r
+ DX POP,\r
+ BP PUSH,\r
+ SI PUSH,\r
+ DX PUSH,\r
+ CX PUSH,\r
+ BX SI MOV, \ SI = Ðe\8biÅ¡\97a\r
+ Á¡¬÷¥¥ # BX AND,\r
+ 10 # CL MOV,\r
+ BX CL SHR,\r
+ Á¡¬÷\8bi\8d©Å¡\97aÎa [BX] BL MOV,\r
+ BX AX MOV, \ AX = Á¡¬÷\8bi\8d©Å¡\97aÎa\r
+ SI BX MOV,\r
+ º\97¬÷¥¥ # BX AND,\r
+ 5 # CL MOV,\r
+ BX CL SHR,\r
+ º\97¬÷\8bi\8d©Å¡\97aÎa [BX] BL MOV,\r
+ BX DX MOV, \ DX = º\97¬÷\8bi\8d©Å¡\97aÎa\r
+xhere ( HFONT!µA¬á \9aá´áµ© º\81¡\9fi \94ᣡµA \90q\8b±)\r
+ BINARY 00100000 DECIMAL # AL TEST,\r
+ 1 L# JZ,\r
+ \ AX(=Á¡¬÷)\88a À\81¶\91¸a·¡\88á\90a ¢\81Òa\8bi\8d©·¡¡e\r
+ À\81¶\91\8bi\8d© # SI MOV,\r
+ BINARY 01000000 DECIMAL # AL TEST,\r
+ 2 L# JZ,\r
+ \8ba\9f±¸a\8bi\8d© # SI MOV,\r
+ 2 L# JU,\r
+1 L:\r
+ BX BX XOR,\r
+ BINARY 00100000 DECIMAL # DL TEST,\r
+ 3 L# JNZ,\r
+ DX BX MOV,\r
+ BX 1 SHL,\r
+3 L:\r
+ ¤hñ´ô\93eÁ¡¬÷\8bi\8d©¤é£» [BX] SI MOV,\r
+ AX SI ADD,\r
+ 5 # CL MOV,\r
+ SI CL SHL,\r
+ Á¡¬÷\8bi\8d© # SI ADD,\r
+2 L: \ SI = Á¡¬÷\8bi\8d©º\81¡\r
+ BINARY 00100000 DECIMAL # DL TEST,\r
+ 4 L# JZ,\r
+ \ DX(=º\97¬÷)\88a À\81¶\91¸a·¡\88á\90a ¢\81Òa\8bi\8d©·¡¡e\r
+ À\81¶\91\8bi\8d© # DI MOV,\r
+ BINARY 01000000 DECIMAL # DL TEST,\r
+ 5 L# JZ,\r
+ \8ba\9f±¸a\8bi\8d© # DI MOV,\r
+ 5 L# JU,\r
+4 L:\r
+ BX BX XOR,\r
+ BINARY 00100000 DECIMAL # AL TEST,\r
+ 6 L# JNZ,\r
+ AX BX MOV,\r
+ BX 1 SHL,\r
+6 L:\r
+ ¤hñ´ô\93eº\97¬÷\8bi\8d©¤é£» [BX] DI MOV,\r
+ DX DI ADD,\r
+ 5 # CL MOV,\r
+ DI CL SHL,\r
+ º\97¬÷\8bi\8d© # DI ADD,\r
+5 L: \ DI = º\97¬÷\8bi\8d©º\81¡\r
+ BX POP, \ BX = y\r
+ DX POP, \ DX = x\r
+ 5 # CL MOV,\r
+ BX CL SHL, \ BX = y * 32\r
+ Y>SegTable ) BX ADD,\r
+ 2 # CX MOV,\r
+ 15\r
+ WORD LODS, 0 [DI] AX OR, 0 [BX] ES MOV, BX DX XCHG, ES: AX 0 [BX] MOV, BX DX XCHG, CX DI ADD, CX BX ADD, 1- ?DUP [IF] 0 >IN ! [THEN]\r
+ WORD LODS, 0 [DI] AX OR, 0 [BX] ES MOV, BX DX XCHG, ES: AX 0 [BX] MOV,\r
+ SI POP,\r
+ BP POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ : CCCFONT! ( x y ¤hñ·¶\93e16§¡ËaÐe\8biÅ¡\97a -- )\r
+\ DUP Á¡¬÷¥¥ AND 10 RSHIFT CHARS\r
+\ Á¡¬÷\8bi\8d©Å¡\97aÎa + C@ SWAP \ x y Á¡¬÷\8bi\8d©Å¡\97a Ðe\8biÅ¡\97a\r
+\ DUP º\97¬÷¥¥ AND 5 RSHIFT CHARS\r
+\ º\97¬÷\8bi\8d©Å¡\97aÎa + C@ SWAP \ x y Á¡¬÷\8bi\8d©Å¡\97a º\97¬÷\8bi\8d©Å¡\97a Ðe\8biÅ¡\97a\r
+\ ¤hñ¥¥ AND CHARS\r
+\ ¤hñ\8bi\8d©Å¡\97aÎa + C@ \ x y Á¡¬÷\8bi\8d©Å¡\97a º\97¬÷\8bi\8d©Å¡\97a ¤hñ\8bi\8d©Å¡\97a\r
+\ DUP 31 > IF 63 > IF \8ba\9f±¸a\8bi\8d© ELSE À\81¶\91\8bi\8d© THEN\r
+\ ELSE OVER DUP 31 > IF DROP 0 THEN\r
+\ CELLS ¤hñ\8bi\8d©¤é£» + @ + 5 LSHIFT ¤hñ\8bi\8d© + THEN\r
+\ ROT ROT\r
+\ 2DUP OVER 31 > IF DROP 63 > IF \8ba\9f±¸a\8bi\8d© ELSE À\81¶\91\8bi\8d© THEN\r
+\ ELSE DUP 31 > IF DROP 0 THEN\r
+\ CELLS ¤hñ·¶\93eÁ¡¬÷\8bi\8d©¤é£» + @ + 5 LSHIFT Á¡¬÷\8bi\8d© + THEN\r
+\ ROT ROT DUP 31 > IF NIP 63 > IF \8ba\9f±¸a\8bi\8d© ELSE À\81¶\91\8bi\8d© THEN\r
+\ ELSE SWAP DUP 31 > IF DROP 0 THEN\r
+\ CELLS ¤hñ·¶\93eº\97¬÷\8bi\8d©¤é£» + @ + 5 LSHIFT º\97¬÷\8bi\8d© + THEN\r
+\ H3FONT! ;\r
+\r
+\ : HFONT! ( x y 16§¡ËaÐe\8biÅ¡\97a -- )\r
+\ DUP ¤hñ¥¥ AND 1 = IF CCFONT! ELSE CCCFONT! THEN ;\r
+\r
+CODE HFONT! ( x y 16§¡ËaÐe\8biÅ¡\97a -- )\r
+ CX POP,\r
+ DX POP,\r
+ BP PUSH,\r
+ SI PUSH,\r
+ DX PUSH,\r
+ CX PUSH,\r
+ BX SI MOV, \ SI = Ðe\8biÅ¡\97a\r
+ Á¡¬÷¥¥ # BX AND,\r
+ 10 # CL MOV,\r
+ BX CL SHR,\r
+ Á¡¬÷\8bi\8d©Å¡\97aÎa [BX] BL MOV,\r
+ BX AX MOV, \ AX = Á¡¬÷\8bi\8d©Å¡\97aÎa\r
+ SI BX MOV,\r
+ º\97¬÷¥¥ # BX AND,\r
+ 5 # CL MOV,\r
+ BX CL SHR,\r
+ º\97¬÷\8bi\8d©Å¡\97aÎa [BX] BL MOV,\r
+ BX DX MOV, \ DX = º\97¬÷\8bi\8d©Å¡\97aÎa\r
+ SI BX MOV,\r
+ ¤hñ¥¥ # BX AND,\r
+ 1 # BX CMP,\r
+ 0 L# JNZ,\r
+ ( CCFONT! ¸÷·\81 ´eµA¬á \90q\8b¥ º\81¡) # JMP,\r
+0 L:\r
+ ¤hñ\8bi\8d©Å¡\97aÎa [BX] BL MOV,\r
+ BX CX MOV, \ CX = ¤hñ\8bi\8d©Å¡\97aÎa\r
+ BINARY 00100000 DECIMAL # CL TEST,\r
+ 1 L# JZ,\r
+ \ CX(=¤hñ)\88a À\81¶\91¸a·¡\88á\90a ¢\81Òa\8bi\8d©·¡¡e\r
+ À\81¶\91\8bi\8d© # BP MOV,\r
+ BINARY 01000000 DECIMAL # CL TEST,\r
+ 2 L# JZ,\r
+ \8ba\9f±¸a\8bi\8d© # BP MOV,\r
+ 2 L# JU,\r
+1 L:\r
+ BX BX XOR,\r
+ BINARY 00100000 DECIMAL # DL TEST,\r
+ 3 L# JNZ,\r
+ DX BX MOV,\r
+ BX 1 SHL,\r
+3 L:\r
+ ¤hñ\8bi\8d©¤é£» [BX] BP MOV,\r
+ CX BP ADD,\r
+ 5 # CL MOV,\r
+ BP CL SHL,\r
+ ¤hñ\8bi\8d© # BP ADD,\r
+2 L: \ BP = ¤hñ\8bi\8d©º\81¡\r
+ BINARY 00100000 DECIMAL # AL TEST,\r
+ 4 L# JZ,\r
+ \ AX(=Á¡¬÷)\88a À\81¶\91¸a·¡\88á\90a ¢\81Òa\8bi\8d©·¡¡e\r
+ À\81¶\91\8bi\8d© # SI MOV,\r
+ BINARY 01000000 DECIMAL # AL TEST,\r
+ 5 L# JZ,\r
+ \8ba\9f±¸a\8bi\8d© # SI MOV,\r
+ 5 L# JU,\r
+4 L:\r
+ BX BX XOR,\r
+ BINARY 00100000 DECIMAL # DL TEST,\r
+ 6 L# JNZ,\r
+ DX BX MOV,\r
+ BX 1 SHL,\r
+6 L:\r
+ ¤hñ·¶\93eÁ¡¬÷\8bi\8d©¤é£» [BX] SI MOV,\r
+ AX SI ADD,\r
+ 5 # CL MOV,\r
+ SI CL SHL,\r
+ Á¡¬÷\8bi\8d© # SI ADD,\r
+5 L: \ SI = Á¡¬÷\8bi\8d©º\81¡\r
+ BINARY 00100000 DECIMAL # DL TEST,\r
+ 7 L# JZ,\r
+ \ DX(=º\97¬÷)\88a À\81¶\91¸a·¡\88á\90a ¢\81Òa\8bi\8d©·¡¡e\r
+ À\81¶\91\8bi\8d© # DI MOV,\r
+ BINARY 01000000 DECIMAL # DL TEST,\r
+ 8 L# JZ,\r
+ \8ba\9f±¸a\8bi\8d© # DI MOV,\r
+ 8 L# JU,\r
+7 L:\r
+ BX BX XOR,\r
+ BINARY 00100000 DECIMAL # AL TEST,\r
+ 9 L# JNZ,\r
+ AX BX MOV,\r
+ BX 1 SHL,\r
+9 L:\r
+ ¤hñ·¶\93eº\97¬÷\8bi\8d©¤é£» [BX] DI MOV,\r
+ DX DI ADD,\r
+ 5 # CL MOV,\r
+ DI CL SHL,\r
+ º\97¬÷\8bi\8d© # DI ADD,\r
+8 L: \ DI = º\97¬÷\8bi\8d©º\81¡\r
+ BX POP, \ BX = y\r
+ DX POP, \ DX = x\r
+ 5 # CL MOV,\r
+ BX CL SHL, \ BX = y * 32\r
+ Y>SegTable ) BX ADD,\r
+ 2 # CX MOV,\r
+ 15\r
+ WORD LODS, 0 [DI] AX OR, 0 [BP] AX OR, 0 [BX] ES MOV, BX DX XCHG, ES: AX 0 [BX] MOV, BX DX XCHG, CX DI ADD, CX BP ADD, CX BX ADD, 1- ?DUP [IF] 0 >IN ! [THEN]\r
+ WORD LODS, 0 [DI] AX OR, 0 [BP] AX OR, 0 [BX] ES MOV, BX DX XCHG, ES: AX 0 [BX] MOV,\r
+ SI POP,\r
+ BP POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+: xySTR! ( x y c_addr u -- )\r
+ BEGIN >R >R 2DUP R@ C@\r
+ DUP 128 < IF EFONT!\r
+ ELSE 8 LSHIFT R> CHAR+ DUP >R C@ OR HFONT! SWAP 1+ SWAP\r
+ THEN\r
+ SWAP 1+ SWAP R> CHAR+ R> 1- DUP 0=\r
+ UNTIL 2DROP 2DROP ;\r
+\r
+DECIMAL 30 TO MAX-Y\r
+\r
+CREATE MAX-X*Table MAX-Y 1+ CELLS ALLOT\r
+MARKER ~TEMP\r
+:NONAME MAX-Y 1+ 0 DO I MAX-X * MAX-X*Table I CELLS + ! LOOP ; EXECUTE\r
+~TEMP\r
+: MAX-X* ( y -- MAX_X*y ) CELLS MAX-X*Table + @ ;\r
+\r
+HEX\r
+: SHOW-LINE ( y -- ) \ \88a¬wÑÁ¡e·\81 y º\89·i \8ba\9c\81Ï¢ ÑÁ¡eµA Îa¯¡\r
+ >R 1 MAX-X* 0 \ max-x 0 R: y\r
+ BEGIN\r
+ DUP R@ OVER >VSCR-ADDR DUP C@ \ max-x x x 0 c_addr char\r
+ DUP 80 < IF NIP EFONT!\r
+ ELSE 8 LSHIFT\r
+ SWAP CHAR+ C@ OR HFONT! CHAR+ THEN\r
+ CHAR+ 2DUP =\r
+ UNTIL 2DROP R> DROP ;\r
+\r
+0 VALUE YTop\r
+\r
+: SCROLL ( -- )\r
+ MAX-Y MAX-X* DUP MAX-X + SWAP\r
+ DO BL I >VSCR-ADDR C! LOOP\r
+ MAX-Y 1- MAX-X 0 DO I OVER BL EFONT! LOOP DROP\r
+ VSCR0 @ MAX-X + VSCR-MASK AND VSCR0 !\r
+ YTop SHOW-LINE\r
+ 0 XX ! YTop YY ! ;\r
+\r
+: VIR_X+! ( n -- )\r
+ VIR_X @ + MAX-X /MOD VIR_Y +! VIR_X !\r
+ VIR_Y @ MAX-Y = IF SCROLL -1 VIR_Y +! THEN ;\r
+\r
+: VSCR! ( char -- ) VIR_Y @ MAX-X* VIR_X @ + >VSCR-ADDR C! ;\r
+\r
+: multiEMIT ( char -- )\r
+ DUP \96õ®A= IF DROP VIR_X @ VIR_Y @ BL EFONT! -1 VIR_X +! BL VSCR! EXIT THEN\r
+ DUP 0D ( CR) = IF DROP 0 VIR_X ! EXIT THEN\r
+ DUP 0A ( LF) = IF DROP VIR_Y @ 1+ MAX-Y < IF 1 VIR_Y +! EXIT THEN\r
+ SCROLL EXIT THEN\r
+ VSCR! 1 VIR_X+! ;\r
+\r
+: HEMIT ( char -- )\r
+ HCHAR @ 0= IF \ ¬\81\9d¡ ¯¡¸bÐa\93e \8bi¸a\r
+ DUP 80 < IF multiEMIT EXIT THEN \ Ðe\8bi·¡ ´a\93¡¡e \8ba\94\81\9d¡ Â\89\9db\r
+ VIR_X @ 1+ MAX-X = IF VIR_X @ multiEMIT BL multiEMIT THEN\r
+ HCHAR ! EXIT \ Àõ 8 §¡Ëa ¤e¸a\9fi \88i¢\81\9f¡\r
+ THEN\r
+ HCHAR @ multiEMIT multiEMIT 0 HCHAR ! ;\r
+\r
+\\r
+\ Ðe\8bi ·³\9db \90{ i\97i\r
+\\r
+\r
+CR .( Loading character input words)\r
+\r
+CODE INT16h\r
+ BX AX MOV,\r
+ 16 INT,\r
+ AX BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ a»¡ b \8bi®A ·³\9db \98\81 ¶E½¢ ¶õ\8bi®A\88a \92\89\9dv·a¡e Àq, ´a\93¡¡e \88ỵ\r
+: ¶E½¢¶õ®A\92\89\9f±? ( -- flag )\r
+ 200 INT16h [ BINARY ] 00000010 [ HEX ] AND 0= 0= ;\r
+\r
+\ a»¡ b \8bi®A ·³\9db \98\81 CapsLock ¬wÈ\81µv·a¡e Àq, ´a\93¡¡e \88ỵ\r
+: CapsLock? ( -- flag )\r
+ 200 INT16h [ BINARY ] 01000000 [ HEX ] AND 0= 0= ;\r
+\r
+VARIABLE \8bi®A·³\9db¬wÈ\81\r
+VARIABLE \8bi®AÉ·\r
+VARIABLE £¡µÅ¬÷¸a\r
+CREATE \8bi®A·³\9db¬wÈ\81\8b¡´â 8 CELLS ALLOT\r
+CREATE £¡µÅ¬÷¸a\8b¡´â 8 CELLS ALLOT\r
+VARIABLE ¼\81·³\9db¬wÈ\81\r
+VARIABLE ¼\81£¡µÅ¬÷¸a\r
+: ´|¸a\8b¡´â ( -- )\r
+ £¡µÅ¬÷¸a @ ¼\81£¡µÅ¬÷¸a @ 7 AND CELLS £¡µÅ¬÷¸a\8b¡´â + !\r
+ 1 ¼\81£¡µÅ¬÷¸a +! ;\r
+: ¬wÈ\81\8b¡´â ( ¬wÈ\81 -- )\r
+ ¼\81·³\9db¬wÈ\81 @ 7 AND CELLS \8bi®A·³\9db¬wÈ\81\8b¡´â + !\r
+ 1 ¼\81·³\9db¬wÈ\81 +! ;\r
+\r
+DECIMAL\r
+: | ( "<spaces>name" -- ) ' , ;\r
+: Äe ;\r
+: µ¡É¡ aÈa: ( width -- )\r
+ CREATE , ;\r
+: ;µ¡É¡ aÈa\r
+ DOES>\r
+ TUCK @ \ º\81¡ ¹·\9fA Äe®\81\r
+ \8bi®A·³\9db¬wÈ\81 @\r
+ DUP ¬wÈ\81\8b¡´â ´|¸a\8b¡´â \ Ðe\8bi\8bi¸a·¡¡e\r
+ * + 2* CELLS + CELL+\r
+ DUP >R\r
+ @ EXECUTE\r
+ R> CELL+\r
+ @ EXECUTE\r
+ \8bi®A·³\9db¬wÈ\81 ! ;\r
+\r
+0 CONSTANT >0 IMMEDIATE\r
+1 CONSTANT >1 IMMEDIATE\r
+2 CONSTANT >2 IMMEDIATE\r
+3 CONSTANT >3 IMMEDIATE\r
+5 CONSTANT >5 IMMEDIATE\r
+\r
+HEX\r
+\ ¤e\97¡\88a ÑÁ¡e µ¡\9fe½¢\8f{µA ·¶·a¡e \94a·qÐ\97µA¬á ·³\9db¤h·q\r
+: ¤e\97¡¶áṡ¸÷ ( -- ) VIR_X @ 1+ MAX-X = ( -1|0) NEGATE VIR_X+! ;\r
+: £¡µÅ¬÷¸a¥¡µa ( -- ) VIR_X @ VIR_Y @ £¡µÅ¬÷¸a @ HFONT! ;\r
+: \8ba\90· ( -- ) VIR_X @ VIR_Y @ BL EFONT! ;\r
+: À\81¶\91! ( -- ) À\81¶\91¸a £¡µÅ¬÷¸a ! 1 ¬wÈ\81\8b¡´â ´|¸a\8b¡´â ;\r
+: £¡µÅ¬÷¸aÁ¡¬÷ ( -- Á¡¬÷ ) £¡µÅ¬÷¸a @ Á¡¬÷¥¥ AND 0A RSHIFT ;\r
+: £¡µÅ¬÷¸aº\97¬÷ ( -- º\97¬÷ ) £¡µÅ¬÷¸a @ º\97¬÷¥¥ AND 05 RSHIFT ;\r
+: £¡µÅ¬÷¸a¤hñ ( -- ¤hñ ) £¡µÅ¬÷¸a @ ¤hñ¥¥ AND ;\r
+: ·³\9db\89\81¢ ( -- 0 ) £¡µÅ¬÷¸a¥¡µa 0 ;\r
+: \90{¸a¤a\8e¡ ( \88t »¡¶\91¥¥ -- ) £¡µÅ¬÷¸a @ AND OR £¡µÅ¬÷¸a ! ;\r
+: Á¡¬÷¤a\8e¡ ( Á¡¬÷ -- ) 0A LSHIFT Á¡¬÷»¡¶\91¥¥ \90{¸a¤a\8e¡ ;\r
+: º\97¬÷¤a\8e¡ ( º\97¬÷ -- ) 05 LSHIFT º\97¬÷»¡¶\91¥¥ \90{¸a¤a\8e¡ ;\r
+: ¤hñ¤a\8e¡ ( ¤hñ -- ) ¤hñ»¡¶\91¥¥ \90{¸a¤a\8e¡ ;\r
+: Á¡¬÷! ( Á¡¬÷ -- 0 ) ¤e\97¡¶áṡ¸÷ Á¡¬÷¤a\8e¡ ·³\9db\89\81¢ ;\r
+: º\97¬÷! ( º\97¬÷ -- 0 ) º\97¬÷¤a\8e¡ ·³\9db\89\81¢ ;\r
+\r
+: µÅ¬÷ ( 0 -- 16§¡Ëa¸a ) DROP £¡µÅ¬÷¸a @ À\81¶\91! ;\r
+: µÅ+ch ( char -- 16§¡Ëa¸a ) \8bi®AÉ· ! £¡µÅ¬÷¸a @ À\81¶\91! ;\r
+: µÅ+Á¡ ( Á¡¬÷ -- 16§¡Ëa¸a ) £¡µÅ¬÷¸a @ À\81¶\91! SWAP Á¡¬÷¤a\8e¡ ;\r
+: µÅ+º\97 ( º\97¬÷ -- 16§¡Ëa¸a ) £¡µÅ¬÷¸a @ À\81¶\91! SWAP º\97¬÷¤a\8e¡ ;\r
+\r
+: \96á\9d¡ ( \96õ®A -- 0 )\r
+ DROP -2 ¼\81£¡µÅ¬÷¸a +!\r
+ ¼\81£¡µÅ¬÷¸a @ 7 AND CELLS £¡µÅ¬÷¸a\8b¡´â + @ £¡µÅ¬÷¸a ! ·³\9db\89\81¢ ;\r
+: >\96á ( -- ´|¬wÈ\81 )\r
+ -2 ¼\81·³\9db¬wÈ\81 +!\r
+ ¼\81·³\9db¬wÈ\81 @ 7 AND CELLS \8bi®A·³\9db¬wÈ\81\8b¡´â + @ ;\r
+\r
+CREATE Á¡¬÷>\89sÁ¡¬÷Îa \ \89sÁ¡¬÷·i e\97i®\81 ·¶\93e \88A,\94A,¤A,¬A,¸AµA \94\81Ð\81¬á\93e 1,\r
+ \ ´a\93¡¡e 0\r
+\ * À\81¶\91 \88A \8cA \90A \94A \98A \9cA A ¤A ¨A\r
+ 0 C, 0 C, 1 C, 0 C, 0 C, 1 C, 0 C, 0 C, 0 C, 1 C, 0 C,\r
+\ ¬A °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 1 C, 0 C, 0 C, 1 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, ALIGN\r
+\r
+CREATE Á¡¬÷>¤hñÎa \ ¤hñ·¡ ´a\93¥ Á¡¬÷ \98A,¨A,¼AµA \94\81Ð\81¬á\93e 0, ´a\93¡¡e ¤hñ\88t\r
+\ * À\81¶\91 \88A \8cA \90A \94A \98A \9cA A ¤A ¨A\r
+ 0 C, 1 C, 2 C, 3 C, 5 C, 8 C, 0 C, 9 C, 11 C, 13 C, 0 C,\r
+\ ¬A °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 15 C, 16 C, 17 C, 18 C, 0 C, 19 C, 1A C, 1B C, 1C C, 1D C, ALIGN\r
+\r
+CREATE ¤hñ>Ñ»¤hñÁ¡¬÷Îa \ \89s¤hñ: ¶á8§¡Ëa\93e Ñ»¤hñ\88t, ´a\9c\818§¡Ëa\93e Á¡¬÷\88t\r
+ \ Ñ»¤hñ: ¶á8§¡Ëa\93e À\81¶\91\88t, ´a\9c\818§¡Ëa\93e Á¡¬÷\88t\r
+\ * À\81¶\91 \84B \84C \84D \84E \84F \84G \84H \84I\r
+ 0 , 0 , 0102 , 0103 , 020B , 0104 , 050E , 0514 , 0105 , 0107 ,\r
+\ \84J \84K \84L \84M \84N \84O \84P \84Q * \84S\r
+ 0902 , 0908 , 0909 , 090B , 0912 , 0913 , 0914 , 0108 , 0 , 0109 ,\r
+\ \84T \84U \84V \84W \84X \84Y \84Z \84[ \84\ \84]\r
+ 130B , 010B , 010C , 010D , 010E , 0110 , 0111 , 0112 , 0113 , 0114 ,\r
+\r
+CREATE \9cAÁ¡¬÷>\89s¤hñÎa \ \9cA\89Á \89s¤hñ·i e\97i®\81 ·¶\93e Á¡¬÷·¡¡e \89s¤hñ\88t, ´a\93¡¡e 0\r
+\ * À\81¶\91 \88A \8cA \90A \94A \98A \9cA A ¤A ¨A\r
+ 0 C, 0 C, 0A C, 0 C, 0 C, 0 C, 0 C, 0 C, 0B C, 0C C, 0 C,\r
+\ ¬A °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 0D C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0E C, 0F C, 10 C, ALIGN\r
+\r
+CREATE \89s>Ñ»º\97¬÷Îa \ \89sº\97¬÷µA \94\81Ð\81 ´|Ñ»º\97¬÷\88t, \89sº\97¬÷·¡ ´a\93¡¡e 0\r
+\ * * À\81¶\91 \84a \84\81 \84¡ \84Á \84á * *\r
+ 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C,\r
+\ \85A \85a \85\81 \85¡ \85Á \85á * * \86A \86a\r
+ 0 C, 0 C, 0 C, 0 C, 0D C, 0D C, 0 C, 0 C, 0D C, 0 C,\r
+\ \86\81 \86¡ \86Á \86á * * \87A \87a \87\81 \87¡\r
+ 0 C, 14 C, 14 C, 14 C, 0 C, 0 C, 0 C, 0 C, 1B C, 0 C,\r
+\r
+: Á¡¬÷>\89sÁ¡¬÷? ( Á¡¬÷ -- Á¡¬÷ 0 | \89sÁ¡¬÷ -1 )\r
+ DUP £¡µÅ¬÷¸aÁ¡¬÷ = IF\r
+ DUP CHARS Á¡¬÷>\89sÁ¡¬÷Îa + C@ 1 = IF 1+ -1 EXIT THEN THEN\r
+ 0 ;\r
+: \89sÁ¡¬÷? ( Á¡¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ Á¡¬÷>\89sÁ¡¬÷? IF Á¡¬÷¤a\8e¡ ·³\9db\89\81¢\r
+ ELSE £¡µÅ¬÷¸a @ SWAP À\81¶\91! Á¡¬÷¤a\8e¡ THEN ;\r
+: Á¡¬÷>¤hñ? ( Á¡¬÷ -- Á¡¬÷ 0 | ¤hñ -1 )\r
+ DUP CHARS Á¡¬÷>¤hñÎa + C@ DUP IF NIP -1 EXIT THEN ;\r
+: \9cAÁ¡¬÷>\89s¤hñ ( Á¡¬÷ -- 0|\89s¤hñ ) CHARS \9cAÁ¡¬÷>\89s¤hñÎa + C@ ;\r
+: \89s>Ñ»º\97¬÷ ( º\97¬÷ -- 0|Ñ»º\97¬÷ ) CHARS \89s>Ñ»º\97¬÷Îa + C@ ;\r
+: \89s>´|Ñ»¤hñ ( ¤hñ -- 0|Ñ»¤hñ )\r
+ CELLS ¤hñ>Ñ»¤hñÁ¡¬÷Îa + @ 8 RSHIFT DUP À\81¶\91¤hñ <> AND ;\r
+: ¤hñ>¤hñÁ¡¬÷ ( ¤hñ -- ¤hñ Á¡¬÷ )\r
+ CELLS ¤hñ>Ñ»¤hñÁ¡¬÷Îa + @ DUP 8 RSHIFT SWAP 0FF AND ;\r
+\r
+\ \94}¡\9f¡\88a \98A, ¨A, ¼A·¡¡e µÅ¬÷, ´a\93¡¡e ¤hñµA \90ý\89¡ \89\81¢\r
+: ¤hñ? ( Á¡¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ Á¡¬÷>¤hñ? IF ¤hñ¤a\8e¡ ·³\9db\89\81¢\r
+ ELSE £¡µÅ¬÷¸a @ SWAP À\81¶\91! Á¡¬÷¤a\8e¡ THEN ;\r
+: >3? ( -- 3|4 ) £¡µÅ¬÷¸aº\97¬÷ \89s>Ñ»º\97¬÷ 0= ( -1|0) 4 + ;\r
+: >5? ( -- 2|5 ) £¡µÅ¬÷¸a¤hñ À\81¶\91¤hñ = ( -1|0) 3 * 5 + ;\r
+: >6? ( -- 2|6 ) £¡µÅ¬÷¸a¤hñ À\81¶\91¤hñ = ( -1|0) 2* 2* 6 + ;\r
+\r
+: Á¡¬÷>\89s¤hñ? ( Á¡¬÷ -- Á¡¬÷ 0 | \89s¤hñ -1 )\r
+ £¡µÅ¬÷¸a¤hñ\r
+ CASE\r
+ ( \84B) 02 OF DUP ( ¬A) 0B = IF DROP 04 -1 EXIT THEN ENDOF\r
+ ( \84S) 13 OF DUP ( ¬A) 0B = IF DROP 14 -1 EXIT THEN ENDOF\r
+ ( \84E) 05 OF DUP ( ¸A) 0E = IF DROP 06 -1 EXIT THEN\r
+ DUP ( ÐA) 14 = IF DROP 07 -1 EXIT THEN ENDOF\r
+ ( \84I) 09 OF DUP \9cAÁ¡¬÷>\89s¤hñ ?DUP IF NIP -1 EXIT THEN ENDOF\r
+ ENDCASE 0 ;\r
+\r
+: \89s¤hñ? ( Á¡¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ Á¡¬÷>\89s¤hñ? IF ¤hñ¤a\8e¡ ·³\9db\89\81¢ ELSE µÅ+Á¡ THEN ;\r
+: Ñ»¤hñ ( \96õ®A -- 0 )\r
+ DROP £¡µÅ¬÷¸a¤hñ \89s>´|Ñ»¤hñ ¤hñ¤a\8e¡ ·³\9db\89\81¢ ;\r
+\r
+: º\97¬÷>\89sº\97¬÷? ( º\97¬÷ -- º\97¬÷ 0 | \89sº\97¬÷ -1 )\r
+ £¡µÅ¬÷¸aº\97¬÷\r
+ CASE\r
+ ( \87a) 1B OF DUP ( \87¡) 1D = IF DROP 1C -1 EXIT THEN\r
+ 0 EXIT ENDOF\r
+ ( \85¡) 0D OF DUP ( \84a) 03 = IF DROP 0E -1 EXIT THEN\r
+ DUP ( \84\81) 04 = IF DROP 0F -1 EXIT THEN\r
+ DUP ( \87¡) 1D = IF DROP 12 -1 EXIT THEN\r
+ 0 EXIT ENDOF\r
+ ( \86\81) 14 OF DUP ( \84á) 07 = IF DROP 15 -1 EXIT THEN\r
+ DUP ( \85A) 0A = IF DROP 16 -1 EXIT THEN\r
+ DUP ( \87¡) 1D = IF DROP 17 -1 EXIT THEN\r
+ 0 EXIT ENDOF\r
+ ENDCASE 0 ;\r
+\r
+: \89sº\97¬÷? ( º\97¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ º\97¬÷>\89sº\97¬÷? IF º\97¬÷¤a\8e¡ ·³\9db\89\81¢ ELSE µÅ+º\97 THEN ;\r
+: Ñ»º\97¬÷ ( \96õ®A -- 0 )\r
+ DROP £¡µÅ¬÷¸aº\97¬÷ \89s>Ñ»º\97¬÷ º\97¬÷¤a\8e¡ ·³\9db\89\81¢ ;\r
+\r
+\ £¡µÅ¬÷¸aµA¬á ¤hñ·i ¨\85 \8bi¸a\9fi µÅ¬÷¸a\9d¡ \90\81¥¡\90\81\89¡\r
+\ \8ba ¤hñ·i £¡µÅ¬÷¸a·\81 Á¡¬÷µA \90ý\89¡ º\97¬÷·i £¡µÅ¬÷¸aµA \90ý·q\r
+: µÅ+Á¡º\97 ( º\97¬÷ -- 16§¡Ëa¸a )\r
+ £¡µÅ¬÷¸a¤hñ ¤hñ>¤hñÁ¡¬÷ \ º\97¬÷ ¬\81¤hñ Á¡¬÷\r
+ SWAP ¤hñ¤a\8e¡ £¡µÅ¬÷¸a @ \ º\97¬÷ Á¡¬÷ 16§¡ËaÐe\8bi¸a\r
+ À\81¶\91! SWAP Á¡¬÷¤a\8e¡ 2 ¬wÈ\81\8b¡´â ´|¸a\8b¡´â SWAP º\97¬÷¤a\8e¡ ;\r
+\r
+CREATE µw®A>Ðe\8bi¸a\r
+\ a> A b>\87A c>ÀA d>´A e>\94A f>\9cA g>ÐA h>\85¡ i>\84¡ j>\84á\r
+ 308 , 41A , 310 , 30D , 305 , 307 , 314 , 40D , 405 , 407 ,\r
+\ k>\84a l>\87¡ m>\87a n>\86\81 o>\84\81 p>\85A q>¤A r>\88A s>\90A t>¬A\r
+ 403 , 41D , 41B , 414 , 404 , 40A , 309 , 302 , 304 , 30B ,\r
+\ u>\85a v>ÌA w>¸A x>ÈA y>\86a z>ÄA\r
+ 40B , 313 , 30E , 312 , 413 , 311 ,\r
+\r
+CREATE µw¶õ®A>Ðe\8bi¸a\r
+\ A>A B>B C>C D>D E>\98A F>F G>G H>H I>I J>J\r
+ 041 , 042 , 043 , 044 , 306 , 046 , 047 , 048 , 049 , 04A ,\r
+\ K>K L>L M>M N>N O>\84Á P>\85\81 Q>¨A R>\8cA S>S T>°A\r
+ 04B , 04C , 04D , 04E , 406 , 40C , 30A , 303 , 053 , 30C ,\r
+\ U>U V>V W>¼A X>X Y>Y Z>Z\r
+ 055 , 056 , 30F , 058 , 059 , 05A ,\r
+\r
+\ EKEY \9d¡ ¤h·e \88tµA¬á \8bi®A·\81 ¹·\9fA\9fi '>\8bi¸a-2¤é¯¢'\9d¡ \90ñ\8b±\r
+\ 2¤é¯¢µA¬á \8bi®A ¹·\9fA\93e \94a¬õ \88a»¡:\r
+\ Ðeµw¤a\8e\91(1), \96õ®A(2), \94}¡\9f¡(3), Ñ©¡\9f¡(4), \90a ỡ(0)\r
+: >\8bi®A\88t\89Á¹·\9fA-2¤é¯¢ ( \8bi®A\88t -- \8bi®A\88t' ¹·\9fA )\r
+ 0FF AND \ special key \93e ¢\81¯¡\r
+ DUP BL = ¶E½¢¶õ®A\92\89\9f±? AND IF DROP 0 1 EXIT THEN \ Ðeµw¤a\8e\91\8bi®A·¡¡e 0 1\r
+ DUP \96õ®A= IF DROP 8 2 EXIT THEN \ \96õ\8bi®A·¡¡e\r
+ DUP [CHAR] A [CHAR] Z 1+ WITHIN \8bi®A·³\9db¬wÈ\81 @ AND IF \ Ðe\8bi·³\9db·¡\89¡ A-Z ·¡¡e\r
+ [CHAR] A - CELLS µw¶õ®A>Ðe\8bi¸a\r
+ [ µw®A>Ðe\8bi¸a µw¶õ®A>Ðe\8bi¸a - ] LITERAL CapsLock? AND\r
+ + + @ DUP 0FF AND SWAP 8 RSHIFT EXIT THEN\r
+ DUP [CHAR] a [CHAR] z 1+ WITHIN \8bi®A·³\9db¬wÈ\81 @ AND IF \ Ðe\8bi·³\9db·¡\89¡ a-z ·¡¡e\r
+ [CHAR] a - CELLS µw®A>Ðe\8bi¸a\r
+ [ µw¶õ®A>Ðe\8bi¸a µw®A>Ðe\8bi¸a - ] LITERAL CapsLock? AND\r
+ + + @ DUP 0FF AND SWAP 8 RSHIFT EXIT THEN\r
+ 0 ; \ \90a ỡ\r
+\r
+\ 2¤é¯¢ ¸aÌe ¬wÈ\81\r
+\ 0 : µw¢\85 ·³\9db\r
+\ 1 : Ðe\8bi·³\9db ¯¡¸b\r
+\ 2 : Á¡¬÷ ·³\9db\r
+\ 3 : Á¡¬÷+º\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 4 : Á¡¬÷+\89sº\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 5 : Á¡¬÷+º\97¬÷+¤hñ ·³\9db\r
+\ 6 : Á¡¬÷+º\97¬÷+\89s¤hñ ·³\9db\r
+5 Äe µ¡É¡ aÈa: >\8bi¸a-2¤é¯¢\r
+\ ·³\9db| \90a ỡ? | Ðeµw¤a\8e\91? | \96õ®A? | \94}¡\9f¡? | Ñ©¡\9f¡? |\r
+\ ¬wÈ\81----------------------------------------------------------------------\r
+ ( 0) | \8ba\90· | >0 | À\81¶\91! | >1 | \8ba\90· | >0 | \8ba\90· | >0 | \8ba\90· | >0\r
+ ( 1) | \8ba\90· | >1 | \8ba\90· | >0 | \8ba\90· | >1 | Á¡¬÷! | >2 | º\97¬÷! | >3\r
+ ( 2) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | \89sÁ¡¬÷? | >2 | º\97¬÷! | >3\r
+ ( 3) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | ¤hñ? | >5? | \89sº\97¬÷? | >3?\r
+ ( 4) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | ¤hñ? | >5? | µÅ+º\97 | >3\r
+ ( 5) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | \89s¤hñ? | >6? | µÅ+Á¡º\97 | >3\r
+ ( 6) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+Á¡º\97 | >3\r
+;µ¡É¡ aÈa\r
+\r
+\\r
+\ 3¤é¯¢ ¸aÌe ·³\9dbµA Ï©¶aÐe \90{ i\97i\r
+\\r
+\r
+CREATE \9cA¤hñ>\89s¤hñÎa \ \9cA\89Á \89s¤hñ·i e\97i®\81 ·¶\93e ¤hñ·¡¡e \89s¤hñ\88t, ´a\93¡¡e 0\r
+\ * À\81¶\91 \84B \84C \84D \84E \84F \84G \84H \84I\r
+ 0 C, 0 C, 0A C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C,\r
+\ \84J \84K \84L \84M \84N \84O \84P \84Q * \84S\r
+ 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0B C, 0 C, 0C C,\r
+\ \84T \84U \84V \84W \84X \84Y \84Z \84[ \84\ \84]\r
+ 0 C, 0D C, 0 C, 0 C, 0 C, 0 C, 0 C, 0E C, 0F C, 10 C, ALIGN\r
+\r
+: ¤hñ! ( ¤hñ -- 0 ) ¤hñ¤a\8e¡ ·³\9db\89\81¢ ;\r
+: µÅ+¤hñ ( ¤hñ -- 16§¡Ëa¸a ) £¡µÅ¬÷¸a @ À\81¶\91! SWAP ¤hñ¤a\8e¡ ;\r
+: \9cA¤hñ>\89s¤hñ ( ¤hñ -- 0|\89s¤hñ ) CHARS \9cA¤hñ>\89s¤hñÎa + C@ ;\r
+: ¤hñ>\89s¤hñ? ( ¤hñ -- ¤hñ 0 | \89s¤hñ -1 )\r
+ £¡µÅ¬÷¸a¤hñ\r
+ CASE\r
+ ( \84B) 02 OF DUP ( \84B) 02 = IF DROP 03 -1 EXIT THEN\r
+ ( \84U) 15 = IF DROP 04 -1 EXIT THEN ENDOF\r
+ ( \84S) 13 OF DUP ( \84U) 15 = IF DROP 14 -1 EXIT THEN ENDOF\r
+ ( \84U) 15 OF DUP ( \84U) 15 = IF DROP 16 -1 EXIT THEN ENDOF\r
+ ( \84E) 05 OF DUP ( \84X) 18 = IF DROP 06 -1 EXIT THEN\r
+ DUP ( \84]) 1D = IF DROP 07 -1 EXIT THEN ENDOF\r
+ ( \84I) 09 OF DUP \9cA¤hñ>\89s¤hñ ?DUP IF NIP -1 EXIT THEN ENDOF\r
+ ENDCASE 0 ;\r
+: \89s¤hñ? ( ¤hñ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ ¤hñ>\89s¤hñ? IF ¤hñ¤a\8e¡ ·³\9db\89\81¢ ELSE µÅ+¤hñ THEN ;\r
+\r
+CREATE 3¤é®A>Ðe\8bi¸a\r
+\ !>\84X ">" #># $>$ %>% &>& '>ÈA (>( )>) *>* +>+ ,>,\r
+ 518 , 022 , 023 , 024 , 025 , 026 , 312 , 028 , 029 , 02A , 02B , 02C ,\r
+\ ->- .>. />\85¡ 0>ÄA 1>\84] 2>\84V 3>\84S 4>\86a 5>\87A 6>\84¡ 7>\85\81 8>\87\81\r
+ 02D , 02E , 40D , 311 , 51D , 516 , 513 , 413 , 41A , 405 , 40C , 41C ,\r
+\ 9>\86\81 :>: ;>¤A <>2 =>= >>3 ?>? @>@ A>\84H B>! C>\84K D>\84J\r
+ 414 , 03A , 309 , 032 , 03D , 033 , 03F , 040 , 508 , 021 , 50B , 50A ,\r
+\ E>\84Z F>\84C G>/ H>' I>8 J>4 K>5 L>6 M>1 N>0 O>9 P>>\r
+ 51A , 503 , 02F , 027 , 038 , 034 , 035 , 036 , 031 , 030 , 039 , 03E ,\r
+\ Q>\84\ R>\84Á S>\84G T>; U>7 V>\84P W>\84[ X>\84T Y>8 Z>\84Y [>[ \>\\r
+ 51C , 406 , 507 , 03B , 037 , 510 , 51B , 514 , 038 , 519 , 05B , 05C ,\r
+\ ]>] ^>^ _>_ `>` a>\84W b>\86\81 c>\85A d>\87¡ e>\85a f>\84a g>\87a h>\90A\r
+ 05D , 05E , 05F , 060 , 517 , 414 , 40A , 41D , 40B , 403 , 41B , 304 ,\r
+\ i> A j>´A k>\88A l>¸A m>ÐA n>¬A o>ÀA p>ÌA q>\84U r>\84\81 s>\84E t>\84á\r
+ 308 , 30D , 302 , 30E , 314 , 30B , 310 , 313 , 515 , 404 , 505 , 407 ,\r
+\ u>\94A v>\85¡ w>\84I x>\84B y>\9cA z>\84Q {>{ |>| }>} ~>~\r
+ 305 , 40D , 509 , 502 , 307 , 511 , 07B , 07C , 07D , 07E ,\r
+\r
+\ EKEY \9d¡ ¤h·e \88tµA¬á \8bi®A·\81 ¹·\9fA\9fi '>\8bi¸a-3¤é¯¢'·a\9d¡ \90ñ\8b±\r
+\ 3¤é¯¢µA¬á \8bi®A ¹·\9fA\93e \94a¬õ \88a»¡:\r
+\ Ðeµw¤a\8e\91(1), \96õ®A(2), Á¡¬÷(3), º\97¬÷(4), ¤hñ(5), \90a ỡ(0)\r
+: >\8bi®A\88t\89Á¹·\9fA-3¤é¯¢ ( \8bi®A\88t -- \8bi®A\88t' ¹·\9fA )\r
+ 0FF AND \ special key \93e ¢\81¯¡\r
+ DUP BL = ¶E½¢¶õ®A\92\89\9f±? AND IF DROP 0 1 EXIT THEN \ Ðeµw¤a\8e\91\8bi®A·¡¡e 0 1\r
+ DUP \96õ®A= IF DROP 8 2 EXIT THEN \ \96õ\8bi®A·¡¡e\r
+ DUP BL > 0= IF 0 EXIT THEN \ ¹A´á¢\85¸a\90a §¥Äe·¡¡e\r
+ \8bi®A·³\9db¬wÈ\81 @ 0= IF 0 EXIT THEN \ µw¢\85·³\9db\r
+ CapsLock? IF\r
+ DUP [CHAR] A [CHAR] Z 1+ WITHIN IF\r
+ [ CHAR a CHAR A - ] LITERAL +\r
+ ELSE DUP [CHAR] a [CHAR] z 1+ WITHIN IF\r
+ [ CHAR A CHAR a - ] LITERAL + THEN THEN THEN\r
+ [CHAR] ! - CELLS 3¤é®A>Ðe\8bi¸a + @\r
+ DUP 0FF AND SWAP 8 RSHIFT ;\r
+\r
+\ 3¤é¯¢ ¸aÌe ¬wÈ\81\r
+\ 0 : µw¢\85 ·³\9db\r
+\ 1 : Ðe\8bi·³\9db ¯¡¸b\r
+\ 2 : Á¡¬÷ ·³\9db\r
+\ 3 : Á¡¬÷+º\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 4 : Á¡¬÷+\89sº\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 5 : Á¡¬÷+º\97¬÷+¤hñ ·³\9db\r
+\ 6 : Á¡¬÷+º\97¬÷+\89s¤hñ ·³\9db\r
+6 Äe µ¡É¡ aÈa: >\8bi¸a-3¤é¯¢\r
+\ ·³\9db| \90a ỡ? | Ðeµw¤a\8e\91? | \96õ®A? | Á¡¬÷? | º\97¬÷? | ¤hñ? |\r
+\ ¬wÈ\81--------------------------------------------------------------------------------------\r
+ ( 0) | \8ba\90· | >0 | À\81¶\91! | >1 | \8ba\90· | >0 | \8ba\90· | >0 | \8ba\90· | >0 | \8ba\90· | >0\r
+ ( 1) | \8ba\90· | >1 | \8ba\90· | >0 | \8ba\90· | >1 | Á¡¬÷! | >2 | º\97¬÷! | >3 | ¤hñ! | >5\r
+ ( 2) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | \89sÁ¡¬÷? | >2 | º\97¬÷! | >3 | ¤hñ! | >5\r
+ ( 3) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | \89sº\97¬÷? | >3? | ¤hñ! | >5\r
+ ( 4) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+º\97 | >3 | ¤hñ! | >5\r
+ ( 5) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+º\97 | >3 | \89s¤hñ? | >5?\r
+ ( 6) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+º\97 | >3 | µÅ+¤hñ | >5\r
+;µ¡É¡ aÈa\r
+\r
+' >\8bi¸a-2¤é¯¢ VALUE '>\8bi¸a\r
+' >\8bi®A\88t\89Á¹·\9fA-2¤é¯¢ VALUE '>\8bi®A\88t\89Á¹·\9fA\r
+: >\8bi¸a '>\8bi¸a EXECUTE ;\r
+: >\8bi®A\88t\89Á¹·\9fA '>\8bi®A\88t\89Á¹·\9fA EXECUTE ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+: 2BUL ( -- )\r
+ ['] >\8bi¸a-2¤é¯¢ TO '>\8bi¸a\r
+ ['] >\8bi®A\88t\89Á¹·\9fA-2¤é¯¢ TO '>\8bi®A\88t\89Á¹·\9fA ;\r
+: 3BUL ( -- )\r
+ ['] >\8bi¸a-3¤é¯¢ TO '>\8bi¸a\r
+ ['] >\8bi®A\88t\89Á¹·\9fA-3¤é¯¢ TO '>\8bi®A\88t\89Á¹·\9fA ;\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+: HEKEY\r
+ \8bi®AÉ· @ ?DUP IF \ \8bi®AÉ·µA \8bi¸a\88a ·¶·a¡e \8ba \8bi¸a\9fi ¥¡\90\91\r
+ DUP 0FF00 AND \ \8bi®AÉ·µA \96\81 \8bi¸a\88a ·¶·a¡e ¶á 8 §¡Ëa\9fi ¥¡\90\91\r
+ IF DUP 8 RSHIFT\r
+ SWAP 0FF AND\r
+ \8bi®AÉ· ! EXIT THEN\r
+ 0 \8bi®AÉ· ! EXIT THEN \ \8bi®AÉ··\81 Ðe \8bi¸a\9fi ¥¡\90\91\r
+ £¡µÅ¬÷¸a @ À\81¶\91¸a <> \8bi®A·³\9db¬wÈ\81 @ AND IF £¡µÅ¬÷¸a¥¡µa THEN\r
+ BEGIN BEGIN PAUSE RX? UNTIL RX@ >\8bi®A\88t\89Á¹·\9fA >\8bi¸a ?DUP UNTIL\r
+ \ BEGIN ... UNTIL ·i ¨a¹a \90aµ© \98\81 \94ᣡµA \90q·e \88t·e\r
+ \ 8 §¡Ëa : Ðe \8bi¸a : \8ba\90·\r
+ \ 16 §¡Ëa : \96\81 \8bi¸a : µÅ¬÷ , µÅ+Á¡ , µÅ+Á¡º\97 , ...\r
+ \ 16 §¡Ëa : A \8bi¸a : µÅ¬÷+ch ( char \88t·e \8bi®AÉ· µA \97i´á ·¶·q )\r
+ DUP 0FF00 AND IF \ 16§¡Ëa Ðe\8bi¸a·¡¡e \90a ỡ \8bi¸a\9fi \8bi®AÉ·µA \94q·q\r
+ DUP 8 RSHIFT SWAP 0FF AND \ \94ᣡ: ¶á8§¡Ëa ´a\9c\818§¡Ëa\r
+ \8bi®AÉ· @ ?DUP IF \ \94ᣡ: ¶á8§¡Ëa ´a\9c\818§¡Ëa char\r
+ SWAP 8 LSHIFT OR THEN\r
+ \8bi®AÉ· !\r
+ THEN ;\r
+\r
+: HEKEY?\r
+ £¡µÅ¬÷¸a @ À\81¶\91¸a <> \8bi®AÉ· @ OR IF -1 ELSE RX? THEN ;\r
+\r
+: SET-TEXT-I/O ( -- )\r
+ ['] RX? TO 'ekey?\r
+ ['] RX@ TO 'ekey\r
+ ['] TX! TO 'emit ;\r
+\r
+: SET-HGRAPHIC-I/O\r
+ ['] HEKEY? TO 'ekey?\r
+ ['] HEKEY TO 'ekey\r
+ ['] HEMIT TO 'emit ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+DECIMAL VARIABLE \8cq¤b·±\r
+0 60 CELLS 60 CELLS HAT multiI/O multiI/O BUILD\r
+0 60 CELLS 60 CELLS HAT HCURSOR HCURSOR BUILD\r
+\r
+: TEXT\r
+ textmode# SET-MODE\r
+ SET-TEXT-I/O\r
+ 0 TO GRAPHIC?\r
+ multiI/O SLEEP HCURSOR SLEEP ;\r
+\r
+HEX\r
+CODE ReadClockCount ( -- ud )\r
+ BX PUSH,\r
+ AX AX XOR, \ MOV AH,00\r
+ 1A INT,\r
+ DX PUSH,\r
+ CX BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+DECIMAL\r
+: \8cq¤b·±¹¡¸é ( -- )\r
+ ReadClockCount\r
+ BEGIN 2DUP DNEGATE ReadClockCount D+ DROP UNTIL 2DROP\r
+ ReadClockCount\r
+ -1 0 DO PAUSE 0 0 BL EFONT! 0 0 BL EFONT!\r
+ 2DUP DNEGATE ReadClockCount D+ DROP\r
+ IF 2DROP I \8cq¤b·± ! UNLOOP EXIT THEN LOOP\r
+ 2DROP -1 \8cq¤b·± ! ;\r
+\r
+: HGRAPHIC\r
+ VGA? IF\r
+ 3 TO textmode#\r
+ ['] VGA-SET-GRAPHIC TO 'SET-GRAPHIC\r
+ VGA-Y>SegTable Y>SegTable !\r
+ 30 TO MAX-Y \ 640X480 Ð\81¬w\95¡; 480 / 16 = 30 º\89\r
+ ELSE HERC? IF\r
+ 7 TO textmode#\r
+ ['] HERC-SET-GRAPHIC TO 'SET-GRAPHIC\r
+ HERC-Y>SegTable Y>SegTable !\r
+ 25 TO MAX-Y \ 640X400 Ð\81¬w\95¡; 400 / 16 = 25 º\89\r
+ MAX-Y 0 DO 1 MAX-X* 0 DO I J BL EFONT! LOOP LOOP\r
+ ELSE SET-TEXT-I/O 0 TO GRAPHIC?\r
+ ." Korean characters can be displayed only on VGA or Hercules Graphics screen."\r
+ multiI/O SLEEP HCURSOR SLEEP EXIT\r
+ THEN THEN\r
+ VSCREEN VSCREEN-SIZE CHARS BL FILL\r
+ SET-GRAPHIC\r
+ 0 HCHAR !\r
+ 0 \8bi®A·³\9db¬wÈ\81 !\r
+ 0 \8bi®AÉ· !\r
+ À\81¶\91!\r
+ 0 VSCR0 !\r
+ 0 YY ! 0 VIR_Y !\r
+ 0 XX ! 0 VIR_X !\r
+ SET-HGRAPHIC-I/O\r
+ multiI/O AWAKE HCURSOR SLEEP \8cq¤b·±¹¡¸é HCURSOR AWAKE ;\r
+\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+: NEW-SET-I/O\r
+ GRAPHIC? IF SET-HGRAPHIC-I/O ELSE SET-TEXT-I/O THEN ;\r
+\r
+HEX\r
+: NEW-hi\r
+ DOSCommand>PAD\r
+ GET-MODE TO OldMode# HGRAPHIC hi\r
+ ." ·\81\89e\89Á ¹A´e\89Á §¡Íw·i ¶á ·¥Èá\91U º\81¡\90a Ða·¡ÉI wykoh\9d¡ ¥¡\90\81 º\81¯³¯¡µ¡." CR\r
+ S" BLOCKS.BLK" MAPPED-TO-BLOCK QUIT ;\r
+\r
+' NEW-SET-I/O TO 'init-i/o\r
+' NEW-hi TO 'boot\r
+\r
+: XX+! ( n -- )\r
+ XX @ + MAX-X /MOD YY +! XX ! ;\r
+\r
+FALSE VALUE SCREEN-UPDATED?\r
+\r
+HEX\r
+:NONAME multiI/O ACTIVATE\r
+ BEGIN\r
+ PAUSE\r
+ YY @ MAX-X* XX @ + DUP VIR_Y @ MAX-X* VIR_X @ + < IF\r
+ FALSE TO SCREEN-UPDATED?\r
+ YY @ VIR_Y @ < IF YY @ 1+ MAX-X*\r
+ ELSE VIR_Y @ MAX-X* VIR_X @ + THEN\r
+ SWAP\r
+ BEGIN DUP >VSCR-ADDR C@\r
+ DUP 80 < IF\r
+ XX @ YY @ ROT EFONT! 1 XX+! ELSE\r
+ 8 LSHIFT >R\r
+ CHAR+ DUP >VSCR-ADDR C@ R> OR\r
+ XX @ YY @ ROT HFONT! 2 XX+! THEN\r
+ CHAR+ 2DUP > 0= UNTIL 2DROP ELSE\r
+ TRUE TO SCREEN-UPDATED?\r
+ DROP VIR_X @ XX ! VIR_Y @ YY ! THEN\r
+ AGAIN\r
+; EXECUTE\r
+\r
+:NONAME HCURSOR ACTIVATE\r
+ BEGIN\r
+ \8cq¤b·± @ 0 DO PAUSE LOOP\r
+ SCREEN-UPDATED? IF\r
+ GRAPHIC? IF\r
+ \8bi®A·³\9db¬wÈ\81 @ ?DUP IF\r
+ 1- IF\r
+ £¡µÅ¬÷¸a¥¡µa ELSE\r
+ XX @ YY @ [CHAR] _ EFONT! THEN ELSE\r
+ XX @ YY @ [CHAR] - EFONT! THEN THEN\r
+ \8cq¤b·± @ 0 DO PAUSE LOOP\r
+ GRAPHIC? IF\r
+ XX @ YY @ BL EFONT!\r
+ \8bi®A·³\9db¬wÈ\81 @ IF\r
+ XX @ CHAR+ YY @ BL EFONT! THEN THEN THEN\r
+ AGAIN\r
+; EXECUTE\r
+\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+HEX\r
+CODE textAT-XY ( column row -- )\r
+ 2 # AH MOV,\r
+ DX POP,\r
+ BL DH MOV,\r
+ BX BX XOR,\r
+ 10 INT,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ AT-XY ( u1 u2 -- ) \ FACILITY\r
+\ Perform implementation-dependent steps so that the next\r
+\ character displayed will appear in column u1, row u2 of the\r
+\ user output device, the upper left corner of which is column\r
+\ zero, row zero. An ambiguous condition exists if the\r
+\ operation cannot be performed on the user output Adevice\r
+\ with the specified parameters.\r
+: AT-XY\r
+ GRAPHIC? IF DUP YY ! VIR_Y ! DUP XX ! VIR_X !\r
+ ELSE textAT-XY THEN ;\r
+\r
+\ PAGE ( -- ) \ FACILITY\r
+\ Move to another page for output. Actual function depends on\r
+\ the output device. On a terminal, PAGE clears the screen\r
+\ and resets the cursor position to the upper left corner. On\r
+\ a printer, PAGE performs a form feed.\r
+DECIMAL\r
+: PAGE\r
+ GRAPHIC? IF MAX-Y 0 DO 1 MAX-X* 0 DO\r
+ BL J MAX-X* I + >VSCR-ADDR C! I J BL EFONT!\r
+ LOOP LOOP\r
+ 0 TO YTop\r
+ ELSE 0 0 AT-XY 25 0 DO 80 0 DO BL EMIT LOOP LOOP\r
+ THEN 0 0 AT-XY ;\r
+\r
+: BYE OldMode# SET-MODE BYE ;\r
+\r
+HGRAPHIC\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
--- /dev/null
+\ IBM-PCµA¬á ³a\93e hForth ¶w Ðe\8bi ·³Â\89\9db Ïa\9d¡\8ba\9c\91·³\93¡\94a. »¡\8bq·e ¹¡ÐsÑw\r
+\ Ðe\8bi e ³i ®\81 ·¶·s\93¡\94a.\r
+\\r
+\ ·¡ Ïa\9d¡\8ba\9c\91·e VGA \8ba\9c\81Ï¢ Äa\97aµÁ ÐáÇI\9dA¯a \8ba\9c\81Ï¢ Äa\97a e·i »¡¶¥Ðs\93¡\94a.\r
+\\r
+\ 'TEXT'\9ca\89¡ ¯¡Åa¡e ÉB¯aËa ÑÁ¡e·a\9d¡ ¤a\8eá\89¡ 'HGRAPHIC'·¡\9ca\89¡ ¯¡Ç¡¡e \8ba\9c\81Ï¢\r
+\ ÑÁ¡e·a\9d¡ ¤a\8eá´á¬á Ðe\8bi·i ÑÁ¡eµA Îa¯¡Ði ®\81 ·¶·s\93¡\94a.\r
+\\r
+\ Àá·qµA\93e \96\81¤é¯¢ ¸aÌe·a\9d¡ ¬é¸÷\96A´á ·¶·s\93¡\94a. 3¤é¯¢ ¸aÌe·a\9d¡ ¤a\8e\81\9da¡e\r
+\ '3BUL'·¡\9ca\89¡ ¯¡Ç¡\89¡ 2¤é¯¢ ¸aÌe·a\9d¡ ¤a\8e\81\9da¡e '2BUL'·¡\9ca\89¡ ¯¡Ç¡¯³¯¡µ¡.\r
+\\r
+\ HF86EXE.EXE\9fi ¯¡¸bÐe Ò\81 \94a·q ®\85¬á\9d¡ ·¡ Ïa\9d¡\8ba\9c\91·i µ©\9f© ®\81 ·¶·s\93¡\94a.\r
+\\r
+\ << OPTIONAL.F\r
+\ << ASM8086.F\r
+\ << COREEXT.F\r
+\ << MSDOS.F\r
+\ BL PARSE MULTI.F INCLUDED\r
+\ BL PARSE HIOMULTI.F INCLUDED\r
+\\r
+\ 1996. 2. 9.\r
+\ Wonyong Koh\r
+\\r
+\ Usage:\r
+\ TEXT ( -- )\r
+\ Set text screen and redirect i/o vectors to DOS functions.\r
+\ HGRAPHIC ( -- )\r
+\ Set graphics screen and redirect i/o vectors to handle Korean\r
+\ character input and graphics screen output.\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT? 0= [IF] 0 [THEN]\r
+0= [IF]\r
+ CR .( This program needs FILE wordset words.) ABORT\r
+[THEN]\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+WORDLIST WORDLIST-NAME Ðe\8bi·³Â\89\9db-WORDLIST\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+GET-ORDER Ðe\8bi·³Â\89\9db-WORDLIST SWAP 1+ SET-ORDER\r
+\r
+CR .( Loading English fonts)\r
+HEX\r
+CREATE ENGFONT \ 8x16, 256 ¸a\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ 00h\r
+00000 , 0817E , 081A5 , 0BD81 , 08199 , 07E81 , 00000 , 00000 , \\r
+00000 , 0FF7E , 0FFDB , 0C3FF , 0FFE7 , 07EFF , 00000 , 00000 , \\r
+00000 , 00000 , 0FE6C , 0FEFE , 07CFE , 01038 , 00000 , 00000 , \\r
+00000 , 00000 , 03810 , 0FE7C , 0387C , 00010 , 00000 , 00000 , \\r
+00000 , 01800 , 03C3C , 0E7E7 , 018E7 , 03C18 , 00000 , 00000 , \\r
+00000 , 01800 , 07E3C , 0FFFF , 0187E , 03C18 , 00000 , 00000 , \\r
+00000 , 00000 , 00000 , 03C18 , 0183C , 00000 , 00000 , 00000 , \\r
+0FFFF , 0FFFF , 0FFFF , 0C3E7 , 0E7C3 , 0FFFF , 0FFFF , 0FFFF , \\r
+00000 , 00000 , 03C00 , 04266 , 06642 , 0003C , 00000 , 00000 , \ ^I = TAB\r
+0FFFF , 0FFFF , 0C3FF , 0BD99 , 099BD , 0FFC3 , 0FFFF , 0FFFF , \ ^J = LF\r
+00000 , 00E1E , 0321A , 0CC78 , 0CCCC , 078CC , 00000 , 00000 , \\r
+00000 , 0663C , 06666 , 03C66 , 07E18 , 01818 , 00000 , 00000 , \\r
+00000 , 0333F , 0303F , 03030 , 07030 , 0E0F0 , 00000 , 00000 , \ ^M = CR\r
+00000 , 0637F , 0637F , 06363 , 06763 , 0E6E7 , 000C0 , 00000 , \\r
+00000 , 01800 , 0DB18 , 0E73C , 0DB3C , 01818 , 00000 , 00000 , \\r
+08000 , 0E0C0 , 0F8F0 , 0F8FE , 0E0F0 , 080C0 , 00000 , 00000 , \\r
+00200 , 00E06 , 03E1E , 03EFE , 00E1E , 00206 , 00000 , 00000 , \\r
+00000 , 03C18 , 0187E , 01818 , 03C7E , 00018 , 00000 , 00000 , \\r
+00000 , 06666 , 06666 , 06666 , 00066 , 06666 , 00000 , 00000 , \\r
+00000 , 0DB7F , 0DBDB , 01B7B , 01B1B , 01B1B , 00000 , 00000 , \\r
+07C00 , 060C6 , 06C38 , 0C6C6 , 0386C , 0C60C , 0007C , 00000 , \\r
+00000 , 00000 , 00000 , 00000 , 0FEFE , 0FEFE , 00000 , 00000 , \\r
+00000 , 03C18 , 0187E , 01818 , 03C7E , 07E18 , 00000 , 00000 , \\r
+00000 , 03C18 , 0187E , 01818 , 01818 , 01818 , 00000 , 00000 , \\r
+00000 , 01818 , 01818 , 01818 , 07E18 , 0183C , 00000 , 00000 , \\r
+00000 , 00000 , 01800 , 0FE0C , 0180C , 00000 , 00000 , 00000 , \\r
+00000 , 00000 , 03000 , 0FE60 , 03060 , 00000 , 00000 , 00000 , \\r
+00000 , 00000 , 00000 , 0C0C0 , 0FEC0 , 00000 , 00000 , 00000 , \\r
+00000 , 00000 , 02800 , 0FE6C , 0286C , 00000 , 00000 , 00000 , \\r
+00000 , 00000 , 03810 , 07C38 , 0FE7C , 000FE , 00000 , 00000 , \\r
+00000 , 00000 , 0FEFE , 07C7C , 03838 , 00010 , 00000 , 00000 , \\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ space\r
+00000 , 03C18 , 03C3C , 01818 , 00018 , 01818 , 00000 , 00000 , \ !\r
+06600 , 06666 , 00024 , 00000 , 00000 , 00000 , 00000 , 00000 , \ "\r
+00000 , 06C00 , 0FE6C , 06C6C , 0FE6C , 06C6C , 00000 , 00000 , \ #\r
+01818 , 0C67C , 0C0C2 , 0067C , 08606 , 07CC6 , 01818 , 00000 , \ $\r
+00000 , 00000 , 0C6C2 , 0180C , 06030 , 086C6 , 00000 , 00000 , \ %\r
+00000 , 06C38 , 0386C , 0DC76 , 0CCCC , 076CC , 00000 , 00000 , \ &\r
+03000 , 03030 , 00060 , 00000 , 00000 , 00000 , 00000 , 00000 , \ '\r
+00000 , 0180C , 03030 , 03030 , 03030 , 00C18 , 00000 , 00000 , \ (\r
+00000 , 01830 , 00C0C , 00C0C , 00C0C , 03018 , 00000 , 00000 , \ )\r
+00000 , 00000 , 06600 , 0FF3C , 0663C , 00000 , 00000 , 00000 , \ *\r
+00000 , 00000 , 01800 , 07E18 , 01818 , 00000 , 00000 , 00000 , \ +\r
+00000 , 00000 , 00000 , 00000 , 01800 , 01818 , 00030 , 00000 , \ ,\r
+00000 , 00000 , 00000 , 0FE00 , 00000 , 00000 , 00000 , 00000 , \ -\r
+00000 , 00000 , 00000 , 00000 , 00000 , 01818 , 00000 , 00000 , \ .\r
+00000 , 00000 , 00602 , 0180C , 06030 , 080C0 , 00000 , 00000 , \ /\r
+00000 , 06C38 , 0C6C6 , 0D6D6 , 0C6C6 , 0386C , 00000 , 00000 , \ 0\r
+00000 , 03818 , 01878 , 01818 , 01818 , 07E18 , 00000 , 00000 , \ 1\r
+00000 , 0C67C , 00C06 , 03018 , 0C060 , 0FEC6 , 00000 , 00000 , \ 2\r
+00000 , 0C67C , 00606 , 0063C , 00606 , 07CC6 , 00000 , 00000 , \ 3\r
+00000 , 01C0C , 06C3C , 0FECC , 00C0C , 01E0C , 00000 , 00000 , \ 4\r
+00000 , 0C0FE , 0C0C0 , 006FC , 00606 , 07CC6 , 00000 , 00000 , \ 5\r
+00000 , 06038 , 0C0C0 , 0C6FC , 0C6C6 , 07CC6 , 00000 , 00000 , \ 6\r
+00000 , 0C6FE , 00606 , 0180C , 03030 , 03030 , 00000 , 00000 , \ 7\r
+00000 , 0C67C , 0C6C6 , 0C67C , 0C6C6 , 07CC6 , 00000 , 00000 , \ 8\r
+00000 , 0C67C , 0C6C6 , 0067E , 00606 , 0780C , 00000 , 00000 , \ 9\r
+00000 , 00000 , 01818 , 00000 , 01800 , 00018 , 00000 , 00000 , \ :\r
+00000 , 00000 , 01818 , 00000 , 01800 , 03018 , 00000 , 00000 , \ ;\r
+00000 , 00600 , 0180C , 06030 , 01830 , 0060C , 00000 , 00000 , \ <\r
+00000 , 00000 , 07E00 , 00000 , 0007E , 00000 , 00000 , 00000 , \ =\r
+00000 , 06000 , 01830 , 0060C , 0180C , 06030 , 00000 , 00000 , \ >\r
+00000 , 0C67C , 00CC6 , 01818 , 00018 , 01818 , 00000 , 00000 , \ ?\r
+00000 , 07C00 , 0C6C6 , 0DEDE , 0DCDE , 07CC0 , 00000 , 00000 , \ @\r
+00000 , 03810 , 0C66C , 0FEC6 , 0C6C6 , 0C6C6 , 00000 , 00000 , \ A\r
+00000 , 066FC , 06666 , 0667C , 06666 , 0FC66 , 00000 , 00000 , \ B\r
+00000 , 0663C , 0C0C2 , 0C0C0 , 0C2C0 , 03C66 , 00000 , 00000 , \ C\r
+00000 , 06CF8 , 06666 , 06666 , 06666 , 0F86C , 00000 , 00000 , \ D\r
+00000 , 066FE , 06862 , 06878 , 06260 , 0FE66 , 00000 , 00000 , \ E\r
+00000 , 066FE , 06862 , 06878 , 06060 , 0F060 , 00000 , 00000 , \ F\r
+00000 , 0663C , 0C0C2 , 0DEC0 , 0C6C6 , 03A66 , 00000 , 00000 , \ G\r
+00000 , 0C6C6 , 0C6C6 , 0C6FE , 0C6C6 , 0C6C6 , 00000 , 00000 , \ H\r
+00000 , 0183C , 01818 , 01818 , 01818 , 03C18 , 00000 , 00000 , \ I\r
+00000 , 00C1E , 00C0C , 00C0C , 0CCCC , 078CC , 00000 , 00000 , \ J\r
+00000 , 066E6 , 06C66 , 07878 , 0666C , 0E666 , 00000 , 00000 , \ K\r
+00000 , 060F0 , 06060 , 06060 , 06260 , 0FE66 , 00000 , 00000 , \ L\r
+00000 , 0EEC6 , 0FEFE , 0C6D6 , 0C6C6 , 0C6C6 , 00000 , 00000 , \ M\r
+00000 , 0E6C6 , 0FEF6 , 0CEDE , 0C6C6 , 0C6C6 , 00000 , 00000 , \ N\r
+00000 , 0C67C , 0C6C6 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ O\r
+00000 , 066FC , 06666 , 0607C , 06060 , 0F060 , 00000 , 00000 , \ P\r
+00000 , 0C67C , 0C6C6 , 0C6C6 , 0D6C6 , 07CDE , 00E0C , 00000 , \ Q\r
+00000 , 066FC , 06666 , 06C7C , 06666 , 0E666 , 00000 , 00000 , \ R\r
+00000 , 0C67C , 060C6 , 00C38 , 0C606 , 07CC6 , 00000 , 00000 , \ S\r
+00000 , 07E7E , 0185A , 01818 , 01818 , 03C18 , 00000 , 00000 , \ T\r
+00000 , 0C6C6 , 0C6C6 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ U\r
+00000 , 0C6C6 , 0C6C6 , 0C6C6 , 06CC6 , 01038 , 00000 , 00000 , \ V\r
+00000 , 0C6C6 , 0C6C6 , 0D6D6 , 0FED6 , 06CEE , 00000 , 00000 , \ W\r
+00000 , 0C6C6 , 07C6C , 03838 , 06C7C , 0C6C6 , 00000 , 00000 , \ X\r
+00000 , 06666 , 06666 , 0183C , 01818 , 03C18 , 00000 , 00000 , \ Y\r
+00000 , 0C6FE , 00C86 , 03018 , 0C260 , 0FEC6 , 00000 , 00000 , \ Z\r
+00000 , 0303C , 03030 , 03030 , 03030 , 03C30 , 00000 , 00000 , \ [\r
+00000 , 08000 , 0E0C0 , 03870 , 00E1C , 00206 , 00000 , 00000 , \ /\r
+00000 , 00C3C , 00C0C , 00C0C , 00C0C , 03C0C , 00000 , 00000 , \ ]\r
+03810 , 0C66C , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ ^\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 0FF00 , 00000 , \ _\r
+03030 , 00018 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ `\r
+00000 , 00000 , 07800 , 07C0C , 0CCCC , 076CC , 00000 , 00000 , \ a\r
+00000 , 060E0 , 07860 , 0666C , 06666 , 07C66 , 00000 , 00000 , \ b\r
+00000 , 00000 , 07C00 , 0C0C6 , 0C0C0 , 07CC6 , 00000 , 00000 , \ c\r
+00000 , 00C1C , 03C0C , 0CC6C , 0CCCC , 076CC , 00000 , 00000 , \ d\r
+00000 , 00000 , 07C00 , 0FEC6 , 0C0C0 , 07CC6 , 00000 , 00000 , \ e\r
+00000 , 06C38 , 06064 , 060F0 , 06060 , 0F060 , 00000 , 00000 , \ f\r
+00000 , 00000 , 07600 , 0CCCC , 0CCCC , 07CCC , 0CC0C , 00078 , \ g\r
+00000 , 060E0 , 06C60 , 06676 , 06666 , 0E666 , 00000 , 00000 , \ h\r
+00000 , 01818 , 03800 , 01818 , 01818 , 03C18 , 00000 , 00000 , \ i\r
+00000 , 00606 , 00E00 , 00606 , 00606 , 00606 , 06666 , 0003C , \ j\r
+00000 , 060E0 , 06660 , 0786C , 06C78 , 0E666 , 00000 , 00000 , \ k\r
+00000 , 01838 , 01818 , 01818 , 01818 , 03C18 , 00000 , 00000 , \ l\r
+00000 , 00000 , 0EC00 , 0D6FE , 0D6D6 , 0C6D6 , 00000 , 00000 , \ m\r
+00000 , 00000 , 0DC00 , 06666 , 06666 , 06666 , 00000 , 00000 , \ n\r
+00000 , 00000 , 07C00 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ o\r
+00000 , 00000 , 0DC00 , 06666 , 06666 , 07C66 , 06060 , 000F0 , \ p\r
+00000 , 00000 , 07600 , 0CCCC , 0CCCC , 07CCC , 00C0C , 0001E , \ q\r
+00000 , 00000 , 0DC00 , 06676 , 06060 , 0F060 , 00000 , 00000 , \ r\r
+00000 , 00000 , 07C00 , 060C6 , 00C38 , 07CC6 , 00000 , 00000 , \ s\r
+00000 , 03010 , 0FC30 , 03030 , 03030 , 01C36 , 00000 , 00000 , \ t\r
+00000 , 00000 , 0CC00 , 0CCCC , 0CCCC , 076CC , 00000 , 00000 , \ u\r
+00000 , 00000 , 06600 , 06666 , 06666 , 0183C , 00000 , 00000 , \ v\r
+00000 , 00000 , 0C600 , 0D6C6 , 0D6D6 , 06CFE , 00000 , 00000 , \ w\r
+00000 , 00000 , 0C600 , 0386C , 03838 , 0C66C , 00000 , 00000 , \ x\r
+00000 , 00000 , 0C600 , 0C6C6 , 0C6C6 , 07EC6 , 00C06 , 000F8 , \ y\r
+00000 , 00000 , 0FE00 , 018CC , 06030 , 0FEC6 , 00000 , 00000 , \ z\r
+00000 , 0180E , 01818 , 01870 , 01818 , 00E18 , 00000 , 00000 , \ {\r
+00000 , 01818 , 01818 , 00000 , 01818 , 01818 , 00000 , 00000 , \ |\r
+00000 , 01870 , 01818 , 0180E , 01818 , 07018 , 00000 , 00000 , \ }\r
+00000 , 0DC76 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ ~\r
+00000 , 00000 , 03810 , 0C66C , 0C6C6 , 000FE , 00000 , 00000 , \ \7f\r
+\ 00000 , 0663C , 0C0C2 , 0C0C0 , 066C2 , 00C3C , 07C06 , 00000 , \ \80\r
+\ 00000 , 000CC , 0CC00 , 0CCCC , 0CCCC , 076CC , 00000 , 00000 , \ \81\r
+\ 00C00 , 03018 , 07C00 , 0FEC6 , 0C0C0 , 07CC6 , 00000 , 00000 , \ \82\r
+\ 01000 , 06C38 , 07800 , 07C0C , 0CCCC , 076CC , 00000 , 00000 , \ \83\r
+\ 00000 , 000CC , 07800 , 07C0C , 0CCCC , 076CC , 00000 , 00000 , \ \84\r
+\ 06000 , 01830 , 07800 , 07C0C , 0CCCC , 076CC , 00000 , 00000 , \ \85\r
+\ 03800 , 0386C , 07800 , 07C0C , 0CCCC , 076CC , 00000 , 00000 , \ \86\r
+\ 00000 , 00000 , 0663C , 06060 , 03C66 , 0060C , 0003C , 00000 , \ \87\r
+\ 01000 , 06C38 , 07C00 , 0FEC6 , 0C0C0 , 07CC6 , 00000 , 00000 , \ \88\r
+\ 00000 , 000C6 , 07C00 , 0FEC6 , 0C0C0 , 07CC6 , 00000 , 00000 , \ \89\r
+\ 06000 , 01830 , 07C00 , 0FEC6 , 0C0C0 , 07CC6 , 00000 , 00000 , \ \8a\r
+\ 00000 , 00066 , 03800 , 01818 , 01818 , 03C18 , 00000 , 00000 , \ \8b\r
+\ 01800 , 0663C , 03800 , 01818 , 01818 , 03C18 , 00000 , 00000 , \ \8c\r
+\ 06000 , 01830 , 03800 , 01818 , 01818 , 03C18 , 00000 , 00000 , \ \8d\r
+\ 0C600 , 01000 , 06C38 , 0C6C6 , 0C6FE , 0C6C6 , 00000 , 00000 , \ \8e\r
+\ 06C38 , 00038 , 06C38 , 0C6C6 , 0C6FE , 0C6C6 , 00000 , 00000 , \ \8f\r
+\ 03018 , 00060 , 066FE , 07C60 , 06060 , 0FE66 , 00000 , 00000 , \ \90\r
+\ 00000 , 00000 , 0CC00 , 03676 , 0D87E , 06ED8 , 00000 , 00000 , \ \91\r
+\ 00000 , 06C3E , 0CCCC , 0CCFE , 0CCCC , 0CECC , 00000 , 00000 , \ \92\r
+\ 01000 , 06C38 , 07C00 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ \93\r
+\ 00000 , 000C6 , 07C00 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ \94\r
+\ 06000 , 01830 , 07C00 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ \95\r
+\ 03000 , 0CC78 , 0CC00 , 0CCCC , 0CCCC , 076CC , 00000 , 00000 , \ \96\r
+\ 06000 , 01830 , 0CC00 , 0CCCC , 0CCCC , 076CC , 00000 , 00000 , \ \97\r
+\ 00000 , 000C6 , 0C600 , 0C6C6 , 0C6C6 , 07EC6 , 00C06 , 00078 , \ \98\r
+\ 0C600 , 07C00 , 0C6C6 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ \99\r
+\ 0C600 , 0C600 , 0C6C6 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ \9a\r
+\ 01800 , 03C18 , 06066 , 06060 , 03C66 , 01818 , 00000 , 00000 , \ \9b\r
+\ 03800 , 0646C , 0F060 , 06060 , 06060 , 0FCE6 , 00000 , 00000 , \ \9c\r
+\ 00000 , 06666 , 0183C , 0187E , 0187E , 01818 , 00000 , 00000 , \ \9d\r
+\ 0F800 , 0CCCC , 0C4F8 , 0DECC , 0CCCC , 0C6CC , 00000 , 00000 , \ \9e\r
+\ 00E00 , 0181B , 01818 , 0187E , 01818 , 01818 , 070D8 , 00000 , \ \9f\r
+\ 01800 , 06030 , 07800 , 07C0C , 0CCCC , 076CC , 00000 , 00000 , \ \r
+\ 00C00 , 03018 , 03800 , 01818 , 01818 , 03C18 , 00000 , 00000 , \ ¡\r
+\ 01800 , 06030 , 07C00 , 0C6C6 , 0C6C6 , 07CC6 , 00000 , 00000 , \ ¢\r
+\ 01800 , 06030 , 0CC00 , 0CCCC , 0CCCC , 076CC , 00000 , 00000 , \ £\r
+\ 00000 , 0DC76 , 0DC00 , 06666 , 06666 , 06666 , 00000 , 00000 , \ ¤\r
+\ 0DC76 , 0C600 , 0F6E6 , 0DEFE , 0C6CE , 0C6C6 , 00000 , 00000 , \ ¥\r
+\ 03C00 , 06C6C , 0003E , 0007E , 00000 , 00000 , 00000 , 00000 , \ ¦\r
+\ 03800 , 06C6C , 00038 , 0007C , 00000 , 00000 , 00000 , 00000 , \ §\r
+\ 00000 , 03030 , 03000 , 06030 , 0C6C0 , 07CC6 , 00000 , 00000 , \ ¨\r
+\ 00000 , 00000 , 00000 , 0C0FE , 0C0C0 , 000C0 , 00000 , 00000 , \ ©\r
+\ 00000 , 00000 , 00000 , 006FE , 00606 , 00006 , 00000 , 00000 , \ ª\r
+\ 0C000 , 0C2C0 , 0CCC6 , 03018 , 0DC60 , 00C86 , 03E18 , 00000 , \ «\r
+\ 0C000 , 0C2C0 , 0CCC6 , 03018 , 0CE66 , 03E9E , 00606 , 00000 , \ ¬\r
+\ 00000 , 01818 , 01800 , 01818 , 03C3C , 0183C , 00000 , 00000 , \ \r
+\ 00000 , 00000 , 03600 , 0D86C , 0366C , 00000 , 00000 , 00000 , \ ®\r
+\ 00000 , 00000 , 0D800 , 0366C , 0D86C , 00000 , 00000 , 00000 , \ ¯\r
+\ 04411 , 04411 , 04411 , 04411 , 04411 , 04411 , 04411 , 04411 , \ °\r
+\ 0AA55 , 0AA55 , 0AA55 , 0AA55 , 0AA55 , 0AA55 , 0AA55 , 0AA55 , \ ±\r
+\ 077DD , 077DD , 077DD , 077DD , 077DD , 077DD , 077DD , 077DD , \ ²\r
+\ 01818 , 01818 , 01818 , 01818 , 01818 , 01818 , 01818 , 01818 , \ ³\r
+\ 01818 , 01818 , 01818 , 0F818 , 01818 , 01818 , 01818 , 01818 , \ ´\r
+\ 01818 , 01818 , 0F818 , 0F818 , 01818 , 01818 , 01818 , 01818 , \ µ\r
+\ 03636 , 03636 , 03636 , 0F636 , 03636 , 03636 , 03636 , 03636 , \ ¶\r
+\ 00000 , 00000 , 00000 , 0FE00 , 03636 , 03636 , 03636 , 03636 , \ ·\r
+\ 00000 , 00000 , 0F800 , 0F818 , 01818 , 01818 , 01818 , 01818 , \ ¸\r
+\ 03636 , 03636 , 0F636 , 0F606 , 03636 , 03636 , 03636 , 03636 , \ ¹\r
+\ 03636 , 03636 , 03636 , 03636 , 03636 , 03636 , 03636 , 03636 , \ º\r
+\ 00000 , 00000 , 0FE00 , 0F606 , 03636 , 03636 , 03636 , 03636 , \ »\r
+\ 03636 , 03636 , 0F636 , 0FE06 , 00000 , 00000 , 00000 , 00000 , \ ¼\r
+\ 03636 , 03636 , 03636 , 0FE36 , 00000 , 00000 , 00000 , 00000 , \ ½\r
+\ 01818 , 01818 , 0F818 , 0F818 , 00000 , 00000 , 00000 , 00000 , \ ¾\r
+\ 00000 , 00000 , 00000 , 0F800 , 01818 , 01818 , 01818 , 01818 , \ ¿\r
+\ 01818 , 01818 , 01818 , 01F18 , 00000 , 00000 , 00000 , 00000 , \ À\r
+\ 01818 , 01818 , 01818 , 0FF18 , 00000 , 00000 , 00000 , 00000 , \ Á\r
+\ 00000 , 00000 , 00000 , 0FF00 , 01818 , 01818 , 01818 , 01818 , \ Â\r
+\ 01818 , 01818 , 01818 , 01F18 , 01818 , 01818 , 01818 , 01818 , \ Ã\r
+\ 00000 , 00000 , 00000 , 0FF00 , 00000 , 00000 , 00000 , 00000 , \ Ä\r
+\ 01818 , 01818 , 01818 , 0FF18 , 01818 , 01818 , 01818 , 01818 , \ Å\r
+\ 01818 , 01818 , 01F18 , 01F18 , 01818 , 01818 , 01818 , 01818 , \ Æ\r
+\ 03636 , 03636 , 03636 , 03736 , 03636 , 03636 , 03636 , 03636 , \ Ç\r
+\ 03636 , 03636 , 03736 , 03F30 , 00000 , 00000 , 00000 , 00000 , \ È\r
+\ 00000 , 00000 , 03F00 , 03730 , 03636 , 03636 , 03636 , 03636 , \ É\r
+\ 03636 , 03636 , 0F736 , 0FF00 , 00000 , 00000 , 00000 , 00000 , \ Ê\r
+\ 00000 , 00000 , 0FF00 , 0F700 , 03636 , 03636 , 03636 , 03636 , \ Ë\r
+\ 03636 , 03636 , 03736 , 03730 , 03636 , 03636 , 03636 , 03636 , \ Ì\r
+\ 00000 , 00000 , 0FF00 , 0FF00 , 00000 , 00000 , 00000 , 00000 , \ Í\r
+\ 03636 , 03636 , 0F736 , 0F700 , 03636 , 03636 , 03636 , 03636 , \ Î\r
+\ 01818 , 01818 , 0FF18 , 0FF00 , 00000 , 00000 , 00000 , 00000 , \ Ï\r
+\ 03636 , 03636 , 03636 , 0FF36 , 00000 , 00000 , 00000 , 00000 , \ Ð\r
+\ 00000 , 00000 , 0FF00 , 0FF00 , 01818 , 01818 , 01818 , 01818 , \ Ñ\r
+\ 00000 , 00000 , 00000 , 0FF00 , 03636 , 03636 , 03636 , 03636 , \ Ò\r
+\ 03636 , 03636 , 03636 , 03F36 , 00000 , 00000 , 00000 , 00000 , \ Ó\r
+\ 01818 , 01818 , 01F18 , 01F18 , 00000 , 00000 , 00000 , 00000 , \ Ô\r
+\ 00000 , 00000 , 01F00 , 01F18 , 01818 , 01818 , 01818 , 01818 , \ Õ\r
+\ 00000 , 00000 , 00000 , 03F00 , 03636 , 03636 , 03636 , 03636 , \ Ö\r
+\ 03636 , 03636 , 03636 , 0FF36 , 03636 , 03636 , 03636 , 03636 , \ ×\r
+\ 01818 , 01818 , 0FF18 , 0FF18 , 01818 , 01818 , 01818 , 01818 , \ Ø\r
+\ 01818 , 01818 , 01818 , 0F818 , 00000 , 00000 , 00000 , 00000 , \ Ù\r
+\ 00000 , 00000 , 00000 , 01F00 , 01818 , 01818 , 01818 , 01818 , \ Ú\r
+\ 0FFFF , 0FFFF , 0FFFF , 0FFFF , 0FFFF , 0FFFF , 0FFFF , 0FFFF , \ Û\r
+\ 00000 , 00000 , 00000 , 0FF00 , 0FFFF , 0FFFF , 0FFFF , 0FFFF , \ Ü\r
+\ 0F0F0 , 0F0F0 , 0F0F0 , 0F0F0 , 0F0F0 , 0F0F0 , 0F0F0 , 0F0F0 , \ Ý\r
+\ 00F0F , 00F0F , 00F0F , 00F0F , 00F0F , 00F0F , 00F0F , 00F0F , \ Þ\r
+\ 0FFFF , 0FFFF , 0FFFF , 000FF , 00000 , 00000 , 00000 , 00000 , \ ß\r
+\ 00000 , 00000 , 07600 , 0D8DC , 0D8D8 , 076DC , 00000 , 00000 , \ à\r
+\ 00000 , 0CC78 , 0CCCC , 0CCD8 , 0C6C6 , 0CCC6 , 00000 , 00000 , \ á\r
+\ 00000 , 0C6FE , 0C0C6 , 0C0C0 , 0C0C0 , 0C0C0 , 00000 , 00000 , \ â\r
+\ 00000 , 00000 , 06CFE , 06C6C , 06C6C , 06C6C , 00000 , 00000 , \ ã\r
+\ 00000 , 0FE00 , 060C6 , 01830 , 06030 , 0FEC6 , 00000 , 00000 , \ ä\r
+\ 00000 , 00000 , 07E00 , 0D8D8 , 0D8D8 , 070D8 , 00000 , 00000 , \ å\r
+\ 00000 , 00000 , 06666 , 06666 , 07C66 , 06060 , 000C0 , 00000 , \ æ\r
+\ 00000 , 00000 , 0DC76 , 01818 , 01818 , 01818 , 00000 , 00000 , \ ç\r
+\ 00000 , 07E00 , 03C18 , 06666 , 03C66 , 07E18 , 00000 , 00000 , \ è\r
+\ 00000 , 03800 , 0C66C , 0FEC6 , 0C6C6 , 0386C , 00000 , 00000 , \ é\r
+\ 00000 , 06C38 , 0C6C6 , 06CC6 , 06C6C , 0EE6C , 00000 , 00000 , \ ê\r
+\ 00000 , 0301E , 00C18 , 0663E , 06666 , 03C66 , 00000 , 00000 , \ ë\r
+\ 00000 , 00000 , 07E00 , 0DBDB , 07EDB , 00000 , 00000 , 00000 , \ ì\r
+\ 00000 , 00300 , 07E06 , 0DBDB , 07EF3 , 0C060 , 00000 , 00000 , \ í\r
+\ 00000 , 0301C , 06060 , 0607C , 06060 , 01C30 , 00000 , 00000 , \ î\r
+\ 00000 , 07C00 , 0C6C6 , 0C6C6 , 0C6C6 , 0C6C6 , 00000 , 00000 , \ ï\r
+\ 00000 , 00000 , 000FE , 0FE00 , 00000 , 000FE , 00000 , 00000 , \ ð\r
+\ 00000 , 00000 , 01818 , 0187E , 00018 , 0FF00 , 00000 , 00000 , \ ñ\r
+\ 00000 , 03000 , 00C18 , 00C06 , 03018 , 07E00 , 00000 , 00000 , \ ò\r
+\ 00000 , 00C00 , 03018 , 03060 , 00C18 , 07E00 , 00000 , 00000 , \ ó\r
+\ 00000 , 01B0E , 0181B , 01818 , 01818 , 01818 , 01818 , 01818 , \ ô\r
+\ 01818 , 01818 , 01818 , 01818 , 0D8D8 , 070D8 , 00000 , 00000 , \ õ\r
+\ 00000 , 00000 , 01818 , 07E00 , 01800 , 00018 , 00000 , 00000 , \ ö\r
+\ 00000 , 00000 , 07600 , 000DC , 0DC76 , 00000 , 00000 , 00000 , \ ÷\r
+\ 03800 , 06C6C , 00038 , 00000 , 00000 , 00000 , 00000 , 00000 , \ ø\r
+\ 00000 , 00000 , 00000 , 01800 , 00018 , 00000 , 00000 , 00000 , \ \r
+\ 00000 , 00000 , 00000 , 00000 , 00018 , 00000 , 00000 , 00000 , \ ú\r
+\ 00F00 , 00C0C , 00C0C , 0EC0C , 06C6C , 01C3C , 00000 , 00000 , \ û\r
+\ 0D800 , 06C6C , 06C6C , 0006C , 00000 , 00000 , 00000 , 00000 , \ ü\r
+\ 07000 , 030D8 , 0C860 , 000F8 , 00000 , 00000 , 00000 , 00000 , \ ý\r
+\ 00000 , 00000 , 07E7E , 07E7E , 07E7E , 0007E , 00000 , 00000 , \ þ\r
+\ 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ 0FFh\r
+\r
+CR .( Loading Korean fonts)\r
+CREATE Á¡¬÷\8bi\8d© \ 16x16, 21 ¸a\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ À\81¶\91\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0807F , 08021 , 08001 , 08001 , 00001 , 00000 , 00000 , \ \88A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 080FF , 08019 , 08019 , 08019 , 00011 , 00000 , 00000 , \ \8cA\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 000C0 , 00060 , 00060 , 00061 , 0803F , 00000 , 00000 , \ \90A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0807F , 00060 , 00060 , 00060 , 0803F , 00000 , 00000 , \ \94A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 080FF , 000CC , 000CC , 000CC , 0807F , 00000 , 00000 , \ \98A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0807F , 08001 , 0007F , 00060 , 0803F , 00000 , 00000 , \ \9cA\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0807F , 08031 , 08031 , 00031 , 0803F , 00000 , 00000 , \ A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+08003 , 080E1 , 08061 , 0807F , 08061 , 0807F , 00040 , 00000 , \ ¤A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+08003 , 080ED , 0806D , 0807F , 0806D , 0807F , 00040 , 00000 , \ ¨A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+0001C , 0000C , 0000C , 0001E , 00073 , 080C1 , 00000 , 00000 , \ ¬A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 00036 , 00036 , 0007F , 080D9 , 08098 , 00000 , 00000 , \ °A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0001F , 08031 , 08020 , 08031 , 0001F , 00000 , 00000 , \ ´A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0807F , 0000C , 0001E , 00033 , 08061 , 00000 , 00000 , \ ¸A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 080FF , 00036 , 0003E , 0806F , 080D9 , 00000 , 00000 , \ ¼A\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+0000C , 0807F , 0000C , 0001E , 00033 , 08061 , 00000 , 00000 , \ ÀA\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0807F , 08021 , 08003 , 0803D , 00001 , 00000 , 00000 , \ ÄA\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 080FF , 00060 , 0007F , 00060 , 0803F , 00000 , 00000 , \ ÈA\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 0807F , 00023 , 00033 , 0001A , 0807F , 00000 , 00000 , \ ÌA\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+0001C , 080FF , 0003E , 00063 , 00063 , 0003E , 00000 , 00000 , \ ÐA\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+\r
+CREATE º\97¬÷\8bi\8d© \ 16x16, 30 ¸a\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ À\81¶\91\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+03800 , 01800 , 01800 , 01800 , 01E00 , 01800 , 01800 , 01800 , \ \84a\r
+01800 , 01800 , 01000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00E00 , 07600 , 03600 , 03600 , 03E00 , 03600 , 03600 , 03600 , \ \84\81\r
+03600 , 02600 , 00400 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+03800 , 01800 , 01800 , 01E00 , 01800 , 01E00 , 01800 , 01800 , \ \84¡\r
+01800 , 01800 , 01000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00E00 , 03600 , 03600 , 03E00 , 03600 , 03E00 , 03600 , 03600 , \ \84Á\r
+03600 , 02600 , 00400 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+01C00 , 00C00 , 00C00 , 03C00 , 00C00 , 00C00 , 00C00 , 00C00 , \ \84á\r
+00C00 , 00C00 , 00800 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+00700 , 01B00 , 01B00 , 07B00 , 01B00 , 01B00 , 01B00 , 01B00 , \ \85A\r
+01B00 , 01300 , 00200 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+01C00 , 00C00 , 03C00 , 00C00 , 03C00 , 00C00 , 00C00 , 00C00 , \ \85a\r
+00C00 , 00C00 , 00800 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00700 , 01B00 , 07B00 , 01B00 , 07B00 , 01B00 , 01B00 , 01B00 , \ \85\81\r
+01B00 , 01300 , 00200 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 0000C , 0000C , \ \85¡\r
+0C0FF , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+03800 , 01800 , 01800 , 01800 , 01800 , 01800 , 01E0C , 0180C , \ \85Á\r
+0D8FF , 01800 , 01000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00E00 , 03600 , 03600 , 03600 , 03E00 , 03600 , 0360C , 0360C , \ \85á\r
+0B6FF , 02600 , 00400 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+03800 , 01800 , 01800 , 01800 , 01800 , 01800 , 0180C , 0180C , \ \86A\r
+0D8FF , 01800 , 01000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00036 , 00036 , \ \86a\r
+0C0FF , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 0E0FF , \ \86\81\r
+0000C , 0000C , 00008 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+01C00 , 00C00 , 00C00 , 03C00 , 00C00 , 00C00 , 00C00 , 0ECFF , \ \86¡\r
+00C06 , 00C0C , 00800 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00700 , 01B00 , 01B00 , 07B00 , 01B00 , 01B00 , 01B00 , 0DBFF , \ \86Á\r
+01B0C , 01318 , 00200 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+03800 , 01800 , 01800 , 01800 , 01800 , 01800 , 01800 , 0D8FF , \ \86á\r
+0180C , 01818 , 01000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 0F0FF , \ \87A\r
+00033 , 00033 , 00022 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 02000 , \ \87a\r
+0F0FF , 00040 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+03800 , 01800 , 01800 , 01800 , 01800 , 01800 , 01800 , 01800 , \ \87\81\r
+0D8FF , 01000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+03800 , 01800 , 01800 , 01800 , 01800 , 01800 , 01800 , 01800 , \ \87¡\r
+01800 , 01000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+\r
+CREATE ¤hñ\8bi\8d© \ 16x16, 30 ¸a\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ À\81¶\91\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84B\r
+00000 , 00000 , 0C03F , 0C010 , 0C000 , 0C000 , 08000 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84C\r
+00000 , 00000 , 0E07D , 0600C , 0600C , 0600C , 0C018 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84D\r
+00000 , 00000 , 0C07C , 0C00C , 0E00D , 0300F , 0101A , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84E\r
+00000 , 00000 , 00060 , 00030 , 00030 , 00030 , 0C01F , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84F\r
+00000 , 00000 , 0E063 , 08030 , 0C031 , 06033 , 0201E , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84G\r
+00000 , 00000 , 0C060 , 0F033 , 0E031 , 03033 , 0E01D , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84H\r
+00000 , 00000 , 0C07F , 00030 , 00030 , 00030 , 0C01F , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84I\r
+00000 , 00000 , 0C03F , 0C000 , 0C03F , 00030 , 0C01F , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84J\r
+00000 , 00000 , 0E07F , 0600C , 0607C , 06060 , 0C03C , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84K\r
+00000 , 00000 , 0E07F , 0600F , 0607B , 04063 , 0E03D , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84L\r
+00000 , 00000 , 0607F , 0600F , 0E07B , 06063 , 0E03D , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84M\r
+00000 , 00000 , 0C07C , 0C00C , 0E07D , 03063 , 0103E , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84N\r
+00000 , 00000 , 0F07D , 0800D , 0E07D , 08061 , 0F03C , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84O\r
+00000 , 00000 , 0F07D , 0A00C , 0A07C , 0A060 , 0F03D , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84P\r
+00000 , 00000 , 0C07C , 0F00F , 0E07D , 03063 , 0E03D , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84Q\r
+00000 , 00000 , 0C03F , 0C018 , 0C018 , 08018 , 0C01F , 00000 ,\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , \ ³a»¡ ´g·q\r
+05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA , 05555 , 0AAAA ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84S\r
+00000 , 00000 , 08073 , 08031 , 0803F , 08031 , 0801F , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84T\r
+00000 , 00000 , 0C06C , 0C06C , 0E07D , 0306F , 0107A , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84U\r
+00000 , 00000 , 00006 , 00006 , 0000F , 08019 , 0C070 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84V\r
+00000 , 00000 , 0C018 , 0C018 , 0E03D , 03067 , 018C3 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84W\r
+00000 , 00000 , 0001F , 08031 , 08020 , 08031 , 0001F , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84X\r
+00000 , 00000 , 00000 , 0807F , 0001E , 08037 , 0C061 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84Y\r
+00000 , 00000 , 00006 , 00003 , 0E03F , 0800D , 0E038 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84Z\r
+00000 , 00000 , 0C03F , 0C000 , 0C01F , 0C000 , 08001 , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84[\r
+00000 , 00000 , 0C07F , 00030 , 0803F , 00030 , 0C01F , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84\\r
+00000 , 00000 , 0E03F , 08011 , 08019 , 00009 , 0E03F , 00000 ,\r
+00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , 00000 , \ \84]\r
+00000 , 00000 , 00003 , 0E01F , 0C00F , 06018 , 0C00F , 00000 ,\r
+\r
+\\r
+\ Ðe\8bi Â\89\9db \90{ i\r
+\\r
+CR .( Loading character output words)\r
+\r
+DECIMAL 80 CONSTANT MAX-X\r
+VARIABLE VIR_X\r
+VARIABLE VIR_Y\r
+\r
+HEX\r
+: BINARY 2 BASE ! ;\r
+: 16* ( n -- 16*n ) 2* 2* 2* 2* ;\r
+: \96õ®A= ( char -- 0|-1 ) DUP 08 = OVER 07F = OR SWAP 0FF = OR ;\r
+\r
+CODE INT10 ( AX -- AX )\r
+ BX AX MOV, \ BX\88a \94ᣡ·\81 \85 ¶á \88t·³\93¡\94a.\r
+ 10 INT, \ AH = 0\r
+ AX BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+: GET-MODE ( -- mode )\r
+ 0F00 INT10 0FF AND ;\r
+\r
+3 VALUE OldMode#\r
+\r
+: SET-MODE ( mode -- ) INT10 DROP ;\r
+\r
+: VGA? ( -- flag ) 1A00 INT10 0FF AND 1A = ;\r
+\r
+0 VALUE GRAPHIC?\r
+3 VALUE textmode#\r
+\r
+\ for VGA graphics card\r
+DECIMAL 30 VALUE MAX-Y \ 640X480 Ð\81¬w\95¡; 480 / 16 = 30 º\89\r
+HEX\r
+\r
+: VGA-SET-GRAPHIC ( -- ) 11 SET-MODE -1 TO GRAPHIC? ;\r
+\r
+\ VGA §¡\97¡µ¡ ¡A¡¡\9f¡·\81 \88b º\89µA \94\81Ðe A\8ba åËa º\81¡·\81 Îa\9fi e\97k\r
+\ Y ¹ÁÎa\9d¡ ·¡ A\8ba åËa \88t·i ´è·a¡e X ¹ÁÎa\9fi ¤a\9d¡\r
+\ µ¡ÏaU º\81¡\9d¡ ³i ®\81 ·¶·s\93¡\94a.\r
+CREATE VGA-Y>SegTable MAX-Y 16* CELLS ALLOT\r
+\r
+MARKER ~TEMP\r
+:NONAME\r
+ MAX-Y 16* 0 DO 0A000 I 5 * + VGA-Y>SegTable I CELLS + ! LOOP ;\r
+EXECUTE\r
+~TEMP \ Îa\9fi À\81¶\81\89¡ ¶á \90{ i·i »¡¶\91\r
+\r
+\ for Hercules monochrome grahics card\r
+DECIMAL 25 TO MAX-Y \ 640X400 Ð\81¬w\95¡; 400 / 16 = 25 º\89\r
+HEX\r
+\r
+CREATE 6854REGS \ 640X400 Ð\81¬w\95¡µA Ï©¶aÐe 6845 \9dA»¡¯aÈá Á¡\8b¡\88t\r
+31 C, 28 C, 29 C, 08 C, 68 C, 02 C, 64 C, 65 C, 02 C, 03 C,\r
+\r
+: HERC? ( -- flag )\r
+ 03B5 PC@ 4F DUP 03B5 PC! 100 0 DO LOOP\r
+ 03B5 PC@ ROT 03B5 PC! = IF\r
+ 03BA PC@ 80 AND\r
+ 8000 0 DO 03BA PC@ 80 AND OVER <> IF UNLOOP DROP TRUE EXIT THEN LOOP\r
+ THEN FALSE ;\r
+\r
+: HERC-SET-GRAPHIC ( -- )\r
+ 0A 0 DO I 03B4 PC! 6854REGS I + C@ 03B5 PC! LOOP\r
+ 1 03BF PC! \ \8ba\9c\81Ï¢ ¡¡\97a\9fi Ðá¶w, \8ba\9c\81Ï¢ ÍA·¡»¡ 1 ·e ¬a¶w ¦\89\88a\93w\r
+ [ BINARY ] 00001010 [ HEX ]\r
+ 03B8 PC! \ \8ba\9c\81Ï¢ ÍA·¡»¡ 0 ·i \8ba\9c\81Ï¢ ¡¡\97a\9d¡ Îa¯¡\r
+ -1 TO GRAPHIC? ;\r
+\r
+\ ÐáÇI\9dA¯a §¡\97¡µ¡ ¡A¡¡\9f¡·\81 \88b º\89µA \94\81Ðe A\8ba åËa º\81¡·\81 Îa\9fi e\97k\r
+\ \8ba\9c\81Ï¢ ÍA·¡»¡ 1·e 0B000:0hµA¬á ¯¡¸b\r
+\ Y ¹ÁÎa\9d¡ ·¡ A\8ba åËa \88t·i ´è·a¡e X ¹ÁÎa\9fi ¤a\9d¡\r
+\ µ¡ÏaU º\81¡\9d¡ ³i ®\81 ·¶·s\93¡\94a.\r
+CREATE HERC-Y>SegTable MAX-Y 16* CELLS ALLOT\r
+\r
+MARKER ~TEMP\r
+:NONAME\r
+ MAX-Y 16* 0 DO 0B000 I 4 MOD 200 * + I 4 / 5 * +\r
+ HERC-Y>SegTable I CELLS + ! LOOP ;\r
+EXECUTE\r
+~TEMP \ Îa\9fi À\81¶\81\89¡ ¶á \90{ i·i »¡¶\91\r
+\r
+VARIABLE Y>SegTable\r
+: Y>SEG ( y -- segment_addr )\r
+ CELLS Y>SegTable @ + @ ;\r
+\r
+' VGA-SET-GRAPHIC VALUE 'SET-GRAPHIC\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+: SET-GRAPHIC ( -- ) 'SET-GRAPHIC EXECUTE ;\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+DECIMAL\r
+\r
+\ ÉB¯aËa Y ¹ÁÎa·\81 ÑÁ¡eµA Îa¯¡\96E ¢\85¸a\97i·i ¤a\9d¡ ¶á º\89\9d¡ µ«\8b±\r
+\ \8ba\9c\81Ï¢ ¹ÁÎa\9d¡\93e 16y ¦\81Èá 16 \88a\9d¡º\89·i \88b\88b 16 º\89 ¶á\9d¡ µ«\8b±\r
+\ : UP-LINE\r
+\ 16* DUP 16 - DO\r
+\ I 16 + Y>SEG I Y>SEG\r
+\ 40 0 DO OVER I 2* L@ OVER I 2* L! LOOP 2DROP\r
+\ LOOP ;\r
+\r
+CODE UP-LINE ( y -- )\r
+ SI PUSH,\r
+ BX DEC,\r
+ 5 # CL MOV,\r
+ BX CL SHL, \ BX = (VIR_Y@-1)@ * 32\r
+ Y>SegTable ) BX ADD,\r
+ 16 # DX MOV,\r
+1 L:\r
+ SI SI XOR,\r
+ DI DI XOR,\r
+ SS: 0 [BX] ES MOV,\r
+ SS: 32 [BX] DS MOV,\r
+ 40 # CX MOV,\r
+ REPE, WORD MOVS,\r
+ 2 # BX ADD,\r
+ DX DEC,\r
+ 1 L# JNE,\r
+ SS AX MOV,\r
+ AX DS MOV,\r
+ SI POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ ÉB¯aËa Y ¹ÁÎa·\81 º\89·i »¡¶\91\r
+\ : CLEAR-LINE\r
+\ 16* DUP 16 + SWAP\r
+\ DO I Y>SEG\r
+\ 40 0 DO 0 OVER I 2* L! LOOP DROP\r
+\ LOOP ;\r
+\r
+CODE CLEAR-LINE ( y -- )\r
+ 5 # CL MOV,\r
+ BX CL SHL, \ BX = VIR_Y@ * 32\r
+ Y>SegTable ) BX ADD,\r
+ AX AX XOR,\r
+ 16 # DX MOV,\r
+1 L:\r
+ 0 [BX] ES MOV,\r
+ DI DI XOR,\r
+ 40 # CX MOV,\r
+ REPE,\r
+ WORD STOS,\r
+ 2 # BX ADD,\r
+ DX DEC,\r
+ 1 L# JNE,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+HEX\r
+VARIABLE VSCR0\r
+VARIABLE YY\r
+VARIABLE XX\r
+1000 CONSTANT VSCREEN-SIZE\r
+0FFF CONSTANT VSCR-MASK\r
+CREATE VSCREEN VSCREEN-SIZE CHARS ALLOT\r
+: >VSCR-ADDR ( offset -- c_addr )\r
+ VSCR0 @ + VSCR-MASK AND VSCREEN + ;\r
+\r
+DECIMAL\r
+\r
+\ : EFONT! ( x y char -- )\r
+\ 16* ENGFONT + \ x y font-addr\r
+\ SWAP 16* \ x font-addr 16y\r
+\ 16 0 DO OVER I + C@ OVER I + Y>SEG 4 PICK LC! LOOP DROP 2DROP ;\r
+\r
+CODE EFONT! ( x y char -- )\r
+ SI DX MOV, \ MOV DX,SI\r
+ BX SI MOV, \ MOV SI,BX\r
+ BX POP, \ POP BX\r
+ DI POP, \ POP DI\r
+ 4 # CL MOV, \ MOV CL,#4\r
+ SI CL SHL, \ SHL SI,CL\r
+ ENGFONT # SI ADD, \ ADD SI,ENGFONT ; SI = font-addr\r
+ CL INC, \ INC CL ; CL = 5\r
+ BX CL SHL, \ SHL BX,CL ; BX = VIR_Y@ * 32\r
+ Y>SegTable ) BX ADD,\r
+ 2 # CX MOV,\r
+ 15\r
+ 0 [BX] ES MOV, BYTE LODS, ES: AL 0 [DI] MOV, CX BX ADD, 1- ?DUP [IF] 0 >IN ! [THEN]\r
+ 0 [BX] ES MOV, BYTE LODS, ES: AL 0 [DI] MOV,\r
+ DX SI MOV,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+BINARY\r
+00001 CONSTANT À\81¶\91Á¡¬÷\r
+00010 CONSTANT À\81¶\91º\97¬÷\r
+00001 CONSTANT À\81¶\91¤hñ\r
+1000010001000001 CONSTANT À\81¶\91¸a \ Á¡¬÷, º\97¬÷, ¤hñ ¡¡\96\81 À\81¶\91¸a\r
+0111110000000000 CONSTANT Á¡¬÷¥¥\r
+0000001111100000 CONSTANT º\97¬÷¥¥\r
+0000000000011111 CONSTANT ¤hñ¥¥\r
+1000001111111111 CONSTANT Á¡¬÷»¡¶\91¥¥\r
+1111110000011111 CONSTANT º\97¬÷»¡¶\91¥¥\r
+1111111111100000 CONSTANT ¤hñ»¡¶\91¥¥\r
+DECIMAL\r
+\r
+VARIABLE HCHAR\r
+\r
+\ VARIABLE H1FONT\r
+\ VARIABLE H2FONT\r
+\ VARIABLE H3FONT\r
+\\r
+\ : HFONT! ( x y 16_bit_hangul_code -- )\r
+\ DUP [ BINARY ] 0111110000000000 AND [ DECIMAL ] \ Àõ¸a\r
+\ 5 RSHIFT ( == 10 RSHIFT 16* 2* ) Á¡¬÷\8bi\8d© + H1FONT !\r
+\ \ \8bi\8d© º\81¡, Ðe\8bi·e Í¢·¡ 2 ¤a·¡Ëa\r
+\ DUP [ BINARY ] 0000001111100000 AND [ DECIMAL ] \ \88a¶\85\95A¸a\r
+\ ( 5 RSHIFT 16* 2* == noop ) º\97¬÷\8bi\8d© + H2FONT !\r
+\ [ BINARY ] 0000000000011111 AND [ DECIMAL ] \ ¤hñ\r
+\ 16* 2* ¤hñ\8bi\8d© + H3FONT !\r
+\ 16*\r
+\ 16 0 DO H1FONT @ @\r
+\ H2FONT @ @ OR\r
+\ H3FONT @ @ OR\r
+\ OVER I + Y>SEG 3 PICK L!\r
+\ 2 H1FONT +! 2 H2FONT +! 2 H3FONT +!\r
+\ LOOP 2DROP ;\r
+\r
+CODE HFONT! ( x y 16_bit_hangul_code -- )\r
+ BX DI MOV,\r
+ BX POP,\r
+ DX POP,\r
+ BP PUSH,\r
+ SI PUSH,\r
+ DI SI MOV,\r
+ DI BP MOV,\r
+ Á¡¬÷¥¥ # SI AND,\r
+ º\97¬÷¥¥ # DI AND,\r
+ ¤hñ¥¥ # BP AND,\r
+ 5 # CL MOV,\r
+ SI CL SHR,\r
+ Á¡¬÷\8bi\8d© # SI ADD, \ SI = Àõ¸a \8bi\8d©\r
+ º\97¬÷\8bi\8d© # DI ADD, \ DI = \88a¶\85\95A¸a \8bi\8d©\r
+ BP CL SHL,\r
+ ¤hñ\8bi\8d© # BP ADD, \ BP = ¤hñ \8bi\8d©\r
+ BX CL SHL, \ BX = VIR_Y@ * 32\r
+ Y>SegTable ) BX ADD,\r
+ 2 # CX MOV,\r
+ 15\r
+ WORD LODS, 0 [DI] AX OR, 0 [BP] AX OR, 0 [BX] ES MOV, BX DX XCHG, ES: AX 0 [BX] MOV, BX DX XCHG, CX DI ADD, CX BX ADD, CX BP ADD, 1- ?DUP [IF] 0 >IN ! [THEN]\r
+ WORD LODS, 0 [DI] AX OR, 0 [BP] AX OR, 0 [BX] ES MOV, BX DX XCHG, ES: AX 0 [BX] MOV,\r
+ SI POP,\r
+ BP POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+: xySTR! ( x y c_addr u -- )\r
+ BEGIN >R >R 2DUP R@ C@\r
+ DUP 128 < IF EFONT!\r
+ ELSE 8 LSHIFT R> CHAR+ DUP >R C@ OR HFONT! SWAP 1+ SWAP\r
+ THEN\r
+ SWAP 1+ SWAP R> CHAR+ R> 1- DUP 0=\r
+ UNTIL 2DROP 2DROP ;\r
+\r
+DECIMAL 30 TO MAX-Y\r
+\r
+CREATE MAX-X*Table MAX-Y 1+ CELLS ALLOT\r
+MARKER ~TEMP\r
+:NONAME MAX-Y 1+ 0 DO I MAX-X * MAX-X*Table I CELLS + ! LOOP ; EXECUTE\r
+~TEMP\r
+: MAX-X* ( y -- MAX_X*y ) CELLS MAX-X*Table + @ ;\r
+\r
+HEX\r
+: SHOW-LINE ( y -- ) \ \88a¬wÑÁ¡e·\81 y º\89·i \8ba\9c\81Ï¢ ÑÁ¡eµA Îa¯¡\r
+ >R 1 MAX-X* 0 \ max-x 0 R: y\r
+ BEGIN\r
+ DUP R@ OVER >VSCR-ADDR DUP C@ \ max-x x x 0 c_addr char\r
+ DUP 80 < IF NIP EFONT!\r
+ ELSE 8 LSHIFT\r
+ SWAP CHAR+ C@ OR HFONT! CHAR+ THEN\r
+ CHAR+ 2DUP =\r
+ UNTIL 2DROP R> DROP ;\r
+\r
+0 VALUE YTop\r
+\r
+: SCROLL ( -- )\r
+ MAX-Y MAX-X* DUP MAX-X + SWAP\r
+ DO BL I >VSCR-ADDR C! LOOP\r
+ MAX-Y 1- MAX-X 0 DO I OVER BL EFONT! LOOP DROP\r
+ VSCR0 @ MAX-X + VSCR-MASK AND VSCR0 !\r
+ YTop SHOW-LINE\r
+ 0 XX ! YTop YY ! ;\r
+\r
+: VIR_X+! ( n -- )\r
+ VIR_X @ + MAX-X /MOD VIR_Y +! VIR_X !\r
+ VIR_Y @ MAX-Y = IF SCROLL -1 VIR_Y +! THEN ;\r
+\r
+: VSCR! ( char -- ) VIR_Y @ MAX-X* VIR_X @ + >VSCR-ADDR C! ;\r
+\r
+: multiEMIT ( char -- )\r
+ DUP \96õ®A= IF DROP VIR_X @ VIR_Y @ BL EFONT! -1 VIR_X +! BL VSCR! EXIT THEN\r
+ DUP 0D ( CR) = IF DROP 0 VIR_X ! EXIT THEN\r
+ DUP 0A ( LF) = IF DROP VIR_Y @ 1+ MAX-Y < IF 1 VIR_Y +! EXIT THEN\r
+ SCROLL EXIT THEN\r
+ VSCR! 1 VIR_X+! ;\r
+\r
+: HEMIT ( char -- )\r
+ HCHAR @ 0= IF \ ¬\81\9d¡ ¯¡¸bÐa\93e \8bi¸a\r
+ DUP 80 < IF multiEMIT EXIT THEN \ Ðe\8bi·¡ ´a\93¡¡e \8ba\94\81\9d¡ Â\89\9db\r
+ VIR_X @ 1+ MAX-X = IF VIR_X @ multiEMIT BL multiEMIT THEN\r
+ HCHAR ! EXIT \ Àõ 8 §¡Ëa ¤e¸a\9fi \88i¢\81\9f¡\r
+ THEN\r
+ HCHAR @ multiEMIT multiEMIT 0 HCHAR ! ;\r
+\r
+\\r
+\ Ðe\8bi ·³\9db \90{ i\97i\r
+\\r
+\r
+CR .( Loading character input words)\r
+\r
+CODE INT16h\r
+ BX AX MOV,\r
+ 16 INT,\r
+ AX BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ a»¡ b \8bi®A ·³\9db \98\81 ¶E½¢ ¶õ\8bi®A\88a \92\89\9dv·a¡e Àq, ´a\93¡¡e \88ỵ\r
+: ¶E½¢¶õ®A\92\89\9f±? ( -- flag )\r
+ 200 INT16h [ BINARY ] 00000010 [ HEX ] AND 0= 0= ;\r
+\r
+\ a»¡ b \8bi®A ·³\9db \98\81 CapsLock ¬wÈ\81µv·a¡e Àq, ´a\93¡¡e \88ỵ\r
+: CapsLock? ( -- flag )\r
+ 200 INT16h [ BINARY ] 01000000 [ HEX ] AND 0= 0= ;\r
+\r
+VARIABLE \8bi®A·³\9db¬wÈ\81\r
+VARIABLE \8bi®AÉ·\r
+VARIABLE £¡µÅ¬÷¸a\r
+CREATE \8bi®A·³\9db¬wÈ\81\8b¡´â 8 CELLS ALLOT\r
+CREATE £¡µÅ¬÷¸a\8b¡´â 8 CELLS ALLOT\r
+VARIABLE ¼\81·³\9db¬wÈ\81\r
+VARIABLE ¼\81£¡µÅ¬÷¸a\r
+: ´|¸a\8b¡´â ( -- )\r
+ £¡µÅ¬÷¸a @ ¼\81£¡µÅ¬÷¸a @ 7 AND CELLS £¡µÅ¬÷¸a\8b¡´â + !\r
+ 1 ¼\81£¡µÅ¬÷¸a +! ;\r
+: ¬wÈ\81\8b¡´â ( ¬wÈ\81 -- )\r
+ ¼\81·³\9db¬wÈ\81 @ 7 AND CELLS \8bi®A·³\9db¬wÈ\81\8b¡´â + !\r
+ 1 ¼\81·³\9db¬wÈ\81 +! ;\r
+\r
+DECIMAL\r
+: | ( "<spaces>name" -- ) ' , ;\r
+: Äe ;\r
+: µ¡É¡ aÈa: ( width -- )\r
+ CREATE , ;\r
+: ;µ¡É¡ aÈa\r
+ DOES>\r
+ TUCK @ \ º\81¡ ¹·\9fA Äe®\81\r
+ \8bi®A·³\9db¬wÈ\81 @\r
+ DUP ¬wÈ\81\8b¡´â ´|¸a\8b¡´â \ Ðe\8bi\8bi¸a·¡¡e\r
+ * + 2* CELLS + CELL+\r
+ DUP >R\r
+ @ EXECUTE\r
+ R> CELL+\r
+ @ EXECUTE\r
+ \8bi®A·³\9db¬wÈ\81 ! ;\r
+\r
+0 CONSTANT >0 IMMEDIATE\r
+1 CONSTANT >1 IMMEDIATE\r
+2 CONSTANT >2 IMMEDIATE\r
+3 CONSTANT >3 IMMEDIATE\r
+5 CONSTANT >5 IMMEDIATE\r
+\r
+HEX\r
+\ ¤e\97¡\88a ÑÁ¡e µ¡\9fe½¢\8f{µA ·¶·a¡e \94a·qÐ\97µA¬á ·³\9db¤h·q\r
+: ¤e\97¡¶áṡ¸÷ ( -- ) VIR_X @ 1+ MAX-X = ( -1|0) NEGATE VIR_X+! ;\r
+: £¡µÅ¬÷¸a¥¡µa ( -- ) VIR_X @ VIR_Y @ £¡µÅ¬÷¸a @ HFONT! ;\r
+: \8ba\90· ( -- ) VIR_X @ VIR_Y @ BL EFONT! ;\r
+: À\81¶\91! ( -- ) À\81¶\91¸a £¡µÅ¬÷¸a ! 1 ¬wÈ\81\8b¡´â ´|¸a\8b¡´â ;\r
+: £¡µÅ¬÷¸aÁ¡¬÷ ( -- Á¡¬÷ ) £¡µÅ¬÷¸a @ Á¡¬÷¥¥ AND 0A RSHIFT ;\r
+: £¡µÅ¬÷¸aº\97¬÷ ( -- º\97¬÷ ) £¡µÅ¬÷¸a @ º\97¬÷¥¥ AND 05 RSHIFT ;\r
+: £¡µÅ¬÷¸a¤hñ ( -- ¤hñ ) £¡µÅ¬÷¸a @ ¤hñ¥¥ AND ;\r
+: ·³\9db\89\81¢ ( -- 0 ) £¡µÅ¬÷¸a¥¡µa 0 ;\r
+: \90{¸a¤a\8e¡ ( \88t »¡¶\91¥¥ -- ) £¡µÅ¬÷¸a @ AND OR £¡µÅ¬÷¸a ! ;\r
+: Á¡¬÷¤a\8e¡ ( Á¡¬÷ -- ) 0A LSHIFT Á¡¬÷»¡¶\91¥¥ \90{¸a¤a\8e¡ ;\r
+: º\97¬÷¤a\8e¡ ( º\97¬÷ -- ) 05 LSHIFT º\97¬÷»¡¶\91¥¥ \90{¸a¤a\8e¡ ;\r
+: ¤hñ¤a\8e¡ ( ¤hñ -- ) ¤hñ»¡¶\91¥¥ \90{¸a¤a\8e¡ ;\r
+: Á¡¬÷! ( Á¡¬÷ -- 0 ) ¤e\97¡¶áṡ¸÷ Á¡¬÷¤a\8e¡ ·³\9db\89\81¢ ;\r
+: º\97¬÷! ( º\97¬÷ -- 0 ) º\97¬÷¤a\8e¡ ·³\9db\89\81¢ ;\r
+\r
+: µÅ¬÷ ( 0 -- 16§¡Ëa¸a ) DROP £¡µÅ¬÷¸a @ À\81¶\91! ;\r
+: µÅ+ch ( char -- 16§¡Ëa¸a ) \8bi®AÉ· ! £¡µÅ¬÷¸a @ À\81¶\91! ;\r
+: µÅ+Á¡ ( Á¡¬÷ -- 16§¡Ëa¸a ) £¡µÅ¬÷¸a @ À\81¶\91! SWAP Á¡¬÷¤a\8e¡ ;\r
+: µÅ+º\97 ( º\97¬÷ -- 16§¡Ëa¸a ) £¡µÅ¬÷¸a @ À\81¶\91! SWAP º\97¬÷¤a\8e¡ ;\r
+\r
+: \96á\9d¡ ( \96õ®A -- 0 )\r
+ DROP -2 ¼\81£¡µÅ¬÷¸a +!\r
+ ¼\81£¡µÅ¬÷¸a @ 7 AND CELLS £¡µÅ¬÷¸a\8b¡´â + @ £¡µÅ¬÷¸a ! ·³\9db\89\81¢ ;\r
+: >\96á ( -- ´|¬wÈ\81 )\r
+ -2 ¼\81·³\9db¬wÈ\81 +!\r
+ ¼\81·³\9db¬wÈ\81 @ 7 AND CELLS \8bi®A·³\9db¬wÈ\81\8b¡´â + @ ;\r
+\r
+CREATE Á¡¬÷>\89sÁ¡¬÷Îa \ \89sÁ¡¬÷·i e\97i®\81 ·¶\93e \88A,\94A,¤A,¬A,¸AµA \94\81Ð\81¬á\93e 1,\r
+ \ ´a\93¡¡e 0\r
+\ * À\81¶\91 \88A \8cA \90A \94A \98A \9cA A ¤A ¨A\r
+ 0 C, 0 C, 1 C, 0 C, 0 C, 1 C, 0 C, 0 C, 0 C, 1 C, 0 C,\r
+\ ¬A °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 1 C, 0 C, 0 C, 1 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, ALIGN\r
+\r
+CREATE Á¡¬÷>¤hñÎa \ ¤hñ·¡ ´a\93¥ Á¡¬÷ \98A,¨A,¼AµA \94\81Ð\81¬á\93e 0, ´a\93¡¡e ¤hñ\88t\r
+\ * À\81¶\91 \88A \8cA \90A \94A \98A \9cA A ¤A ¨A\r
+ 0 C, 1 C, 2 C, 3 C, 5 C, 8 C, 0 C, 9 C, 11 C, 13 C, 0 C,\r
+\ ¬A °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 15 C, 16 C, 17 C, 18 C, 0 C, 19 C, 1A C, 1B C, 1C C, 1D C, ALIGN\r
+\r
+CREATE ¤hñ>Ñ»¤hñÁ¡¬÷Îa \ \89s¤hñ: ¶á8§¡Ëa\93e Ñ»¤hñ\88t, ´a\9c\818§¡Ëa\93e Á¡¬÷\88t\r
+ \ Ñ»¤hñ: ¶á8§¡Ëa\93e À\81¶\91\88t, ´a\9c\818§¡Ëa\93e Á¡¬÷\88t\r
+\ * À\81¶\91 \84B \84C \84D \84E \84F \84G \84H \84I\r
+ 0 , 0 , 0102 , 0103 , 020B , 0104 , 050E , 0514 , 0105 , 0107 ,\r
+\ \84J \84K \84L \84M \84N \84O \84P \84Q * \84S\r
+ 0902 , 0908 , 0909 , 090B , 0912 , 0913 , 0914 , 0108 , 0 , 0109 ,\r
+\ \84T \84U \84V \84W \84X \84Y \84Z \84[ \84\ \84]\r
+ 130B , 010B , 010C , 010D , 010E , 0110 , 0111 , 0112 , 0113 , 0114 ,\r
+\r
+CREATE \9cAÁ¡¬÷>\89s¤hñÎa \ \9cA\89Á \89s¤hñ·i e\97i®\81 ·¶\93e Á¡¬÷·¡¡e \89s¤hñ\88t, ´a\93¡¡e 0\r
+\ * À\81¶\91 \88A \8cA \90A \94A \98A \9cA A ¤A ¨A\r
+ 0 C, 0 C, 0A C, 0 C, 0 C, 0 C, 0 C, 0 C, 0B C, 0C C, 0 C,\r
+\ ¬A °A ´A ¸A ¼A ÀA ÄA ÈA ÌA ÐA\r
+ 0D C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0E C, 0F C, 10 C, ALIGN\r
+\r
+CREATE \89s>Ñ»º\97¬÷Îa \ \89sº\97¬÷µA \94\81Ð\81 ´|Ñ»º\97¬÷\88t, \89sº\97¬÷·¡ ´a\93¡¡e 0\r
+\ * * À\81¶\91 \84a \84\81 \84¡ \84Á \84á * *\r
+ 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C,\r
+\ \85A \85a \85\81 \85¡ \85Á \85á * * \86A \86a\r
+ 0 C, 0 C, 0 C, 0 C, 0D C, 0D C, 0 C, 0 C, 0D C, 0 C,\r
+\ \86\81 \86¡ \86Á \86á * * \87A \87a \87\81 \87¡\r
+ 0 C, 14 C, 14 C, 14 C, 0 C, 0 C, 0 C, 0 C, 1B C, 0 C,\r
+\r
+: Á¡¬÷>\89sÁ¡¬÷? ( Á¡¬÷ -- Á¡¬÷ 0 | \89sÁ¡¬÷ -1 )\r
+ DUP £¡µÅ¬÷¸aÁ¡¬÷ = IF\r
+ DUP CHARS Á¡¬÷>\89sÁ¡¬÷Îa + C@ 1 = IF 1+ -1 EXIT THEN THEN\r
+ 0 ;\r
+: \89sÁ¡¬÷? ( Á¡¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ Á¡¬÷>\89sÁ¡¬÷? IF Á¡¬÷¤a\8e¡ ·³\9db\89\81¢\r
+ ELSE £¡µÅ¬÷¸a @ SWAP À\81¶\91! Á¡¬÷¤a\8e¡ THEN ;\r
+: Á¡¬÷>¤hñ? ( Á¡¬÷ -- Á¡¬÷ 0 | ¤hñ -1 )\r
+ DUP CHARS Á¡¬÷>¤hñÎa + C@ DUP IF NIP -1 EXIT THEN ;\r
+: \9cAÁ¡¬÷>\89s¤hñ ( Á¡¬÷ -- 0|\89s¤hñ ) CHARS \9cAÁ¡¬÷>\89s¤hñÎa + C@ ;\r
+: \89s>Ñ»º\97¬÷ ( º\97¬÷ -- 0|Ñ»º\97¬÷ ) CHARS \89s>Ñ»º\97¬÷Îa + C@ ;\r
+: \89s>´|Ñ»¤hñ ( ¤hñ -- 0|Ñ»¤hñ )\r
+ CELLS ¤hñ>Ñ»¤hñÁ¡¬÷Îa + @ 8 RSHIFT DUP À\81¶\91¤hñ <> AND ;\r
+: ¤hñ>¤hñÁ¡¬÷ ( ¤hñ -- ¤hñ Á¡¬÷ )\r
+ CELLS ¤hñ>Ñ»¤hñÁ¡¬÷Îa + @ DUP 8 RSHIFT SWAP 0FF AND ;\r
+\r
+\ \94}¡\9f¡\88a \98A, ¨A, ¼A·¡¡e µÅ¬÷, ´a\93¡¡e ¤hñµA \90ý\89¡ \89\81¢\r
+: ¤hñ? ( Á¡¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ Á¡¬÷>¤hñ? IF ¤hñ¤a\8e¡ ·³\9db\89\81¢\r
+ ELSE £¡µÅ¬÷¸a @ SWAP À\81¶\91! Á¡¬÷¤a\8e¡ THEN ;\r
+: >3? ( -- 3|4 ) £¡µÅ¬÷¸aº\97¬÷ \89s>Ñ»º\97¬÷ 0= ( -1|0) 4 + ;\r
+: >5? ( -- 2|5 ) £¡µÅ¬÷¸a¤hñ À\81¶\91¤hñ = ( -1|0) 3 * 5 + ;\r
+: >6? ( -- 2|6 ) £¡µÅ¬÷¸a¤hñ À\81¶\91¤hñ = ( -1|0) 2* 2* 6 + ;\r
+\r
+: Á¡¬÷>\89s¤hñ? ( Á¡¬÷ -- Á¡¬÷ 0 | \89s¤hñ -1 )\r
+ £¡µÅ¬÷¸a¤hñ\r
+ CASE\r
+ ( \84B) 02 OF DUP ( ¬A) 0B = IF DROP 04 -1 EXIT THEN ENDOF\r
+ ( \84S) 13 OF DUP ( ¬A) 0B = IF DROP 14 -1 EXIT THEN ENDOF\r
+ ( \84E) 05 OF DUP ( ¸A) 0E = IF DROP 06 -1 EXIT THEN\r
+ DUP ( ÐA) 14 = IF DROP 07 -1 EXIT THEN ENDOF\r
+ ( \84I) 09 OF DUP \9cAÁ¡¬÷>\89s¤hñ ?DUP IF NIP -1 EXIT THEN ENDOF\r
+ ENDCASE 0 ;\r
+\r
+: \89s¤hñ? ( Á¡¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ Á¡¬÷>\89s¤hñ? IF ¤hñ¤a\8e¡ ·³\9db\89\81¢ ELSE µÅ+Á¡ THEN ;\r
+: Ñ»¤hñ ( \96õ®A -- 0 )\r
+ DROP £¡µÅ¬÷¸a¤hñ \89s>´|Ñ»¤hñ ¤hñ¤a\8e¡ ·³\9db\89\81¢ ;\r
+\r
+: º\97¬÷>\89sº\97¬÷? ( º\97¬÷ -- º\97¬÷ 0 | \89sº\97¬÷ -1 )\r
+ £¡µÅ¬÷¸aº\97¬÷\r
+ CASE\r
+ ( \87a) 1B OF DUP ( \87¡) 1D = IF DROP 1C -1 EXIT THEN\r
+ 0 EXIT ENDOF\r
+ ( \85¡) 0D OF DUP ( \84a) 03 = IF DROP 0E -1 EXIT THEN\r
+ DUP ( \84\81) 04 = IF DROP 0F -1 EXIT THEN\r
+ DUP ( \87¡) 1D = IF DROP 12 -1 EXIT THEN\r
+ 0 EXIT ENDOF\r
+ ( \86\81) 14 OF DUP ( \84á) 07 = IF DROP 15 -1 EXIT THEN\r
+ DUP ( \85A) 0A = IF DROP 16 -1 EXIT THEN\r
+ DUP ( \87¡) 1D = IF DROP 17 -1 EXIT THEN\r
+ 0 EXIT ENDOF\r
+ ENDCASE 0 ;\r
+\r
+: \89sº\97¬÷? ( º\97¬÷ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ º\97¬÷>\89sº\97¬÷? IF º\97¬÷¤a\8e¡ ·³\9db\89\81¢ ELSE µÅ+º\97 THEN ;\r
+: Ñ»º\97¬÷ ( \96õ®A -- 0 )\r
+ DROP £¡µÅ¬÷¸aº\97¬÷ \89s>Ñ»º\97¬÷ º\97¬÷¤a\8e¡ ·³\9db\89\81¢ ;\r
+\r
+\ £¡µÅ¬÷¸aµA¬á ¤hñ·i ¨\85 \8bi¸a\9fi µÅ¬÷¸a\9d¡ \90\81¥¡\90\81\89¡\r
+\ \8ba ¤hñ·i £¡µÅ¬÷¸a·\81 Á¡¬÷µA \90ý\89¡ º\97¬÷·i £¡µÅ¬÷¸aµA \90ý·q\r
+: µÅ+Á¡º\97 ( º\97¬÷ -- 16§¡Ëa¸a )\r
+ £¡µÅ¬÷¸a¤hñ ¤hñ>¤hñÁ¡¬÷ \ º\97¬÷ ¬\81¤hñ Á¡¬÷\r
+ SWAP ¤hñ¤a\8e¡ £¡µÅ¬÷¸a @ \ º\97¬÷ Á¡¬÷ 16§¡ËaÐe\8bi¸a\r
+ À\81¶\91! SWAP Á¡¬÷¤a\8e¡ 2 ¬wÈ\81\8b¡´â ´|¸a\8b¡´â SWAP º\97¬÷¤a\8e¡ ;\r
+\r
+CREATE µw®A>Ðe\8bi¸a\r
+\ a> A b>\87A c>ÀA d>´A e>\94A f>\9cA g>ÐA h>\85¡ i>\84¡ j>\84á\r
+ 308 , 41A , 310 , 30D , 305 , 307 , 314 , 40D , 405 , 407 ,\r
+\ k>\84a l>\87¡ m>\87a n>\86\81 o>\84\81 p>\85A q>¤A r>\88A s>\90A t>¬A\r
+ 403 , 41D , 41B , 414 , 404 , 40A , 309 , 302 , 304 , 30B ,\r
+\ u>\85a v>ÌA w>¸A x>ÈA y>\86a z>ÄA\r
+ 40B , 313 , 30E , 312 , 413 , 311 ,\r
+\r
+CREATE µw¶õ®A>Ðe\8bi¸a\r
+\ A>A B>B C>C D>D E>\98A F>F G>G H>H I>I J>J\r
+ 041 , 042 , 043 , 044 , 306 , 046 , 047 , 048 , 049 , 04A ,\r
+\ K>K L>L M>M N>N O>\84Á P>\85\81 Q>¨A R>\8cA S>S T>°A\r
+ 04B , 04C , 04D , 04E , 406 , 40C , 30A , 303 , 053 , 30C ,\r
+\ U>U V>V W>¼A X>X Y>Y Z>Z\r
+ 055 , 056 , 30F , 058 , 059 , 05A ,\r
+\r
+\ EKEY \9d¡ ¤h·e \88tµA¬á \8bi®A·\81 ¹·\9fA\9fi '>\8bi¸a-2¤é¯¢'\9d¡ \90ñ\8b±\r
+\ 2¤é¯¢µA¬á \8bi®A ¹·\9fA\93e \94a¬õ \88a»¡:\r
+\ Ðeµw¤a\8e\91(1), \96õ®A(2), \94}¡\9f¡(3), Ñ©¡\9f¡(4), \90a ỡ(0)\r
+: >\8bi®A\88t\89Á¹·\9fA-2¤é¯¢ ( \8bi®A\88t -- \8bi®A\88t' ¹·\9fA )\r
+ 0FF AND \ special key \93e ¢\81¯¡\r
+ DUP BL = ¶E½¢¶õ®A\92\89\9f±? AND IF DROP 0 1 EXIT THEN \ Ðeµw¤a\8e\91\8bi®A·¡¡e 0 1\r
+ DUP \96õ®A= IF DROP 8 2 EXIT THEN \ \96õ\8bi®A·¡¡e\r
+ DUP [CHAR] A [CHAR] Z 1+ WITHIN \8bi®A·³\9db¬wÈ\81 @ AND IF \ Ðe\8bi·³\9db·¡\89¡ A-Z ·¡¡e\r
+ [CHAR] A - CELLS µw¶õ®A>Ðe\8bi¸a\r
+ [ µw®A>Ðe\8bi¸a µw¶õ®A>Ðe\8bi¸a - ] LITERAL CapsLock? AND\r
+ + + @ DUP 0FF AND SWAP 8 RSHIFT EXIT THEN\r
+ DUP [CHAR] a [CHAR] z 1+ WITHIN \8bi®A·³\9db¬wÈ\81 @ AND IF \ Ðe\8bi·³\9db·¡\89¡ a-z ·¡¡e\r
+ [CHAR] a - CELLS µw®A>Ðe\8bi¸a\r
+ [ µw¶õ®A>Ðe\8bi¸a µw®A>Ðe\8bi¸a - ] LITERAL CapsLock? AND\r
+ + + @ DUP 0FF AND SWAP 8 RSHIFT EXIT THEN\r
+ 0 ; \ \90a ỡ\r
+\r
+\ 2¤é¯¢ ¸aÌe ¬wÈ\81\r
+\ 0 : µw¢\85 ·³\9db\r
+\ 1 : Ðe\8bi·³\9db ¯¡¸b\r
+\ 2 : Á¡¬÷ ·³\9db\r
+\ 3 : Á¡¬÷+º\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 4 : Á¡¬÷+\89sº\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 5 : Á¡¬÷+º\97¬÷+¤hñ ·³\9db\r
+\ 6 : Á¡¬÷+º\97¬÷+\89s¤hñ ·³\9db\r
+5 Äe µ¡É¡ aÈa: >\8bi¸a-2¤é¯¢\r
+\ ·³\9db| \90a ỡ? | Ðeµw¤a\8e\91? | \96õ®A? | \94}¡\9f¡? | Ñ©¡\9f¡? |\r
+\ ¬wÈ\81----------------------------------------------------------------------\r
+ ( 0) | \8ba\90· | >0 | À\81¶\91! | >1 | \8ba\90· | >0 | \8ba\90· | >0 | \8ba\90· | >0\r
+ ( 1) | \8ba\90· | >1 | \8ba\90· | >0 | \8ba\90· | >1 | Á¡¬÷! | >2 | º\97¬÷! | >3\r
+ ( 2) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | \89sÁ¡¬÷? | >2 | º\97¬÷! | >3\r
+ ( 3) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | ¤hñ? | >5? | \89sº\97¬÷? | >3?\r
+ ( 4) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | ¤hñ? | >5? | µÅ+º\97 | >3\r
+ ( 5) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | \89s¤hñ? | >6? | µÅ+Á¡º\97 | >3\r
+ ( 6) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+Á¡º\97 | >3\r
+;µ¡É¡ aÈa\r
+\r
+\\r
+\ 3¤é¯¢ ¸aÌe ·³\9dbµA Ï©¶aÐe \90{ i\97i\r
+\\r
+\r
+CREATE \9cA¤hñ>\89s¤hñÎa \ \9cA\89Á \89s¤hñ·i e\97i®\81 ·¶\93e ¤hñ·¡¡e \89s¤hñ\88t, ´a\93¡¡e 0\r
+\ * À\81¶\91 \84B \84C \84D \84E \84F \84G \84H \84I\r
+ 0 C, 0 C, 0A C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C,\r
+\ \84J \84K \84L \84M \84N \84O \84P \84Q * \84S\r
+ 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0 C, 0B C, 0 C, 0C C,\r
+\ \84T \84U \84V \84W \84X \84Y \84Z \84[ \84\ \84]\r
+ 0 C, 0D C, 0 C, 0 C, 0 C, 0 C, 0 C, 0E C, 0F C, 10 C, ALIGN\r
+\r
+: ¤hñ! ( ¤hñ -- 0 ) ¤hñ¤a\8e¡ ·³\9db\89\81¢ ;\r
+: µÅ+¤hñ ( ¤hñ -- 16§¡Ëa¸a ) £¡µÅ¬÷¸a @ À\81¶\91! SWAP ¤hñ¤a\8e¡ ;\r
+: \9cA¤hñ>\89s¤hñ ( ¤hñ -- 0|\89s¤hñ ) CHARS \9cA¤hñ>\89s¤hñÎa + C@ ;\r
+: ¤hñ>\89s¤hñ? ( ¤hñ -- ¤hñ 0 | \89s¤hñ -1 )\r
+ £¡µÅ¬÷¸a¤hñ\r
+ CASE\r
+ ( \84B) 02 OF DUP ( \84B) 02 = IF DROP 03 -1 EXIT THEN\r
+ ( \84U) 15 = IF DROP 04 -1 EXIT THEN ENDOF\r
+ ( \84S) 13 OF DUP ( \84U) 15 = IF DROP 14 -1 EXIT THEN ENDOF\r
+ ( \84U) 15 OF DUP ( \84U) 15 = IF DROP 16 -1 EXIT THEN ENDOF\r
+ ( \84E) 05 OF DUP ( \84X) 18 = IF DROP 06 -1 EXIT THEN\r
+ DUP ( \84]) 1D = IF DROP 07 -1 EXIT THEN ENDOF\r
+ ( \84I) 09 OF DUP \9cA¤hñ>\89s¤hñ ?DUP IF NIP -1 EXIT THEN ENDOF\r
+ ENDCASE 0 ;\r
+: \89s¤hñ? ( ¤hñ -- 0 | 16§¡ËaÐe\8bi¸a )\r
+ ¤hñ>\89s¤hñ? IF ¤hñ¤a\8e¡ ·³\9db\89\81¢ ELSE µÅ+¤hñ THEN ;\r
+\r
+CREATE 3¤é®A>Ðe\8bi¸a\r
+\ !>\84X ">" #># $>$ %>% &>& '>ÈA (>( )>) *>* +>+ ,>,\r
+ 518 , 022 , 023 , 024 , 025 , 026 , 312 , 028 , 029 , 02A , 02B , 02C ,\r
+\ ->- .>. />\85¡ 0>ÄA 1>\84] 2>\84V 3>\84S 4>\86a 5>\87A 6>\84¡ 7>\85\81 8>\87\81\r
+ 02D , 02E , 40D , 311 , 51D , 516 , 513 , 413 , 41A , 405 , 40C , 41C ,\r
+\ 9>\86\81 :>: ;>¤A <>2 =>= >>3 ?>? @>@ A>\84H B>! C>\84K D>\84J\r
+ 414 , 03A , 309 , 032 , 03D , 033 , 03F , 040 , 508 , 021 , 50B , 50A ,\r
+\ E>\84Z F>\84C G>/ H>' I>8 J>4 K>5 L>6 M>1 N>0 O>9 P>>\r
+ 51A , 503 , 02F , 027 , 038 , 034 , 035 , 036 , 031 , 030 , 039 , 03E ,\r
+\ Q>\84\ R>\84Á S>\84G T>; U>7 V>\84P W>\84[ X>\84T Y>8 Z>\84Y [>[ \>\\r
+ 51C , 406 , 507 , 03B , 037 , 510 , 51B , 514 , 038 , 519 , 05B , 05C ,\r
+\ ]>] ^>^ _>_ `>` a>\84W b>\86\81 c>\85A d>\87¡ e>\85a f>\84a g>\87a h>\90A\r
+ 05D , 05E , 05F , 060 , 517 , 414 , 40A , 41D , 40B , 403 , 41B , 304 ,\r
+\ i> A j>´A k>\88A l>¸A m>ÐA n>¬A o>ÀA p>ÌA q>\84U r>\84\81 s>\84E t>\84á\r
+ 308 , 30D , 302 , 30E , 314 , 30B , 310 , 313 , 515 , 404 , 505 , 407 ,\r
+\ u>\94A v>\85¡ w>\84I x>\84B y>\9cA z>\84Q {>{ |>| }>} ~>~\r
+ 305 , 40D , 509 , 502 , 307 , 511 , 07B , 07C , 07D , 07E ,\r
+\r
+\ EKEY \9d¡ ¤h·e \88tµA¬á \8bi®A·\81 ¹·\9fA\9fi '>\8bi¸a-3¤é¯¢'·a\9d¡ \90ñ\8b±\r
+\ 3¤é¯¢µA¬á \8bi®A ¹·\9fA\93e \94a¬õ \88a»¡:\r
+\ Ðeµw¤a\8e\91(1), \96õ®A(2), Á¡¬÷(3), º\97¬÷(4), ¤hñ(5), \90a ỡ(0)\r
+: >\8bi®A\88t\89Á¹·\9fA-3¤é¯¢ ( \8bi®A\88t -- \8bi®A\88t' ¹·\9fA )\r
+ 0FF AND \ special key \93e ¢\81¯¡\r
+ DUP BL = ¶E½¢¶õ®A\92\89\9f±? AND IF DROP 0 1 EXIT THEN \ Ðeµw¤a\8e\91\8bi®A·¡¡e 0 1\r
+ DUP \96õ®A= IF DROP 8 2 EXIT THEN \ \96õ\8bi®A·¡¡e\r
+ DUP BL > 0= IF 0 EXIT THEN \ ¹A´á¢\85¸a\90a §¥Äe·¡¡e\r
+ \8bi®A·³\9db¬wÈ\81 @ 0= IF 0 EXIT THEN \ µw¢\85·³\9db\r
+ CapsLock? IF\r
+ DUP [CHAR] A [CHAR] Z 1+ WITHIN IF\r
+ [ CHAR a CHAR A - ] LITERAL +\r
+ ELSE DUP [CHAR] a [CHAR] z 1+ WITHIN IF\r
+ [ CHAR A CHAR a - ] LITERAL + THEN THEN THEN\r
+ [CHAR] ! - CELLS 3¤é®A>Ðe\8bi¸a + @\r
+ DUP 0FF AND SWAP 8 RSHIFT ;\r
+\r
+\ 3¤é¯¢ ¸aÌe ¬wÈ\81\r
+\ 0 : µw¢\85 ·³\9db\r
+\ 1 : Ðe\8bi·³\9db ¯¡¸b\r
+\ 2 : Á¡¬÷ ·³\9db\r
+\ 3 : Á¡¬÷+º\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 4 : Á¡¬÷+\89sº\97¬÷ ·³\9db ( Á¡¬÷µA À\81¶\91 \8bi¸a\95¡ Ðá¶w )\r
+\ 5 : Á¡¬÷+º\97¬÷+¤hñ ·³\9db\r
+\ 6 : Á¡¬÷+º\97¬÷+\89s¤hñ ·³\9db\r
+6 Äe µ¡É¡ aÈa: >\8bi¸a-3¤é¯¢\r
+\ ·³\9db| \90a ỡ? | Ðeµw¤a\8e\91? | \96õ®A? | Á¡¬÷? | º\97¬÷? | ¤hñ? |\r
+\ ¬wÈ\81--------------------------------------------------------------------------------------\r
+ ( 0) | \8ba\90· | >0 | À\81¶\91! | >1 | \8ba\90· | >0 | \8ba\90· | >0 | \8ba\90· | >0 | \8ba\90· | >0\r
+ ( 1) | \8ba\90· | >1 | \8ba\90· | >0 | \8ba\90· | >1 | Á¡¬÷! | >2 | º\97¬÷! | >3 | ¤hñ! | >5\r
+ ( 2) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | \89sÁ¡¬÷? | >2 | º\97¬÷! | >3 | ¤hñ! | >5\r
+ ( 3) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | \89sº\97¬÷? | >3? | ¤hñ! | >5\r
+ ( 4) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+º\97 | >3 | ¤hñ! | >5\r
+ ( 5) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+º\97 | >3 | \89s¤hñ? | >5?\r
+ ( 6) | µÅ+ch | >1 | µÅ¬÷ | >0 | \96á\9d¡ | >\96á | µÅ+Á¡ | >2 | µÅ+º\97 | >3 | µÅ+¤hñ | >5\r
+;µ¡É¡ aÈa\r
+\r
+' >\8bi¸a-2¤é¯¢ VALUE '>\8bi¸a\r
+' >\8bi®A\88t\89Á¹·\9fA-2¤é¯¢ VALUE '>\8bi®A\88t\89Á¹·\9fA\r
+: >\8bi¸a '>\8bi¸a EXECUTE ;\r
+: >\8bi®A\88t\89Á¹·\9fA '>\8bi®A\88t\89Á¹·\9fA EXECUTE ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+: 2BUL ( -- )\r
+ ['] >\8bi¸a-2¤é¯¢ TO '>\8bi¸a\r
+ ['] >\8bi®A\88t\89Á¹·\9fA-2¤é¯¢ TO '>\8bi®A\88t\89Á¹·\9fA ;\r
+: 3BUL ( -- )\r
+ ['] >\8bi¸a-3¤é¯¢ TO '>\8bi¸a\r
+ ['] >\8bi®A\88t\89Á¹·\9fA-3¤é¯¢ TO '>\8bi®A\88t\89Á¹·\9fA ;\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+: HEKEY\r
+ \8bi®AÉ· @ ?DUP IF \ \8bi®AÉ·µA \8bi¸a\88a ·¶·a¡e \8ba \8bi¸a\9fi ¥¡\90\91\r
+ DUP 0FF00 AND \ \8bi®AÉ·µA \96\81 \8bi¸a\88a ·¶·a¡e ¶á 8 §¡Ëa\9fi ¥¡\90\91\r
+ IF DUP 8 RSHIFT\r
+ SWAP 0FF AND\r
+ \8bi®AÉ· ! EXIT THEN\r
+ 0 \8bi®AÉ· ! EXIT THEN \ \8bi®AÉ··\81 Ðe \8bi¸a\9fi ¥¡\90\91\r
+ £¡µÅ¬÷¸a @ À\81¶\91¸a <> \8bi®A·³\9db¬wÈ\81 @ AND IF £¡µÅ¬÷¸a¥¡µa THEN\r
+ BEGIN BEGIN PAUSE RX? UNTIL RX@ >\8bi®A\88t\89Á¹·\9fA >\8bi¸a ?DUP UNTIL\r
+ \ BEGIN ... UNTIL ·i ¨a¹a \90aµ© \98\81 \94ᣡµA \90q·e \88t·e\r
+ \ 8 §¡Ëa : Ðe \8bi¸a : \8ba\90·\r
+ \ 16 §¡Ëa : \96\81 \8bi¸a : µÅ¬÷ , µÅ+Á¡ , µÅ+Á¡º\97 , ...\r
+ \ 16 §¡Ëa : A \8bi¸a : µÅ¬÷+ch ( char \88t·e \8bi®AÉ· µA \97i´á ·¶·q )\r
+ DUP 0FF00 AND IF \ 16§¡Ëa Ðe\8bi¸a·¡¡e \90a ỡ \8bi¸a\9fi \8bi®AÉ·µA \94q·q\r
+ DUP 8 RSHIFT SWAP 0FF AND \ \94ᣡ: ¶á8§¡Ëa ´a\9c\818§¡Ëa\r
+ \8bi®AÉ· @ ?DUP IF \ \94ᣡ: ¶á8§¡Ëa ´a\9c\818§¡Ëa char\r
+ SWAP 8 LSHIFT OR THEN\r
+ \8bi®AÉ· !\r
+ THEN ;\r
+\r
+: HEKEY?\r
+ £¡µÅ¬÷¸a @ À\81¶\91¸a <> \8bi®AÉ· @ OR IF -1 ELSE RX? THEN ;\r
+\r
+: SET-TEXT-I/O ( -- )\r
+ ['] RX? TO 'ekey?\r
+ ['] RX@ TO 'ekey\r
+ ['] TX! TO 'emit ;\r
+\r
+: SET-HGRAPHIC-I/O\r
+ ['] HEKEY? TO 'ekey?\r
+ ['] HEKEY TO 'ekey\r
+ ['] HEMIT TO 'emit ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+DECIMAL VARIABLE \8cq¤b·±\r
+0 60 CELLS 60 CELLS HAT multiI/O multiI/O BUILD\r
+0 60 CELLS 60 CELLS HAT HCURSOR HCURSOR BUILD\r
+\r
+: TEXT\r
+ textmode# SET-MODE\r
+ SET-TEXT-I/O\r
+ 0 TO GRAPHIC?\r
+ multiI/O SLEEP HCURSOR SLEEP ;\r
+\r
+HEX\r
+CODE ReadClockCount ( -- ud )\r
+ BX PUSH,\r
+ AX AX XOR, \ MOV AH,00\r
+ 1A INT,\r
+ DX PUSH,\r
+ CX BX MOV,\r
+ NEXT,\r
+END-CODE\r
+\r
+DECIMAL\r
+: \8cq¤b·±¹¡¸é ( -- )\r
+ ReadClockCount\r
+ BEGIN 2DUP DNEGATE ReadClockCount D+ DROP UNTIL 2DROP\r
+ ReadClockCount\r
+ -1 0 DO PAUSE 0 0 BL EFONT! 0 0 BL EFONT!\r
+ 2DUP DNEGATE ReadClockCount D+ DROP\r
+ IF 2DROP I \8cq¤b·± ! UNLOOP EXIT THEN LOOP\r
+ 2DROP -1 \8cq¤b·± ! ;\r
+\r
+: HGRAPHIC\r
+ VGA? IF\r
+ 3 TO textmode#\r
+ ['] VGA-SET-GRAPHIC TO 'SET-GRAPHIC\r
+ VGA-Y>SegTable Y>SegTable !\r
+ 30 TO MAX-Y \ 640X480 Ð\81¬w\95¡; 480 / 16 = 30 º\89\r
+ ELSE HERC? IF\r
+ 7 TO textmode#\r
+ ['] HERC-SET-GRAPHIC TO 'SET-GRAPHIC\r
+ HERC-Y>SegTable Y>SegTable !\r
+ 25 TO MAX-Y \ 640X400 Ð\81¬w\95¡; 400 / 16 = 25 º\89\r
+ MAX-Y 0 DO 1 MAX-X* 0 DO I J BL EFONT! LOOP LOOP\r
+ ELSE SET-TEXT-I/O 0 TO GRAPHIC?\r
+ ." Korean characters can be displayed only on VGA or Hercules Graphics screen."\r
+ multiI/O SLEEP HCURSOR SLEEP EXIT\r
+ THEN THEN\r
+ VSCREEN VSCREEN-SIZE CHARS BL FILL\r
+ SET-GRAPHIC\r
+ 0 HCHAR !\r
+ 0 \8bi®A·³\9db¬wÈ\81 !\r
+ 0 \8bi®AÉ· !\r
+ À\81¶\91!\r
+ 0 VSCR0 !\r
+ 0 YY ! 0 VIR_Y !\r
+ 0 XX ! 0 VIR_X !\r
+ SET-HGRAPHIC-I/O\r
+ multiI/O AWAKE HCURSOR SLEEP \8cq¤b·±¹¡¸é HCURSOR AWAKE ;\r
+\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+: NEW-SET-I/O\r
+ GRAPHIC? IF SET-HGRAPHIC-I/O ELSE SET-TEXT-I/O THEN ;\r
+\r
+HEX\r
+: NEW-hi\r
+ DOSCommand>PAD\r
+ GET-MODE TO OldMode# HGRAPHIC hi\r
+ ." ·\81\89e\89Á ¹A´e\89Á §¡Íw·i ¶á ·¥Èá\91U º\81¡\90a Ða·¡ÉI wykoh\9d¡ ¥¡\90\81 º\81¯³¯¡µ¡." CR\r
+ S" BLOCKS.BLK" MAPPED-TO-BLOCK QUIT ;\r
+\r
+' NEW-SET-I/O TO 'init-i/o\r
+' NEW-hi TO 'boot\r
+\r
+: XX+! ( n -- )\r
+ XX @ + MAX-X /MOD YY +! XX ! ;\r
+\r
+FALSE VALUE SCREEN-UPDATED?\r
+\r
+HEX\r
+:NONAME multiI/O ACTIVATE\r
+ BEGIN\r
+ PAUSE\r
+ YY @ MAX-X* XX @ + DUP VIR_Y @ MAX-X* VIR_X @ + < IF\r
+ FALSE TO SCREEN-UPDATED?\r
+ YY @ VIR_Y @ < IF YY @ 1+ MAX-X*\r
+ ELSE VIR_Y @ MAX-X* VIR_X @ + THEN\r
+ SWAP\r
+ BEGIN DUP >VSCR-ADDR C@\r
+ DUP 80 < IF\r
+ XX @ YY @ ROT EFONT! 1 XX+! ELSE\r
+ 8 LSHIFT >R\r
+ CHAR+ DUP >VSCR-ADDR C@ R> OR\r
+ XX @ YY @ ROT HFONT! 2 XX+! THEN\r
+ CHAR+ 2DUP > 0= UNTIL 2DROP ELSE\r
+ TRUE TO SCREEN-UPDATED?\r
+ DROP VIR_X @ XX ! VIR_Y @ YY ! THEN\r
+ AGAIN\r
+; EXECUTE\r
+\r
+:NONAME HCURSOR ACTIVATE\r
+ BEGIN\r
+ \8cq¤b·± @ 0 DO PAUSE LOOP\r
+ SCREEN-UPDATED? IF\r
+ GRAPHIC? IF\r
+ \8bi®A·³\9db¬wÈ\81 @ ?DUP IF\r
+ 1- IF\r
+ £¡µÅ¬÷¸a¥¡µa ELSE\r
+ XX @ YY @ [CHAR] _ EFONT! THEN ELSE\r
+ XX @ YY @ [CHAR] - EFONT! THEN THEN\r
+ \8cq¤b·± @ 0 DO PAUSE LOOP\r
+ GRAPHIC? IF\r
+ XX @ YY @ BL EFONT!\r
+ \8bi®A·³\9db¬wÈ\81 @ IF\r
+ XX @ CHAR+ YY @ BL EFONT! THEN THEN THEN\r
+ AGAIN\r
+; EXECUTE\r
+\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+HEX\r
+CODE textAT-XY ( column row -- )\r
+ 2 # AH MOV,\r
+ DX POP,\r
+ BL DH MOV,\r
+ BX BX XOR,\r
+ 10 INT,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ AT-XY ( u1 u2 -- ) \ FACILITY\r
+\ Perform implementation-dependent steps so that the next\r
+\ character displayed will appear in column u1, row u2 of the\r
+\ user output device, the upper left corner of which is column\r
+\ zero, row zero. An ambiguous condition exists if the\r
+\ operation cannot be performed on the user output Adevice\r
+\ with the specified parameters.\r
+: AT-XY\r
+ GRAPHIC? IF DUP YY ! VIR_Y ! DUP XX ! VIR_X !\r
+ ELSE textAT-XY THEN ;\r
+\r
+\ PAGE ( -- ) \ FACILITY\r
+\ Move to another page for output. Actual function depends on\r
+\ the output device. On a terminal, PAGE clears the screen\r
+\ and resets the cursor position to the upper left corner. On\r
+\ a printer, PAGE performs a form feed.\r
+DECIMAL\r
+: PAGE\r
+ GRAPHIC? IF MAX-Y 0 DO 1 MAX-X* 0 DO\r
+ BL J MAX-X* I + >VSCR-ADDR C! I J BL EFONT!\r
+ LOOP LOOP\r
+ 0 TO YTop\r
+ ELSE 0 0 AT-XY 25 0 DO 80 0 DO BL EMIT LOOP LOOP\r
+ THEN 0 0 AT-XY ;\r
+\r
+: BYE OldMode# SET-MODE BYE ;\r
+\r
+HGRAPHIC\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
--- /dev/null
++ ( \88t1 \88t2 -- \88t3 )\r
+ \88t1\89Á \88t2\9fi \94áÐe\94a.\r
+ 1 2 +\r
+ Àá\9cñ ¯¡Ç¡¡e 1\89Á 2\9fi \94áÐe \88t 3·i \94ᣡµA µ©\9f¥\94a.\r
+- ( \88t1 \88t2 -- \88t3 )\r
+ \88t1µA¬á \88t2\9fi ¨\85\94a.\r
+ 2 1 -\r
+ Àá\9cñ ¯¡Ç¡¡e 2µA¬á 1·i ¨\85 \88t 1·i \94ᣡµA µ©\9f¥\94a.\r
+* ( \88t1 \88t2 -- \88t3 )\r
+ \88t1µA \88t2\9fi \89³Ðe\94a.\r
+ 2 3 *\r
+ Àá\9cñ ¯¡Ç¡¡e \89³Ðe \88t 6·i \94ᣡµA µ©\9f¥\94a.\r
+/ ( \88t1 \88t2 -- \88t3 )\r
+ \88t1·i \88t2\9d¡ \90a\92\85\94a.\r
+ 6 2 /\r
+ Àá\9cñ ¯¡Ç¡¡e 6·i 2\9d¡ \90a\92\85 \88t 3·i \94ᣡµA µ©\9f¥\94a.\r
+MOD ( \88t1 \88t2 -- \88t3 )\r
+ \88t1·i \88t2\9d¡ \90a\92\85 \90a ỡ\9fi \8a\81Ðe\94a.\r
+ 8 3 MOD\r
+ Àá\9cñ ¯¡Ç¡¡e 8·i 3·a\9d¡ \90a\92\85 \90a ỡ 2\9fi \94ᣡµA µ©\9f¥\94a.\r
+\90a ỡ ( \88t1 \88t2 -- \88t3 )\r
+ \88t1·i \88t2\9d¡ \90a\92\85 \90a ỡ\9fi \8a\81Ðe\94a.\r
+ 8 3 \90a ỡ\r
+ Àá\9cñ ¯¡Ç¡¡e 8·i 3·a\9d¡ \90a\92\85 \90a ỡ 2\9fi \94ᣡµA µ©\9f¥\94a.\r
+. ( \88t -- )\r
+ \94ᣡ·\81 \85 ¶á \88t·i ÑÁ¡eµA ¯³»¥®\81\9d¡ ¥¡·¥\94a.\r
+DUP ( \88t -- \88t \88t )\r
+ \94ᣡ·\81 \85 ¶á \88t·i ¥A\8da¬á \94ᣡµA µ©\9f¥\94a.\r
+ 1 DUP\r
+ Àá\9cñ ¯¡Ç¡¡e 1·i \96\81 \88\81 \94ᣡµA µ©\9f¥\94a.\r
+¥A\8da ( \88t -- \88t \88t )\r
+ \94ᣡ·\81 \85 ¶á \88t·i ¥A\8da¬á \94ᣡµA µ©\9f¥\94a.\r
+ 1 ¥A\8da\r
+ Àá\9cñ ¯¡Ç¡¡e 1·i \96\81 \88\81 \94ᣡµA µ©\9f¥\94a.\r
+OVER ( \88t1 \88t2 -- \88t1 \88t2 \88t1 )\r
+ \94ᣡ·\81 \96\81 ¤å¼\81 \88t·i ¥A\8da¬á \94ᣡµA µ©\9f¥\94a.\r
+ 1 2 OVER\r
+ Àá\9cñ ¯¡Ç¡¡e 1, 2, 1·i Àa\9d\81\9d¡ \94ᣡµA µ©\9f¥\94a.\r
+\88å\90á ( \88t1 \88t2 -- \88t1 \88t2 \88t1 )\r
+ "\88å\90á (¥A\8da)". \94ᣡ·\81 \96\81 ¤å¼\81 \88t·i ¥A\8da¬á \94ᣡµA µ©\9f¥\94a.\r
+ 1 2 \88å\90á\r
+ Àá\9cñ ¯¡Ç¡¡e 1, 2, 1·i Àa\9d\81\9d¡ \94ᣡµA µ©\9f¥\94a.\r
+SWAP ( \88t1 \88t2 -- \88t2 \88t1 )\r
+ \94ᣡ·\81 \85 ¶á \96\81 \88t·\81 ¸a\9f¡\9fi ¤a\8e\85\94a.\r
+ 1 2 SWAP\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡ·\81 \85 ¶áµA\93e 1·¡, ¤a\9d¡ £»µA 2\88a ·¶\94a.\r
+¤a\8e¡ ( \88t1 \88t2 -- \88t2 \88t1 )\r
+ \94ᣡ·\81 \85 ¶á \96\81 \88t·\81 ¸a\9f¡\9fi ¤a\8e\85\94a.\r
+ 1 2 ¤a\8e¡\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡ·\81 \85 ¶áµA\93e 1·¡, ¤a\9d¡ £»µA 2\88a ·¶\94a.\r
+DROP ( \88t1 -- )\r
+ \94ᣡ·\81 \85 ¶á \88t·i ¤á\9f¥\94a.\r
+¤á\9da ( \88t1 -- )\r
+ \94ᣡ·\81 \85 ¶á \88t·i ¤á\9f¥\94a.\r
+ROT ( \88t1 \88t2 \88t3 -- \88t2 \88t3 \88t1 )\r
+ \94ᣡ·\81 \85 ¶á A \88t·i \95©\9f¥\94a. A ¤å¼\81 \88t·i \8cá\90\81 \85 ¶áµA µ©\9f¥\94a.\r
+ 1 2 3 ROT\r
+ Àá\9cñ ¯¡Ç¡¡e 2, 3, 1·i Àa\9d\81\9d¡ \94ᣡµA µ©\9f¥\94a.\r
+\95©\9da ( \88t1 \88t2 \88t3 -- \88t2 \88t3 \88t1 )\r
+ \94ᣡ·\81 \85 ¶á A \88t·i \95©\9f¥\94a. A ¤å¼\81 \88t·i \8cá\90\81 \85 ¶áµA µ©\9f¥\94a.\r
+ 1 2 3 \95©\9da\r
+ Àá\9cñ ¯¡Ç¡¡e 2, 3, 1·i Àa\9d\81\9d¡ \94ᣡµA µ©\9f¥\94a.\r
+>R ( \88t\94ᣡ: \88t -- ; \96A\95©·¡\94ᣡ: -- \88t )\r
+ \88t\94ᣡ·\81 \88t·i \96A\95©·¡\94ᣡ\9d¡ µ«\8b¥\94a. 'DO ... LOOP'\90a ' \91 ...\r
+ \95©´a'\88a \96A\95©·¡\94ᣡ\9fi ¬a¶wÐa£a\9d¡ LOOPµÁ '\95©´a' ¸åµA \96A\95©·¡\94ᣡ\9fi\r
+ ¶¥¬wÈ\81\9d¡ \95©\9da \91½´a´¡ Ðe\94a.\r
+>\96A ( \88t\94ᣡ: \88t -- ; \96A\95©·¡\94ᣡ: -- \88t )\r
+ \88t\94ᣡ·\81 \88t·i \96A\95©·¡\94ᣡ\9d¡ µ«\8b¥\94a. 'DO ... LOOP'\90a ' \91 ...\r
+ \95©´a'\88a \96A\95©·¡\94ᣡ\9fi ¬a¶wÐa£a\9d¡ LOOPµÁ '\95©´a' ¸åµA \96A\95©·¡\94ᣡ\9fi\r
+ ¶¥¬wÈ\81\9d¡ \95©\9da \91½´a´¡ Ðe\94a.\r
+R> ( \88t\94ᣡ: -- \88t ; \96A\95©·¡\94ᣡ: \88t -- )\r
+ \96A\95©·¡\94ᣡ·\81 \88t·i \88t\94ᣡ\9d¡ µ«\8b¥\94a. 'DO ... LOOP'\90a ' \91 ...\r
+ \95©´a'\88a \96A\95©·¡\94ᣡ\9fi ¬a¶wÐa£a\9d¡ LOOPµÁ '\95©´a' ¸åµA \96A\95©·¡\94ᣡ\9fi\r
+ ¶¥¬wÈ\81\9d¡ \95©\9da \91½´a´¡ Ðe\94a.\r
+\96A> ( \88t\94ᣡ: -- \88t ; \96A\95©·¡\94ᣡ: \88t -- )\r
+ \96A\95©·¡\94ᣡ·\81 \88t·i \88t\94ᣡ\9d¡ µ«\8b¥\94a. 'DO ... LOOP'\90a ' \91 ...\r
+ \95©´a'\88a \96A\95©·¡\94ᣡ\9fi ¬a¶wÐa£a\9d¡ LOOPµÁ '\95©´a' ¸åµA \96A\95©·¡\94ᣡ\9fi\r
+ ¶¥¬wÈ\81\9d¡ \95©\9da \91½´a´¡ Ðe\94a.\r
+R@ ( \88t\94ᣡ: -- \88t ; \96A\95©·¡\94ᣡ: \88t -- \88t )\r
+ \96A\95©·¡\94ᣡ·\81 \88t·i \88t\94ᣡ\9d¡ ¥A\8f¥\94a.\r
+\96A@ ( \88t\94ᣡ: -- \88t ; \96A\95©·¡\94ᣡ: \88t -- \88t )\r
+ \96A\95©·¡\94ᣡ·\81 \88t·i \88t\94ᣡ\9d¡ ¥A\8f¥\94a.\r
+= ( \88t1 \88t2 -- -1|0 )\r
+ 5 5 = Àá\9cñ ¯¡Ç¡¡e \94ᣡµA -1·i µ©\9f¡\89¡\r
+ 6 5 = Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i µ©\9f¥\94a.\r
+== ( \88t1 \88t2 -- -1|0 )\r
+ 5 5 = Àá\9cñ ¯¡Ç¡¡e \94ᣡµA -1·i µ©\9f¡\89¡\r
+ 6 5 = Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i µ©\9f¥\94a.\r
+> ( \88t1 \88t2 -- -1|0 )\r
+ 5 6 > Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i µ©\9f¡\89¡\r
+ 5 5 > Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i µ©\9f¡\89¡\r
+ 6 5 > Àá\9cñ ¯¡Ç¡¡e \94ᣡµA -1·i µ©\9f¥\94a.\r
+< ( \88t1 \88t2 -- -1|0 )\r
+ 5 6 < Àá\9cñ ¯¡Ç¡¡e \94ᣡµA -1·i µ©\9f¡\89¡\r
+ 5 5 < Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i µ©\9f¡\89¡\r
+ 6 5 < Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i µ©\9f¥\94a.\r
+AND ( \88t1 \88t2 -- \88t3 )\r
+ \88t1\89Á \88t2·\81 \88b \90{(bit)µA \94\81Ðe \91¥\9f¡\89³·i \94ᣡµA µ©\9f¥\94a.\r
+\90{Ðq\8dA ( \88t1 \88t2 -- \88t3 )\r
+ \88t1\89Á \88t2·\81 \88b \90{(bit)µA \94\81Ðe \91¥\9f¡\89³·i \94ᣡµA µ©\9f¥\94a.\r
+OR ( \88t1 \88t2 -- \88t3 )\r
+ \88t1\89Á \88t2·\81 \88b \90{(bit)µA \94\81Ðe \91¥\9f¡Ðs·i \94ᣡµA µ©\9f¥\94a.\r
+\90{´a¶\89\9cá ( \88t1 \88t2 -- \88t3 )\r
+ \88t1\89Á \88t2·\81 \88b \90{(bit)µA \94\81Ðe \91¥\9f¡Ðs·i \94ᣡµA µ©\9f¥\94a.\r
+XOR ( \88t1 \88t2 -- \88t3 )\r
+ \88t1\89Á \88t2·\81 \88b \90{(bit)µA \94\81Ðe ¤\81Èa¸â \91¥\9f¡\89³·i \94ᣡµA µ©\9f¥\94a.\r
+\90{\98a\9d¡ ( \88t1 \88t2 -- \88t3 )\r
+ \88t1\89Á \88t2·\81 \88b \90{(bit)µA \94\81Ðe ¤\81Èa¸â \91¥\9f¡\89³·i \94ᣡµA µ©\9f¥\94a.\r
+WORDS ( -- )\r
+ ³i ®\81 ·¶\93e ¯¡Ç± i\97i·i ÑÁ¡eµA ¥¡·¥\94a.\r
+ iÍa ( -- )\r
+ ³i ®\81 ·¶\93e ¯¡Ç± i\97i·i ÑÁ¡eµA ¥¡·¥\94a.\r
+.S ( -- )\r
+ \88t\94ᣡ·\81 \88t\97i·i ¥¡·¥\94a.\r
+.\94ᣡ ( -- )\r
+ \88t\94ᣡ·\81 \88t\97i·i ¥¡·¥\94a.\r
+BYE ( -- )\r
+ \93iÎ\91·i \8f{\90\85\94a.\r
+\8f{ ( -- )\r
+ \93iÎ\91·i \8f{\90\85\94a.\r
+CR ( -- )\r
+ ÑÁ¡eµA ¬\81 º\89·i e\97e\94a.\r
+\94a·qº\89 ( -- )\r
+ ÑÁ¡eµA ¬\81 º\89·i e\97e\94a.\r
+HELP ( -- )\r
+ HELP \94a·q·\81 \90{ iµA \94\81Ðe \95¡¶\91 i·i Ìa·© 'HFORTH.HLP'µA¬á Àx´a ¥¡·¥\94a.\r
+ HELP DUP\r
+ Àá\9cñ ¯¡Ç¡¡e '¥A\8da'\9fi ´á\98ý\89A ³a\93e»¡ ÑÁ¡eµA ¥¡·¥\94a.\r
+\95¡¶\91 i ( -- )\r
+ HELP \94a·q·\81 \90{ iµA \94\81Ðe \95¡¶\91 i·i Ìa·© 'HFORTH.HLP'µA¬á Àx´a ¥¡·¥\94a.\r
+ \95¡¶\91 i ¥A\8da\r
+ Àá\9cñ ¯¡Ç¡¡e '¥A\8da'\9fi ´á\98ý\89A ³a\93e»¡ ÑÁ¡eµA ¥¡·¥\94a.\r
+CLS ( -- )\r
+ ÑÁ¡e·i »¡¶\85\94a.\r
+ÑÁ¡e»¡¶¡ ( -- )\r
+ ÑÁ¡e·i »¡¶\85\94a.\r
+CONSTANT ( \88t -- )\r
+ »¡·e \90{ i·¡ ¯¡Åa»© \98\81: ( -- \88t )\r
+ \94ᣡ·\81 \88t·i °á¬á '\8a\88·e\88t' \94a·qµA \90aµ¡\93e ·¡\9fq·a\9d¡ \8a\88·e\88t(¬w®\81)·i\r
+ e\97e\94a.\r
+ 5 CONSTANT FIVE\r
+ Àá\9cñ ¯¡Ç¡¡e 'FIVE'\9ca\93e ·¡\9fq·\81 \8a\88·e\88t·i e\97e\94a. \8ba\9f¡\89¡ \90a¬á\r
+ FIVE\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡ·\81 \85 ¶áµA 5\9fi µ©\9f¥\94a.\r
+\8a\88·e\88t ( \88t -- )\r
+ »¡·e \90{ i·¡ ¯¡Åa»© \98\81: ( -- \88t )\r
+ \94ᣡ·\81 \88t·i °á¬á '\8a\88·e\88t' \94a·qµA \90aµ¡\93e ·¡\9fq·a\9d¡ \8a\88·e\88t(¬w®\81)·i\r
+ e\97e\94a.\r
+ 5 \8a\88·e\88t \94a¬õ\r
+ Àá\9cñ ¯¡Ç¡¡e '\94a¬õ'·¡\9ca\93e ·¡\9fq·\81 \8a\88·e\88t·i e\97e\94a. \8ba\9f¡\89¡ \90a¬á\r
+ \94a¬õ\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡ·\81 \85 ¶áµA 5\9fi µ©\9f¥\94a.\r
+VARIABLE ( -- )\r
+ »¡·e \90{ i·¡ ¯¡Åa»© \98\81: ( -- º\81¡ )\r
+ VARIABLE AGE\r
+ Àá\9cñ ¯¡Ç¡¡e 'AGE'\9ca\93e ·¡\9fq·\81 ¢\81\9fe\88t(¥e®\81)·i e\97e\94a. \8ba\9f¡\89¡ \90a¬á\r
+ AGE\r
+ Àá\9cñ ¯¡Ç¡¡e 'AGE'·\81 \88t·\81 º\81¡\9fi \94ᣡ·\81 \85 ¶áµA µ©\9f¥\94a.\r
+¢\81\9fe\88t ( -- )\r
+ »¡·e \90{ i·¡ ¯¡Åa»© \98\81: ( -- º\81¡ )\r
+ ¢\81\9fe\88t \90a·¡\r
+ Àá\9cñ ¯¡Ç¡¡e '\90a·¡'\9ca\93e ·¡\9fq·\81 ¢\81\9fe\88t(¥e®\81)·i e\97e\94a. \8ba\9f¡\89¡ \90a¬á\r
+ \90a·¡\r
+ Àá\9cñ ¯¡Ç¡¡e '\90a·¡'·\81 \88t·\81 º\81¡\9fi \94ᣡ·\81 \85 ¶áµA µ©\9f¥\94a.\r
+! ( \88t º\81¡ -- )\r
+ \94ᣡ·\81 \85 ¶áµA ·¶\93e º\81¡µA \94ᣡ·\81 \96\81 ¤å¼\81 \88t·i °á\90ý\93e\94a.\r
+ 16 \90a·¡ !\r
+ Àá\9cñ ¯¡Ç¡¡e ¢\81\9fe\88t '\90a·¡'µA 16·i °á\90ý\93e\94a.\r
+@ ( º\81¡ -- \88t )\r
+ \94ᣡ·\81 \85 ¶áµA ·¶\93e º\81¡µA \97e \88t·i \94ᣡµA µ©\9f¥\94a.\r
+ \90a·¡ @\r
+ Àá\9cñ ¯¡Ç¡¡e ¢\81\9fe\88t '\90a·¡'·\81 \88t·i \94ᣡµA µ©\9f¥\94a.\r
+: ( -- )\r
+ \90{ i »µ\8b¡\9fi ¯¡¸bÐe\94a.\r
+ : ¬\81\90{ i \90{ i1 \90{ i2 \90{ i3 ;\r
+ Àá\9cñ °á¬á ¬\81 \90{ i '¬\81\90{ i'·\81 ¸÷·\81\9fi ¯¡¸bÐe\94a.\r
+; ( -- )\r
+ \90{ i »µ\8b¡\9fi \8f{\90\85\94a.\r
+ : ¬\81\90{ i \90{ i1 \90{ i2 \90{ i3 ;\r
+ Àá\9cñ ³e\94a.\r
+( ( -- )\r
+ ')' \90aµ© \98\81\8ca»¡ \8bi·i ¯¡Ç¡»¡ ´g\89¡ \88å\90á\9aå\94a. '('\95¡ Ða\90a·\81 \90{ i·¡£a\9d¡\r
+ \96áµA §¥Äe·¡ ¤e\97a¯¡ Ða\90a ·¡¬w ·¶´á´¡ Ðe\94a.\r
+ ( ·¡\88õ·e \94õ¦\9b·± i·³\93¡\94a.)\r
+ Àá\9cñ ³e\94a. º\81·\81: '('\93e ¯¡Ç± i·¡»¡ e ')'\93e ¯¡Ç± i·¡ ´a\93¡\94a.\r
+." ( -- )\r
+ '"'·¡ \90aµ© \98\81\8ca»¡·\81 \8bi·i ÑÁ¡eµA ¥¡·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81\r
+ ·¶\94a.\r
+ : ¯¡Ðñ ." ·¡ \8bi·¡ ÑÁ¡eµA ¥¡µa»³\93¡\94a." ;\r
+ Àá\9cñ ¯¡Ç¥ \94a·q\r
+ ¯¡Ðñ\r
+ ·¡\9ca\89¡ ¯¡Ç¡¡e ÑÁ¡eµA '·¡ \8bi·¡ ÑÁ¡eµA ¥¡µa»³\93¡\94a.'\9fi ¥¡·¥\94a.\r
+IF ¯¡Åa»© \98\81: ( \88t -- )\r
+ 'IF ... THEN'\90a 'IF ... ELSE ... THEN'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡\r
+ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a. 'IF ... THEN'·\81 ¼b·a\9d¡ ³a·¡¡e \94ᣡ·\81 \85 ¶á\r
+ \88t·¡ 0·¡ ´a\93© \98\81 e 'IF ... THEN' ¬a·¡·\81 \90{ i·¡ ¯¡Åa»¥\94a. 'IF ...\r
+ ELSE ... THEN'·\81 ¼b·a\9d¡ ³a·¡¡e \94ᣡ·\81 \85 ¶á \88t·¡ 0·¡ ´a\93¡¡e 'IF ...\r
+ THEN' ¬a·¡·\81 \90{ i·¡ ¯¡Åa»¡\89¡, \88t·¡ 0·¡¡e 'ELSE ... THEN' ¬a·¡·\81\r
+ \90{ i·¡ ¯¡Åa»¥\94a.\r
+ : ?DUP DUP IF DUP THEN ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 3 ?DUP\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 3·i 2 \88\81 µ©\9f¥\94a.\r
+ 0 ?DUP\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i 1 \88\81 µ©\9f¥\94a.\r
+¡e ¯¡Åa»© \98\81: ( \88t -- )\r
+ '¡e ... \9ca'\90a '¡e ... ´a\93¡¡e ... \9ca'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡\r
+ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a. '¡e ... \9ca'·\81 ¼b·a\9d¡ ³a·¡¡e \94ᣡ·\81 \85 ¶á\r
+ \88t·¡ 0·¡ ´a\93© \98\81 e '¡e ... \9ca' ¬a·¡·\81 \90{ i·¡ ¯¡Åa»¥\94a. '¡e ...\r
+ ´a\93¡¡e ... \9ca'·\81 ¼b·a\9d¡ ³a·¡¡e \94ᣡ·\81 \85 ¶á \88t·¡ 0·¡ ´a\93¡¡e '¡e\r
+ ... \9ca' ¬a·¡·\81 \90{ i·¡ ¯¡Åa»¡\89¡, \88t·¡ 0·¡¡e '´a\93¡¡e ... \9ca' ¬a·¡·\81\r
+ \90{ i·¡ ¯¡Åa»¥\94a.\r
+ : ?¥A\8da ¥A\8da ¡e ¥A\8da \9ca ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 3 ?¥A\8da\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 3·i 2 \88\81 µ©\9f¥\94a.\r
+ 0 ?¥A\8da\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 0·i 1 \88\81 µ©\9f¥\94a.\r
+ELSE ¯¡Åa»© \98\81: ( -- )\r
+ 'IF ... ELSE ... THEN'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81\r
+ ·¶\94a. \94ᣡ·\81 \85 ¶á \88t·¡ 0·¡ ´a\93¡¡e 'IF ... ELSE' ¬a·¡·\81 \90{ i·¡\r
+ ¯¡Åa»¡\89¡, \88t·¡ 0·¡¡e 'ELSE ... THEN' ¬a·¡·\81 \90{ i·¡ ¯¡Åa»¥\94a.\r
+ : TEST IF DUP ELSE DROP THEN ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 3 1 TEST\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 3·i 2 \88\81 µ©\9f¥\94a.\r
+ 3 0 TEST\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA ´a¢\81 \88õ\95¡ µ©\9f¡»¡ ´g\93e\94a.\r
+´a\93¡¡e ¯¡Åa»© \98\81: ( -- )\r
+ '¡e ... ´a\93¡¡e ... \9ca'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81\r
+ ·¶\94a. \94ᣡ·\81 \85 ¶á \88t·¡ 0·¡ ´a\93¡¡e '¡e ... ´a\93¡¡e' ¬a·¡·\81 \90{ i·¡\r
+ ¯¡Åa»¡\89¡, \88t·¡ 0·¡¡e '´a\93¡¡e ... \9ca' ¬a·¡·\81 \90{ i·¡ ¯¡Åa»¥\94a.\r
+ : ¯¡Ðñ ¡e ¥A\8da ´a\93¡¡e ¤á\9da \9ca ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 3 1 ¯¡Ðñ\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA 3·i 2 \88\81 µ©\9f¥\94a.\r
+ 3 0 ¯¡Ðñ\r
+ Àá\9cñ ¯¡Ç¡¡e \94ᣡµA ´a¢\81 \88õ\95¡ µ©\9f¡»¡ ´g\93e\94a.\r
+THEN ¯¡Åa»© \98\81: ( -- )\r
+ 'IF ... THEN'\90a 'IF ... ELSE ... THEN'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡\r
+ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a.\r
+\9ca ¯¡Åa»© \98\81: ( -- )\r
+ '¡e ... \9ca'\90a '¡e ... ´a\93¡¡e ... \9ca'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡\r
+ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a.\r
+ENDIF ¯¡Åa»© \98\81: ( -- )\r
+ 'IF ... ENDIF'\90a 'IF ... ELSE ... ENDIF'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡\r
+ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a.\r
+BEGIN ¯¡Åa»© \98\81: ( -- )\r
+ 'BEGIN ... UNTIL'\90a 'BEGIN ... WHILE ... REPEAT'·\81 ¼b·a\9d¡ ³aµa\r
+ \88á\97s¯¡Ç±·\81 Àá·q·i Îa¯¡Ðe\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a.\r
+·¡¹A¦\81Èá ¯¡Åa»© \98\81: ( -- )\r
+ '·¡¹A¦\81Èá ... \8ca»¡'\90a '·¡¹A¦\81Èá ... \95·´e... \88á\97sÐ\81'·\81 ¼b·a\9d¡ ³aµa\r
+ \88á\97s¯¡Ç±·\81 Àá·q·i Îa¯¡Ðe\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a.\r
+UNTIL ¯¡Åa»© \98\81: ( \88t -- )\r
+ 'BEGIN ... UNTIL'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a.\r
+ '\88t'·¡ 0·¡ ´a\93¡¡e \88á\97s¯¡Ç±·i ¤õ´á\90a 'UNTIL' \94a·q·\81 \90{ i·¡ ¯¡Åa»¡\89¡\r
+ '\88t'·¡ 0·¡¡e 'BEGIN ... UNTIL' ¬a·¡·\81 \90{ i·i \88á\97s¯¡Ç¥\94a.\r
+ : COUNTDOWN BEGIN DUP . 1 - DUP 0 = UNTIL ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 5 COUNTDOWN\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '5 4 3 2 1'·i ¥¡·¥\94a.\r
+\8ca»¡ ¯¡Åa»© \98\81: ( \88t -- )\r
+ '·¡¹A¦\81Èá ... \8ca»¡'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81 ·¶\94a.\r
+ '\88t'·¡ 0·¡ ´a\93¡¡e \88á\97s¯¡Ç±·i ¤õ´á\90a '\8ca»¡' \94a·q·\81 \90{ i·¡ ¯¡Åa»¡\89¡\r
+ '\88t'·¡ 0·¡¡e '·¡¹A¦\81Èá ... \8ca»¡' ¬a·¡·\81 \90{ i·i \88á\97s¯¡Ç¥\94a.\r
+ : ¦\81Èá.´a\9c\81\9d¡.A ·¡¹A¦\81Èá ¥A\8da . 1 - ¥A\8da 0 = \8ca»¡ ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 5 ¦\81Èá.´a\9c\81\9d¡.A\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '5 4 3 2 1'·i ¥¡·¥\94a.\r
+WHILE ¯¡Åa»© \98\81: ( \88t -- )\r
+ 'BEGIN ... WHILE ... REPEAT'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e\r
+ ³i ®\81 ·¶\94a. '\88t'·¡ 0·¡ ´a\93¡¡e \88á\97s¯¡Ç±·¡ \89\81¢\96A´á 'WHILE' \94a·q·\81\r
+ \90{ i·¡ ¯¡Åa»¡\89¡ '\88t'·¡ 0·¡¡e \88á\97s¯¡Ç±·i ¤õ´á\90a 'REPEAT' \94a·q·\81\r
+ \90{ i·¡ ¯¡Åa»¥\94a.\r
+ : COUNTDOWN BEGIN DUP WHILE DUP . 1 - REPEAT ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 5 COUNTDOWN\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '5 4 3 2 1'·i ¥¡·¥\94a.\r
+\95·´e ¯¡Åa»© \98\81: ( \88t -- )\r
+ '·¡¹A¦\81Èá ... \95·´e... \88á\97sÐ\81'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e\r
+ ³i ®\81 ·¶\94a. '\88t'·¡ 0·¡ ´a\93¡¡e \88á\97s¯¡Ç±·¡ \89\81¢\96A´á '\95·´e' \94a·q·\81\r
+ \90{ i·¡ ¯¡Åa»¡\89¡ '\88t'·¡ 0·¡¡e \88á\97s¯¡Ç±·i ¤õ´á\90a '\88á\97sÐ\81' \94a·q·\81\r
+ \90{ i·¡ ¯¡Åa»¥\94a.\r
+ : ¦\81Èá.´a\9c\81\9d¡.A ·¡¹A¦\81Èá ¥A\8da \95·´e ¥A\8da . 1 - \88á\97sÐ\81 ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 5 ¦\81Èá.´a\9c\81\9d¡.A\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '5 4 3 2 1'·i ¥¡·¥\94a.\r
+REPEAT ¯¡Åa»© \98\81: ( -- )\r
+ 'BEGIN ... WHILE ... REPEAT'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e\r
+ ³i ®\81 ·¶\94a. 'BEGIN' \94a·q·a\9d¡ \88á\97s¯¡Ç±·i \89\81¢Ðe\94a.\r
+\88á\97sÐ\81 ¯¡Åa»© \98\81: ( -- )\r
+ '·¡¹A¦\81Èá ... \95·´e... \88á\97sÐ\81'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e\r
+ ³i ®\81 ·¶\94a. '·¡¹A¦\81Èá' \94a·q·a\9d¡ \88á\97s¯¡Ç±·i \89\81¢Ðe\94a.\r
+DO ¯¡Åa»© \98\81: ( \88t1 \88t2 -- )\r
+ ¤e\97a¯¡ 'DO ... LOOP'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81\r
+ ·¶\94a. '\88t2'\88a Ða\90a³¢ Äá¹a¬á '\88t1'·¡ \96I \98\81\8ca»¡ 'DO ... LOOP' ¬a·¡·\81\r
+ \90{ i·i \88á\97s¯¡Ç¥\94a.\r
+ : 5STARS 5 0 DO ." *" LOOP ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 5STARS\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '*****'\88a Îa¯¡\96E\94a.\r
+ \91 ¯¡Åa»© \98\81: ( \88t1 \88t2 -- )\r
+ ¤e\97a¯¡ ' \91 ... \95©´a'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81\r
+ ·¶\94a. '\88t2'\88a Ða\90a³¢ Äá¹a¬á '\88t1'·¡ \96I \98\81\8ca»¡ ' \91 ... \95©´a' ¬a·¡·\81\r
+ \90{ i·i \88á\97s¯¡Ç¥\94a.\r
+ : \94a¬õ¥i 5 0 \91 ." *" \95©´a ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ \94a¬õ¥i\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '*****'\88a Îa¯¡\96E\94a.\r
+LOOP ¯¡Åa»© \98\81: ( -- )\r
+ ¤e\97a¯¡ 'DO ... LOOP'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81\r
+ ·¶\94a. '\88t2'\88a Ða\90a³¢ Äá¹a¬á '\88t1'·¡ \96I \98\81\8ca»¡ 'DO ... LOOP' ¬a·¡·\81\r
+ \90{ i·i \88á\97s¯¡Ç¥\94a.\r
+\95©´a ¯¡Åa»© \98\81: ( -- )\r
+ ¤e\97a¯¡ ' \91 ... \95©´a'·\81 ¼b·a\9d¡ ³a·¥\94a. i»µ\8b¡ ¬wÈ\81µA¬á e ³i ®\81\r
+ ·¶\94a. '\88t2'\88a Ða\90a³¢ Äá¹a¬á '\88t1'·¡ \96I \98\81\8ca»¡ ' \91 ... \95©´a' ¬a·¡·\81\r
+ \90{ i·i \88á\97s¯¡Ç¥\94a.\r
+I ¯¡Åa»© \98\81: ( -- \88t )\r
+ \91\95©·¡ \88a\9f¡Ç±®\81\9d¡ ¤e\97a¯¡ 'DO ... LOOP' ´eµA¬á ³e\94a.\r
+ '\88t2 \88t1 DO I LOOP'µA¬á '\88a'\93e Àa\9d\81\9d¡ '\88t1'µA¬á '\88t2'-1 \8ca»¡·\81\r
+ \88t\97i·i \94ᣡµA µ©\9f¥\94a.\r
+ : COUNT 0 DO I . LOOP ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 5 COUNT\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '0 1 2 3 4'\9fi ¥¡·¥\94a.\r
+\88a ¯¡Åa»© \98\81: ( -- \88t )\r
+ "\88a(\9f¡Ç±®\81)." \91\95©·¡ \88a\9f¡Ç±®\81\9d¡ ¤e\97a¯¡ ' \91 ... \95©´a' ´eµA¬á ³e\94a.\r
+ '\88t2 \88t1 \91 \88a \95©´a'µA¬á '\88a'\93e Àa\9d\81\9d¡ '\88t1'µA¬á '\88t2'-1 \8ca»¡·\81\r
+ \88t\97i·i \94ᣡµA µ©\9f¥\94a.\r
+ : ¤å.A\8b¡ 0 \91 \88a . \95©´a ;\r
+ Àá\9cñ \90{ i·i »µ\89¡\r
+ 5 ¤å.A\8b¡\r
+ Àá\9cñ ¯¡Ç¡¡e ÑÁ¡eµA '0 1 2 3 4'\9fi ¥¡·¥\94a.\r
+IMMEDIATE ( -- )\r
+ ¤w\8bq »¡·e i·i i»µ\8b¡ ¬wÈ\81µA¬á\95¡ ¯©Ð\97\96A\93e '¤a\9d¡ i'\9d¡ e\97e\94a.\r
+¤a\9d¡ i ( -- )\r
+ ¤w\8bq »¡·e i·i i»µ\8b¡ ¬wÈ\81µA¬á\95¡ ¯©Ð\97\96A\93e '¤a\9d¡ i'\9d¡ e\97e\94a.\r
+' ( -- º\81¡ )\r
+ "'" \94a·qµA \90aµ¡\93e \90{ i·\81 º\81¡\9fi \94ᣡµA \90q\8b¥\94a.\r
+\88{·e i ( º\81¡ -- )\r
+ '\88{·e i' \94a·qµA \90aµ¡\93e ·¡\9fq·a\9d¡, \94ᣡµA º\81¡\88a ·¶\93e \90{ i\89Á \99¢\88{·e\r
+ ·©·i Ða\93e \90{ i·i e\97e\94a.\r
+ ' DUP \88{·e i ¥A\8da\r
+ Àá\9cñ ¯¡Ç¡¡e DUP µÁ \88{·e ·©·i Ða\93e \90{ i '¥A\8da'\9fi e\97e\94a.\r
+º\89ÑÁ¡e ( º\89®\81 -- )\r
+ ´a\9c\81¬á¦\81Èá \8bi¸a\88a ¥¡·© º\89 ®\81\9fi ¸÷Ðe\94a.\r
+sin* ( \8b©·¡ \88b\95¡ -- \8b©·¡*sin[\88b\95¡] )\r
+ \8b©·¡µÁ \88b\95¡\9d¡¦\81Èá \8b©·¡µA ¬q\88b§¡\9fi \89³Ðe \88t·i \89\81¬eÐe\94a.\r
+cos* ( \8b©·¡ \88b\95¡ -- \8b©·¡*cos[\88b\95¡] )\r
+ \8b©·¡µÁ \88b\95¡\9d¡¦\81Èá \8b©·¡µA ¬q\88b§¡\9fi \89³Ðe \88t·i \89\81¬eÐe\94a.\r
+\9d¡.\8ba´á ( x y -- )\r
+ »¡\8bq ¸a\9f¡µA¬á \88á¦\82¹ÁÎa (x,y)\9d¡ ¬å·i \8bu\93e\94a. ÑÁ¡eµA \8bq·i \8bu\93e \88a¸w\r
+ \8b¡¥¥¸â·¥ \90{ i·¡\94a. \88á¦\82 ¶\91»¢·± \90{ i '¹A¸a\9f¡\9d¡'µÁ ' eÇq.\88a'µA\r
+ ³a·¥\94a.\r
+\88á¦\82¥¡µa ( -- )\r
+ ÑÁ¡eµA \88á¦\82·¡ ·¶·a¡e »¡¶\81\89¡ ´ô·a¡e ¥¡·¥\94a.\r
+¤wз ( -- º\81¡ )\r
+ ¢\81\9fe\88t '¤wз'. \88á¦\82·\81 ¤wз·¡ \94q\89a ·¶\94a.\r
+\88a\9d¡¶áá ( -- º\81¡ )\r
+ ¢\81\9fe\88t '\88a\9d¡¶áá'. \88á¦\82·\81 x ¹ÁÎa\88a \94q\89a ·¶\94a.\r
+A\9d¡¶áá ( -- º\81¡ )\r
+ ¢\81\9fe\88t '\88a\9d¡¶áá'. \88á¦\82·\81 y ¹ÁÎa\88a \94q\89a ·¶\94a.\r
+ eÇq.\88a ( \88a\9d¡\88á\9f¡ A\9d¡\88á\9f¡ -- )\r
+ \88á¦\82·¡ »¡\8bq ¹ÁÎa (x,y)µA¬á (x+\88a\9d¡\88á\9f¡, y+A\9d¡\88á\9f¡)\9d¡ ¶\91»¢·¥\94a.\r
+ \90{ i '´|·a\9d¡'µÁ '\96á\9d¡'µA ³a·¥\94a.\r
+__µ¡\9fe½¢.ÑÉ\8d© ( \88á\9f¡ ÒU®\81 -- )\r
+ \88á\9f¡ eÇq \88a\89¡ 10 \95¡ µ¡\9fe½¢·a\9d¡ \95¡\93e \88õ·i ÒU®\81 eÇq \96AÎ\89·¡Ðe\94a.\r
+ \90{ i 'µ¡\9fe½¢.ÑÉ\8d©'µA ³a·¥\94a.\r
+__¶E½¢.ÑÉ\8d© ( \88á\9f¡ ÒU®\81 -- )\r
+ \88á\9f¡ eÇq \88a\89¡ 10 \95¡ ¶E½¢·a\9d¡ \95¡\93e \88õ·i ÒU®\81 eÇq \96AÎ\89·¡Ðe\94a.\r
+ \90{ i '¶E½¢.ÑÉ\8d©'µA ³a·¥\94a.\r
+\8a\8a\89A ( -- )\r
+ \88á¦\82·¡ »¡\90a\88e ¸aÂá\9fi \8a\8a\89A \8ba\9f¥\94a.\r
+\88a\93i\89A ( -- )\r
+ \88á¦\82·¡ »¡\90a\88e ¸aÂá\9fi \88a\93i\89A \8ba\9f¥\94a.\r
+¦\95\97i´á ( -- )\r
+ \88á¦\82·¡ »¡\90a\88e ¸aÂá\9fi \90q\8b¡»¡ ´g\93e\94a.\r
+¦\95\90\81\9da ( -- )\r
+ \88á¦\82·¡ º\89·i \8ba·a¡a \88e\94a.\r
+ÑÁ¡e»¡¶¡ ( -- )\r
+ \88á¦\82·i ¹A¸a\9f¡\9d¡ ¥¡\90\81\89¡ ÑÁ¡e·i »¡¶\85\94a.\r
+½¡\88\85ÑÁ¡e ( -- )\r
+ \8bi¸a\9fi ´a\9c\81 8 º\89µA e ¥¡·¥\94a.\r
+µ¥ÑÁ¡e ( -- )\r
+ \8bi¸a\9fi ¸åÁA ÑÁ¡eµA ¥¡·¥\94a.\r
+¹A¸a\9f¡\9d¡ ( -- )\r
+ \88á¦\82·\81 á\9f¡\9fi ¶á½¢·a\9d¡ Ð\81¬á ÑÁ¡e \88a¶\85\95A\9d¡ ¥¡\90\81\89¡ ÑÁ¡e·i »¡¶\85\94a.\r
+\95¡.µ¡\9fe½¢ ( \88b\95¡ -- )\r
+ \88á¦\82·\81 ¤wз·i \88b\95¡ eÇq µ¡\9fe½¢·a\9d¡ \95©\9f¥\94a.\r
+\95¡.¶E½¢ ( \88b\95¡ -- )\r
+ \88á¦\82·\81 ¤wз·i \88b\95¡ eÇq ¶E½¢·a\9d¡ \95©\9f¥\94a.\r
+´|·a\9d¡ ( \88á\9f¡ -- )\r
+ \88á¦\82·¡ \88á\9f¡ eÇq ´|·a\9d¡ \88e\94a.\r
+\96á\9d¡ ( \88á\9f¡ -- )\r
+ \88á¦\82·¡ \88á\9f¡ eÇq \96á\9d¡ \88e\94a.\r
+µ¡\9fe½¢.ÑÉ\8d© ( ¤e»¡\9fq \88b\95¡ -- )\r
+ º\81´á»¥ ¤e»¡\9fq\89Á \88b\95¡\9d¡ µ¡\9fe½¢·a\9d¡ ÑÉ\8d©·i \8ba\9f¥\94a.\r
+µ¡\9fe½¢.¶¥ ( ¤e»¡\9fq -- )\r
+ º\81´á»¥ ¤e»¡\9fq·a\9d¡ µ¡\9fe½¢·a\9d¡ \95·\8ba\9ca£¡\9fi \8ba\9f¥\94a.\r
+¶E½¢.ÑÉ\8d© ( ¤e»¡\9fq \88b\95¡ -- )\r
+ º\81´á»¥ ¤e»¡\9fq\89Á \88b\95¡\9d¡ ¶E½¢·a\9d¡ ÑÉ\8d©·i \8ba\9f¥\94a.\r
+¶E½¢.¶¥ ( ¤e»¡\9fq -- )\r
+ º\81´á»¥ ¤e»¡\9fq·a\9d¡ ¶E½¢·a\9d¡ \95·\8ba\9ca£¡\9fi \8ba\9f¥\94a.\r
+\91A¡¡ ( Ça\8b¡ --\r
+ º\81´á»¥ Ça\8b¡·\81 \91A¡¡\9fi \8ba\9f¥\94a.\r
+\89sÃ¥\91A¡¡ ( -- )\r
+ \88b ¥e·\81 \8b©·¡\88a 100, 200, 300, 400 ·¥ \91A¡¡\9fi \89sÁa \8ba\9f¥\94a.\r
+\94a·¡´a¡¥\97a ( -- )\r
+ \94a·¡´a¡¥\97a ¡¡´··i \8ba\9f¥\94a.\r
+\8bµ¤i ( Ça\8b¡ -- )\r
+ \8bµ¤i ¡¡´··i \8ba\9f¥\94a.\r
+µa¬õ\8bµ¤i ( Ça\8b¡ -- )\r
+ 60 \95¡³¢ \95©´a\88a¡a \8bµ¤i 6 \88\81\9fi \8ba\9f¥\94a.\r
+¤a\9cq\88\81§¡ ( -- )\r
+ ¤a\9cq\88\81§¡ ¡¡´··i \8ba\9f¥\94a.\r
+\8d¹·¼ ( Ça\8b¡ -- )\r
+ \8d¹·¼ ¡¡´··i \8ba\9f¥\94a.\r
+\8d¹ ( Ça\8b¡ -- )\r
+ \8d¹·¼ 8 \88\81·¥ \8d¹·i \8ba\9f¥\94a.\r
+\94a\9fe\8d¹·¼ ( Ça\8b¡ -- )\r
+ \94a\9fe ¡¡´··\81 \8d¹·¼·i \8ba\9f¥\94a.\r
+\94a\9fe\8d¹ ( Ça\8b¡ -- )\r
+ \8d¹·¼ 6 \88\81·¥ \8d¹·i \8ba\9f¥\94a.\r
+Ð\95¬i ( Ça\8b¡ -- )\r
+ ¢\89\89i ¡¡´··i \8ba\9f¥\94a.\r
+Ð\81 ( Ça\8b¡ -- )\r
+ Ð\81 ¡¡´··i \8ba\9f¥\94a.\r
+\88bÑw ( Ça\8b¡ ¡¡¬á\9f¡®\81 -- )\r
+ ¸÷\94a\88bÑw·i \8ba\9f¥\94a.\r
+¥i ( ¥e·\81_®\81 ÒU®\81 -- )\r
+ ¥i ¡¡´··i \8ba\9f¥\94a.\r
+\94a\88bÑw ( Ça\8b¡ \88b\95¡ -- )\r
+ Ça\8b¡µÁ \88b\95¡µA \98a\9ca µa\9cá ¡¡´··\81 \94a\88bÑw\89Á ¥i ¡¡´··i \8ba\9f¥\94a.\r
+\94a\88bÑw¸a\9cw5 ( -- )\r
+ \90{ i '\94a\88bÑw'·i ·¡¶wÐe ¸a\9cw\r
+\94a\88bÑw¸a\9cw4 ( -- )\r
+ \90{ i '\94a\88bÑw'·i ·¡¶wÐe \94a\9fe ¸a\9cw\r
+\94a\88bÑw¸a\9cw12 ( -- )\r
+ \90{ i '\94a\88bÑw'·i ·¡¶wÐe \99¡ \94a\9fe ¸a\9cw\r
+\90a¢\81 ( \88a»¡\88b\95¡ \88a»¡\8b©·¡ \88a»¡Ã¡\8b¡®\81 -- )\r
+ ¯a¯a\9d¡\9fi \96A¦\89\9cá¬á (recursive call) \90a¢\81 ¡¡´··i \8ba\9f¥\94a.\r
+§¡\93iÇa\8b¡ ( -- º\81¡ )\r
+ \90{ i '¶w'µA¬á ¬a¶wÐa\93e ¢\81\9fe\88t\r
+¶w ( \90a·¡ -- )\r
+ ¯a¯a\9d¡\9fi \96A¦\89\9cá¬á ¶w\8ba\9f±(dragon curve)·i \8ba\9f¥\94a.\r
--- /dev/null
+\\r
+\ LOG.F\r
+\ Capture screen output in a textfile for hForth.\r
+\\r
+\ 1996. 2. 28.\r
+\ Wonyong Koh.\r
+\\r
+\ Usage:\r
+\ LOGON ( -- )\r
+\ ÑÁ¡e Â\89\9db·i HFORTH.LOGµA \88i¢\81\9f¡Ðs\93¡\94a. Â\89\9db \88a\9f¡Ç±¯©Ð\97\88t 'emit·¡\r
+\ ¤a\8eå Ò\81µA\93e (µ\81\9fi \97i´á, HIOMULT?.F·\81 TEXT\90a HGRAPHIC·i ¯¡Ç¥ Ò\81\90a\r
+\ Í¡¯a ¯¡¯aÉQ·¡ '?'·i ¥¡µa ¸i¡µ·i ´i\9f¥ \89w¶\81) LOGON·¡\9ca\89¡ \94a¯¡ ¯¡Åa´¡\r
+\ \88i¢\81\9f¡\88a \89\81¢\96S\93¡\94a.\r
+\ Start to save screen output in HFORTH.LOG.\r
+\ Please reissue 'LOGON' after changing "'emit" vector.\r
+\ (for example, after TEXT or HGRAPHIC of HIOMULT?.F)\r
+\ LOGOFF ( -- )\r
+\ HFORTH.LOG\9fi \94h\89¡ ÑÁ¡e \88i¢\81\9f¡\9fi ñÂ\93\93¡\94a.\r
+\ Close HFORTH.LOG and stop saving screen output.\r
+\r
+MARKER ~LOG\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+\r
+GET-ORDER DOS-WORDLIST SWAP 1+ SET-ORDER\r
+DOS-WORDLIST SET-CURRENT\r
+\r
+HEX\r
+8000 CONSTANT invalid-fid\r
+\r
+invalid-fid VALUE logfid\r
+0 VALUE old'emit\r
+CREATE LogBUFFER 1 CHARS ALLOT ALIGN\r
+\r
+: LogEMIT ( char -- )\r
+ DUP LogBUFFER C! LogBUFFER 1 CHARS logfid WRITE-FILE THROW\r
+ old'emit EXECUTE ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+: LOGON\r
+ logfid CLOSE-FILE DROP\r
+ S" HFORTH.LOG" W/O OPEN-FILE\r
+ ?DUP IF\r
+ DUP [ 2 iorOffset + ] LITERAL <> \ file not found?\r
+ IF THROW THEN\r
+ 2DROP S" HFORTH.LOG" W/O CREATE-FILE THROW TO logfid\r
+ ELSE\r
+ TO logfid\r
+ logfid FILE-SIZE THROW logfid REPOSITION-FILE THROW\r
+ THEN\r
+ CR ." All characters on screen will be saved in HFORTH.LOG until 'emit is revectored."\r
+ CR ." ÑÁ¡eµA ¥¡·¡\93e \8bi¸a\97i·e ¡¡\96\81 'emit·¡ ¤a\8eá\8b¡ ¸å\8ca»¡ HFORTH.LOGµA \88i¢\81\9f¡\96S\93¡\94a." CR\r
+ 'emit ['] LogEMIT <> IF\r
+ 'emit TO old'emit\r
+ ['] LogEMIT TO 'emit\r
+ THEN ;\r
+\r
+: LOGOFF\r
+ logfid CLOSE-FILE\r
+ invalid-fid TO logfid\r
+ old'emit TO 'emit ;\r
+\r
+LOGON\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\ BASE must be DECIMAL.\r
+\ 'heapsize' is adjusted to 8 k CELLS from original 16 k CELLS for 8086 hForth.\r
+\ Implementation words are hidden in MEMORY-ALLOC-WORDLIST.\r
+\ Feb. 20, 1996\r
+\ Wonyong Koh\r
+\r
+BASE @\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM@ RAM [THEN]\r
+GET-ORDER GET-CURRENT\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+WORDLIST WORDLIST-NAME MEMORY-ALLOC-WORDLIST\r
+MEMORY-ALLOC-WORDLIST SET-CURRENT\r
+GET-ORDER MEMORY-ALLOC-WORDLIST SWAP 1+ SET-ORDER\r
+\r
+\ This is freeware, copyright Gordon Charlton, 12th of September 1994.\r
+\ Copy and distribute it. Use it. Don't mess with this file. Acknowledge\r
+\ its use. I make no guarentees as to its fitness for any purpose. Tell\r
+\ me about any bugs. Tell me how much you like it.\r
+\r
+\ An ANS Heap\r
+\r
+\ This is an implementation of the ANS Forth Memory-Allocation Word Set.\r
+\ This is an ANS standard program that has the following environmental\r
+\ dependency - two's complement arithmetic. It requires four words\r
+\ from the core extension: 0> NIP TUCK \\r
+\r
+\ (If you go to the trouble of checking these claims, please e-mail me\r
+\ with your findings; gordon@charlton.demon.co.uk)\r
+\r
+\ There are five broad areas that the program covers;\r
+\r
+\ 1, General purpose extensions to the Forth system.\r
+\r
+\ 2, Creation of the heap and associated use of the data space.\r
+\r
+\ 3, Allocation of space from the heap.\r
+\r
+\ 4, Releasing space back to the heap.\r
+\r
+\ 5, Altering the size of allocated heap space.\r
+\r
+\r
+\ The ANS word set consists of three words, ALLOCATE, FREE, and RESIZE\r
+\ which give the minimum functionality required to use the heap. These are\r
+\ given in areas 3, 4 and 5 respectively.\r
+\r
+\ The heap is maintained as a doubly linked ordered circular list of nodes\r
+\ with an additional field noting the size of each node and whether it is in\r
+\ use. The size of the heap is specified by the constant HEAPSIZE. The\r
+\ constant HYSTERESIS controls the amount of spare space that is added to\r
+\ an allocation, to reduce the need for block moves during resizing.\r
+\r
+\ Initially there is only one node, the size of the heap. Aditional nodes\r
+\ are created by dividing an existing node into two parts. Nodes are removed\r
+\ by marking as free, and merging with adjoining free nodes. Nodes are\r
+\ altered in size by merging with a following free node, if possible, and a\r
+\ node being created above the new size of the node, if needed, or by\r
+\ allocating a new node and block moving the data field if necessary.\r
+\r
+\ Finding an available node is done by sequential search and comparison. The\r
+\ first node to be found that is large enough is used for allocation. Each\r
+\ search starts from the node most recently allocated, making this a\r
+\ "nextfit" algorithm. The redundancy in the head fields is required to\r
+\ optimise the search loop, as is the use of a sentinel to terminate the\r
+\ search once every node has been looked at, by always succeeding. A final\r
+\ refinement is the use of the sign bit of the size field to mark "in-use"\r
+\ nodes so that they are disregarded without a separate test.\r
+\r
+\r
+\ **1** General Purpose Extensions\r
+\r
+: unique ( ) VARIABLE ;\r
+\\r
+\ Defining word. Each child returns a different non-zero number. The\r
+\ standard introduces the need for unique identifiers in the form of IORs\r
+\ and THROW codes, but provides no means for generating them. This does\r
+\ the trick.\r
+\r
+: k ( n--n) 1024 * ;\r
+\\r
+\ A convenient way of referring to large numbers. Multiplies a number by\r
+\ 1024.\r
+\r
+0 1 2 UM/MOD NIP 1- CONSTANT maxpos\r
+\\r
+\ The largest positive single length integer.\r
+\r
+\r
+\ **2** Heap Creation\r
+\r
+\ ANSI Heap --- Constants\r
+\r
+8 k CELLS CONSTANT heapsize\r
+\\r
+\ Number of address units of data space that the heap occupies.\r
+\r
+4 CELLS 1- CONSTANT hysteresis\r
+\\r
+\ Node lengths are rounded up according to the value of HYSTERESIS to\r
+\ reduce the number of block moves during RESIZE operations. The value of\r
+\ this constant must be one less than a power of two and at least equal to\r
+\ one less than the size of a cell.\r
+\r
+unique allocationerror\r
+\\r
+\ Indicates there is less contiguous heap space available than required.\r
+\r
+3 CELLS CONSTANT headsize\r
+\\r
+\ A node on the heap consists of a three cell head followed by a variable\r
+\ length data space. The first cell in the head points to the next node in\r
+\ the heap. The second cell indicates the size of the node, and the third\r
+\ points to the previous node. The second cell is negated to indicate the\r
+\ node is in use. The heap consists of a doubly linked circular list. There\r
+\ is no special notation to indicate an empty list, as this situation\r
+\ cannot occur.\r
+\r
+: adjustsize ( n--n) headsize + hysteresis OR 1+ ;\r
+\\r
+\ The amount of space that is requested for a node needs adjusting to\r
+\ include the length of the head, and to incorporate the hysteresis.\r
+\r
+0 adjustsize CONSTANT overhead\r
+\\r
+\ The size of the smallest possible node.\r
+\r
+\r
+\ ANSI Heap --- Structure\r
+\r
+CREATE sentinel HERE CELL+ , maxpos , 0 , 0 ,\r
+\\r
+\ A dummy node used to speed up searching the heap. The search, which is\r
+\ for a node larger than or equal to the specified size will always succeed.\r
+\ The cell that points to the next node is set up so that the there is a zero\r
+\ three cells ahead of where it points, where the pointer to the previous\r
+\ node (ie the sentinel) should be. This is a special value that indicates the\r
+\ search has failed.\r
+\r
+CREATE heap heapsize ALLOT\r
+\\r
+\ The heap is as described in HEADSIZE.\r
+\r
+VARIABLE nextnode\r
+\\r
+\ Searching is done using a "nextfit" algorithm. NEXTNODE points to the\r
+\ most recently allocated node to indicate where the next search is to\r
+\ start from.\r
+\r
+: >size ( addr--addr) CELL+ ;\r
+\\r
+\ Move from the "next" cell in the node head to the "size" cell. Within the\r
+\ word set nodes are referred to by the address of the "next" cell.\r
+\ Externally they are referred to by the address of the start of the data\r
+\ field.\r
+\r
+: >prev ( addr--addr) 2 CELLS + ;\r
+\\r
+\ Move from the "next" cell to the "previous" cell.\r
+\r
+: init-heap ( ) heap DUP nextnode !\r
+ DUP DUP !\r
+ DUP heapsize OVER >size !\r
+ >prev ! ;\r
+\\r
+\ Initially the heap contains only one node, which is the same size as the\r
+\ heap. Both the "next" cell and the "previous" cell point to the "next"\r
+\ cell, as does NEXTNODE.\r
+\r
+init-heap\r
+\r
+\ **3** Heap Allocation\r
+\r
+\ ANSI Heap --- List Searching\r
+\r
+: attach ( addr) >prev @\r
+ DUP sentinel ROT !\r
+ sentinel >prev ! ;\r
+\\r
+\ The sentinel is joined into the nodelist. The "next" field of the node\r
+\ preceding the one specified (addr) is set to point to the sentinel, and\r
+\ the "prev" field of the sentinel to point to the node that points to the\r
+\ sentinel.\r
+\r
+: search ( addr size--addr|0)\r
+ >R BEGIN 2@ SWAP R@ < INVERT UNTIL\r
+ R> DROP >prev @ ;\r
+\\r
+\ Search the nodelist, starting at the node specified (addr), for a free\r
+\ node larger than or equal to the specified size. Return the address of the\r
+\ first node that matches, or zero for no match. The heap structure is set up\r
+\ to make this a near optimal search loop. The "size" field is next to the "next"\r
+\ field so that both can be collected in a single operation (2@). Nodes in\r
+\ use have negated sizes so they never match the search. The "previous"\r
+\ field is included to allow the search to overshoot the match by one node\r
+\ and then link back outside the loop, rather than remembering the address\r
+\ of the node just examined. The sentinel removes the need for a separate\r
+\ test for failure. SEARCH assumes the sentinel is in place.\r
+\r
+: detach ( addr) DUP >prev @ ! ;\r
+\\r
+\ Remake the link from the node prior to the one specified to the one\r
+\ specified. This will remove the sentinel if it is attached here. (It will\r
+\ be.)\r
+\r
+: findspace ( size--addr|0) nextnode @\r
+ DUP attach\r
+ DUP ROT search\r
+ SWAP detach ;\r
+\\r
+\ Search the nodelist for a node larger or equal to that specified. Return\r
+\ the address of a suitable node, or zero if none found. The search starts at\r
+\ the node pointed to by NEXTNODE, the sentinal temporarily attached, the\r
+\ search proceeded with and the sentinel detached.\r
+\r
+\r
+\ ANSI Heap --- Head Creation\r
+\r
+: fits ( size addr--flag) >size @ SWAP - overhead < ;\r
+\\r
+\ Returns TRUE if the size of the node specified is the same as the\r
+\ specified size, or larger than it by less than the size of the smallest\r
+\ possible node. Returns FALSE otherwise.\r
+\r
+: togglesize ( addr) >size DUP @ NEGATE SWAP ! ;\r
+\\r
+\ Negate the contents of the "size" field of the specified node. If the\r
+\ node was available it is marked as in use, and vice versa.\r
+\r
+: next! ( addr) nextnode ! ;\r
+\\r
+\ Make the specified node the starting node for future searches of the node\r
+\ list.\r
+\r
+: sizes! ( size addr--addr) 2DUP + >R\r
+ >size 2DUP @ SWAP -\r
+ R@ >size !\r
+ SWAP NEGATE SWAP ! R> ;\r
+\\r
+\ Given a free node (addr), reduce its size to that specified and mark it\r
+\ as in use. Start to construct a new node within the specified node beyond\r
+\ its new length, by storing the length of the remainder of the node in the\r
+\ size field of the new node. Return the address of the partially\r
+\ constructed node.\r
+\r
+: links! ( addr1 addr2) 2DUP SWAP @ 2DUP SWAP ! >prev !\r
+ 2DUP >prev ! SWAP ! ;\r
+\r
+\\r
+\ Addr1 is an existing node. Addr2 is the address of a new node just above\r
+\ the existing node. Break the links from the existing node to the next\r
+\ node and from the next node to the existing node and join the new node to\r
+\ them.\r
+\r
+\r
+\ ANSI heap --- Node Construction ALLOCATE\r
+\r
+: newnode ( size addr) TUCK sizes! links! ;\r
+\\r
+\ Given a free node at addr split it into an in-use node of the specified\r
+\ size and a new free node above the in-use node.\r
+\r
+: makenode ( size addr) 2DUP fits IF togglesize DROP\r
+ ELSE newnode\r
+ THEN ;\r
+\\r
+\ Given a free node at addr make an in-use node of the specified size\r
+\ and free the remainder, if there is any usable space left.\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+: ALLOCATE ( u--addr ior)\r
+ DUP 0< IF allocationerror\r
+ ELSE adjustsize\r
+ DUP findspace\r
+ DUP IF DUP next!\r
+ TUCK makenode\r
+ headsize + 0\r
+ ELSE DROP allocationerror\r
+ THEN\r
+ THEN ;\r
+MEMORY-ALLOC-WORDLIST SET-CURRENT\r
+\\r
+\ Make an in-use node with a data field at least u address units long.\r
+\ Return the address of the data field and an ior of 0 to indicate success.\r
+\ If the space is not available return any old number and an ior equal to the\r
+\ constant ALLOCATIONERROR. The standard specifies that the argument to\r
+\ ALLOCATE is unsigned. As the implementation uses the sign bit of the size\r
+\ field for its own purposes any request for an amount of space greater\r
+\ than MAXPOS must fail. As this would be a request for half the\r
+\ addressable memory or more this is not unreasonable.\r
+\r
+\ **4** Releasing Space\r
+\r
+\ ANSI heap --- Head Destruction\r
+\r
+: mergesizes ( addr addr)\r
+ >size @ SWAP >size +! ;\r
+\\r
+\ Make the size field of the node at addr1 equal to the sum of the sizes of\r
+\ the two specified nodes. In usage the node at addr2 will be the one\r
+\ immediately above addr1.\r
+\r
+: mergelinks ( addr addr)\r
+ @ 2DUP SWAP !\r
+ >prev ! ;\r
+\\r
+\ The node at addr2 is removed from the node list. As with MERGESIZES the\r
+\ node at addr2 will be immediately above that at addr1. Destroy the link\r
+\ from node1 to node2 and relink node1 to the node above node2. Destroy the\r
+\ backward link from the node above node2 and relink it to node1.\r
+\r
+: jiggle ( )\r
+ nextnode @ @ >prev @ next! ;\r
+\\r
+\ There is a possibility when a node is removed from the node list that\r
+\ NEXTNODE may point to it. This is cured by making it point to the node\r
+\ prior to the one removed. We do not want to alter the pointer if it does\r
+\ not point to the removed node as that could be detrimental to the\r
+\ efficiency of the nextfit search algorithm. Rather than testing for this\r
+\ condition we jiggle the pointer about a bit to settle it into a linked\r
+\ node. This is done for reasons of programmer amusement. Specifically\r
+\ NEXTNODE is set to point to the node pointed to by the "previous" field\r
+\ of the node pointed to in the "next" field of the node pointed to by\r
+\ NEXTNODE. Ordinarily this is a no-op (ie I am my father's son) but when\r
+\ the node has had its links merged it sets NEXTNODE to point to the node\r
+\ prior to the node it pointed to (ie when I died my father adopted my son,\r
+\ so now my son is my father's son).\r
+\r
+: merge ( addr)\r
+ DUP @ 2DUP mergesizes\r
+ mergelinks jiggle ;\r
+\\r
+\ Combine the node specified with the node above it. Merge the sizes, merge\r
+\ the lengths and jiggle.\r
+\r
+\r
+\ ANSI Heap --- Node Removal FREE\r
+\r
+: ?merge ( addr1 addr2) >size @\r
+ 0> IF DUP DUP @\r
+ U< IF DUP merge\r
+ THEN\r
+ THEN DROP ;\r
+\\r
+\ Merge the node at addr1 with the one above it on two conditions, firstly\r
+\ that the node at addr2 is free, and secondly that the node pointed to by\r
+\ the next field in addr1 is actually above addr1 (ie that it does not wrap\r
+\ around because it is the topmost node). In usage addr2 will be either\r
+\ addr1 or the node above it. In each instance the other affected node\r
+\ (either the node above addr1 or addr1) is known to be free, so no test is\r
+\ needed for this.\r
+\r
+: ?mergenext ( addr) DUP @ ?merge ;\r
+\\r
+\ Merge the node following the specified node with the specified node, if\r
+\ following node is free.\r
+\r
+: ?mergeprev ( addr) >prev @ DUP ?merge ;\r
+\\r
+\ Merge the specified node with the one preceding it, if the preceding node\r
+\ is free.\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+: FREE ( addr--ior) headsize -\r
+ DUP togglesize\r
+ DUP ?mergenext\r
+ ?mergeprev 0 ;\r
+MEMORY-ALLOC-WORDLIST SET-CURRENT\r
+\\r
+\ Mark the specified in-use word as free, and merge with any adjacent free\r
+\ space. As this is a standard word addr is the address of the data field\r
+\ rather than the "next" field. As there is no compelling reason for this\r
+\ to fail the ior is zero.\r
+\r
+\r
+\ **5** Resizing Allocated Space\r
+\r
+\ ANSI Heap --- Node Repairing\r
+\r
+VARIABLE stash\r
+\\r
+\ The RESIZE algorithm is simplified and made faster by assuming that it\r
+\ will always succeed. STASH holds the minimum information required to make\r
+\ good when it fails.\r
+\r
+: savelink ( addr) @ stash ! ;\r
+\\r
+\ Saves the contents of the >NEXT field of the node being RESIZEd in STASH\r
+\ (above).\r
+\r
+: restorelink ( addr) stash @ SWAP ! ;\r
+\\r
+\ Converse operation to SAVELINK (above).\r
+\r
+: fixprev ( addr) DUP >prev @ ! ;\r
+\\r
+\ The >NEXT field of the node prior to the node being RESIZEd should point\r
+\ to the node being RESIZEd. It may very well do already, but this makes\r
+\ sure.\r
+\r
+: fixnext ( addr) DUP @ >prev ! ;\r
+\\r
+\ The >PREV field of the node after the node resized may need correcting.\r
+\ This corrects it whether it needs it or not. (Its quicker just to do it\r
+\ than to check first.)\r
+\r
+: fixlinks ( addr) DUP fixprev DUP fixnext @ fixnext ;\r
+\\r
+\ RESIZE may very well merge its argument node with the previous one. It\r
+\ may very well merge that with the next one. This means we need to fix the\r
+\ previous one, the next one and the one after next. To extend the metaphor\r
+\ started in the description of JIGGLE (above), not only did I die, but my\r
+\ father did too. This brings my grandfather into the picture as guardian\r
+\ of my son. Now to confound things we have all come back to life. I still\r
+\ remember who my son is, and my father remembers who his father is. Once I\r
+\ know who my father is I can tell my son that I am his father, I can tell\r
+\ my father that I am his son and my grandfather who his son is. Thankfully\r
+\ we are only concerned about the male lineage here! (In fact nodes\r
+\ reproduce by division, like amoebae, which is where the metaphor breaks\r
+\ down -- (1) they are sexless and (2) which half is parent and which\r
+\ child?)\r
+\r
+: fixsize ( addr) DUP >size @ 0>\r
+ IF DUP @ 2DUP <\r
+ IF OVER - SWAP >size !\r
+ ELSE 2DROP\r
+ THEN\r
+ ELSE DROP\r
+ THEN ;\r
+\\r
+\ Reconstruct the size field of a node from the address of the head and the\r
+\ contents of the >NEXT field provided that the node is free and it is not\r
+\ the topmost node in the heap (ie there is no wraparound). Both these\r
+\ conditions need to be true for the node to have been merged with its\r
+\ successor.\r
+\r
+: fixsizes ( addr) DUP fixsize >prev @ fixsize ;\r
+\\r
+\ The two nodes whose size fields may need repairing are the one passed as\r
+\ an argument to RESIZE (damaged by ?MERGENEXT) and its predecessor\r
+\ (damaged by ?MERGEPREV).\r
+\r
+: repair ( addr) DUP restorelink\r
+ DUP fixlinks DUP fixsizes\r
+ togglesize ;\r
+\\r
+\ Make good the damage done by RESIZE. Restore the >next field, fix the\r
+\ links, fix the size fields and mark the node as in-use. Note that this\r
+\ may not restore the system to exactly how it was. In particular the pointer\r
+\ NEXTNODE may have moved back one or two nodes by virtue of having been\r
+\ JIGGLEd about if it happened to be pointing to the wrong node. This is not\r
+\ serious, so I have chosen to ignore it.\r
+\r
+\r
+\ ANSI Heap --- Node Movement\r
+\r
+: toobig? ( addr size--flag)\r
+ SWAP >size @ > ;\r
+\\r
+\ Flag is true if the node at addr is smaller than the specified size.\r
+\r
+: copynode ( addr1 addr2)\r
+ OVER >size @ headsize -\r
+ ROT headsize + ROT ROT MOVE ;\r
+\\r
+\ Move the contents of the data field of the node at addr1 to the data\r
+\ field at addr2. Assumes addr2 is large enough. It will be.\r
+\r
+: enlarge ( addr1 size--addr2 ior)\r
+ OVER ?mergeprev\r
+ ALLOCATE DUP >R\r
+ IF SWAP repair\r
+ ELSE TUCK copynode\r
+ THEN R> ;\r
+\\r
+\ Make a new node of the size specified. Copy the data field of addr1 to\r
+\ the new node. Merge the node at addr1 with the one preceding it, if\r
+\ possible. This last behaviour is to finish off removing the node at\r
+\ addr1. The word ADJUST (below) starts removing the node. The node is\r
+\ removed before allocation to increase the probability of ALLOCATE\r
+\ succeeding. The address returned by ENLARGE is that returned by ALLOCATE,\r
+\ which is that of the data field, not the head. If the allocation fails\r
+\ repair the damage done by removing the node at addr1.\r
+\r
+\r
+\ ANSI Heap --- Node Restructuring RESIZE\r
+\r
+: adjust ( addr1 size1--addr2 size2) adjustsize >R\r
+ headsize -\r
+ DUP savelink\r
+ DUP togglesize\r
+ DUP ?mergenext R> ;\r
+\\r
+\ Addr1 points to the data field of a node, not the "next" field. This\r
+\ needs correcting. Size1 also needs adjusting as per ADJUSTSIZE. In\r
+\ addition it is easier to work with free nodes than live ones as the size\r
+\ field is correct, and, as we intend to change the nodes size we will\r
+\ inevitably want to muck about with the next node, if its free, so lets\r
+\ merge with it straight away. Sufficient information is first saved to put\r
+\ the heap back as it was, if necessary. Now we are ready to get down to\r
+\ business.\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+: RESIZE ( addr1 u--addr2 ior)\r
+ DUP 0< IF DROP allocationerror\r
+ ELSE adjust 2DUP\r
+ toobig? IF enlarge\r
+ ELSE OVER makenode\r
+ headsize + 0\r
+ THEN\r
+ THEN ;\r
+MEMORY-ALLOC-WORDLIST SET-CURRENT\r
+\\r
+\ Resize the node at addr1 to the specified size. Return the address of the\r
+\ resized node (addr2) along with an ior of zero if successful and\r
+\ ALLOCATIONERROR if not. Addr2 may be the same as, or different to, addr1.\r
+\ If ior is non-zero then addr2 is not meaningful. Being a standard word\r
+\ the arguments need adjusting to the internal representation on entry, and\r
+\ back again on exit. If after the first merge the requested size is still\r
+\ too large to reuse the specified node then it is moved to a larger node\r
+\ and the specified node released. If, on the other hand the request is not\r
+\ too big for the node, then we remake the node at the right length, and\r
+\ free any space at the top using MAKENODE, which has just the right\r
+\ functionality. In this case the ior is zero. As this is a standard word it\r
+\ takes an unsigned size argument, but excessive requests fail\r
+\ automatically, as with ALLOCATE.\r
+\r
+envQList SET-CURRENT\r
+-1 CONSTANT MEMORY-ALLOC\r
+\r
+SET-CURRENT SET-ORDER\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF] RAM/ROM! [THEN]\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\ This is freeware, copyright Gordon Charlton, 12th of September 1994.\r
+\ Copy and distribute it. Use it. Don't mess with this file. Acknowledge\r
+\ its use. I make no guarentees as to its fitness for any purpose. Tell\r
+\ me about any bugs. Tell me how much you like it.\r
+\r
+\ An ANS Heap\r
+\r
+\ This is an implementation of the ANS Forth Memory-Allocation Word Set.\r
+\ This is an ANS standard program that has the following environmental\r
+\ dependency - two's complement arithmetic. It requires four words\r
+\ from the core extension: 0> NIP TUCK \\r
+\r
+\ (If you go to the trouble of checking these claims, please e-mail me\r
+\ with your findings; gordon@charlton.demon.co.uk)\r
+\r
+\ There are five broad areas that the program covers;\r
+\r
+\ 1, General purpose extensions to the Forth system.\r
+\r
+\ 2, Creation of the heap and associated use of the data space.\r
+\r
+\ 3, Allocation of space from the heap.\r
+\r
+\ 4, Releasing space back to the heap.\r
+\r
+\ 5, Altering the size of allocated heap space.\r
+\r
+\r
+\ The ANS word set consists of three words, ALLOCATE, FREE, and RESIZE\r
+\ which give the minimum functionality required to use the heap. These are\r
+\ given in areas 3, 4 and 5 respectively.\r
+\r
+\ The heap is maintained as a doubly linked ordered circular list of nodes\r
+\ with an additional field noting the size of each node and whether it is in\r
+\ use. The size of the heap is specified by the constant HEAPSIZE. The\r
+\ constant HYSTERESIS controls the amount of spare space that is added to\r
+\ an allocation, to reduce the need for block moves during resizing.\r
+\r
+\ Initially there is only one node, the size of the heap. Aditional nodes\r
+\ are created by dividing an existing node into two parts. Nodes are removed\r
+\ by marking as free, and merging with adjoining free nodes. Nodes are\r
+\ altered in size by merging with a following free node, if possible, and a\r
+\ node being created above the new size of the node, if needed, or by\r
+\ allocating a new node and block moving the data field if necessary.\r
+\r
+\ Finding an available node is done by sequential search and comparison. The\r
+\ first node to be found that is large enough is used for allocation. Each\r
+\ search starts from the node most recently allocated, making this a\r
+\ "nextfit" algorithm. The redundancy in the head fields is required to\r
+\ optimise the search loop, as is the use of a sentinel to terminate the\r
+\ search once every node has been looked at, by always succeeding. A final\r
+\ refinement is the use of the sign bit of the size field to mark "in-use"\r
+\ nodes so that they are disregarded without a separate test.\r
+\r
+\r
+\ **1** General Purpose Extensions\r
+\r
+: unique ( ) VARIABLE ;\r
+\\r
+\ Defining word. Each child returns a different non-zero number. The\r
+\ standard introduces the need for unique identifiers in the form of IORs\r
+\ and THROW codes, but provides no means for generating them. This does\r
+\ the trick.\r
+\r
+: k ( n--n) 1024 * ;\r
+\\r
+\ A convenient way of referring to large numbers. Multiplies a number by\r
+\ 1024.\r
+\r
+0 1 2 UM/MOD NIP 1- CONSTANT maxpos\r
+\\r
+\ The largest positive single length integer.\r
+\r
+\r
+\ **2** Heap Creation\r
+\r
+\ ANSI Heap --- Constants\r
+\r
+16 k CELLS CONSTANT heapsize\r
+\\r
+\ Number of address units of data space that the heap occupies.\r
+\r
+4 CELLS 1- CONSTANT hysteresis\r
+\\r
+\ Node lengths are rounded up according to the value of HYSTERESIS to\r
+\ reduce the number of block moves during RESIZE operations. The value of\r
+\ this constant must be one less than a power of two and at least equal to\r
+\ one less than the size of a cell.\r
+\r
+unique allocationerror\r
+\\r
+\ Indicates there is less contiguous heap space available than required.\r
+\r
+3 CELLS CONSTANT headsize\r
+\\r
+\ A node on the heap consists of a three cell head followed by a variable\r
+\ length data space. The first cell in the head points to the next node in\r
+\ the heap. The second cell indicates the size of the node, and the third\r
+\ points to the previous node. The second cell is negated to indicate the\r
+\ node is in use. The heap consists of a doubly linked circular list. There\r
+\ is no special notation to indicate an empty list, as this situation\r
+\ cannot occur.\r
+\r
+: adjustsize ( n--n) headsize + hysteresis OR 1+ ;\r
+\\r
+\ The amount of space that is requested for a node needs adjusting to\r
+\ include the length of the head, and to incorporate the hysteresis.\r
+\r
+0 adjustsize CONSTANT overhead\r
+\\r
+\ The size of the smallest possible node.\r
+\r
+\r
+\ ANSI Heap --- Structure\r
+\r
+CREATE sentinel HERE CELL+ , maxpos , 0 , 0 ,\r
+\\r
+\ A dummy node used to speed up searching the heap. The search, which is\r
+\ for a node larger than or equal to the specified size will always succeed.\r
+\ The cell that points to the next node is set up so that the there is a zero\r
+\ three cells ahead of where it points, where the pointer to the previous\r
+\ node (ie the sentinel) should be. This is a special value that indicates the\r
+\ search has failed.\r
+\r
+CREATE heap heapsize ALLOT\r
+\\r
+\ The heap is as described in HEADSIZE.\r
+\r
+VARIABLE nextnode\r
+\\r
+\ Searching is done using a "nextfit" algorithm. NEXTNODE points to the\r
+\ most recently allocated node to indicate where the next search is to\r
+\ start from.\r
+\r
+: >size ( addr--addr) CELL+ ;\r
+\\r
+\ Move from the "next" cell in the node head to the "size" cell. Within the\r
+\ word set nodes are referred to by the address of the "next" cell.\r
+\ Externally they are referred to by the address of the start of the data\r
+\ field.\r
+\r
+: >prev ( addr--addr) 2 CELLS + ;\r
+\\r
+\ Move from the "next" cell to the "previous" cell.\r
+\r
+: init-heap ( ) heap DUP nextnode !\r
+ DUP DUP !\r
+ DUP heapsize OVER >size !\r
+ >prev ! ;\r
+\\r
+\ Initially the heap contains only one node, which is the same size as the\r
+\ heap. Both the "next" cell and the "previous" cell point to the "next"\r
+\ cell, as does NEXTNODE.\r
+\r
+init-heap\r
+\r
+\ **3** Heap Allocation\r
+\r
+\ ANSI Heap --- List Searching\r
+\r
+: attach ( addr) >prev @\r
+ DUP sentinel ROT !\r
+ sentinel >prev ! ;\r
+\\r
+\ The sentinel is joined into the nodelist. The "next" field of the node\r
+\ preceding the one specified (addr) is set to point to the sentinel, and\r
+\ the "prev" field of the sentinel to point to the node that points to the\r
+\ sentinel.\r
+\r
+: search ( addr size--addr|0)\r
+ >R BEGIN 2@ SWAP R@ < INVERT UNTIL\r
+ R> DROP >prev @ ;\r
+\\r
+\ Search the nodelist, starting at the node specified (addr), for a free\r
+\ node larger than or equal to the specified size. Return the address of the\r
+\ first node that matches, or zero for no match. The heap structure is set up\r
+\ to make this a near optimal search loop. The "size" field is next to the "next"\r
+\ field so that both can be collected in a single operation (2@). Nodes in\r
+\ use have negated sizes so they never match the search. The "previous"\r
+\ field is included to allow the search to overshoot the match by one node\r
+\ and then link back outside the loop, rather than remembering the address\r
+\ of the node just examined. The sentinel removes the need for a separate\r
+\ test for failure. SEARCH assumes the sentinel is in place.\r
+\r
+: detach ( addr) DUP >prev @ ! ;\r
+\\r
+\ Remake the link from the node prior to the one specified to the one\r
+\ specified. This will remove the sentinel if it is attached here. (It will\r
+\ be.)\r
+\r
+: findspace ( size--addr|0) nextnode @\r
+ DUP attach\r
+ DUP ROT search\r
+ SWAP detach ;\r
+\\r
+\ Search the nodelist for a node larger or equal to that specified. Return\r
+\ the address of a suitable node, or zero if none found. The search starts at\r
+\ the node pointed to by NEXTNODE, the sentinal temporarily attached, the\r
+\ search proceeded with and the sentinel detached.\r
+\r
+\r
+\ ANSI Heap --- Head Creation\r
+\r
+: fits ( size addr--flag) >size @ SWAP - overhead < ;\r
+\\r
+\ Returns TRUE if the size of the node specified is the same as the\r
+\ specified size, or larger than it by less than the size of the smallest\r
+\ possible node. Returns FALSE otherwise.\r
+\r
+: togglesize ( addr) >size DUP @ NEGATE SWAP ! ;\r
+\\r
+\ Negate the contents of the "size" field of the specified node. If the\r
+\ node was available it is marked as in use, and vice versa.\r
+\r
+: next! ( addr) nextnode ! ;\r
+\\r
+\ Make the specified node the starting node for future searches of the node\r
+\ list.\r
+\r
+: sizes! ( size addr--addr) 2DUP + >R\r
+ >size 2DUP @ SWAP -\r
+ R@ >size !\r
+ SWAP NEGATE SWAP ! R> ;\r
+\\r
+\ Given a free node (addr), reduce its size to that specified and mark it\r
+\ as in use. Start to construct a new node within the specified node beyond\r
+\ its new length, by storing the length of the remainder of the node in the\r
+\ size field of the new node. Return the address of the partially\r
+\ constructed node.\r
+\r
+: links! ( addr1 addr2) 2DUP SWAP @ 2DUP SWAP ! >prev !\r
+ 2DUP >prev ! SWAP ! ;\r
+\r
+\\r
+\ Addr1 is an existing node. Addr2 is the address of a new node just above\r
+\ the existing node. Break the links from the existing node to the next\r
+\ node and from the next node to the existing node and join the new node to\r
+\ them.\r
+\r
+\r
+\ ANSI heap --- Node Construction ALLOCATE\r
+\r
+: newnode ( size addr) TUCK sizes! links! ;\r
+\\r
+\ Given a free node at addr split it into an in-use node of the specified\r
+\ size and a new free node above the in-use node.\r
+\r
+: makenode ( size addr) 2DUP fits IF togglesize DROP\r
+ ELSE newnode\r
+ THEN ;\r
+\\r
+\ Given a free node at addr make an in-use node of the specified size\r
+\ and free the remainder, if there is any usable space left.\r
+\r
+: ALLOCATE ( u--addr ior)\r
+ DUP 0< IF allocationerror\r
+ ELSE adjustsize\r
+ DUP findspace\r
+ DUP IF DUP next!\r
+ TUCK makenode\r
+ headsize + 0\r
+ ELSE DROP allocationerror\r
+ THEN\r
+ THEN ;\r
+\\r
+\ Make an in-use node with a data field at least u address units long.\r
+\ Return the address of the data field and an ior of 0 to indicate success.\r
+\ If the space is not available return any old number and an ior equal to the\r
+\ constant ALLOCATIONERROR. The standard specifies that the argument to\r
+\ ALLOCATE is unsigned. As the implementation uses the sign bit of the size\r
+\ field for its own purposes any request for an amount of space greater\r
+\ than MAXPOS must fail. As this would be a request for half the\r
+\ addressable memory or more this is not unreasonable.\r
+\r
+\ **4** Releasing Space\r
+\r
+\ ANSI heap --- Head Destruction\r
+\r
+: mergesizes ( addr addr)\r
+ >size @ SWAP >size +! ;\r
+\\r
+\ Make the size field of the node at addr1 equal to the sum of the sizes of\r
+\ the two specified nodes. In usage the node at addr2 will be the one\r
+\ immediately above addr1.\r
+\r
+: mergelinks ( addr addr)\r
+ @ 2DUP SWAP !\r
+ >prev ! ;\r
+\\r
+\ The node at addr2 is removed from the node list. As with MERGESIZES the\r
+\ node at addr2 will be immediately above that at addr1. Destroy the link\r
+\ from node1 to node2 and relink node1 to the node above node2. Destroy the\r
+\ backward link from the node above node2 and relink it to node1.\r
+\r
+: jiggle ( )\r
+ nextnode @ @ >prev @ next! ;\r
+\\r
+\ There is a possibility when a node is removed from the node list that\r
+\ NEXTNODE may point to it. This is cured by making it point to the node\r
+\ prior to the one removed. We do not want to alter the pointer if it does\r
+\ not point to the removed node as that could be detrimental to the\r
+\ efficiency of the nextfit search algorithm. Rather than testing for this\r
+\ condition we jiggle the pointer about a bit to settle it into a linked\r
+\ node. This is done for reasons of programmer amusement. Specifically\r
+\ NEXTNODE is set to point to the node pointed to by the "previous" field\r
+\ of the node pointed to in the "next" field of the node pointed to by\r
+\ NEXTNODE. Ordinarily this is a no-op (ie I am my father's son) but when\r
+\ the node has had its links merged it sets NEXTNODE to point to the node\r
+\ prior to the node it pointed to (ie when I died my father adopted my son,\r
+\ so now my son is my father's son).\r
+\r
+: merge ( addr)\r
+ DUP @ 2DUP mergesizes\r
+ mergelinks jiggle ;\r
+\\r
+\ Combine the node specified with the node above it. Merge the sizes, merge\r
+\ the lengths and jiggle.\r
+\r
+\r
+\ ANSI Heap --- Node Removal FREE\r
+\r
+: ?merge ( addr1 addr2) >size @\r
+ 0> IF DUP DUP @\r
+ U< IF DUP merge\r
+ THEN\r
+ THEN DROP ;\r
+\\r
+\ Merge the node at addr1 with the one above it on two conditions, firstly\r
+\ that the node at addr2 is free, and secondly that the node pointed to by\r
+\ the next field in addr1 is actually above addr1 (ie that it does not wrap\r
+\ around because it is the topmost node). In usage addr2 will be either\r
+\ addr1 or the node above it. In each instance the other affected node\r
+\ (either the node above addr1 or addr1) is known to be free, so no test is\r
+\ needed for this.\r
+\r
+: ?mergenext ( addr) DUP @ ?merge ;\r
+\\r
+\ Merge the node following the specified node with the specified node, if\r
+\ following node is free.\r
+\r
+: ?mergeprev ( addr) >prev @ DUP ?merge ;\r
+\\r
+\ Merge the specified node with the one preceding it, if the preceding node\r
+\ is free.\r
+\r
+: FREE ( addr--ior) headsize -\r
+ DUP togglesize\r
+ DUP ?mergenext\r
+ ?mergeprev 0 ;\r
+\\r
+\ Mark the specified in-use word as free, and merge with any adjacent free\r
+\ space. As this is a standard word addr is the address of the data field\r
+\ rather than the "next" field. As there is no compelling reason for this\r
+\ to fail the ior is zero.\r
+\r
+\r
+\ **5** Resizing Allocated Space\r
+\r
+\ ANSI Heap --- Node Repairing\r
+\r
+VARIABLE stash\r
+\\r
+\ The RESIZE algorithm is simplified and made faster by assuming that it\r
+\ will always succeed. STASH holds the minimum information required to make\r
+\ good when it fails.\r
+\r
+: savelink ( addr) @ stash ! ;\r
+\\r
+\ Saves the contents of the >NEXT field of the node being RESIZEd in STASH\r
+\ (above).\r
+\r
+: restorelink ( addr) stash @ SWAP ! ;\r
+\\r
+\ Converse operation to SAVELINK (above).\r
+\r
+: fixprev ( addr) DUP >prev @ ! ;\r
+\\r
+\ The >NEXT field of the node prior to the node being RESIZEd should point\r
+\ to the node being RESIZEd. It may very well do already, but this makes\r
+\ sure.\r
+\r
+: fixnext ( addr) DUP @ >prev ! ;\r
+\\r
+\ The >PREV field of the node after the node resized may need correcting.\r
+\ This corrects it whether it needs it or not. (Its quicker just to do it\r
+\ than to check first.)\r
+\r
+: fixlinks ( addr) DUP fixprev DUP fixnext @ fixnext ;\r
+\\r
+\ RESIZE may very well merge its argument node with the previous one. It\r
+\ may very well merge that with the next one. This means we need to fix the\r
+\ previous one, the next one and the one after next. To extend the metaphor\r
+\ started in the description of JIGGLE (above), not only did I die, but my\r
+\ father did too. This brings my grandfather into the picture as guardian\r
+\ of my son. Now to confound things we have all come back to life. I still\r
+\ remember who my son is, and my father remembers who his father is. Once I\r
+\ know who my father is I can tell my son that I am his father, I can tell\r
+\ my father that I am his son and my grandfather who his son is. Thankfully\r
+\ we are only concerned about the male lineage here! (In fact nodes\r
+\ reproduce by division, like amoebae, which is where the metaphor breaks\r
+\ down -- (1) they are sexless and (2) which half is parent and which\r
+\ child?)\r
+\r
+: fixsize ( addr) DUP >size @ 0>\r
+ IF DUP @ 2DUP <\r
+ IF OVER - SWAP >size !\r
+ ELSE 2DROP\r
+ THEN\r
+ ELSE DROP\r
+ THEN ;\r
+\\r
+\ Reconstruct the size field of a node from the address of the head and the\r
+\ contents of the >NEXT field provided that the node is free and it is not\r
+\ the topmost node in the heap (ie there is no wraparound). Both these\r
+\ conditions need to be true for the node to have been merged with its\r
+\ successor.\r
+\r
+: fixsizes ( addr) DUP fixsize >prev @ fixsize ;\r
+\\r
+\ The two nodes whose size fields may need repairing are the one passed as\r
+\ an argument to RESIZE (damaged by ?MERGENEXT) and its predecessor\r
+\ (damaged by ?MERGEPREV).\r
+\r
+: repair ( addr) DUP restorelink\r
+ DUP fixlinks DUP fixsizes\r
+ togglesize ;\r
+\\r
+\ Make good the damage done by RESIZE. Restore the >next field, fix the\r
+\ links, fix the size fields and mark the node as in-use. Note that this\r
+\ may not restore the system to exactly how it was. In particular the pointer\r
+\ NEXTNODE may have moved back one or two nodes by virtue of having been\r
+\ JIGGLEd about if it happened to be pointing to the wrong node. This is not\r
+\ serious, so I have chosen to ignore it.\r
+\r
+\r
+\ ANSI Heap --- Node Movement\r
+\r
+: toobig? ( addr size--flag)\r
+ SWAP >size @ > ;\r
+\\r
+\ Flag is true if the node at addr is smaller than the specified size.\r
+\r
+: copynode ( addr1 addr2)\r
+ OVER >size @ headsize -\r
+ ROT headsize + ROT ROT MOVE ;\r
+\\r
+\ Move the contents of the data field of the node at addr1 to the data\r
+\ field at addr2. Assumes addr2 is large enough. It will be.\r
+\r
+: enlarge ( addr1 size--addr2 ior)\r
+ OVER ?mergeprev\r
+ ALLOCATE DUP >R\r
+ IF SWAP repair\r
+ ELSE TUCK copynode\r
+ THEN R> ;\r
+\\r
+\ Make a new node of the size specified. Copy the data field of addr1 to\r
+\ the new node. Merge the node at addr1 with the one preceding it, if\r
+\ possible. This last behaviour is to finish off removing the node at\r
+\ addr1. The word ADJUST (below) starts removing the node. The node is\r
+\ removed before allocation to increase the probability of ALLOCATE\r
+\ succeeding. The address returned by ENLARGE is that returned by ALLOCATE,\r
+\ which is that of the data field, not the head. If the allocation fails\r
+\ repair the damage done by removing the node at addr1.\r
+\r
+\r
+\ ANSI Heap --- Node Restructuring RESIZE\r
+\r
+: adjust ( addr1 size1--addr2 size2) adjustsize >R\r
+ headsize -\r
+ DUP savelink\r
+ DUP togglesize\r
+ DUP ?mergenext R> ;\r
+\\r
+\ Addr1 points to the data field of a node, not the "next" field. This\r
+\ needs correcting. Size1 also needs adjusting as per ADJUSTSIZE. In\r
+\ addition it is easier to work with free nodes than live ones as the size\r
+\ field is correct, and, as we intend to change the nodes size we will\r
+\ inevitably want to muck about with the next node, if its free, so lets\r
+\ merge with it straight away. Sufficient information is first saved to put\r
+\ the heap back as it was, if necessary. Now we are ready to get down to\r
+\ business.\r
+\r
+: RESIZE ( addr1 u--addr2 ior)\r
+ DUP 0< IF DROP allocationerror\r
+ ELSE adjust 2DUP\r
+ toobig? IF enlarge\r
+ ELSE OVER makenode\r
+ headsize + 0\r
+ THEN\r
+ THEN ;\r
+\\r
+\ Resize the node at addr1 to the specified size. Return the address of the\r
+\ resized node (addr2) along with an ior of zero if successful and\r
+\ ALLOCATIONERROR if not. Addr2 may be the same as, or different to, addr1.\r
+\ If ior is non-zero then addr2 is not meaningful. Being a standard word\r
+\ the arguments need adjusting to the internal representation on entry, and\r
+\ back again on exit. If after the first merge the requested size is still\r
+\ too large to reuse the specified node then it is moved to a larger node\r
+\ and the specified node released. If, on the other hand the request is not\r
+\ too big for the node, then we remake the node at the right length, and\r
+\ free any space at the top using MAKENODE, which has just the right\r
+\ functionality. In this case the ior is zero. As this is a standard word it\r
+\ takes an unsigned size argument, but excessive requests fail\r
+\ automatically, as with ALLOCATE.\r
--- /dev/null
+\\r
+\ MSDOS.F\r
+\ FILES and BLOCK words for MS-DOS\r
+\\r
+\ by Wonyong Koh\r
+\\r
+\ MSDOS.F can be loaded as below:\r
+\\r
+\ << OPTIONAL.F\r
+\ << ASM8086.F\r
+\ << COREEXT.F\r
+\ << MSDOS.F\r
+\\r
+\ Then other files such as MULTI.F, HIOMULTI.F, etc. can be loaded as below:\r
+\\r
+\ BL PARSE MULTI.F INCLUDED\r
+\ BL PARSE HIOMULTI.F INCLUDED\r
+\\r
+\ In HF86EXE.EXE system image can be saved using SYSTEM-SAVED\r
+\ or SAVE-SYSTEM-AS as below:\r
+\\r
+\ SAVE-SYSTEM-AS SAVE2.EXE\r
+\\r
+\ Don't forget to set up "'init-i/o" and "'boot" properly.\r
+\\r
+\ There is only one block buffer and only one file is assigned as BLOCK\r
+\ in current implementation.\r
+\\r
+\ 1996. 3. 1.\r
+\ DOS error code is offsetted by -512 to give 'ior'.\r
+\ 1997. 5. 26.\r
+\ Fix RESTORE-INPUT to restore BLK correctly.\r
+\r
+CHAR " PARSE CPU" ENVIRONMENT? DROP\r
+CHAR " PARSE 8086" COMPARE\r
+[IF]\r
+ CR .( BLOCK and FILE words for MS-DOS are for 8086 RAM and EXE models only.)\r
+ ABORT\r
+[THEN]\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE AND\r
+[IF]\r
+ CR .( BLOCK and FILE words for MS-DOS are for 8086 RAM and EXE models only.)\r
+ ABORT\r
+[THEN]\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+WORDLIST WORDLIST-NAME DOS-WORDLIST\r
+DOS-WORDLIST SET-CURRENT\r
+GET-ORDER DOS-WORDLIST SWAP 1+ SET-ORDER\r
+\r
+DECIMAL\r
+-512 CONSTANT iorOffset\r
+VARIABLE MaxHandle \ contains maximum DOS file handle\r
+0 MaxHandle ! \ to be used to calculate UNUSED data space.\r
+\r
+1024 CHARS CONSTANT 1K\r
+0 VALUE updated \ true if block is updated\r
+CREATE block-buffer 1K ALLOT \ the only block buffer\r
+50 VALUE def#blocks \ default # of blocks for a new mapped file\r
+-1 VALUE block-fid \ BLOCK file id\r
+-1 VALUE current-block#\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+50 VALUE #blocks \ maximum # of blocks\r
+DOS-WORDLIST SET-CURRENT\r
+\r
+VARIABLE error-class 0 error-class !\r
+VARIABLE recommanded-action 0 recommanded-action !\r
+VARIABLE error-locus 0 error-locus !\r
+\r
+: ?dupR>DropExit ?DUP IF R> R> 2DROP EXIT THEN ;\r
+: ?dupR>Drop2NipExit ?DUP IF R> R> 2DROP NIP NIP EXIT THEN ;\r
+: ?dupR>Drop4NipExit ?DUP IF R> R> 2DROP NIP NIP NIP NIP EXIT THEN ;\r
+\r
+HEX\r
+CODE get-ior ( -- ior )\r
+ 59 # AH MOV,\r
+ BX BX XOR,\r
+ 21 INT,\r
+ BH error-class ) MOV,\r
+ BL recommanded-action ) MOV,\r
+ CH error-locus ) MOV,\r
+ AX BX MOV,\r
+ iorOffset # BX ADD,\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE (open-file) ( asciiz fam -- fileid ior )\r
+ 3D # AH MOV,\r
+ BL AL MOV,\r
+ DX POP,\r
+ 21 INT,\r
+ AX PUSH,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+CODE (create-file) ( asciiz -- fileid ior )\r
+ 3C # AH MOV,\r
+ CX CX XOR, \ CX = 0 ; normal read/write\r
+ BX DX MOV,\r
+ 21 INT,\r
+ AX PUSH,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+CODE (delete-file) ( asciiz -- ior )\r
+ 41 # AH MOV,\r
+ BX DX MOV,\r
+ 21 INT,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+CODE (reposition-file) ( ud fileid reposition_method -- ud ior )\r
+ \ reposition_method;\r
+ \ 0 : offset from beginning of file\r
+ \ 1 : offset from present location\r
+ \ 2 : offset from end-of-file\r
+ 42 # AH MOV,\r
+ BL AL MOV, \ AL = reposition-method\r
+ BX POP, \ file handle\r
+ CX POP, \ CX:DX = offset\r
+ DX POP,\r
+ 21 INT,\r
+ AX PUSH,\r
+ DX PUSH,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+CODE crlf= ( char -- flag )\r
+ BX AX MOV,\r
+ -1 # BX MOV,\r
+ 0A # AL CMP,\r
+ 1 L# JZ,\r
+ 0D # AL CMP,\r
+ 1 L# JZ,\r
+ BX INC,\r
+1 L:\r
+ NEXT,\r
+END-CODE\r
+\r
+\ PAD is constant in EXE model.\r
+PAD BL PARSE /PAD ENVIRONMENT? DROP CHARS - CONSTANT S"buffer\r
+\r
+\ Returns file input buffer address\r
+\ Each text file has its own input buffer\r
+\ below buffer for S" below PAD.\r
+\ In MS-DOS, a program can open up to 20 files.\r
+\ Thus fileid(=DOS handle) is normally 5 to 20.\r
+\ DOS handle 0 : standard input (CON)\r
+\ 1 : standard output (CON)\r
+\ 2 : standard output for error message (CON)\r
+\ 3 : standard serial interface (AUX)\r
+\ 4 : standard printer (PRN)\r
+\ <-/fileid6buffer/fileid5buffer/S"buffer/PAD/TIB||memTop\r
+: input-buffer ( -- c_addr )\r
+ SOURCE-ID\r
+ ?DUP IF 1+ ?DUP IF \ source-id = fileid, text file source\r
+ 5 - [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL\r
+ * S"buffer SWAP - EXIT THEN THEN\r
+ \ source-id = 0, user input device source\r
+ \ source-id = -1, string source\r
+ SOURCE DROP ;\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\ UNUSED ( -- u ) \ CORE EXT\r
+\ Return available data space in address units.\r
+: UNUSED\r
+ S"buffer\r
+ MaxHandle @ 5 - [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL * -\r
+ HERE - ; \ Available data space is HERE to assigned buffer addr\r
+DOS-WORDLIST SET-CURRENT\r
+\r
+CODE (file-status) ( asciiz -- x ior )\r
+ 4300 # AX MOV, \ get file attributes\r
+ BX DX MOV,\r
+ 21 INT,\r
+ CX PUSH,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+CODE (rename-file) ( asciiz1 asciiz2 -- ior )\r
+ 56 # AH MOV,\r
+ BX DX MOV,\r
+ DS PUSH,\r
+ ES POP,\r
+ DI POP,\r
+ 21 INT,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ BLK ( -- a_addr ) \ BLOCK\r
+\ a_addr is the address of a cell containing 0 or the\r
+\ mass-strorage block being interpreted. If BLK is 0, the input\r
+\ source is not a block and can be identified by SOURCE-ID .\r
+VARIABLE BLK 0 BLK !\r
+\r
+\ BIN ( fam1 -- fam2 ) \ FILE\r
+\ Modify file access method to binary.\r
+: BIN ; \ Do nothing for MS-DOS handle functions.\r
+\r
+\ CLOSE-FILE ( fileid -- ior ) \ FILE\r
+\ Close the file identified by fileid.\r
+CODE CLOSE-FILE\r
+ 3E # AH MOV, \ BX = file handle\r
+ 21 INT,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+\ OPEN-FILE ( c_addr u fam -- fileid ior ) \ FILE\r
+\ Open a file with the name and file access method.\r
+: OPEN-FILE\r
+ >R asciiz R> (open-file)\r
+ DUP 0= IF OVER MaxHandle @ MAX MaxHandle ! THEN ;\r
+\r
+\ CREATE-FILE ( c_addr u fam -- fileid ior ) \ FILE\r
+\ Create a file with the given name and the file access\r
+\ method and return fileid.\r
+: CREATE-FILE\r
+ >R 2DUP \ ca u ca u R: fam\r
+ asciiz (create-file) \ ca u fileid ior R: fam\r
+ ?dupR>Drop2NipExit\r
+ CLOSE-FILE DROP R> OPEN-FILE ;\r
+\r
+\ DELETE-FILE ( c_addr u -- ior ) \ FILE\r
+\ Delete the named file.\r
+: DELETE-FILE\r
+ asciiz (delete-file) ;\r
+\r
+\ FILE-POSITION ( fileid -- ud ior ) \ FILE\r
+\ ud is the current file position for fileid.\r
+: FILE-POSITION\r
+ >R 0 0 R> 1 (reposition-file) ;\r
+\r
+\ REPOSITION-FILE ( ud fileid -- ior ) \ FILE\r
+\ Reposition the file to ud.\r
+: REPOSITION-FILE\r
+ 0 (reposition-file) NIP NIP ;\r
+\r
+\ FILE-SIZE ( fileid -- ud ior ) \ FILE\r
+\ ud is the size of of fileid in characters.\r
+: FILE-SIZE\r
+ DUP >R \ fid R: fid\r
+ FILE-POSITION \ ud ior R: fid\r
+ ?dupR>DropExit \ save current position\r
+ 0 0 R@ REPOSITION-FILE \ ud ior R: fid\r
+ ?dupR>DropExit \ reset file position\r
+ 0 0 R@ 2 (reposition-file) \ ud ud' ior R: fid\r
+ ?dupR>Drop2NipExit \ size = distance from end of file\r
+ 2SWAP R> REPOSITION-FILE ;\r
+\r
+\ R/O ( -- fam ) \ FILE\r
+\ Put read-only method value on the stack.\r
+0 CONSTANT R/O\r
+\r
+\ W/O ( -- fam ) \ FILE\r
+\ Put write-only method value on the stack.\r
+1 CONSTANT W/O\r
+\r
+\ R/W ( -- fam ) \ FILE\r
+\ Put read/write method value on the stack.\r
+2 CONSTANT R/W\r
+\r
+\ READ-FILE ( c_addr u1 fileid -- u2 ior ) \ FILE\r
+\ Read u1 consecutive characters to c_addr from the current\r
+\ position of the file.\r
+\ Results:\r
+\ u2=u1, ior=0 \ read with no exception\r
+\ u2<u1, ior=0 \ end-of-file\r
+\ u2=0, ior=0 \ FILE-POSITION equals FILE-SIZE\r
+\ u2>=0, ior<>0 \ u2 is # chars read until exception occurs\r
+CODE READ-FILE\r
+ 3F # AH MOV,\r
+ CX POP,\r
+ DX POP,\r
+ 21 INT,\r
+ AX PUSH,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+\ READ-LINE ( c_addr u1 fileid -- u2 flag ior ) \ FILE\r
+\ Read the next line from the file.\r
+\ Results:\r
+\ x x nonzero \ Something bad and unexpected happened l\r
+\ 0 false 0 \ End-of-file; no characters were read\r
+\ 0 true 0 \ A blank line was read\r
+\ 0<u2<u1 true 0 \ The entire line was read\r
+\ u1 true 0 \ A partial line was read; the rest would\r
+\ \ not fit in the buffer, and can be acquired\r
+\ \ by additional calls to READ-LINE.\r
+: READ-LINE\r
+ >R OVER SWAP R@ \ ca ca u1 fid R: fid\r
+ READ-FILE \ ca u2 ior R: fid\r
+ ?dupR>DropExit \ exit on error\r
+ DUP 0= IF NIP DUP DUP R> DROP EXIT THEN \ 0 false 0, end-of-file\r
+ DUP >R OVER + OVER \ ca ca+u2 ca R: fid u2\r
+ DO I C@ \ ca char R: fid u2 loop_index\r
+ DUP 09 ( TAB ) = IF BL I C! THEN\r
+ DUP 1A ( ctrl-Z ) = IF\r
+ DROP I UNLOOP R> DROP\r
+ SWAP - \ ca'-ca (# chars before ctrl-Z) R: fid\r
+ DUP 0= 0= \ u -1|0 R: fid\r
+ R@ FILE-SIZE \ u -1|0 ud ior R: fid\r
+ ?dupR>Drop2NipExit\r
+ R> REPOSITION-FILE EXIT\r
+ THEN\r
+ crlf= IF I UNLOOP \ ca ca' R: fid u1\r
+ TUCK CHAR+ DUP C@ crlf=\r
+ IF CHAR+ THEN \ ca' ca ca'+1|2 R: fid u1\r
+ OVER - \ ca' ca line_length R: fid u1\r
+ R> - \ ca' ca #chars_to_roll_back R: fid\r
+ S>D R> 1 (reposition-file) \ ca' ca ud ior\r
+ DROP 2DROP \ ca' ca ; adjust file position\r
+ - TRUE 0 EXIT\r
+ THEN\r
+ LOOP \ ca R: fid u2\r
+ DROP R> TRUE 0 R> DROP ; \ line terminator not found, partial lile read\r
+\r
+\ S" Interpretation: ( 'ccc<">' -- c_addr u ) \ FILE\r
+\ Compilation: ( 'ccc<">' -- )\r
+\ Run-time: ( -- c_addr u )\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : S"\r
+ STATE @ IF POSTPONE S" EXIT THEN \ CORE word S"\r
+ S"buffer DUP [CHAR] " PARSE DUP >R \ S"buf S"buf c_addr u R: u\r
+ ROT SWAP CHARS MOVE R>\r
+ ; IMMEDIATE\r
+[THEN]\r
+\ Define non-IMMEDIATE S" using special compilation action mechanism\r
+\ Structure of words with special compilation action, CREATEd words and S",\r
+\ for default compilation behavior\r
+\ |compile_xt|name_ptr| execution_code |\r
+\ Structure of dictionary in data segment\r
+\ | xt | link | name |\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ :NONAME\r
+ DROP \ drop execution xt left for special compilation action\r
+ POSTPONE S" ;\r
+ code, \ store compilation xt\r
+ ' S" xt>name DUP code, \ store name pointer\r
+ :NONAME\r
+ [CHAR] " PARSE DUP >R \ c_addr u R: u\r
+ CHARS S"buffer SWAP MOVE\r
+ S"buffer R> ;\r
+ SWAP \ execution_S"_xt S"_name_addr\r
+ DUP C@ \ get flags\r
+ 60 INVERT AND \ clear IMMEDIATE and COMPILE-ONLY flags\r
+ 80 OR \ set special compilation action flag\r
+ OVER C! \ store flags\r
+ cell- cell- ! \ store new execution xt\r
+[THEN]\r
+\r
+\ SOURCE-ID ( -- 0|-1|fileid ) \ FILE\r
+\ Returns input source identifier: 0 for user input device,\r
+\ -1 for string (via EVALUATE), and fileid for text file.\r
+\\r
+\ INCLUDE-FILE and INCLUDED set SOURCE-ID to proper values.\r
+\r
+\ WRITE-FILE ( c_addr u fileid -- ior ) \ FILE\r
+\ Write u characters from c_addr u to the file.\r
+HEX\r
+CODE WRITE-FILE\r
+ 40 # AH MOV,\r
+ CX POP,\r
+ DX POP,\r
+ 21 INT,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+CREATE cr-lf 0D C, 0A C, ALIGN\r
+\r
+\ WRITE-LINE ( c_addr u fileid -- ior ) \ FILE\r
+\ Write u characters from c_addr followed by line terminator\r
+\ to the file.\r
+: WRITE-LINE\r
+ DUP >R WRITE-FILE \ ior R: fid\r
+ ?dupR>DropExit\r
+ cr-lf 2 R> WRITE-FILE ;\r
+\r
+\ RESIZE-FILE ( ud fileid -- ior ) \ FILE\r
+\ Set the size of the file to ud.\r
+: RESIZE-FILE\r
+ DUP >R \ ud1 fid R: fid\r
+ FILE-SIZE \ ud1 ud2 ior R: fid\r
+ ?dupR>Drop4NipExit\r
+ 2OVER DNEGATE D+ \ ud1 ud2-ud1 R: fid\r
+ NIP 0< \ file_size < ud ?\r
+ IF R@ FILE-SIZE \ ud1 ud3 ior R: fid\r
+ ?dupR>Drop4NipExit\r
+ 2DUP R@ REPOSITION-FILE \ ud1 ud3 ior R: fid\r
+ ?dupR>Drop4NipExit\r
+ DNEGATE D+ \ ud1-ud3 R: fid\r
+ BEGIN \ u_low u_high R: fid\r
+ ?DUP WHILE\r
+ 0 8000 R@ WRITE-FILE \ u1 u2 ior R: fid\r
+ ?dupR>Drop2NipExit\r
+ 0 8000 R@ WRITE-FILE \ u1 u2 ior R: fid\r
+ ?dupR>Drop2NipExit\r
+ 1- \ u1 u2-1 R: fid\r
+ REPEAT \ u1 R: fid\r
+ 0 SWAP R> WRITE-FILE EXIT\r
+ THEN \ ud1 R: fid\r
+ R@ REPOSITION-FILE \ ior R: fid\r
+ ?dupR>DropExit\r
+ 0 0 R> WRITE-FILE ; \ writing 0 byte truncates the file in MS-DOS.\r
+\r
+\ FILE-STATUS ( c_addr u -- x ior ) \ FILE EXT\r
+\ Return the status of the named file. If the file exists,\r
+\ ior is 0. x contains implementation-defined information\r
+\ about the file.\r
+: FILE-STATUS\r
+ asciiz (file-status) ;\r
+\r
+\ FLUSH-FILE ( fileid -- ior ) \ FILE EXT\r
+\ Attempt to force any buffered information written to the file\r
+\ and update the directory.\r
+CODE FLUSH-FILE\r
+ 45 # AH MOV,\r
+ 21 INT,\r
+ 1 L# JC,\r
+ AX BX MOV,\r
+ 3E # AH MOV,\r
+ 21 INT,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+1 L:\r
+ ' get-ior # JMP,\r
+END-CODE\r
+\r
+\ RENAME-FILE ( c_addr1 u1 c_addr2 u2 -- ior ) \ FILE\r
+\ Rename the file named bye c_addr1 u1 to the name c_addr2 u2.\r
+: RENAME-FILE\r
+ \ another asciiz buffer after PAD\r
+ PAD [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL +\r
+ DUP >R SWAP 2DUP + 0 SWAP C! CHARS MOVE\r
+ asciiz R> (rename-file) ;\r
+\r
+\ SAVE-BUFFERS ( -- ) \ BLOCK\r
+\ Transfer the contents of each UPDATEd block buffer to mass\r
+\ storage. Mark all buffers as unmodified.\r
+: SAVE-BUFFERS\r
+ updated IF\r
+ current-block# 1K UM* block-fid REPOSITION-FILE THROW\r
+ block-buffer 1K block-fid WRITE-FILE THROW\r
+ block-fid FLUSH-FILE\r
+ 0 TO updated\r
+ THEN ;\r
+\r
+\ BUFFER ( u -- a_addr ) \ BLOCK\r
+\ a_addr is the address of the first character of the block\r
+\ buffer assigned to block u. The contents of the block are\r
+\ unspecified.\r
+\ If block u is already in a block buffer, a_addr is the address\r
+\ of that block buffer.\r
+\ If block u is not already in memory and there is an unassigned\r
+\ block buffer, a_addr is the address of that block buffer.\r
+\ If block u is not already in memory and there are no\r
+\ unassigned block buffer, unassign a block. If the block\r
+\ in that buffer has been UPDATEd, transfer the block to\r
+\ mass storage. a_addr is the address of that block buffer.\r
+\ At the conclusion of the operateion, the block buffer pointed\r
+\ to by a_addr is the current block buffer and is assigned\r
+\ to u.\r
+: BUFFER\r
+ SAVE-BUFFERS\r
+ TO current-block# block-buffer ;\r
+\r
+DECIMAL\r
+\ BLOCK ( u -- a_addr ) \ BLOCK\r
+\ a_addr is the address of the first character of the block\r
+\ buffer assigned to mass-storage block u.\r
+\ If block u is already in a block buffer, a_addr is the address\r
+\ of the block.\r
+\ If block u is not already in memory and there is an unassigned\r
+\ block buffer, transfer block u from mass storage to an\r
+\ unassigned block buffer. a_addr is the address of that\r
+\ block buffer.\r
+\ If block u is not already in memory and there are no\r
+\ unassigned block buffer, unassign a block. If the block\r
+\ in that buffer has been UPDATEd, transfer the block to\r
+\ mass storage and transfer block u from mass storage into\r
+\ that buffer. a_addr is the address of that block buffer.\r
+\ At the conclusion of the operateion, the block buffer pointed\r
+\ to by a_addr is the current block buffer and is assigned\r
+\ to u.\r
+: BLOCK\r
+ DUP current-block# = IF DROP block-buffer EXIT THEN\r
+ DUP BUFFER DROP\r
+ 1K UM* block-fid REPOSITION-FILE THROW\r
+ block-buffer 1K block-fid READ-FILE THROW\r
+ 1K = 0= IF ." Unexpected end of BLOCK file."\r
+ -33 THROW THEN \ block read exception\r
+ block-buffer ;\r
+\r
+\ SAVE-INPUT ( -- xn ... x1 n ) \ CORE EXT\r
+\ Implementated as ( -- c_addr u >in source_id blk@ 5 )\r
+\ x1 through xn describe the current state of the input source\r
+\ specification for later use by RESTORE-INPUT .\r
+: SAVE-INPUT\r
+ SOURCE >IN @ SOURCE-ID BLK @ 5 ;\r
+\r
+\ RESTORE-INPUT ( xn ... x1 n -- flag ) \ CORE EXT\r
+\ Attempt to restore the input specification to the state\r
+\ described by x1 through xn. flag is true if the input\r
+\ source specification cannot be so restored.\r
+: RESTORE-INPUT\r
+ DUP 5 = IF DROP DUP IF BLOCK THEN\r
+ BLK ! TO SOURCE-ID >IN ! sourceVar 2!\r
+ FALSE EXIT\r
+ THEN 0 DO DROP LOOP TRUE ;\r
+\r
+\ EMPTY-BUFFERS ( -- ) \ BLOCK EXT\r
+\ Unassign all block buffers. Do not transfer the contents of\r
+\ any UPDATEd block buffer to mass storage.\r
+: EMPTY-BUFFERS\r
+ -1 TO current-block#\r
+ 0 TO updated ;\r
+\r
+\ EVALUATE ( i*x c-addr u -- j*x ) \ CORE, BLOCK\r
+\ Evaluate the string. Save the input source specification.\r
+\ Store -1 in SOURCE-ID. Store 0 in BLK.\r
+: EVALUATE 0 BLK ! EVALUATE ;\r
+\r
+\ FLUSH ( -- ) \ BLOCK\r
+\ Perform the function of SAVE-BUFFERS, then unassign all block\r
+\ buffers.\r
+: FLUSH SAVE-BUFFERS EMPTY-BUFFERS ;\r
+\r
+\ LOAD ( i*x u -- j*x ) \ BLOCK\r
+\ Save the current input-source specification. Store u in BLK\r
+\ (thus making block u the input source and setting the input\r
+\ source buffer to encompass its contents), set >IN to 0, and\r
+\ interpret. When the parse area is exhausted, restore the\r
+\ prior input source specification. Other stack effects are due\r
+\ to the words LOADed.\r
+: LOAD\r
+ SAVE-INPUT\r
+ DUP BEGIN ?DUP WHILE 1- ROT >R REPEAT >R\r
+ DUP BLK ! BLOCK 1K\r
+ sourceVar 2! 0 >IN !\r
+ interpret\r
+ R> DUP BEGIN ?DUP WHILE 1- R> ROT ROT REPEAT\r
+ RESTORE-INPUT\r
+ IF ." Input source specification was not properly restored."\r
+ -37 THROW \ file I/O exception\r
+ THEN ;\r
+\r
+\ SOURCE ( -- c_addr u ) \ CORE\r
+\\r
+: SOURCE\r
+ BLK @ ?DUP IF BLOCK 1K EXIT THEN\r
+ SOURCE ; \ old SOURCE\r
+\r
+\ UPDATE ( -- ) \ BLOCK\r
+\ Mark the current block buffer as modified.\r
+: UPDATE\r
+ current-block# -1 = IF\r
+ ." There is no current block buffer."\r
+ -35 THROW THEN \ invalid block number\r
+ TRUE TO updated ;\r
+\r
+\ SCR ( -- a_addr ) \ BLOCK EXT\r
+\ a_addr is the address of a cell containing the block number\r
+\ of the block most recently LISTed.\r
+VARIABLE SCR 0 SCR !\r
+\r
+\ LIST ( u -- ) \ BLOCK EXT\r
+\ Display block u in an implementation-defined format.\r
+\ Store u in SCR.\r
+DECIMAL\r
+: LIST\r
+ DUP SCR ! BLOCK BASE @ DECIMAL SWAP\r
+ 16 0 DO CR I 2 .R SPACE\r
+ 64 2DUP TYPE + LOOP CR DROP\r
+ BASE ! ;\r
+\r
+\ THRU ( i*x u1 u2 -- j*x ) \ BLOCK EXT\r
+\ LOAD the mass storage blocks numbered u1 through u2 in\r
+\ sequence. Other stack effects are due to the words LOADed.\r
+: THRU\r
+ 1+ SWAP DO I LOAD LOOP ;\r
+\r
+\ INCLUDE-FILE ( i*x fileid -- j*x ) \ FILE\r
+\ Remove fileid, save the current input source specification\r
+\ including current value of SOURCE-ID. Store fileid in\r
+\ SOURCE-ID . Make the file specified by fileid the input\r
+\ source. Store 0 in BLK . Repeat read a line, fill the input\r
+\ buffer, set >IN 0 and interpret until the end of the file.\r
+\\r
+\ Each text file has its own input buffer below PAD.\r
+\ In MS-DOS, fileid is normally 5 to 20.\r
+DECIMAL\r
+: INCLUDE-FILE\r
+ SAVE-INPUT\r
+ DUP BEGIN ?DUP WHILE 1- ROT >R REPEAT >R\r
+ TO SOURCE-ID input-buffer >R\r
+ BEGIN\r
+ R@ DUP [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL\r
+ SOURCE-ID \ ca ca u1 fileid\r
+ READ-LINE \ ca u2 flag ior\r
+ THROW\r
+ WHILE\r
+ sourceVar 2! 0 >IN !\r
+ interpret\r
+ REPEAT 2DROP R> DROP\r
+ R> DUP BEGIN ?DUP WHILE 1- R> ROT ROT REPEAT\r
+ RESTORE-INPUT\r
+ IF ." Input source specification was not properly restored."\r
+ -37 THROW \ file I/O exception\r
+ THEN ;\r
+\r
+\ INCLUDED ( i*x c_addr u -- j*x ) \ FILE\r
+\ Open the named file and do INCLUDE-FILE .\r
+: INCLUDED\r
+ R/O OPEN-FILE THROW\r
+ DUP >R INCLUDE-FILE\r
+ R> CLOSE-FILE THROW ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+\ for convenience, not to use in Standard program\r
+: INCLUDE ( i*x 'filename<space>' -- j*x )\r
+ BL PARSE INCLUDED ;\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ REFILL ( -- flag ) \ CORE EXT, BLOCK EXT, FILE EXT\r
+\ Extend the execution semantics of REFILL for block and file\r
+\ input.\r
+\ When the input source is a block, make the next block the input\r
+\ source and current input buffer by adding one to the value\r
+\ of BLK and setting >IN to 0. Return true if the new value\r
+\ of BLK is a valid block number, otherwise false.\r
+\ On file input attempt to read the next line from the text-input file.\r
+\ If sucessful, make the result the current input buffer, set\r
+\ >IN to 0, and return true.\r
+: REFILL\r
+ BLK @ IF 1+ DUP BLK ! BLOCK block-buffer 1K sourceVar 2! 0 >IN ! TRUE\r
+ EXIT THEN\r
+ SOURCE-ID -1 = IF 0 EXIT THEN\r
+ SOURCE-ID 0= IF REFILL EXIT THEN \ old REFILL\r
+ input-buffer\r
+ DUP [ BL PARSE /PAD ENVIRONMENT? DROP CHARS ] LITERAL\r
+ SOURCE-ID \ ca ca u1 fileid\r
+ READ-LINE \ ca u2 flag ior\r
+ IF 2DROP DROP FALSE EXIT THEN\r
+ IF sourceVar 2! 0 >IN ! TRUE EXIT THEN\r
+ 2DROP FALSE ;\r
+\r
+\ \ ( 'ccc<eol>' -- ) \ CORE EXT, BLOCK EXT\r
+\ Extend the semantics of '\' for block.\r
+\ If BLK contains 0, parse and discard the remainder of the parse\r
+\ area; otherwise parse and discard the portion of the parse\r
+\ area corresponding to the remainder of the current line.\r
+DECIMAL\r
+: \ BLK @ IF >IN @ 63 + -64 AND\r
+ ELSE SOURCE NIP\r
+ THEN >IN ! ; IMMEDIATE\r
+\r
+\ ( ( 'ccc<)>' -- ) \ CORE, FILE\r
+\ Extend the semantics of '(' for file.\r
+\ Skip until ')' or end-of-file.\r
+: (\r
+ BEGIN\r
+ [CHAR] ) PARSE 2DROP\r
+ SOURCE NIP >IN @ XOR IF EXIT THEN \ ')' is if source is not fully parsed\r
+ SOURCE 1- CHARS + C@ [CHAR] ) = IF EXIT THEN\r
+ REFILL 0=\r
+ UNTIL ; IMMEDIATE\r
+\r
+\ [ELSE] ( *<spaces>name...* - ) \ TOOLS EXT\r
+\ Skipping leading spaces, parse and discard words from the\r
+\ parse area, including nested [IF] ... [THEN] and [IF] ...\r
+\ [ELSE] ... [THEN], until the word [THEN] has been parsed\r
+\ and discared.\r
+: [ELSE] ( -- )\r
+ 1 BEGIN \ level\r
+ BEGIN PARSE-WORD DUP WHILE \ level c-addr len\r
+ 2DUP S" [IF]" COMPARE 0= IF \ level c-addr len\r
+ 2DROP 1+ \ level'\r
+ ELSE \ level c-addr len\r
+ 2DUP S" [ELSE]" COMPARE 0= IF \ level c-addr len\r
+ 2DROP 1- DUP IF 1+ THEN \ level'\r
+ ELSE \ level c-addr len\r
+ S" [THEN]" COMPARE 0= IF \ level\r
+ 1- \ level'\r
+ THEN\r
+ THEN\r
+ THEN ?DUP 0= IF EXIT THEN \ level'\r
+ REPEAT 2DROP \ level\r
+ REFILL 0= UNTIL \ level\r
+ DROP ; IMMEDIATE\r
+\r
+\ [IF] ( flag | flag *<spaces>name...* -- ) \ TOOLS EXT\r
+\ If flag is true, do nothing. Otherwise, Skipping leading\r
+\ spaces, parse and discard words from the parse area,\r
+\ including nested [IF] ... [THEN] and [IF] ... [ELSE] ...\r
+\ [THEN], until either the word [ELSE] or [THEN] has been\r
+\ parsed and discared.\r
+: [IF] ( flag -- ) \ TOOLS EXT\r
+ 0= IF POSTPONE [ELSE] THEN ; IMMEDIATE\r
+\r
+HEX\r
+\ TIME&DATE ( -- +n1 +n2 +n3 +n4 +n5 +n6 ) \ FACILITY EXT\r
+\ Return the current time and date. +n1 is the second {0...59},\r
+\ +n2 is the minute {0...59}, +n3is the hour {0...23}, +n4 is\r
+\ the day {1...31} +n5 is the month {1...12}, and +n6 is the\r
+\ year(e.g., 1991).\r
+CODE TIME&DATE\r
+ BX PUSH,\r
+ BX BX XOR,\r
+ 2C # AH MOV,\r
+ 21 INT,\r
+ DH BL MOV,\r
+ BX PUSH, \ second\r
+ CL BL MOV,\r
+ BX PUSH, \ minute\r
+ CH BL MOV,\r
+ BX PUSH, \ hour\r
+ 2A # AH MOV,\r
+ 21 INT,\r
+ DL BL MOV,\r
+ BX PUSH, \ day\r
+ DH BL MOV,\r
+ BX PUSH, \ month\r
+ CX BX MOV, \ year\r
+ NEXT,\r
+END-CODE\r
+\r
+DOS-WORDLIST SET-CURRENT\r
+\r
+HERE CHAR " PARSE insufficient disk space" HERE pack" TO HERE \ 27h 39\r
+HERE CHAR " PARSE cannot complete file operation (out of input)" HERE pack" TO HERE\r
+HERE CHAR " PARSE code page mismatch" HERE pack" TO HERE\r
+HERE CHAR " PARSE sharing buffer overflow" HERE pack" TO HERE\r
+HERE CHAR " PARSE FCB unavailable" HERE pack" TO HERE\r
+HERE CHAR " PARSE disk change invalid" HERE pack" TO HERE\r
+HERE CHAR " PARSE lock violation" HERE pack" TO HERE\r
+HERE CHAR " PARSE sharing violation" HERE pack" TO HERE\r
+HERE CHAR " PARSE general failure" HERE pack" TO HERE\r
+HERE CHAR " PARSE read fault" HERE pack" TO HERE\r
+HERE CHAR " PARSE write fault" HERE pack" TO HERE\r
+HERE CHAR " PARSE printer out of paper" HERE pack" TO HERE\r
+HERE CHAR " PARSE sector not found" HERE pack" TO HERE\r
+HERE CHAR " PARSE unknown media type (non-DOS disk)" HERE pack" TO HERE\r
+HERE CHAR " PARSE seek error" HERE pack" TO HERE\r
+HERE CHAR " PARSE bad request structure length" HERE pack" TO HERE\r
+HERE CHAR " PARSE data error (CRC)" HERE pack" TO HERE\r
+HERE CHAR " PARSE unknown command" HERE pack" TO HERE\r
+HERE CHAR " PARSE drive not ready" HERE pack" TO HERE\r
+HERE CHAR " PARSE unknown unit" HERE pack" TO HERE\r
+HERE CHAR " PARSE disk write-protected" HERE pack" TO HERE\r
+HERE CHAR " PARSE no more files" HERE pack" TO HERE\r
+HERE CHAR " PARSE not same device" HERE pack" TO HERE\r
+HERE CHAR " PARSE attempted to remove current directory" HERE pack" TO HERE\r
+HERE CHAR " PARSE invalid drive" HERE pack" TO HERE\r
+HERE CHAR " PARSE reserved" HERE pack" TO HERE\r
+HERE CHAR " PARSE data invalid" HERE pack" TO HERE\r
+HERE CHAR " PARSE access code invalid" HERE pack" TO HERE\r
+HERE CHAR " PARSE format invalid" HERE pack" TO HERE\r
+HERE CHAR " PARSE environment invalid (usually >32K in length)" HERE pack" TO HERE\r
+HERE CHAR " PARSE memory block address invalid" HERE pack" TO HERE\r
+HERE CHAR " PARSE insufficient memory" HERE pack" TO HERE\r
+HERE CHAR " PARSE memory control block destroyed" HERE pack" TO HERE\r
+HERE CHAR " PARSE invalid handle" HERE pack" TO HERE\r
+HERE CHAR " PARSE access denied" HERE pack" TO HERE\r
+HERE CHAR " PARSE too many open files (no handles available)" HERE pack" TO HERE\r
+HERE CHAR " PARSE path not found" HERE pack" TO HERE\r
+HERE CHAR " PARSE file not found" HERE pack" TO HERE\r
+HERE CHAR " PARSE function number invalid" HERE pack" TO HERE\r
+HERE CHAR " PARSE no error" HERE pack" TO HERE \ 0\r
+\r
+CREATE DOSErrorMsgTbl\r
+ , , , , , , , , , , , , , , , , , , , ,\r
+ , , , , , , , , , , , , , , , , , , , ,\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+DECIMAL\r
+: QUIT\r
+ BEGIN\r
+ rp0 rp! 0 BLK ! 0 TO SOURCE-ID 0 TO bal POSTPONE [\r
+ BEGIN CR REFILL DROP SPACE \ REFILL returns always true\r
+ ['] interpret CATCH ?DUP 0=\r
+ WHILE STATE @ 0= IF .prompt THEN\r
+ REPEAT\r
+ DUP -1 XOR IF \ ABORT\r
+ DUP -2 = IF SPACE abort"msg 2@ TYPE ELSE \ ABORT"\r
+ SPACE errWord 2@ TYPE\r
+ SPACE [CHAR] ? EMIT SPACE\r
+ DUP [ 1 iorOffset + ] LITERAL\r
+ [ 40 iorOffset + ] LITERAL\r
+ WITHIN IF iorOffset - CELLS DOSErrorMsgTbl +\r
+ @ COUNT TYPE ELSE \ DOS error\r
+ DUP -1 -58 WITHIN IF ." Exeption # " . ELSE \ undefined exeption\r
+ CELLS THROWMsgTbl + @ COUNT TYPE THEN THEN THEN THEN\r
+ sp0 sp!\r
+ AGAIN ;\r
+\r
+: BYE block-fid FLUSH-FILE BYE ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+: MAPPED-TO-BLOCK ( c_addr u -- )\r
+ -1 TO block-fid\r
+ 2DUP R/W OPEN-FILE ?DUP IF\r
+ NIP \ drop invalid fileid\r
+ DUP [ 2 iorOffset + ] LITERAL\r
+ <> IF \ not 'file not found error', cannot map block to BLOCKS.BLK\r
+ -1 TO block-fid\r
+ ." Cannot map BLOCK to " ROT ROT TYPE [CHAR] . EMIT\r
+ THROW THEN\r
+ DROP ." Create " 2DUP TYPE ." for BLOCK"\r
+ 2DUP R/W CREATE-FILE THROW\r
+ HERE 1K BL FILL\r
+ def#blocks 0 DO DUP HERE 1K ROT WRITE-FILE THROW LOOP\r
+ DUP FLUSH-FILE THROW\r
+ THEN\r
+ DUP FILE-SIZE THROW\r
+ 1K UM/MOD TO #blocks DROP \ store file-size/1K in #blocks\r
+ TO block-fid 2DROP ;\r
+\r
+BL PARSE BLOCKS.BLK MAPPED-TO-BLOCK\r
+\ new boot word, jump into new QUIT\r
+\r
+HEX\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : DOSCommand>PAD\r
+ 80 PAD OVER C@ 1+ CHARS MOVE ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : DOSCommand>PAD\r
+ CS@ 10 - \ PSP segment\r
+ 80 2DUP LC@ 1+ 0 DO 2DUP LC@ PAD I + C! CHAR+ LOOP 2DROP ;\r
+[THEN]\r
+\r
+: newboot ( -- )\r
+ 0 MaxHandle ! \ to be used to calculate UNUSED data space.\r
+ DOSCommand>PAD\r
+ hi S" BLOCKS.BLK" MAPPED-TO-BLOCK QUIT ;\r
+\r
+' newboot TO 'boot\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ DOS-WORDLIST SET-CURRENT\r
+ HEX\r
+ CREATE EXEHead\r
+ 5A4D , \ file ID for .EXE file\r
+ 0 , 0 , \ * file size (remainder and # of 512B pages)\r
+ 0 , 20 , \ no relocatable item, head is 20h paragraphs (512B)\r
+ 2000 , \ 128 KB needs to be allocated\r
+ 0FFFF , \ max paragraphs to allocate\r
+ 0 , 0 , \ stack relative segment and initial stack pointer\r
+ 0 , \ checksum\r
+ 06 , 0 , \ initial relative CS:IP\r
+ 1C , \ offset in bytes of the relocation pointer table\r
+ 0 , \ overlay number, 0 for main program\r
+ 0 , 0 , \ Total is 32 bytes.\r
+\r
+ \ xWrite-file ( code_space_addr u fileid -- ior )\r
+ \ Write u characters from c_addr u to the file.\r
+ CODE xWrite-file\r
+ 40 # AH MOV,\r
+ CX POP,\r
+ DX POP,\r
+ CS DI MOV,\r
+ DS PUSH,\r
+ DI DS MOV,\r
+ 21 INT,\r
+ DS POP,\r
+ 1 L# JC,\r
+ BX BX XOR,\r
+ NEXT,\r
+ 1 L:\r
+ ' get-ior # JMP,\r
+ END-CODE\r
+\r
+ NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+ : SYSTEM-SAVED ( c-addr u -- )\r
+ W/O CREATE-FILE THROW ( fileid ) >R\r
+ #order DUP @ #order0 SWAP 1+ CELLS MOVE \ adjust default search order\r
+ HERE 0F + 4 RSHIFT \ data_paragraphs\r
+ 1000 \ data_paragraphs code_paragraphs\r
+ + 0 20 UM/MOD OVER IF 1+ THEN \ add 1 if partial page\r
+ 1+ \ one head page\r
+ \ mod16 #pages\r
+ EXEHead 4 + ! \ mod16\r
+ 4 LSHIFT EXEHead 2 + !\r
+ HERE 200 0 FILL EXEHead HERE 20 MOVE\r
+ HERE 200 R@ WRITE-FILE THROW\r
+ 0 8000 R@ xWrite-file THROW\r
+ 8000 8000 R@ xWrite-file THROW\r
+ 0 HERE 0F + 0FFF0 AND R@ WRITE-FILE THROW\r
+ R> CLOSE-FILE THROW ;\r
+\r
+ : SAVE-SYSTEM-AS ( 'name' -- )\r
+ BL PARSE SYSTEM-SAVED ;\r
+[THEN]\r
+\r
+envQList SET-CURRENT\r
+-1 CONSTANT BLOCK\r
+-1 CONSTANT BLOCK-EXT\r
+-1 CONSTANT FILE\r
+-1 CONSTANT FILE-EXT\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
+\r
+QUIT\r
+\r
+<< CON\r
--- /dev/null
+\\r
+\ Multitasker Demo Program\r
+\\r
+\ This demo is very crude, however, it shows hForth's multitasking ability.\r
+\\r
+\ Reserve enough space for data and return stack for each task.\r
+\ Data stack and return stack seems to be at lease 50 CELLS deep for MS-DOS.\r
+\\r
+\ 1995. 5. 1.\r
+\ By Wonyong Koh\r
+\r
+BASE @ DECIMAL\r
+\r
+0 50 CELLS 50 CELLS HAT TASK0\r
+0 50 CELLS 50 CELLS HAT TASK1\r
+0 50 CELLS 50 CELLS HAT TASK2\r
+0 50 CELLS 50 CELLS HAT TASK3\r
+TASK0 BUILD\r
+TASK1 BUILD\r
+TASK2 BUILD\r
+TASK3 BUILD\r
+:NONAME TASK0 ACTIVATE BEGIN 1000 0 DO PAUSE LOOP [CHAR] 0 EMIT AGAIN ; EXECUTE\r
+:NONAME TASK1 ACTIVATE BEGIN 2000 0 DO PAUSE LOOP [CHAR] 1 EMIT AGAIN ; EXECUTE\r
+:NONAME TASK2 ACTIVATE BEGIN 4000 0 DO PAUSE LOOP [CHAR] 2 EMIT AGAIN ; EXECUTE\r
+:NONAME TASK3 ACTIVATE BEGIN 8000 0 DO PAUSE LOOP [CHAR] 3 EMIT AGAIN ; EXECUTE\r
+TASK0 SLEEP\r
+TASK1 SLEEP\r
+TASK2 SLEEP\r
+TASK3 SLEEP\r
+\r
+BASE !\r
+CR .( Try 'TASK1 AWAKE TASK2 AWAKE' and wait for a while.)\r
+CR .( Try 'TASK2 SLEEP' and wait for a while and try 'TASK1 SLEEP'.)\r
+CR .( You will get the idea.)\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\\r
+\ hForth multitasker\r
+\\r
+\ Originally written by Bill Muench.\r
+\ Adapted to hForth by Wonyong Koh\r
+\\r
+\ Usage:\r
+\ HAT ( user_size ds_size rs_size "<spaces>name" -- )\r
+\ Run-time: ( -- tid )\r
+\ Create a new task.\r
+\ BUILD ( tid -- )\r
+\ Initialize and link new task into PAUSE chain.\r
+\ ACTIVATE ( tid -- )\r
+\ Activate the task identified by tid. ACTIVATE must be used\r
+\ only in definition. The code following ACTIVATE must not\r
+\ EXIT. In other words it must be infinite loop like QUIT.\r
+\ .TASKS ( -- )\r
+\ Display tasks list in status-follower chain.\r
+\ SLEEP ( tid -- )\r
+\ Sleep another task.\r
+\ AWAKE ( tid -- )\r
+\ Awake another task.\r
+\ PAUSE ( -- )\r
+\ Stop current task and transfer control to the task of which\r
+\ 'status' USER variable is stored in 'follower' USER variable\r
+\ of current task.\r
+\ STOP ( -- )\r
+\ Sleep current task.\r
+\\r
+\ 1997. 2. 28.\r
+\ Facelift to be used with other CPUs.\r
+\ 1995. 11. 3.\r
+\ Fix ACTIVATE. sp@ should return a value not larger than sp0.\r
+\r
+BASE @ HEX\r
+GET-CURRENT\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+\ Structure of a task created by HAT\r
+\ userP points follower.\r
+\ //userP//return_stack//data_stack\r
+\ //user_area/user1/taskName/throwFrame/stackTop/status/follower/sp0/rp0\r
+\r
+\ 'PAUSE' and 'wake' are defined in assembler source.\r
+\r
+\ PAUSE ( -- )\r
+\ Stop current task and transfer control to the task of which\r
+\ 'status' USER variable is stored in 'follower' USER variable\r
+\ of current task.\r
+\ CHAR " PARSE systemID" ENVIRONMENT? DROP\r
+\ CHAR " PARSE hForth 8086 ROM Model" COMPARE 0=\r
+\ CHAR " PARSE systemID" ENVIRONMENT? DROP\r
+\ CHAR " PARSE hForth 8086 RAM Model" COMPARE 0= OR\r
+\ [IF]\r
+\ : PAUSE rp@ sp@ stackTop ! follower @ >R ; COMPILE-ONLY\r
+\ [THEN]\r
+\ CHAR " PARSE systemID" ENVIRONMENT? DROP\r
+\ CHAR " PARSE hForth 8086 EXE Model" COMPARE 0=\r
+\ [IF]\r
+\ : PAUSE rp@ sp@ stackTop ! follower @ code@ >R ; COMPILE-ONLY\r
+\ [THEN]\r
+\r
+\ wake ( -- )\r
+\ Wake current task.\r
+\ CHAR " PARSE systemID" ENVIRONMENT? DROP\r
+\ CHAR " PARSE hForth 8086 ROM Model" COMPARE 0=\r
+\ CHAR " PARSE systemID" ENVIRONMENT? DROP\r
+\ CHAR " PARSE hForth 8086 RAM Model" COMPARE 0= OR\r
+\ [IF]\r
+\ : wake R> userP ! \ userP points 'follower' of current task\r
+\ stackTop @ sp! \ set data stack\r
+\ rp! ; COMPILE-ONLY \ set return stack\r
+\ [THEN]\r
+\ CHAR " PARSE systemID" ENVIRONMENT? DROP\r
+\ CHAR " PARSE hForth 8086 EXE Model" COMPARE 0= OR\r
+\ [IF]\r
+\ : wake R> CELL+ code@ userP ! \ userP points 'follower' of current task\r
+\ stackTop @ sp! \ set data stack\r
+\ rp! ; COMPILE-ONLY \ set return stack\r
+\ [THEN]\r
+\r
+\ STOP ( -- )\r
+\ Sleep current task.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : STOP ['] branch status ! PAUSE ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : STOP ['] branch status @ code! PAUSE ;\r
+[THEN]\r
+\r
+\ 's ( tid a-addr -- a-addr' )\r
+\ Index another task's USER variable\r
+: 's\r
+ userP @ - SWAP \ offset tid\r
+ @ + ;\r
+\r
+\ SLEEP ( tid -- )\r
+\ Sleep another task.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : SLEEP status 's ['] branch SWAP ! ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : SLEEP status 's @ ['] branch SWAP code! ;\r
+[THEN]\r
+\r
+\ AWAKE ( tid -- )\r
+\ Awake another task.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : AWAKE status 's ['] wake SWAP ! ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : AWAKE status 's @ ['] wake SWAP code! ;\r
+[THEN]\r
+\r
+\ HAT ( user_size ds_size rs_size "<spaces>name" -- )\r
+\ Run-time: ( -- tid )\r
+\ Create a new task.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : HAT\r
+ RAM/ROM@ >R RAM\r
+ CREATE HERE >R \ user_size ds_size rs_size R: tid\r
+ 0 , ( reserve space for userP pointer)\r
+ ALLOT ( Use 'HERE OVER ALLOT SWAP 0AA FILL')\r
+ ( to see how deep return stack grows.)\r
+ ALIGN HERE cell- >R \ user_size ds_size R: tid rp0\r
+ ALLOT ( Use 'HERE OVER ALLOT SWAP 055 FILL')\r
+ ( to see how deep data stack grows.)\r
+ ALIGN HERE cell- >R \ user_size R: tid rp0 sp0\r
+ ALLOT ALIGN\r
+ [ 6 ( minimul USER variables) CELLS ] LITERAL ALLOT\r
+ HERE cell- \ user_pointer R: tid rp0 sp0\r
+ R> , R> , ( store sp0 and rp0 )\r
+ R@ ! ( store userP pointer)\r
+ lastName R> taskName 's ! \ store task name in new task's 'taskName'\r
+ R> RAM/ROM! ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : HAT\r
+ CREATE HERE >R \ user_size ds_size rs_size R: tid\r
+ 0 , ( reserve space for userP pointer)\r
+ ALLOT ( Use 'HERE OVER ALLOT SWAP 0AA FILL')\r
+ ( to see how deep return stack grows.)\r
+ ALIGN HERE cell- >R \ user_size ds_size R: tid rp0\r
+ ALLOT ( Use 'HERE OVER ALLOT SWAP 055 FILL')\r
+ ( to see how deep data stack grows.)\r
+ ALIGN HERE cell- >R \ user_size R: tid rp0 sp0\r
+ ALLOT ALIGN\r
+ [ 6 ( minimul USER variables) CELLS ] LITERAL ALLOT\r
+ HERE cell- \ user_pointer R: tid rp0 sp0\r
+ R> , R> , ( store sp0 and rp0 )\r
+ R@ ! ( store userP pointer)\r
+ lastName R> taskName 's ! ; \ store task name in new task's 'taskName'\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : HAT\r
+ CREATE HERE >R \ user_size ds_size rs_size R: tid\r
+ 0 , ( reserve space for userP pointer)\r
+ ALLOT ( Use 'HERE OVER ALLOT SWAP 0AA FILL')\r
+ ( to see how deep return stack grows.)\r
+ ALIGN HERE cell- >R \ user_size ds_size R: tid rp0\r
+ ALLOT ( Use 'HERE OVER ALLOT SWAP 055 FILL')\r
+ ( to see how deep data stack grows.)\r
+ ALIGN HERE cell- >R \ user_size R: tid rp0 sp0\r
+ ALLOT ALIGN\r
+ [ 4 ( minimul USER variables less 'status' and 'follower') CELLS ]\r
+ LITERAL ALLOT\r
+ xhere ALIGNED DUP CELL+ CELL+ TO xhere\r
+ DUP , ( store 'status' code-address)\r
+ CELL+ , ( store 'follower' code-address)\r
+ HERE cell- \ user_pointer R: tid rp0 sp0\r
+ DUP COMPILE, ( store 'userP' pointer in code space)\r
+ R> , R> , ( store sp0 and rp0 )\r
+ R@ ! ( store userP pointer)\r
+ lastName R> taskName 's ! ; \ store task name in new task's 'taskName'\r
+[THEN]\r
+\r
+\ BUILD ( tid -- )\r
+\ Initialize and link new task into PAUSE chain.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : BUILD\r
+ DUP SLEEP \ sleep new task\r
+ follower @ OVER \ current task's 'follwer'\r
+ follower 's ! \ store it in new task's 'follower'\r
+ status 's follower ! ; \ store new 'status' in current 'follower'\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : BUILD\r
+ DUP SLEEP \ sleep new task\r
+ follower @ code@ OVER\r
+ follower 's @ code! \ store current task's 'follwer' in new one\r
+ status 's @ follower @ code! ; \ new 'status' in current task's follower\r
+[THEN]\r
+\r
+\ ACTIVATE ( tid -- )\r
+\ Activate the task identified by tid. ACTIVATE must be used\r
+\ only in definition. The code following ACTIVATE must not\r
+\ EXIT. In other words it must be infinite loop like QUIT.\r
+: ACTIVATE\r
+ DUP @ CELL+ 2@ cell- \ top of stack is in BX register\r
+ SWAP \ tid sp0 rp0\r
+ R> OVER ! \ save entry at rp\r
+ OVER ! \ save rp at sp\r
+ OVER stackTop 's ! \ save sp in stackTop\r
+ AWAKE ; COMPILE-ONLY\r
+\r
+\ .TASKS ( -- )\r
+\ Display tasks list in status-follower chain.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : .TASKS\r
+ follower \ current task's follower\r
+ BEGIN\r
+ CR DUP [ taskName follower - ] LITERAL + @ .name\r
+ DUP cell- @ ['] wake = IF ." awaked " ELSE ." sleeping " THEN\r
+ @ CELL+ \ next task's follower\r
+ DUP follower =\r
+ UNTIL DROP CR ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : .TASKS\r
+ follower \ current task's follower\r
+ BEGIN\r
+ CR DUP [ taskName follower - ] LITERAL + @ .name\r
+ DUP @ cell- code@ ['] wake = IF ." awaked " ELSE ." sleeping " THEN\r
+ @ code@ CELL+ CELL+ code@ \ next task's follower\r
+ DUP follower =\r
+ UNTIL DROP CR ;\r
+[THEN]\r
+\r
+\r
+SET-CURRENT\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+\\r
+\ OPTIONAL.F\r
+\ Optional wordset words for 8086 hForth\r
+\\r
+\ by Wonyong Koh\r
+\\r
+\ 1997. 2. 28.\r
+\ Facelift to be used with other CPUs.\r
+\ 1996. 12. 6.\r
+\ Fix 'compiles>' for colon-sys.\r
+\ 1996. 11. 29.\r
+\ Remove PICK which was added in assembly source.\r
+\ Revise CASE, ENDCASE, OF, ENDOF, RETRY for control-flow stack.\r
+\ Revise '.xt' due to the removal of 'do."' and change of 'doS"'.\r
+\ 1995. 12. 26.\r
+\ Revise xt>name.\r
+\ 1995. 11. 25.\r
+\ Add RETRY described by Dr. Astle\r
+\ in Forth Dimensions 17(4), 19-21 (1995).\r
+\ 1995. 11. 7\r
+\ Fix ?DO.\r
+\ 1995. 10. 30.\r
+\ Check validity of xt in 'xt>name'. '-1 @' generates exception.\r
+\ 1995. 10. 17.\r
+\ Replace < with U< in the definition of MARKER for RAM and EXE\r
+\ models. U< should be used to compare addresses.\r
+\ Fix < to U< in the definition of xtSEE\r
+\ 1995. 10. 9.\r
+\ Rename WORDLIST-NAME which more consistant along VARIABLE, CONSTANT\r
+\ than NAME-WORDLIST\r
+\ 1995. 7. 21.\r
+\ Make HERE VALUE type and remove 'hereP'. Revise 'xhere'\r
+\ and remove 'TOxhere'.\r
+\ Make SOURCE-ID VALUE type, replace TOsource-id with\r
+\ "TO SOURCE-ID" and remove TOsource-id .\r
+\ 1995. 6. 11.\r
+\ Fix 'enough?'.\r
+\ 1995. 6. 3.\r
+\ Fix 'xtSEE' for RAM and EXE model.\r
+\\r
+\ Dictionary structures of hForth ROM, RAM and EXE models are all\r
+\ different.\r
+\ o WORDLIST allocate empty wordlist dynamically in RAM and EXE model. Thus,\r
+\ there is no limit on maximum number of wordlist for RAM and EXE model.\r
+\ Maximum number os wordlists are limited to 10 in ROM model.\r
+\ o -1 SET-ORDER is hard coded to put NONSTANDARD-WORDLIST and\r
+\ FORTH-WORDLIST into the search order stack for RAM model.\r
+\ o MARKER is revised for combined code and name space for RAM model.\r
+\ o 'xt>name' are different\r
+\ o PAD, xtSEE, xDUMP are different.\r
+\r
+BASE @\r
+DECIMAL\r
+\r
+\ **********************\r
+\ Optional String wordset\r
+\ **********************\r
+\r
+\ COMPARE ( c-addr1 u1 c-addr2 u2 -- -1|0|1 ) \ STRING\r
+\ Compare the two strings. Return 0 if two strings are identical;\r
+\ -1 if ca1 u1 is smaller than ca2 u2; 1 otherwise.\r
+: COMPARE\r
+ ROT 2DUP SWAP - >R \ ca1 ca2 u2 u1 R: u1-u2\r
+ MIN same? ?DUP\r
+ IF R> DROP EXIT THEN\r
+ R> DUP IF 0< 2* 1+ THEN ;\r
+\r
+\ **********************\r
+\ Optional Prgramming-Tools wordset\r
+\ **********************\r
+\r
+\ [ELSE] ( *<spaces>name...* - ) \ TOOLS EXT\r
+\ Skipping leading spaces, parse and discard words from the\r
+\ parse area, including nested [IF] ... [THEN] and [IF] ...\r
+\ [ELSE] ... [THEN], until the word [THEN] has been parsed\r
+\ and discared.\r
+: [ELSE] ( -- )\r
+ 1 BEGIN \ level\r
+ BEGIN PARSE-WORD DUP WHILE \ level c-addr len\r
+ 2DUP S" [IF]" COMPARE 0= IF \ level c-addr len\r
+ 2DROP 1+ \ level'\r
+ ELSE \ level c-addr len\r
+ 2DUP S" [ELSE]" COMPARE 0= IF \ level c-addr len\r
+ 2DROP 1- DUP IF 1+ THEN \ level'\r
+ ELSE \ level c-addr len\r
+ S" [THEN]" COMPARE 0= IF \ level\r
+ 1- \ level'\r
+ THEN\r
+ THEN\r
+ THEN ?DUP 0= IF EXIT THEN \ level'\r
+ REPEAT 2DROP \ level\r
+ REFILL 0= UNTIL \ level\r
+ DROP ; IMMEDIATE\r
+\r
+\ [IF] ( flag | flag *<spaces>name...* -- ) \ TOOLS EXT\r
+\ If flag is true, do nothing. Otherwise, Skipping leading\r
+\ spaces, parse and discard words from the parse area,\r
+\ including nested [IF] ... [THEN] and [IF] ... [ELSE] ...\r
+\ [THEN], until either the word [ELSE] or [THEN] has been\r
+\ parsed and discared.\r
+: [IF] ( flag -- ) \ TOOLS EXT\r
+ 0= IF POSTPONE [ELSE] THEN ; IMMEDIATE\r
+\r
+\ [THEN] ( -- )\r
+\ Do nothing.\r
+: [THEN] ( -- ) ; IMMEDIATE\r
+\r
+\ **********************\r
+\ Optional Search-Order wordset -- complete\r
+\ **********************\r
+\r
+\ SET-CURRENT ( wid -- ) \ SEARCH\r
+\ Set the compilation wordlist to the wordlist identified by wid.\r
+: SET-CURRENT current ! ;\r
+\r
+\ DEFINITIONS ( -- ) \ SEARCH\r
+\ Make the compilation wordlist the same as the first wordlist\r
+\ in the search order.\r
+: DEFINITIONS #order CELL+ @ SET-CURRENT ;\r
+\r
+\ GET-ORDER ( -- widn .. wid1 n ) \ SEARCH\r
+\ Return the number of wordlist in the search order and the\r
+\ wordlist identifiers widn ... wid1 .\r
+: GET-ORDER\r
+ #order @ DUP\r
+ IF 1- 0 SWAP DO I CELLS #order CELL+ + @ -1 +LOOP\r
+ #order @\r
+ THEN ;\r
+\r
+\ SET-ORDER ( widn .. wid1 n -- ) \ SEARCH\r
+\ Set the search order to the wordlist identified by widn ...\r
+\ wid1. Later wordlist wid1 will be searched first, with wordlist\r
+\ widn searched last. If n is 0, empty the search order. If n\r
+\ is -1, set the search order to the implementation-defined\r
+\ minimum search order.\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : SET-ORDER\r
+ DUP -1 =\r
+ IF DROP [ #order var0 - sysVar0 + ] LITERAL #order\r
+ [ BL PARSE WORDLISTS ENVIRONMENT? DROP 1+ ] LITERAL CELLS\r
+ MOVE EXIT THEN\r
+ DUP [ BL PARSE WORDLISTS ENVIRONMENT? DROP ] LITERAL >\r
+ IF -49 THROW THEN\r
+ DUP #order !\r
+ ?DUP IF 0 DO I CELLS #order CELL+ + ! LOOP THEN ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0= OR\r
+[IF]\r
+ : SET-ORDER\r
+ DUP -1 =\r
+ IF DROP \ restore default # of search order\r
+ #order0 DUP @ #order SWAP 1+ CELLS MOVE EXIT THEN\r
+ DUP [ BL PARSE WORDLISTS ENVIRONMENT? DROP ] LITERAL >\r
+ IF -49 THROW THEN\r
+ DUP #order !\r
+ ?DUP IF 0 DO #order I CELLS + CELL+ ! LOOP THEN ;\r
+[THEN]\r
+\r
+\ WORDLIST ( -- wid ) \ SEARCH\r
+\ Create a new empty wordlist and return its identifier wid.\r
+\ The new wordlist is returned from a preallocated pool for\r
+\ RAM/ROM system in this implementation since they need to be\r
+\ initialized after SAVE-SYSTEM. It may be dynamically allocated\r
+\ in RAM only system.\r
+\\r
+\ structure of a wordlist\r
+\ //lastWord/next_wordlist/wordlist_name//\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : WORDLIST\r
+ FORTH-WORDLIST \ the first wordlist\r
+ BEGIN CELL+ DUP @ WHILE @ REPEAT\r
+ DUP CELL+ CELL+ DUP @ IF \ pre-allocated wordlist is available?\r
+ -49 THROW THEN \ search-order overflow\r
+ DUP ROT ! ; \ attach a wordlist to wordlist link\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0= OR\r
+[IF]\r
+ : WORDLIST\r
+ FORTH-WORDLIST \ the first wordlist\r
+ BEGIN CELL+ DUP @ WHILE @ REPEAT \ find end of wordlist link\r
+ HERE SWAP ! \ attach a wordlist to wordlist link\r
+ HERE 0 , \ no word in this wordlist yet\r
+ 0 , \ this is end of wordlist link\r
+ 0 , ; \ no name is assigned to this wordlist yet.\r
+[THEN]\r
+\r
+\ ALSO ( -- ) \ SEARCH EXT\r
+\ Transform the search order widn ... wid2, wid1 into widn ...\r
+\ wid2, wid1, wid1.\r
+: ALSO GET-ORDER OVER SWAP 1+ SET-ORDER ;\r
+\r
+\ FORTH ( -- )\r
+\ Transform the search order widn ... wid2, wid1 into widn ...\r
+\ wid2, wid_FORTH-WORDLIST.\r
+: FORTH GET-ORDER NIP FORTH-WORDLIST SWAP SET-ORDER ;\r
+\r
+\ ONLY ( -- )\r
+\ Set the search order to the implementation-defined minimum\r
+\ search order.\r
+: ONLY -1 SET-ORDER ;\r
+\r
+\ PREVIOUS ( -- )\r
+\ Transform the search order widn ... wid2, wid1 into widn ...\r
+\ wid2.\r
+: PREVIOUS GET-ORDER NIP 1- SET-ORDER ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+\ .name ( c-addr -- )\r
+\ Display name of a word.\r
+: .name COUNT 31 AND TYPE SPACE ;\r
+\r
+\ WORDLIST-NAME ( wid -- )\r
+\ Name a wordlist. Used to attach a name to a new wordlist\r
+\ returned by WORDLIST to be displayed by ORDER.\r
+: WORDLIST-NAME DUP CONSTANT lastName SWAP CELL+ CELL+ ! ;\r
+\r
+\ .wordlist ( c-addr -- )\r
+\ Display name of a wordlist.\r
+: .wordlist\r
+ 8 SPACES DUP CELL+ CELL+ @ ?DUP\r
+ IF .name DROP CR EXIT THEN . CR ;\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ ORDER ( -- ) \ SEARCH EXT\r
+\ Display the wordlists in the search order from the first\r
+\ to the last. Also display the wordlist into which new\r
+\ definitions will be placed.\r
+: ORDER\r
+ CR ." Search-Order:" CR\r
+ GET-ORDER 0 DO .wordlist LOOP\r
+ ." Current:" CR\r
+ GET-CURRENT .wordlist ;\r
+\r
+envQList SET-CURRENT\r
+-1 CONSTANT SEARCH-ORDER\r
+-1 CONSTANT SEARCH-ORDER-EXT\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ **********************\r
+\ Optional Core Extention wordset\r
+\ **********************\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : xhere HERE ;\r
+ : code, , ;\r
+[THEN]\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ .( ( "ccc<)>" -- ) \ CORE EXT\r
+\ Output following string up to next ) .\r
+: .( [CHAR] ) PARSE TYPE ; IMMEDIATE\r
+\r
+\ D.R ( d n -- ) \ DOUBLE\r
+\ Display d right-justified in field of width n.\r
+: D.R >R (d.) R> OVER - 0 MAX SPACES TYPE ;\r
+\r
+\ .R ( n1 n2 -- ) \ CORE EXT\r
+\ Display n right-justified in field of width n2.\r
+: .R >R S>D R> D.R ;\r
+\r
+\ FALSE ( -- false ) \ CORE EXT\r
+\ Return a false flag.\r
+0 CONSTANT FALSE\r
+\r
+\ HEX ( -- ) \ CORE EXT\r
+\ Set contents of BASE to sixteen.\r
+: HEX 16 BASE ! ;\r
+\r
+\ U> ( u1 u2 -- flag ) \ CORE EXT\r
+\ flag is true if and only if u1 is greater than u2.\r
+: U> SWAP U< ;\r
+\r
+\ MARKER ( "<spaces>name" -- ) \ CORE EXT\r
+\ Create a definition with name. The new definition will\r
+\ restore on execution all dictionary allocations and search\r
+\ order pointers to the state they had just prior to the\r
+\ definition of name.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : MARKER\r
+ ROMB @ ROMT @ RAMB @ RAMT @\r
+ CREATE , , , , GET-CURRENT ,\r
+ FORTH-WORDLIST \ start of wordlist link\r
+ BEGIN CELL+ DUP @ WHILE @ REPEAT \ find end of wordlist link\r
+ , GET-ORDER DUP , 0 DO , LOOP\r
+ DOES> DUP @ RAMT ! CELL+ DUP @ RAMB !\r
+ CELL+ DUP @ ROMT ! CELL+ DUP @ ROMB !\r
+ CELL+ DUP @ SET-CURRENT\r
+ CELL+ DUP @ 0 SWAP ! \ restore end of wordlist link\r
+ CELL+ DUP @ DUP >R CELLS + R@ 0 DO DUP @ SWAP cell- LOOP\r
+ DROP R> SET-ORDER \ restore search order\r
+ FORTH-WORDLIST \ start of wordlist link\r
+ BEGIN DUP @ \ last word name field of wordlist\r
+ BEGIN DUP npVar @ @ U<\r
+ WHILE cell- @\r
+ REPEAT OVER ! \ restore search order pointer\r
+ CELL+ @ ?DUP 0= \ repeat to next wordlist\r
+ UNTIL ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : MARKER\r
+ HERE\r
+ CREATE , GET-CURRENT ,\r
+ FORTH-WORDLIST \ start of wordlist link\r
+ BEGIN CELL+ DUP @ WHILE @ REPEAT \ find end of wordlist link\r
+ , GET-ORDER DUP , 0 DO , LOOP\r
+ DOES> DUP @ TO HERE\r
+ CELL+ DUP @ SET-CURRENT\r
+ CELL+ DUP @ 0 SWAP ! \ restore end of wordlist link\r
+ CELL+ DUP @ DUP >R CELLS + R@ 0 DO DUP @ SWAP cell- LOOP\r
+ DROP R> SET-ORDER \ restore search order\r
+ FORTH-WORDLIST \ start of wordlist link\r
+ BEGIN DUP @ \ last word name field of wordlist\r
+ BEGIN DUP HERE U>\r
+ WHILE cell- @\r
+ REPEAT OVER ! \ restore search order pointer\r
+ CELL+ @ ?DUP 0= \ repeat to next wordlist\r
+ UNTIL ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : MARKER\r
+ HERE xhere\r
+ CREATE , , GET-CURRENT ,\r
+ FORTH-WORDLIST \ start of wordlist link\r
+ BEGIN CELL+ DUP @ WHILE @ REPEAT \ find end of wordlist link\r
+ , GET-ORDER DUP , 0 DO , LOOP\r
+ DOES> DUP @ TO xhere CELL+ DUP @ TO HERE\r
+ CELL+ DUP @ SET-CURRENT\r
+ CELL+ DUP @ 0 SWAP ! \ restore end of wordlist link\r
+ CELL+ DUP @ DUP >R CELLS + R@ 0 DO DUP @ SWAP cell- LOOP\r
+ DROP R> SET-ORDER \ restore search order\r
+ FORTH-WORDLIST \ start of wordlist link\r
+ BEGIN DUP @ \ last word name field of wordlist\r
+ BEGIN DUP HERE U>\r
+ WHILE cell- @\r
+ REPEAT OVER ! \ restore search order pointer\r
+ CELL+ @ ?DUP 0= \ repeat to next wordlist\r
+ UNTIL ;\r
+[THEN]\r
+\r
+\ PAD ( -- a-addr ) \ CORE EXT\r
+\ Return the address of a temporary buffer. See REFILL\r
+\ |PAD|TIB|RAMTop\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : PAD npVar @ [ BL PARSE /PAD ENVIRONMENT? DROP CHARS 3 * NEGATE ] LITERAL + ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : PAD memTop [ BL PARSE /PAD ENVIRONMENT? DROP CHARS 2* NEGATE ] LITERAL + ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : PAD memTop [ BL PARSE /PAD ENVIRONMENT? DROP CHARS 2* NEGATE ] LITERAL + ;\r
+[THEN]\r
+\r
+\ TRUE ( -- true ) \ CORE EXT\r
+\ Return a true flag.\r
+-1 CONSTANT TRUE\r
+\r
+\ U.R ( u n -- ) \ CORE EXT\r
+\ Display u right-justified in field of width n.\r
+: U.R 0 SWAP D.R ;\r
+\r
+HEX\r
+\r
+\ CASE ( C: -- case-sys ) \ CORE EXT\r
+\ Run-time: ( -- )\r
+\ Mark the start of CASE ... OF ... ENDOF ... ENDCASE structure.\r
+\ On run-time, continue execution.\r
+: CASE ( C: -- case-mark )\r
+ 0 3 \ case type is 3\r
+ bal+ ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ ENDCASE ( C: case-sys -- ) \ CORE EXT\r
+\ Run-time: ( x -- )\r
+\ Mark the end of CASE ... OF ... ENDOF ... ENDCASE structure.\r
+\ On run-time, discard the case selector x and continue execution.\r
+: ENDCASE ( C: case-mark of-orig ... of-orig -- )\r
+ POSTPONE DROP\r
+ BEGIN DUP 2 = \ of-orig type is 2\r
+ WHILE 1- POSTPONE THEN\r
+ REPEAT\r
+ 3 - IF -22 THROW THEN \ control structure mismatch\r
+ DROP bal- ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ OF ( C: -- of-sys ) \ CORE EXT\r
+\ Run-time: ( x1 x2 -- |x1 )\r
+\ Mark the start of OF ... ENDOF part of CASE structure.\r
+\ On run-time if two values on the stack are not equal, discard\r
+\ the top value and continue execution following the next ENDOF.\r
+\ Otherwise discard both values and continue execution in line.\r
+: OF ( C: -- of-orig )\r
+ POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP\r
+ 1+ \ change orig type 1 to of-sys type 2\r
+ ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ ENDOF ( C: case-sys1 of-sys -- case-sys2 ) \ CORE EXT\r
+\ Run-time: ( -- )\r
+\ Mark the end of OF ... ENDOF part of CASE structre.\r
+\ On run-time, continue execution following ENDCASE .\r
+: ENDOF ( C: of-orig1 -- of-orig2 )\r
+ 1- POSTPONE ELSE 1+ \ of-orig type is 2; orig type is 1\r
+ ; COMPILE-ONLY IMMEDIATE\r
+\r
+\ UNUSED ( -- u ) \ CORE EXT\r
+\ Return available data space in address units.\r
+: UNUSED PAD HERE - ; \ Available data space is HERE to PAD\r
+\r
+\ **********************\r
+\ Optional Prgramming-Tools wordset -- complete\r
+\ **********************\r
+\r
+DECIMAL\r
+\r
+\ .S ( -- ) \ TOOLS\r
+\ Display the values on the data stack.\r
+: .S CR DEPTH ?DUP\r
+ IF 1- 0 SWAP \ 0 depth-1\r
+ DO I PICK\r
+ BASE @ 10 = IF . ELSE U. THEN\r
+ -1 +LOOP\r
+ THEN ." <sp " ;\r
+\r
+\ ? ( a-addr -- ) \ TOOLS\r
+\ Display the contents at a-addr.\r
+\\r
+: ? @ BASE @ 10 = IF . EXIT THEN U. ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+\ enough? ( -- flag )\r
+\ Return false if no input, else pause and if CR return true.\r
+: enough? EKEY? DUP IF EKEY 2DROP EKEY 13 ( CR) = THEN ;\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ DUMP ( addr u -- ) \ TOOLS\r
+\ Display the contents of u consecutive address units starting\r
+\ at addr.\r
+\\r
+: DUMP ?DUP\r
+ IF BASE @ >R HEX\r
+ 1- 16 / 1+\r
+ 0 DO CR DUP DUP 0 <# # # # # #> TYPE SPACE SPACE\r
+ 16 0 DO DUP C@ 0 <# # # #> TYPE SPACE CHAR+ LOOP\r
+ SPACE SWAP\r
+ 16 0 DO DUP C@ 127 AND DUP 0 BL WITHIN\r
+ OVER 127 = OR\r
+ IF DROP [CHAR] . THEN\r
+ EMIT CHAR+\r
+ LOOP DROP\r
+ enough? IF LEAVE THEN\r
+ LOOP\r
+ R> BASE !\r
+ THEN DROP ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ \ xDUMP ( code-addr u -- )\r
+ \ Display the contents of u consecutive address units\r
+ \ starting at the code addr.\r
+ \\r
+ : xDUMP ?DUP\r
+ IF BASE @ >R HEX\r
+ 1- 16 / 1+\r
+ 0 DO CR DUP 0 <# # # # # #> TYPE SPACE SPACE\r
+ 8 0 DO DUP code@ 0 <# # # # # #> TYPE SPACE CELL+ LOOP\r
+ enough? IF LEAVE THEN\r
+ LOOP\r
+ R> BASE !\r
+ THEN DROP ;\r
+[THEN]\r
+\r
+\ xt>name ( xt -- c-addr | 0 )\r
+\ Remove xt from the stack and return the name address if xt\r
+\ is execution token of valid word; otherwise return 0.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : xt>name\r
+ DUP ALIGNED OVER XOR IF DROP 0 EXIT THEN \ xt should be aligned\r
+ >R \ save xt\r
+ FORTH-WORDLIST \ Start of wordlist link\r
+ BEGIN DUP @ \ last word name field of wordlist\r
+ BEGIN DUP name>xt R@ XOR\r
+ WHILE cell- @ ?DUP 0=\r
+ UNTIL \ continue until the end of wordlist\r
+ ELSE SWAP R> 2DROP EXIT \ found\r
+ THEN CELL+ @ ?DUP 0=\r
+ UNTIL \ continue to next wordlist\r
+ R> DROP 0 ; \ not found\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : xt>name\r
+ DUP ALIGNED OVER XOR IF DROP 0 EXIT THEN \ xt should be aligned\r
+ DUP cell- @ \ xt c-addr\r
+ DUP ALIGNED OVER XOR IF 2DROP 0 EXIT THEN\r
+ SWAP OVER name>xt = AND ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : xt>name\r
+ DUP ALIGNED OVER XOR IF DROP 0 EXIT THEN \ xt should be aligned\r
+ DUP cell- code@ \ xt c-addr\r
+ DUP ALIGNED OVER XOR IF 2DROP 0 EXIT THEN\r
+ SWAP OVER name>xt = AND ;\r
+[THEN]\r
+\r
+\ .xt ( a-addr1 xt -- a-addr2 )\r
+\ Display name of a xt if xt is valid and display string\r
+\ constant and adjust a-addr1 to the end of string if xt is\r
+\ not POSTPONEd 'doS"' ; otherwise display the xt as a number.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0= OR\r
+[IF]\r
+ : .xt\r
+ DUP\r
+ IF DUP xt>name ?DUP\r
+ IF .name DUP >R ['] doS" =\r
+ IF DUP cell- @ ['] doLIT XOR\r
+ IF DUP CELL+ SWAP cell- @ 2DUP TYPE + ALIGNED\r
+ cell- [CHAR] " EMIT SPACE THEN THEN\r
+ R> DUP ['] branch = OVER ['] 0branch = OR\r
+ OVER ['] doLOOP = OR SWAP ['] do+LOOP = OR\r
+ IF DUP cell- @ ['] doLIT XOR\r
+ IF CELL+ DUP @ OVER CELL+ - . THEN THEN\r
+ EXIT\r
+ THEN\r
+ THEN U. ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ : .xt\r
+ DUP\r
+ IF DUP xt>name ?DUP\r
+ IF .name\r
+ DUP ['] branch = OVER ['] 0branch = OR\r
+ OVER ['] doLOOP = OR SWAP ['] do+LOOP = OR\r
+ IF DUP cell- code@ ['] doLIT XOR\r
+ IF CELL+ DUP code@ OVER CELL+ - . THEN THEN\r
+ EXIT\r
+ THEN\r
+ THEN U. ;\r
+[THEN]\r
+\r
+\ xtSEE ( xt -- )\r
+\ Display human-readable representation of xt.\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : xtSEE >R lastName\r
+ BEGIN DUP COUNT 31 AND + ALIGNED CELL+ CELL+ \ na na'\r
+ DUP name>xt R@ U>\r
+ WHILE NIP\r
+ REPEAT DROP name>xt R>\r
+ 2DUP U> 0= IF NIP xhere SWAP THEN \ end-of-code xt\r
+ CR BASE @ >R HEX\r
+ BEGIN ?call ?DUP\r
+ IF ." call-" .xt THEN\r
+ DUP @ .xt enough? 0=\r
+ WHILE CELL+ 2DUP U> 0=\r
+ UNTIL THEN 2DROP R> BASE ! ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ \ Following definition is less dependent on dictionary structure although\r
+ \ slower. It only assumes xt of a word is larger than xt of previously\r
+ \ defined words. This works for ROM model also.\r
+ : xtSEE >R xhere >R \ Search all wordlist to find end of xt.\r
+ FORTH-WORDLIST \ Find smallest link pointer larger than xt.\r
+ BEGIN DUP\r
+ BEGIN @ ?DUP\r
+ WHILE DUP name>xt R@ U<\r
+ IF R> OVER name>xt R@ U>\r
+ IF DROP DUP name>xt THEN\r
+ >R\r
+ THEN\r
+ cell-\r
+ REPEAT\r
+ CELL+ @ ?DUP 0= \ continue to next wordlist\r
+ UNTIL R> R> \ end-of-code xt\r
+ CR BASE @ >R HEX\r
+ BEGIN ?call ?DUP\r
+ IF ." call-" .xt THEN\r
+ DUP @ .xt enough? 0=\r
+ WHILE CELL+ 2DUP U> 0=\r
+ UNTIL THEN 2DROP R> BASE ! ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ \ Following definition is less dependent on dictionary structure although\r
+ \ slower. It only assumes xt of a word is larger than xt of previously\r
+ \ defined words. This works for ROM model also.\r
+ : xtSEE >R xhere >R \ Search all wordlist to find end of xt.\r
+ FORTH-WORDLIST \ Find smallest link pointer larger than xt.\r
+ BEGIN DUP\r
+ BEGIN @ ?DUP\r
+ WHILE DUP name>xt R@ U<\r
+ IF R> OVER name>xt R@ U>\r
+ IF DROP DUP name>xt THEN\r
+ >R\r
+ THEN\r
+ cell-\r
+ REPEAT\r
+ CELL+ @ ?DUP 0= \ continue to next wordlist\r
+ UNTIL R> R> \ end-of-code xt\r
+ CR BASE @ >R HEX\r
+ BEGIN ?call ?DUP\r
+ IF ." call-" .xt THEN\r
+ DUP code@ .xt enough? 0=\r
+ WHILE CELL+ 2DUP U> 0=\r
+ UNTIL THEN 2DROP R> BASE ! ;\r
+[THEN]\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ SEE ( "<spaces>name" -- ) \ TOOLS\r
+\ Display human-readable representation of the name's definition.\r
+: SEE (') 1+ IF ." IMMEDIATE-word" THEN xtSEE ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+\ WORDLIST-WORDS ( wid -- )\r
+\ List the definition names in wordlist identified by wid.\r
+: WORDLIST-WORDS\r
+ CR 0 >R\r
+ BEGIN @ ?DUP\r
+ WHILE DUP .name R> 1+ >R\r
+ cell- \ pointer to next word\r
+ enough? UNTIL\r
+ THEN SPACE R> . ." words " ;\r
+\r
+\ NONSTANDARD-WORDS ( -- )\r
+\ List the definition names in NONSTANDARD-WORDLIST.\r
+: NONSTANDARD-WORDS NONSTANDARD-WORDLIST WORDLIST-WORDS ;\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ WORDS ( -- ) \ TOOLS\r
+\ List the definition names in the first wordlist of the\r
+\ search order.\r
+: WORDS #order CELL+ @ WORDLIST-WORDS ;\r
+\r
+envQList SET-CURRENT\r
+-1 CONSTANT TOOLS\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+\ **********************\r
+\ Nonstandard system utility word\r
+\ **********************\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+\ SAVE-SYSTEM ( -- )\r
+\ Save current state of the system. There must be a way\r
+\ to preserve the memory image. Use non-volatile RAM or\r
+\ DEBUG.EXE to store the image in MS-DOS.\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+ : SAVE-SYSTEM\r
+ var0 sysVar0 [ sysVar0End sysVar0 - ] LITERAL MOVE ;\r
+[THEN]\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE RAM Model" COMPARE 0=\r
+[IF]\r
+ : SAVE-SYSTEM\r
+ #order DUP @ #order0 SWAP 1+ CELLS MOVE ;\r
+[THEN]\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE ROM Model" COMPARE 0=\r
+[IF]\r
+\r
+ \ **********************\r
+ \ RAM/ROM System Only\r
+ \ **********************\r
+\r
+ \ RAM ( -- )\r
+ \ Set data space in RAM area.\r
+ : RAM RAMB TO hereVar ;\r
+\r
+ \ ROM ( -- )\r
+ \ Set data space in ROM area.\r
+ : ROM ROMB TO hereVar ;\r
+\r
+ \ RAM/ROM@ ( -- ram/rom-id )\r
+ \ Return RAM/ROM identifier which will be consumed by RAM/ROM!\r
+ : RAM/ROM@ hereVar ;\r
+\r
+ \ RAM/ROM! ( ram/rom-id -- )\r
+ \ Set HERE according to RAM/ROM identifier on the stack.\r
+ : RAM/ROM! TO hereVar ;\r
+[THEN]\r
+\r
+\ RETRY ( -- )\r
+\ Compile unconditional jump to the start of the current\r
+\ definition. Described by Dr. Astle in Forth Dimensions\r
+\ 17(4), 19-21 (1995).\r
+: RETRY bal 1- 2* PICK 1+ IF -22 THROW THEN\r
+ \ control structure mismatch; colon-sys type is -1\r
+ bal 1- 2* 1+ PICK \ xt of current definition\r
+ ?call DROP POSTPONE branch COMPILE, ; IMMEDIATE COMPILE-ONLY\r
+\r
+CHAR " PARSE model" ENVIRONMENT? DROP\r
+CHAR " PARSE EXE Model" COMPARE 0=\r
+[IF]\r
+ DECIMAL\r
+ \ Structure of CREATEd word:\r
+ \ |compile_xt|name_ptr| call-doCREATE | 0 or DOES>_xt | a-addr |\r
+ : doCompiles>\r
+ lastName DUP C@ 128 ( =seman) <\r
+ IF -12 THROW THEN \ argument type mismatch\r
+ name>xt cell- cell- code! ;\r
+ \ compiles> ( xt colon-sys -- colon-sys )\r
+ \ Assign xt as special compilation action of the last CREATEd\r
+ \ word. It is the user's responsibility to match the special\r
+ \ compilation action and the execution action.\r
+ \ Example: '2CONSTANT' can be defined as following:\r
+ \ :NONAME EXECUTE POSTPONE 2LITERAL ;\r
+ \ : 2CONSTANT CREATE SWAP , , compiles> DOES> DUP @ SWAP CELL+ @ ;\r
+ : compiles> ROT POSTPONE LITERAL POSTPONE doCompiles> ; IMMEDIATE\r
+[THEN]\r
+\r
+FORTH-WORDLIST SET-CURRENT\r
+\r
+BASE !\r
+\r
+CHAR " PARSE FILE" ENVIRONMENT?\r
+[IF]\r
+ 0= [IF] << CON [THEN]\r
+[ELSE] << CON\r
+[THEN]\r
--- /dev/null
+ June 2, 1997\r
+\r
+Dear hForth beta-testers:\r
+\r
+This is beta release of hForth v0.9.9 which is designed for small\r
+embedded system. Following the great Forth tradition hForth is free\r
+software. You can use it for whatever purpose commercial or\r
+non-commercial. Please spread it as widely as you can.\r
+\r
+hForth is based on eForth model published by Mr. Bill Muench and Dr.\r
+C. H. Ting in 1990. The key features of the original eForth model is\r
+preserved. Following is quoted from the original 8086 eForth source.\r
+\r
+ > small machine dependent kernel and portable high level code\r
+ > source code in the MASM format\r
+ > direct threaded code\r
+ > separated code and name dictionaries\r
+ > simple vectored terminal and file interface to host computer\r
+ > aligned with the proposed ANS Forth Standard\r
+ > easy upgrade path to optimize for specific CPU\r
+\r
+These are also the characteristics of hForth. For better, hForth\r
+is ANS Forth system which complies the Standard, not just aligns\r
+with the Standard. Colon definitions for all high level words are\r
+also given as comments in TASM source code. The source code should\r
+be a working example for Forth learners.\r
+\r
+hForth consists of three models: ROM model, RAM model and EXE model.\r
+ROM and RAM models are easily portable while EXE model is more\r
+competitive to other interpretive 8086 Forth systems. ROM model was\r
+first written, then RAM and EXE models came later. Few machine\r
+dependent definitions added to ROM model to derive RAM and EXE\r
+models and only several high-level words which must know dictionary\r
+structures such as HERE and CREATE are redefined for RAM and EXE\r
+models. I believe it shows the flexibility of hForth model.\r
+\r
+ROM model is especially designed for a minimal development system\r
+for embedded system which uses non-volatile RAM or ROM emulator in\r
+place of ROM so that the content of ROM address space can be changed\r
+during development phase and can be copied to real ROM later for\r
+production system. Name space does not need to be included in final\r
+system if the system does not require Forth text interpreter. hForth\r
+occupies little more than 6 KB of code space for CORE words only and\r
+about 8 KB with additional words such as WORDS, HEX, SEE, etc.\r
+hForth requires at least 1 KB of RAM.\r
+\r
+RAM and EXE models are for RAM only system. EXE model is for a\r
+system in which code space is completely separated and xt is not a\r
+valid address for '@'. EXE model can utilize segmented 8086 memory\r
+model. EXE model might be extended for a embedded system development\r
+where name space reside in host computer and code and data space are\r
+in target computer.\r
+\r
+ANS Forth Standard divide Forth dictionary into code, name, and data\r
+space. Five combinations are possible: all separated; code and\r
+name spaces are combined; code and data spaces are combined; name\r
+and data spaces are combined; all combined. I exercised four of\r
+them. Code, name and data spaces are all intermingled in RAM model.\r
+Name and data spaces are combined and code space is separated in\r
+different 8086 segment in EXE model. When ROM model starts, the code\r
+space resides at bottom of ROM, name space at top of ROM, and data\r
+space in RAM address space. If "ROM" is not writable, code and data\r
+part of new definitions goes into bottom of RAM and name part of new\r
+definitions goes into top of RAM.\r
+\r
+All Standard Core words are provided in assembler source. Complete\r
+TOOLS, SEARCH ORDER, SEARCH ORDER EXT words and other useful words\r
+are provided as Forth source in 'OPTIONAL.F'. CORE words were tested\r
+with CORE.FR test program by John Hayes. Many of CORE EXT words are\r
+provided in OPTIONAL.F and almost all the other CORE EXT words\r
+except obsolescent ones and [COMPILE] (for which CORE word POSTPONE\r
+must be used instead) are provided in COREEXT.F. Complete DOUBLE and\r
+DOUBLE EXT words are provided in DOUBLE.F. I believe that hForth\r
+CORE words are bug-free, however, optional words might have few\r
+bugs.\r
+\r
+The files on this package are:\r
+\r
+HF86ROM.ASM MASM source of hForth 8086 ROM model for IBM-PC.\r
+HF86RAM.ASM MASM source of hForth 8086 RAM model for IBM-PC.\r
+HF86EXE.ASM MASM source of hForth 8086 EXE model for IBM-PC.\r
+HF86ROM.COM Executable object of hForth 8086 ROM model.\r
+HF86RAM.COM Executable object of hForth 8086 RAM model.\r
+HF86EXE.EXE Executable object of hForth 8086 EXE model.\r
+SAVE.EXE HF86EXE.EXE with OPTIONAL.F, ASM8086.F, COREEXT.F,\r
+ MSDOS.F and MULTI.F loaded.\r
+SAVE1.EXE SAVE.EXE with HIOMULTI.F loaded.\r
+SAVE2.EXE SAVE.EXE with HIOMULT2.F loaded.\r
+HTURTLE.EXE Turtle Graphics interpreter. Word names in Korean.\r
+ETURTLE.EXE Turtle Graphics interpreter. Word names in English.\r
+OPTIONAL.F Forth source code of Optional wordset words.\r
+ASM8086.F Forth source code of 8086 assembler.\r
+ASMTEST.F Test code to check 8086 assembler.\r
+COREEXT.F Additional definitions for complete CORE EXT words except\r
+ obsolescent ones and [COMPILE].\r
+MULTI.F Forth source code of Bill Muench's multitasker.\r
+MULDEMO.F Simple example for hForth multitasker.\r
+MSDOS.F BLOCK and FILE wordset words for MS-DOS.\r
+DOSEXEC.F Words to call DOS programs from hForth.\r
+SAVE.F Source to generate SAVE.EXE.\r
+DOUBLE.F Complete DOUBLE and DOUBLE EXT word definitions.\r
+HIOMULTI.F Showing English and Korean characters on graphics screen\r
+ using multitasker.\r
+HIOMULT2.F HIOMULTI.F with better looking Korean screen fonts.\r
+ENG.FNT English fonts for HIOMULT2.F.\r
+HAN.FNT Korean fonts for HIOMULT2.F.\r
+CLOCK.F On screen clock using multitasker. Needs HIOMULT2.F.\r
+STACK.F Graphic representation of datastack for Forth learners.\r
+ Needs HIOMULT2.F.\r
+TURTLE.F Turtle Graphics words.\r
+HTURTLE.GLO Glossary of Korean Turtle Graphics words.\r
+SIO.F Serial communication words. Example of direct hardware\r
+ control.\r
+LOG.F Capture screen display to a textfile, HFORTH.LOG.\r
+DISCP.F Words for Dijkstra guarded command control structures\r
+ by M. Edward Borasky\r
+MEMORY.F MEMORY ALLOCATION word definitions.\r
+ Adaptation of Gordon Chlarlton's MEMORY.FTH to hForth.\r
+MEMORY.FTH Original Gordon Charlton's MEMORY ALLOCATION word definitions.\r
+DEBUGGER.ANS Joerg Plewe's ANS Forth debugger. (KEY? was changed to EKEY?)\r
+WHATSNEW.ENG Changes from v0.9.7\r
+HFORTH.HTM My article on hForth published on Forth Dimensions\r
+README.ENG This file.\r
+Other README.* files are in Korean.\r
+\r
+You can make the executable objects as below:\r
+\r
+>TASM /ml HF86ROM or HF86RAM or HF86EXE\r
+>TLINK /t HF86ROM or TLINK /t HF86RAM or TLINK HF86EXE\r
+\r
+You can save the system state using SAVE-SYSTEM so that the system\r
+returns the state when it will boot up next time. You need to save\r
+the content of memory either in non-volatile RAM or some other way.\r
+You can use MS-DOS DEBUG program for this purpose for *.COM files.\r
+\r
+SAVE.EXE was prepared as below after starting HF86EXE.EXE:\r
+\r
+ << OPTIONAL.F\r
+ << ASM8086.F\r
+ << MSDOS.F\r
+ BL PARSE SAVE.F INCLUDED \ or INCLUDE SAVE.F\r
+\r
+SAVE2.EXE which displays English and Korean alphabets on graphics\r
+screen was prepared as below after starting SAVE.EXE:\r
+\r
+ BL PARSE HIOMULT2.F INCLUDED \ or INCLUDE HIOMULT2.F\r
+ SAVE-SYSTEM-AS SAVE2.EXE\r
+\r
+You can load Forth source files using Standard word INCLUDED or\r
+non-Standard word INCLUDE instead of '<<'. Do not use '<<' after you\r
+load MSDOS.F. Please report any bug to me.\r
+\r
+You can easily build application program simply changing "'init-i/o"\r
+and "'boot". When the executable starts 'init-i/o is called first\r
+then 'boot is called. 'init-i/o is also called by THROW. You should\r
+reset I/O for keyboard input after an error. HIOMULT?.F set\r
+'init-i/o to NEW-SET-I/O which determines either output to text\r
+screen or output to graphics screen. 'boot is set to NEW-hi which\r
+displays greeting message, copy command line argument to PAD, and\r
+start Forth interpreter. You can build simple program which displays\r
+command line argument on graphics screen as below:\r
+\r
+ C:\HF>SAVE2\r
+\r
+ hForth 8086 EXE Model v0.9.9 by Wonyong Koh, 1997\r
+ ALL noncommercial and commercial uses are granted.\r
+ Please send comment, bug report and suggestions to:\r
+ wykoh@pado.krict.re.kr\r
+ ·\81\89e\89Á ¹A´e\89Á §¡Íw·i Ða·¡ÉI wykoh\9d¡ ¥¡\90\81 º\81¯³¯¡µ¡.\r
+\r
+ HEX\r
+ : SAMPLE\r
+ CS@ 10 - \ PSP segment\r
+ 80 2DUP LC@ 1+ 0 DO 2DUP LC@ PAD I + C! CHAR+ LOOP 2DROP\r
+ HGRAPHIC\r
+ PAD COUNT TYPE CR CR\r
+ ." Press any key." KEY BYE ;\r
+ ' SAMPLE TO 'boot\r
+ SAVE-SYSTEM-AS BYE.EXE\r
+ BYE\r
+ C:\HF>BYE 11 22 33\r
+\r
+HIOMULTI.F and HIOMULT2.F are real examples of multitasker.\r
+Scrolling costs virtually nothing since screen is updated when Forth\r
+system is waiting for keyboard input. I include HIOMULT?.F in hForth\r
+package to show how multitasking is used in a real problem.\r
+\r
+Using LOGON and LOGOFF in LOG.F, you can control whether or not to\r
+capture screen display into a textfile, HFORTH.LOG. You can build a\r
+source file later from word definitions that you make interactively.\r
+DOS executables can be called from hForth using words in DOSEXEC.F.\r
+You can easily call text editor (for example, Q editor), edit Forth\r
+source, exit the editor, load the source and debug without leaving\r
+hForth. Please consult beginning of LOG.F and DOSEXEC.F for usage.\r
+\r
+TURTLE.F is an implementation of Turtle Graphics. I am sorry that\r
+some files are written in only Korean, especially HIOMULT?.F. I will\r
+try to provide English version if there is enough interests.\r
+\r
+I applied all the best ideas and tricks thatI know to hForth. Most\r
+of them came from other people while I added a few of my own. I\r
+believe some are worth to mention here. hForth text interpreter uses\r
+vector table which tells what to do with a parsed word after search\r
+it in Forth dictionary. The key part of text interpreter is:\r
+\r
+ \ ca u 0 | xt -1 | xt 1\r
+ 1+ 2* STATE @ 1+ + CELLS 'doWord + @ EXECUTE\r
+\r
+So what the interpreter does is summarized in 'doWord table as:\r
+\r
+ +------------------+--------------------+\r
+ |compilation state |interpretation state|\r
+ |(STATE returns -1)|(STATE returns 0) |\r
+ +-------------------+------------------+--------------------+\r
+ | nonimmediate word | optiCOMPILE, | EXECUTE |\r
+ |(top-of-stack = -1)| | |\r
+ +-------------------+------------------+--------------------+\r
+ | not found word | doubleAlso, | doubleAlso |\r
+ |(top-of-stack = 0) | | |\r
+ +-------------------+------------------+--------------------+\r
+ | immediate word | EXECUTE | EXECUTE |\r
+ |(top-of-stack = 1) | | |\r
+ +-------------------+------------------+--------------------+\r
+\r
+You can easily change the behavior of the interpreter by changing\r
+this vector table as below:\r
+\r
+ 1234567890. .S\r
+ 722 18838 <sp ok\r
+ ' singleOnly, 'doWord 2 CELLS + ! ok\r
+ ' singleOnly 'doWord 3 CELLS + ! ok\r
+ 1234567890. 1234567890. ? undefined word\r
+\r
+optiCOMPILE, is used in place of Standard word COMPILE, which\r
+removes one level of EXIT if possible as shown below:\r
+\r
+ : TEST1 ; SEE TEST1\r
+ call-doLIST EXIT ok\r
+ : TEST2 TEST1 ; SEE TEST2\r
+ call-doLIST EXIT ok\r
+ : TEST3 DUP ; SEE TEST3\r
+ call-doLIST DUP EXIT ok\r
+ : TEST4 TEST3 ; SEE TEST4\r
+ call-doLIST DUP EXIT ok\r
+\r
+There is no penalty to use empty definition CHARS or use CELLS\r
+instead of 2* in hForth 8086 models.\r
+\r
+In-line compilation of CONSTANT, VARIABLE and CREATEd words as\r
+literal values can increase execution speed especially for\r
+native-code Forth compilers. To provide special compilation action\r
+for this default compilation behavior, I devised a solution.\r
+CONSTANT, VARIABLE and CREATEd words have a mark and execution token\r
+of special compilation action. If Forth compiler sees the mark, it\r
+pushes the execution token of the words and execute the special\r
+compilation action. (CORE word POSTPONE must also find this action\r
+and compile the special compilation action accordingly.) Special\r
+compilation action can be added to a new data structure using only\r
+two words, implementation-dependent 'doCompiles>' and\r
+implementation-independent 'compile>'.\r
+\r
+ : doCompiles>\r
+ \ verify the last word is ready for special compilation action\r
+ \ attach special compilation action to the word\r
+ ;\r
+\r
+ \ compiles> ( xt -- )\r
+ \ Assign xt as special compilation action of the last CREATEd\r
+ \ word. It is the user's responsibility to match the special\r
+ \ compilation action and the execution action.\r
+ \ Example: '2CONSTANT' can be defined as following:\r
+ \ :NONAME EXECUTE POSTPONE 2LITERAL ;\r
+ \ : 2CONSTANT CREATE SWAP , , compiles> DOES> DUP @ SWAP CELL+ @ ;\r
+ : compiles> POSTPONE LITERAL POSTPONE doCompiles> ; IMMEDIATE\r
+\r
+These words are used for example to define 2CONSTANT:\r
+\r
+ :NONAME EXECUTE POSTPONE 2LITERAL ;\r
+ : 2CONSTANT CREATE SWAP , , compiles> DOES> DUP @ SWAP CELL+ @ ;\r
+\r
+I beleive that this solution is general enough to be applied to\r
+other Forth systems.\r
+\r
+Control-flow stack is fully implemented on data stack. One\r
+control-flow stack item is represented by two data stack item. Control\r
+structure mismatch is rigorously verified.\r
+\r
+I gave up the pin-hole optimization tried in version 0.9.6. It had\r
+some bugs and building one in assembly source seems to be too much\r
+work. I might try again when hForth metacompiler is available.\r
+\r
+hForth is a result of more than a year's hard work. Now I feel\r
+comfortable with it. I would like to receive feedback. Any comment,\r
+bug report or suggestions are appreciated. Please send them to the\r
+address above. I try to provide enough technical information as I\r
+can, however, I doubt I will have time to make User's manual in\r
+English. I will be busy to write one in Korean.\r
+\r
+I ported hForth RAM model to Z80. Only code definitions were needed\r
+to be redefined. I strongly encourage you to implement hForth on\r
+your favorite processors.\r
+\r
+I pick up 'h' in hForth for Han which means Korean in Korean\r
+language. Please let me know if you know the name hForth is used\r
+already by someone else.\r
+\r
+Sincerely,\r
+\r
+Wonyong Koh, Ph.D.\r
+wykoh@pado.krict.re.kr\r
+\r
+Advanced Materials Division\r
+KRICT\r
+P.O.Box 107, Yusong\r
+Taejon, 305-600\r
+South Korea\r
+82-42-861-4245 (FAX)\r
--- /dev/null
+\r
+hForth 0.9.9 Ìe·³\93¡\94a. hForth\93e ANS Forth Îaº\85·i \98a\9fa\93e ¸b·e Í¡¯a\r
+¯¡¯aÉQ·³\93¡\94a. hForth\93e ¢\81\9ea Ïa\9d¡\8ba\9c\91(free software)·³\93¡\94a. ·¡\88õ·i\r
+\88\81·¥¸â·a\9d¡\90a ¬w´ó¸â·a\9d¡\90a ´á\98å ¡¢¸âµA ¬a¶wÐ\81\95¡ ¹½¯s\93¡\94a. \94e, ·¡\r
+Ïa\9d¡\8ba\9c\91 e·i Ìi´a¬á\93e ´e\96A\89¡ (hForth\9fi °á¬á e\97e Ïa\9d¡\8ba\9c\91·i Ìa\93e\r
+\88õ·e ¹A\88a ¬w\89ÅÐa»¡ ´g\89¡ \88á\8b¡µA hForth \8e\81\9cᣡ\88a \97i´á ·¶´á\95¡\r
+¹½¯s\93¡\94a.) hForth\9ca\93e ·¡\9fq·i ³a\9da¡e \8e\81\9cᣡ·\81 Ìa·©\97i·¡ ¥¥\9c\81 ¬wÈ\81\9d¡\r
+·¶´á´¡ Ðs\93¡\94a. \88a\93wÐe Ðe hForth\9fi \90é\9f¡ Ìá\9ba\9daº\81¯³¯¡µ¡.\r
+\r
+hForthµA\93e ´áQ§i\9f¡ ¤aÈw¥¥·¡ 3 \88\81 \97i´á ·¶¯s\93¡\94a. HF86ROM.COM·e\r
+ANSEF86.COMÀá\9cñ RAM\89Á ROM\88a \94a\9fe º\81¡µA ·¶\93e ¯¡¯aÉQµA¬á ³a·¡\95¡\9d¢\r
+ e\97i´ö¯s\93¡\94a. HF86RAM.COM·e HF86RAM·i \89¡Áa RAM e·i ³a\93e ¯¡¯aÉQ\r
+¶w·a\9d¡ e\97i´ö¯s\93¡\94a. HF86EXE.EXE\93e 8086µA¬á Å¡\97aµÁ ¸a\9ea\9fi \94a\9fe\r
+A\8ba åËaµA \90ý\89¡ µa\9cá \90{ i·i \8b¡\89\81´á\9d¡ ¸÷·\81Ð\96¯s\93¡\94a. HF86EXE.EXE\93e\r
+·¡\9cý\89A Ð\81¬á HF86ROM.COM\89Á HF86RAM.COMµA §¡Ð\81 \96\81 ¤\81·\81 ¡A¡¡\9f¡\9fi ³i\r
+®\81 ·¶\89¡ ¢\95¡\95¡ \96\81 ¤\81 ·¡¬w ¨i\9ca¹v¯s\93¡\94a. \88b ´áQ§i\9f¡´á ¤aÈw¥¥·\81 Àõ\r
+ á\9f¡µA \88b ¤aÈw¥¥\97i·¡ ´á\98ý\89A \94a\9fe»¡\9fi ¸â´á \96\81´ö¯s\93¡\94a. Ðe\96\81 \88\81·\81\r
+´áQ§i\9f¡´á \90{ i\9fi \94áÐe \88õ i\89¡\93e \99¢\88{·e ´áQ§i\9f¡´á \90{ i\97i·i°á¬á\r
+HF86ROM.ASM·a\9d¡¦\81Èá HF86RAM·i e\97i´ö¯s\93¡\94a. \8b¡\89\81´á\9d¡ ¸÷·\81Ðe\r
+\90{ i e·i ¤a\8e\81´á¬á Z80µA\95¡ hForth\9fi ¯±´ö¯s\93¡\94a.\r
+\r
+·¡ \8e\81\9cᣡµA\93e ´a\9c\81 Ìa·©\97i·¡ \97i´á ·¶¯s\93¡\94a.\r
+\r
+HF86ROM.ASM IBM-PC ¶w hForth 8086 ROM ¡¡\95I·\81 TASM ¤aÈw¥¥.\r
+HF86RAM.ASM IBM-PC ¶w hForth 8086 RAM ¡¡\95I·\81 TASM ¤aÈw¥¥.\r
+HF86EXE.ASM IBM-PC ¶w hForth 8086 EXE ¡¡\95I·\81 TASM ¤aÈw¥¥.\r
+HF86ROM.COM hForth 8086 ROM ¡¡\95I·\81 ¯©Ð\97 Ìa·©.\r
+HF86RAM.COM hForth 8086 RAM ¡¡\95I·\81 ¯©Ð\97 Ìa·©.\r
+HF86EXE.EXE hForth 8086 EXE ¡¡\95I·\81 ¯©Ð\97 Ìa·©.\r
+SAVE.EXE OPTIONAL.FµÁ ASM8086.FµÁ COREEXT.FµÁ MSDOS.FµÁ\r
+ MULTI.F\9fi \94áÐe HF86EXE.EXE.\r
+SAVE1.EXE HIOMULTI.F\9fi \94áÐe SAVE.EXE.\r
+SAVE2.EXE HIOMULT2.F\9fi \94áÐe SAVE.EXE.\r
+HTURTLE.EXE ¶\81\9f¡ i \88á¦\82 \8ba\9f± É·µb\8b¡.\r
+ETURTLE.EXE µw¢\85 \88á¦\82 \8ba\9f± É·µb\8b¡.\r
+OPTIONAL.F ¬åÈ\82 \90{ i(OPTIONAL wordset words)\97i·\81 Í¡¯a ¤aÈw¥¥.\r
+ASM8086.F 8086 ´áQ§i\9cá Í¡¯a ¤aÈw¥¥.\r
+ASMTEST.F 8086 ´áQ§i\9cá\9fi ¯¡ÐñÐa\8b¡ ¶áÐe Í¡¯a ¤aÈw¥¥.\r
+COREEXT.F ANS Îaº\85 Í¡¯a Ïa\9d¡\8ba\9c\91µA ³a»¡ i´a´¡ Ði \90j·e \90{ i·i ¨\85\r
+ (OPTIONAL.FµA ¨a»¥) \94a\9fe ¡¡\97e CORE EXT \90{ i·\81 Í¡¯a ¤aÈw¥¥.\r
+MULTI.F Bill Muench·\81 \94aº\97¸b´ó\8b¡(multitasker)·\81 Í¡¯a ¤aÈw¥¥.\r
+MULDEMO.F \94aº\97 ¸b´ó\8b¡\9fi ¯¡ÐñÐa\8b¡ ¶áÐe \88e\94eÐe Í¡¯a ¤aÈw¥¥.\r
+MSDOS.F DOS Ðq®\81\9fi °á¬á ¸÷·\81Ðe FILE \90{ i\89Á BLOCK \90{ i\97i.\r
+DOSEXEC.F hForthµA¬á \95¡¯a Ïa\9d¡\8ba\9c\91·i ¦\81\9fa\93e \90{ i·\81 ¸÷·\81.\r
+SAVE.F SAVE.EXE\9fi e\97a\93e Í¡¯a ¤aÈw¥¥.\r
+DOUBLE.F µÅ¸åÐe DOUBLE\89Á DOUBLE EXT \90{ i·\81 ¸÷·\81.\r
+HIOMULTI.F \94aº\97¸b´ó\8b¡\9fi ³a\93e Ðe\8bi·³Â\89\9db Í¡¯a ¤aÈw¥¥.\r
+HIOMULT2.F \8bi\8d©·i ¤a\8e\89 ®\81 ·¶\93e Ðe\8bi·³Â\89\9db Í¡¯a ¤aÈw¥¥.\r
+ENG.FNT HIOMULT2.FµA¬á ³a\93e µw¢\85 \8bi\8d©.\r
+HAN.FNT HIOMULT2.FµA¬á ³a\93e Ðe\8bi \8bi\8d©.\r
+CLOCK.F SAVE2.EXEµA¬á ³i ®\81 ·¶\93e \94aº\97 ¸b´ó\8b¡ ¯¡\89\81\r
+STACK.F SAVE2.EXEµA¬á ÑÁ¡eµA \94ᣡ·\81 \90\81¶w·i ¥¡·¡\93e Ïa\9d¡\8ba\9c\91.\r
+TURTLE.F ¶\81\9f¡ i \88á¦\82 \8ba\9f± É·µb\8b¡ Í¡¯a ¤aÈw¥¥.\r
+HTURTLE.GLO \88á¦\82 \8ba\9f± \90{ i Î\89·¡.\r
+SIO.F »¢\9di É·¯¥ Ïa\9d¡\8ba\9c\91. \8a\88·e¡¡ ¹A´á·\81 µ\81.\r
+LOG.F ÑÁ¡e Â\89\9db·i HFORTH.LOGµA \88i¢\81\9f¡Ða\93e Ïa\9d¡\8ba\9c\91.\r
+DISCP.F M. Edward Borasky·\81 Dijkstra guarded command control\r
+ structures.\r
+MEMORY.F MEMORY ALLOCATION \90{ i·\81 ¸÷·\81. Gordon Chlarlton·\81\r
+ MEMORY.FTH\9fi \89¡Ã¥ \88õ.\r
+MEMORY.FTH Gordon Charlton·\81 ¥¥\9c\81 Ìa·©.\r
+DEBUGGER.ANS ANS Îaº\85 Í¡¯a \90{ i\9d¡ e\97e Joerg Plewe·\81 ¤é\9dA¸s\88\81.\r
+HFORTH.HTM Forth DimensionsµA ¯©\9dv\94å hForth ¡\88\81\8bi\r
+README.KOR ·¡ Ìa·© (¹¡ÐsÑw Ðe\8bi).\r
+README.KS ·¡ Ìa·© (µÅ¬÷Ñw Ðe\8bi).\r
+\r
+\88b ¯©Ð\97 Ìa·©\97i·e ´a\9c\81 ¤w¤ó·a\9d¡ e\97i´ö¯s\93¡\94a.\r
+\r
+>TASM /ml HF86ROM \99¡\93e HF86RAM \99¡\93e HF86EXE\r
+>TLINK /t HF86ROM \99¡\93e TLINK /t HF86RAM \99¡\93e TLINK HF86EXE\r
+\r
+\8e\81\9cᣡ ´e·\81 SAVE.EXE\93e HF86EXE.EXE\9fi ¯¡¸bÐe \94a·q ´a\9c\81Àá\9cñ Ð\81¬á\r
+ a\9deÐe \88õ·³\93¡\94a.\r
+\r
+ << OPTIONAL.F\r
+ << ASM8086.F\r
+ << MSDOS.F\r
+ BL PARSE SAVE.F INCLUDED \ \99¡\93e INCLUDE SAVE.F\r
+\r
+¯¡¸bÐa¡e ¤a\9d¡ \8ba\9c\81Ï¢ ÑÁ¡eµA µw¢\85 ´iÌa¥U\89Á Ðe\8bi·i ¥¡·¡\93e SAVE2.EXE\93e\r
+SAVE.EXE\9fi ¯¡¸bÐe \94a·q, ´a\9c\81Àá\9cñ Ð\81¬á a\9deÐe \88õ·³\93¡\94a.\r
+\r
+ BL PARSE HIOMULT2.F INCLUDED \ \99¡\93e INCLUDE HIOMULT2.F\r
+ SAVE-SYSTEM-AS SAVE2.EXE\r
+\r
+¤a\9d¡ ¶áµA¬á ¥¡¯¥ \88õÀá\9cñ ·¡¹A '<<'\9fi ³a»¡ ´g\89¡ Îaº\85 Í¡¯a·\81 FILE\r
+\90{ i·¥ INCLUDED\90a §¡Îaº\85 \90{ i INCLUDE\9fi °á¬á Í¡¯a ¤aÈw¥¥·i ·ª´á \97i·©\r
+®\81 ·¶¯s\93¡\94a. MSDOS.F\9fi µ©\9f¡¯¥ Ò\81µA\93e '<<'\9fi ³a»¡ a¯³¯¡µ¡.\r
+\r
+´\85¯¡ Îaº\85 Í¡¯a·\81 CORE \90{ i\97i·e ¡¡\96\81 ´áQ§i\9f¡´á ¤aÈw¥¥µA\r
+\97i´á·¶¯s\93¡\94a. µÅ¸åÐe TOOLS \90{ i\89Á SEARCH ORDER \90{ i\89Á SEARCH ORDER\r
+EXTENSION \90{ i\97i\89Á \94a\9fe ³i¡¡·¶\93e \90{ i\97i·e OPTIONAL.FµA\r
+\97i´á·¶¯s\93¡\94a. ´áQ§i\9f¡´á\9d¡ ¸÷·\81Ða\93e \88õ·¡ \90a·e CORE EXTENSION\r
+\90{ i\97i·e COREEXT.FµA \97i´á·¶¯s\93¡\94a.\r
+\r
+'init-i/oµÁ 'boot\9fi °á¬á ¸÷Ð\81»¥ ·©·i Ða\93e ·w¶w Ïa\9d¡\8ba\9c\91·i e\97i ®\81\r
+·¶¯s\93¡\94a. SAVE-SYSTEM·¡\90a SAVE-SYSTEM-AS\9d¡ \88i¢\81\9f¡Ðe Ïa\9d¡\8ba\9c\91·¡ Àá·q\r
+¯¡Åa»© \98\81 'init-i/o\88a ¯¡Åa»¡\89¡ \90a¬á 'boot\88a ¯¡Åa»³\93¡\94a. 'init-i/o\93e\r
+µ\81¶A Àá\9f¡\9fi Ða\93e THROW\95¡ ¬a¶wÐs\93¡\94a. µA\9cá\88a ¤i¬\97Ð\96\94a¡e ·³Â\89\9db·\81\r
+¤wз·i ¹A\94\81\9d¡ \95©\9da \91½´a´¡ e \8bi®AÌeµA¬á ·³\9db·i ¤h·i ®\81 ·¶·i\r
+\88õ·³\93¡\94a. HIOMULTI.FµÁ HIOMULT2.FµA¬á 'init-i/o\93e ÉB¯aËa ÑÁ¡eµA\r
+Â\89\9dbÐa\89¡ µw¢\85 ´iÌa¥U ·³\9db e ¤h·i \88õ·¥»¡ \8ba\9c\81Ï¢ ÑÁ¡eµA Â\89\9dbÐa\89¡ Ðe\8bi\r
+·³\9db\95¡ ¤h·i \88õ·¥»¡\9fi ¸÷Ða\93e NEW-SET-I/O\9fi \88a\9f¡Ç³\93¡\94a. HIOMULTI.FµÁ\r
+HIOMULT2.FµA¬á 'boot\93e ·¥¬a i·i ¥¡·¡\89¡ \95¡¯a ¡w\9dwÐ\97µA¬á Ïa\9d¡\8ba\9c\91·i\r
+¨\85 \90a ỡ ¦\81¦\85·i PAD\9d¡ µ«\8b¡\89¡ Í¡¯a É·µb\8b¡\9fi ¯¡¸bÐs\93¡\94a. ¡w\9dwÐ\97·i\r
+\8ba\9c\81Ï¢ ÑÁ¡eµA ¥¡·¡\93e Ïa\9d¡\8ba\9c\91·i HIOMULT2.F·\81 NEW-hi\9fi \89¡Áa¬á\r
+´a\9c\81Àá\9cñ e\97i\89¡ ¯¡Åa ¥¡¯³¯¡µ¡.\r
+\r
+ C:\HF>SAVE2\r
+\r
+ hForth 8086 EXE Model v0.9.9 by Wonyong Koh, 1997\r
+ ALL noncommercial and commercial uses are granted.\r
+ Please send comment, bug report and suggestions to:\r
+ wykoh@pado.krict.re.kr or 82-42-861-4245 (FAX)\r
+ ·\81\89e\89Á ¹A´e\89Á §¡Íw·i Ða·¡ÉI wykoh\9d¡ ¥¡\90\81 º\81¯³¯¡µ¡.\r
+\r
+ HEX\r
+ : SAMPLE\r
+ CS@ 10 - \ PSP segment\r
+ 80 2DUP LC@ 1+ 0 DO 2DUP LC@ PAD I + C! CHAR+ LOOP 2DROP\r
+ HGRAPHIC\r
+ PAD COUNT TYPE CR CR\r
+ ." ´a¢\81 \8bi®A\90a \92\81\9fa¯³¯¡µ¡." KEY BYE ;\r
+ ' SAMPLE TO 'boot\r
+ SAVE-SYSTEM-AS BYE.EXE\r
+ BYE\r
+ C:\HF>BYE 11 22 33\r
+\r
+HIOMULTI.FµÁ HIOMULT2.FµA¬á \94aº\97¸b´ó\8b¡\9fi ¯©¹A ¢\85¹AµA ´á\98ý\89A\r
+¸â¶wÐa\93e»¡ ¥© ®\81 ·¶¯s\93¡\94a. Í¡¯a É·µb\8b¡\88a \8bi®A ·³\9db·i \8b¡\94a\9f¡\93e \95·´eµA\r
+ÑÁ¡e·¡ ¶á\9d¡ i\9f¡\8b¡ \98\81¢\85µA \8ba\9c\81Ï¢ ÑÁ¡e Â\89\9db·¡ ÉB¯aËa ÑÁ¡e Â\89\9db eÇq\r
+¨a\9fs\93¡\94a.\r
+\r
+LOG.FµA \97i´á ·¶\93e LOGON, LOGOFF \90{ i·i °á¬á ÑÁ¡e Â\89\9db·i ÉB¯aËa Ìa·©\r
+HFORTH.LOGµA \88i¢\81\9f¡Ði ®\81 ·¶¯s\93¡\94a. \8bi®AÌeµA e\97e \90{ i\97i·i \88i¢\81\9f¡\r
+Ð\81¬á \90aº\97µA ®ó\89A Í¡¯a ¤aÈw¥¥·i e\97i ®\81 ·¶¯s\93¡\94a. DOSEXEC.F·\81 \90{ i·i\r
+°á¬á \95¡¯a ¯©Ð\97 Ìa·©·i hForthµA¬á ¦\81\9fi ®\81 ·¶¯s\93¡\94a. hForth\9fi ¨a¹a\r
+\90a\88a»¡ ´g\89¡ Q Editor\90a U Editor\9fi ¦\89\9cá Í¡¯a ¤aÈw¥¥·i Íe»³Ða\89¡\r
+Íe»³\8b¡\9fi ¨a¹a \90aµÁ¬á Í¡¯a ¤aÈw¥¥·i µ©\9f¡\89¡ \90{ i\97i·i ¯¡ÐñÐi ®\81\r
+·¶¯s\93¡\94a. ·¡\9cý\89A Ði \98\81\93e Í¡¯a ¤aÈw¥¥·\81 \85 ´|µA 'MARKER »¡¶\81\8b¡'·i\r
+\90ý´á¬á \90aº\97µA \90{ i '»¡¶\81\8b¡'\9fi ¯¡Åa¬á \94áÐe \90{ i\97i·i ®ó\89A »¡¶\89 ®\81 ·¶\89A\r
+Ða\93e \88õ·¡ ¹½·i \88õ·³\93¡\94a. LOG.FµÁ DOSEXEC.F Ìa·© ´|¦\81¦\85·\81 \90{ i ¬a¶w\r
+¬é¡w·i Àq¹¡Ða¯³¯¡µ¡.\r
+\r
+\88á¦\82 \8ba\9f±(Turtle Graphics) É·µb\8b¡\93e ·¡¹A ³i eÐe ¬wÈ\81\88a \96A´ö¯s\93¡\94a.\r
+\r
+hForth\93e 1990 \91eµA Bill MuenchµÁ Dr. C. H. Ting·¡ ¤iÎaÐe\r
+eForth\9fi¤aÈw·a\9d¡ e\97i´á¬á ¥¥\9c\81·\81 eForth·\81 Ëb»·\97i·i \8ba\94\81\9d¡\r
+¬i\9dv¯s\93¡\94a. ´a\9c\81\93e 8086 eForth ¤aÈw¥¥µA¬á \98a µ¥ \88õ·³\93¡\94a.\r
+\r
+ > \88b\88b·\81 a·¡Ça\9d¡Ïa\9d¡A¬áµA xÂ\85 ¡y ´e\96A\93e CODE \90{ i\97i\89Á ¡¡\97e\r
+ > a·¡Ça\9d¡Ïa\9d¡A¬áµA \89·É··¥ \89¡\8bs (high level) \90{ i\97i\9d¡\r
+ > ·¡\9e\81´á¹a ·¶¯s\93¡\94a.\r
+ > ¶¥¯¡Å¡\97a\93e MASM ´áQ§i\9cá¶w·³\93¡\94a.\r
+ > »¢¸ó \8eÅ (direct threaded) ¤w¤ó·i ³s\93¡\94a.\r
+ > ¬a¸å·\81 Å¡\97aµÁ ·¡\9fq·¡ ¡A¡¡\9f¡µA \98a\9d¡ ¸a\9f¡Ðs\93¡\94a.\r
+ > ·³Â\89\9db·e \88a\9f¡Ç± \90{ i·i É·Ða\89¡ º\81 ÄñÏAÈá(host computer)\9fi\r
+ > \94e i\8b¡µÁ Ìa·© ·³Â\89\9dbµA ·¡¶wÐs\93¡\94a.\r
+ > ¹A´e\96E £¡\8a\82 Îaº\85 Í¡¯a(ANS Forth)·\81 ¤wз·i \98a\9cv¯s\93¡\94a.\r
+ > ´á\98å a·¡Ça\9d¡Ïa\9d¡A¬áµA xÂ\81´á ÂA¸âÑÁÐa\8b¡\88a ®ó¯s\93¡\94a.\r
+\r
+·¡\88õ\97i·e \8ba\94\81\9d¡ hForth·\81 ¬÷»©·³\93¡\94a. \8ba\9f¡\89¡ hForth \93e ´\85¯¡ Îaº\85\r
+Í¡¯a·\81 ¤wз e·i \98a\9fa\93e \88õ·¡ ´a\93¡\9ca ´\85¯¡ Îaº\85 Í¡¯a·\81 ¶a\8a\81 ¹¡\88å·i\r
+¡¡\96\81 e¹¢Ða\93e ´\85¯¡ Îaº\85 Í¡¯a ¯¡¯aÉQ·³\93¡\94a.\r
+\r
+µa\9cá ¦\85·\81 ·\81\89e, ¹A´e, §¡Íw·i \97i\9da º\81¯³¯¡µ¡. \95¡¶\91·i º\81¯© ®\81 ·¶\94a¡e\r
+\94á¶\82 ¹½¯s\93¡\94a.\r
+\r
+1996. 6. 2.\r
+\r
+\89¡¶¥¶w\r
+·¥Èá\91U: wykoh@pado.krict.re.kr\r
+Ða·¡ÉI: wykoh\r
--- /dev/null
+\r
+hForth 0.9.9 ÆÇÀÔ´Ï´Ù. hForth´Â ANS Forth Ç¥ÁØÀ» µû¸£´Â ÀÛÀº Æ÷½º\r
+½Ã½ºÅÛÀÔ´Ï´Ù. hForth´Â ¹«·á ÇÁ·Î±×·¥(free software)ÀÔ´Ï´Ù. ÀÌ°ÍÀ»\r
+°³ÀÎÀûÀ¸·Î³ª »ó¾÷ÀûÀ¸·Î³ª ¾î¶² ¸ñÀû¿¡ »ç¿ëÇصµ ÁÁ½À´Ï´Ù. ´Ü, ÀÌ\r
+ÇÁ·Î±×·¥¸¸À» ÆȾƼ´Â ¾ÈµÇ°í (hForth¸¦ ½á¼ ¸¸µç ÇÁ·Î±×·¥À» ÆÄ´Â\r
+°ÍÀº Á¦°¡ »ó°üÇÏÁö ¾Ê°í °Å±â¿¡ hForth ²Ù·¯¹Ì°¡ µé¾î À־\r
+ÁÁ½À´Ï´Ù.) hForth¶ó´Â À̸§À» ¾²·Á¸é ²Ù·¯¹ÌÀÇ ÆÄÀϵéÀÌ º»·¡ »óÅ·Î\r
+ÀÖ¾î¾ß ÇÕ´Ï´Ù. °¡´ÉÇÑ ÇÑ hForth¸¦ ³Î¸® Æ۶߷ÁÁֽʽÿÀ.\r
+\r
+hForth¿¡´Â ¾î¼Àºí¸® ¹ÙÅÁº»ÀÌ 3 °³ µé¾î ÀÖ½À´Ï´Ù. HF86ROM.COMÀº\r
+ANSEF86.COMó·³ RAM°ú ROM°¡ ´Ù¸¥ ÁÖ¼Ò¿¡ ÀÖ´Â ½Ã½ºÅÛ¿¡¼ ¾²À̵µ·Ï\r
+¸¸µé¾ú½À´Ï´Ù. HF86RAM.COMÀº HF86RAMÀ» °íÃÄ RAM¸¸À» ¾²´Â ½Ã½ºÅÛ\r
+¿ëÀ¸·Î ¸¸µé¾ú½À´Ï´Ù. HF86EXE.EXE´Â 8086¿¡¼ ÄÚµå¿Í ÀڷḦ ´Ù¸¥\r
+¼¼±×¸ÕÆ®¿¡ ³Ö°í ¿©·¯ ³¹¸»À» ±â°è¾î·Î Á¤ÀÇÇß½À´Ï´Ù. HF86EXE.EXE´Â\r
+ÀÌ·¸°Ô Çؼ HF86ROM.COM°ú HF86RAM.COM¿¡ ºñÇØ µÎ ¹èÀÇ ¸Þ¸ð¸®¸¦ ¾µ\r
+¼ö ÀÖ°í ¼Óµµµµ µÎ ¹è ÀÌ»ó »¡¶óÁ³½À´Ï´Ù. °¢ ¾î¼Àºí¸®¾î ¹ÙÅÁº»ÀÇ Ã¹\r
+¸Ó¸®¿¡ °¢ ¹ÙÅÁº»µéÀÌ ¾î¶»°Ô ´Ù¸¥Áö¸¦ Àû¾î µÎ¾ú½À´Ï´Ù. ÇѵΠ°³ÀÇ\r
+¾î¼Àºí¸®¾î ³¹¸»¸¦ ´õÇÑ °Í ¸»°í´Â ¶È°°Àº ¾î¼Àºí¸®¾î ³¹¸»µéÀ»½á¼\r
+HF86ROM.ASMÀ¸·ÎºÎÅÍ HF86RAMÀ» ¸¸µé¾ú½À´Ï´Ù. ±â°è¾î·Î Á¤ÀÇÇÑ\r
+³¹¸»¸¸À» ¹Ù²Ù¾î¼ Z80¿¡µµ hForth¸¦ ½É¾ú½À´Ï´Ù.\r
+\r
+ÀÌ ²Ù·¯¹Ì¿¡´Â ¾Æ·¡ ÆÄÀϵéÀÌ µé¾î ÀÖ½À´Ï´Ù.\r
+\r
+HF86ROM.ASM IBM-PC ¿ë hForth 8086 ROM ¸ðµ¨ÀÇ TASM ¹ÙÅÁº».\r
+HF86RAM.ASM IBM-PC ¿ë hForth 8086 RAM ¸ðµ¨ÀÇ TASM ¹ÙÅÁº».\r
+HF86EXE.ASM IBM-PC ¿ë hForth 8086 EXE ¸ðµ¨ÀÇ TASM ¹ÙÅÁº».\r
+HF86ROM.COM hForth 8086 ROM ¸ðµ¨ÀÇ ½ÇÇà ÆÄÀÏ.\r
+HF86RAM.COM hForth 8086 RAM ¸ðµ¨ÀÇ ½ÇÇà ÆÄÀÏ.\r
+HF86EXE.EXE hForth 8086 EXE ¸ðµ¨ÀÇ ½ÇÇà ÆÄÀÏ.\r
+SAVE.EXE OPTIONAL.F¿Í ASM8086.F¿Í COREEXT.F¿Í MSDOS.F¿Í\r
+ MULTI.F¸¦ ´õÇÑ HF86EXE.EXE.\r
+SAVE1.EXE HIOMULTI.F¸¦ ´õÇÑ SAVE.EXE.\r
+SAVE2.EXE HIOMULT2.F¸¦ ´õÇÑ SAVE.EXE.\r
+HTURTLE.EXE ¿ì¸®¸» °ÅºÏ ±×¸² Å뿪±â.\r
+ETURTLE.EXE ¿µ¹® °ÅºÏ ±×¸² Å뿪±â.\r
+OPTIONAL.F ¼±Åà ³¹¸»(OPTIONAL wordset words)µéÀÇ Æ÷½º ¹ÙÅÁº».\r
+ASM8086.F 8086 ¾î¼Àºí·¯ Æ÷½º ¹ÙÅÁº».\r
+ASMTEST.F 8086 ¾î¼Àºí·¯¸¦ ½ÃÇèÇϱâ À§ÇÑ Æ÷½º ¹ÙÅÁº».\r
+COREEXT.F ANS Ç¥ÁØ Æ÷½º ÇÁ·Î±×·¥¿¡ ¾²Áö ¸»¾Æ¾ß ÇÒ ³°Àº ³¹¸»À» »«\r
+ (OPTIONAL.F¿¡ ºüÁø) ´Ù¸¥ ¸ðµç CORE EXT ³¹¸»ÀÇ Æ÷½º ¹ÙÅÁº».\r
+MULTI.F Bill MuenchÀÇ ´ÙÁßÀÛ¾÷±â(multitasker)ÀÇ Æ÷½º ¹ÙÅÁº».\r
+MULDEMO.F ´ÙÁß ÀÛ¾÷±â¸¦ ½ÃÇèÇϱâ À§ÇÑ °£´ÜÇÑ Æ÷½º ¹ÙÅÁº».\r
+MSDOS.F DOS ÇÔ¼ö¸¦ ½á¼ Á¤ÀÇÇÑ FILE ³¹¸»°ú BLOCK ³¹¸»µé.\r
+DOSEXEC.F hForth¿¡¼ µµ½º ÇÁ·Î±×·¥À» ºÎ¸£´Â ³¹¸»ÀÇ Á¤ÀÇ.\r
+SAVE.F SAVE.EXE¸¦ ¸¸µå´Â Æ÷½º ¹ÙÅÁº».\r
+DOUBLE.F ¿ÏÀüÇÑ DOUBLE°ú DOUBLE EXT ³¹¸»ÀÇ Á¤ÀÇ.\r
+HIOMULTI.F ´ÙÁßÀÛ¾÷±â¸¦ ¾²´Â ÇѱÛÀÔÃâ·Â Æ÷½º ¹ÙÅÁº».\r
+HIOMULT2.F ±Û²ÃÀ» ¹Ù²Ü ¼ö ÀÖ´Â ÇѱÛÀÔÃâ·Â Æ÷½º ¹ÙÅÁº».\r
+ENG.FNT HIOMULT2.F¿¡¼ ¾²´Â ¿µ¹® ±Û²Ã.\r
+HAN.FNT HIOMULT2.F¿¡¼ ¾²´Â ÇÑ±Û ±Û²Ã.\r
+CLOCK.F SAVE2.EXE¿¡¼ ¾µ ¼ö ÀÖ´Â ´ÙÁß ÀÛ¾÷±â ½Ã°è\r
+STACK.F SAVE2.EXE¿¡¼ ȸ鿡 ´õ¹ÌÀÇ ³»¿ëÀ» º¸ÀÌ´Â ÇÁ·Î±×·¥.\r
+TURTLE.F ¿ì¸®¸» °ÅºÏ ±×¸² Å뿪±â Æ÷½º ¹ÙÅÁº».\r
+HTURTLE.GLO °ÅºÏ ±×¸² ³¹¸» Ç®ÀÌ.\r
+SIO.F Á÷·Ä Åë½Å ÇÁ·Î±×·¥. ±»Àº¸ð Á¦¾îÀÇ ¿¹.\r
+LOG.F ȸé Ãâ·ÂÀ» HFORTH.LOG¿¡ °¥¹«¸®ÇÏ´Â ÇÁ·Î±×·¥.\r
+DISCP.F M. Edward BoraskyÀÇ Dijkstra guarded command control\r
+ structures.\r
+MEMORY.F MEMORY ALLOCATION ³¹¸»ÀÇ Á¤ÀÇ. Gordon ChlarltonÀÇ\r
+ MEMORY.FTH¸¦ °íÄ£ °Í.\r
+MEMORY.FTH Gordon CharltonÀÇ º»·¡ ÆÄÀÏ.\r
+DEBUGGER.ANS ANS Ç¥ÁØ Æ÷½º ³¹¸»·Î ¸¸µç Joerg PleweÀÇ ¹ú·¹Àâ°³.\r
+HFORTH.HTM Forth Dimensions¿¡ ½Ç·È´ø hForth ¼Ò°³±Û\r
+README.KOR ÀÌ ÆÄÀÏ (Á¶ÇÕÇü ÇѱÛ).\r
+README.KS ÀÌ ÆÄÀÏ (¿Ï¼ºÇü ÇѱÛ).\r
+\r
+°¢ ½ÇÇà ÆÄÀϵéÀº ¾Æ·¡ ¹æ¹ýÀ¸·Î ¸¸µé¾ú½À´Ï´Ù.\r
+\r
+>TASM /ml HF86ROM ¶Ç´Â HF86RAM ¶Ç´Â HF86EXE\r
+>TLINK /t HF86ROM ¶Ç´Â TLINK /t HF86RAM ¶Ç´Â TLINK HF86EXE\r
+\r
+²Ù·¯¹Ì ¾ÈÀÇ SAVE.EXE´Â HF86EXE.EXE¸¦ ½ÃÀÛÇÑ ´ÙÀ½ ¾Æ·¡Ã³·³ Çؼ\r
+¸¶·ÃÇÑ °ÍÀÔ´Ï´Ù.\r
+\r
+ << OPTIONAL.F\r
+ << ASM8086.F\r
+ << MSDOS.F\r
+ BL PARSE SAVE.F INCLUDED \ ¶Ç´Â INCLUDE SAVE.F\r
+\r
+½ÃÀÛÇÏ¸é ¹Ù·Î ±×·¡ÇÈ È¸é¿¡ ¿µ¹® ¾ËÆĺª°ú ÇѱÛÀ» º¸ÀÌ´Â SAVE2.EXE´Â\r
+SAVE.EXE¸¦ ½ÃÀÛÇÑ ´ÙÀ½, ¾Æ·¡Ã³·³ Çؼ ¸¶·ÃÇÑ °ÍÀÔ´Ï´Ù.\r
+\r
+ BL PARSE HIOMULT2.F INCLUDED \ ¶Ç´Â INCLUDE HIOMULT2.F\r
+ SAVE-SYSTEM-AS SAVE2.EXE\r
+\r
+¹Ù·Î À§¿¡¼ º¸½Å °Íó·³ ÀÌÁ¦ '<<'¸¦ ¾²Áö ¾Ê°í Ç¥ÁØ Æ÷½ºÀÇ FILE\r
+³¹¸»ÀÎ INCLUDED³ª ºñÇ¥ÁØ ³¹¸» INCLUDE¸¦ ½á¼ Æ÷½º ¹ÙÅÁº»À» ÀÐ¾î µéÀÏ\r
+¼ö ÀÖ½À´Ï´Ù. MSDOS.F¸¦ ¿Ã¸®½Å ÈÄ¿¡´Â '<<'¸¦ ¾²Áö ¸¶½Ê½Ã¿À.\r
+\r
+¾Ø½Ã Ç¥ÁØ Æ÷½ºÀÇ CORE ³¹¸»µéÀº ¸ðµÎ ¾î¼Àºí¸®¾î ¹ÙÅÁº»¿¡\r
+µé¾îÀÖ½À´Ï´Ù. ¿ÏÀüÇÑ TOOLS ³¹¸»°ú SEARCH ORDER ³¹¸»°ú SEARCH ORDER\r
+EXTENSION ³¹¸»µé°ú ´Ù¸¥ ¾µ¸ðÀÖ´Â ³¹¸»µéÀº OPTIONAL.F¿¡\r
+µé¾îÀÖ½À´Ï´Ù. ¾î¼Àºí¸®¾î·Î Á¤ÀÇÇÏ´Â °ÍÀÌ ³ªÀº CORE EXTENSION\r
+³¹¸»µéÀº COREEXT.F¿¡ µé¾îÀÖ½À´Ï´Ù.\r
+\r
+'init-i/o¿Í 'boot¸¦ ½á¼ Á¤ÇØÁø ÀÏÀ» ÇÏ´Â ÀÀ¿ë ÇÁ·Î±×·¥À» ¸¸µé ¼ö\r
+ÀÖ½À´Ï´Ù. SAVE-SYSTEMÀ̳ª SAVE-SYSTEM-AS·Î °¥¹«¸®ÇÑ ÇÁ·Î±×·¥ÀÌ Ã³À½\r
+½ÃÄÑÁú ¶§ 'init-i/o°¡ ½ÃÄÑÁö°í ³ª¼ 'boot°¡ ½ÃÄÑÁý´Ï´Ù. 'init-i/o´Â\r
+¿¹¿Ü 󸮸¦ ÇÏ´Â THROWµµ »ç¿ëÇÕ´Ï´Ù. ¿¡·¯°¡ ¹ß»ýÇß´Ù¸é ÀÔÃâ·ÂÀÇ\r
+¹æÇâÀ» Á¦´ë·Î µ¹·Á ³õ¾Æ¾ß¸¸ ±Û¼èÆÇ¿¡¼ ÀÔ·ÂÀ» ¹ÞÀ» ¼ö ÀÖÀ»\r
+°ÍÀÔ´Ï´Ù. HIOMULTI.F¿Í HIOMULT2.F¿¡¼ 'init-i/o´Â ÅؽºÆ® ȸ鿡\r
+Ãâ·ÂÇÏ°í ¿µ¹® ¾ËÆĺª ÀԷ¸¸ ¹ÞÀ» °ÍÀÎÁö ±×·¡ÇÈ È¸é¿¡ Ãâ·ÂÇÏ°í ÇѱÛ\r
+ÀԷµµ ¹ÞÀ» °ÍÀÎÁö¸¦ Á¤ÇÏ´Â NEW-SET-I/O¸¦ °¡¸®Åµ´Ï´Ù. HIOMULTI.F¿Í\r
+HIOMULT2.F¿¡¼ 'boot´Â Àλ縻À» º¸ÀÌ°í µµ½º ¸í·ÉÇà¿¡¼ ÇÁ·Î±×·¥À»\r
+»« ³ª¸ÓÁö ºÎºÐÀ» PAD·Î ¿Å±â°í Æ÷½º Å뿪±â¸¦ ½ÃÀÛÇÕ´Ï´Ù. ¸í·ÉÇàÀ»\r
+±×·¡ÇÈ È¸é¿¡ º¸ÀÌ´Â ÇÁ·Î±×·¥À» HIOMULT2.FÀÇ NEW-hi¸¦ °íÃļ\r
+¾Æ·¡Ã³·³ ¸¸µé°í ½ÃÄÑ º¸½Ê½Ã¿À.\r
+\r
+ C:\HF>SAVE2\r
+\r
+ hForth 8086 EXE Model v0.9.9 by Wonyong Koh, 1997\r
+ ALL noncommercial and commercial uses are granted.\r
+ Please send comment, bug report and suggestions to:\r
+ wykoh@pado.krict.re.kr or 82-42-861-4245 (FAX)\r
+ ÀÇ°ß°ú Á¦¾È°ú ºñÆòÀ» ÇÏÀÌÅÚ wykoh·Î º¸³» ÁֽʽÿÀ.\r
+\r
+ HEX\r
+ : SAMPLE\r
+ CS@ 10 - \ PSP segment\r
+ 80 2DUP LC@ 1+ 0 DO 2DUP LC@ PAD I + C! CHAR+ LOOP 2DROP\r
+ HGRAPHIC\r
+ PAD COUNT TYPE CR CR\r
+ ." ¾Æ¹« ±Û¼è³ª ´©¸£½Ê½Ã¿À." KEY BYE ;\r
+ ' SAMPLE TO 'boot\r
+ SAVE-SYSTEM-AS BYE.EXE\r
+ BYE\r
+ C:\HF>BYE 11 22 33\r
+\r
+HIOMULTI.F¿Í HIOMULT2.F¿¡¼ ´ÙÁßÀÛ¾÷±â¸¦ ½ÇÁ¦ ¹®Á¦¿¡ ¾î¶»°Ô\r
+Àû¿ëÇÏ´ÂÁö º¼ ¼ö ÀÖ½À´Ï´Ù. Æ÷½º Å뿪±â°¡ ±Û¼è ÀÔ·ÂÀ» ±â´Ù¸®´Â µ¿¾È¿¡\r
+ȸéÀÌ À§·Î ¸»¸®±â ¶§¹®¿¡ ±×·¡ÇÈ È¸é Ãâ·ÂÀÌ ÅؽºÆ® ȸé Ãâ·Â¸¸Å\r
+ºü¸¨´Ï´Ù.\r
+\r
+LOG.F¿¡ µé¾î ÀÖ´Â LOGON, LOGOFF ³¹¸»À» ½á¼ ȸé Ãâ·ÂÀ» ÅؽºÆ® ÆÄÀÏ\r
+HFORTH.LOG¿¡ °¥¹«¸®ÇÒ ¼ö ÀÖ½À´Ï´Ù. ±Û¼èÆÇ¿¡ ¸¸µç ³¹¸»µéÀ» °¥¹«¸®\r
+Çؼ ³ªÁß¿¡ ½±°Ô Æ÷½º ¹ÙÅÁº»À» ¸¸µé ¼ö ÀÖ½À´Ï´Ù. DOSEXEC.FÀÇ ³¹¸»À»\r
+½á¼ µµ½º ½ÇÇà ÆÄÀÏÀ» hForth¿¡¼ ºÎ¸¦ ¼ö ÀÖ½À´Ï´Ù. hForth¸¦ ºüÁ®\r
+³ª°¡Áö ¾Ê°í Q Editor³ª U Editor¸¦ ºÒ·¯ Æ÷½º ¹ÙÅÁº»À» ÆíÁýÇÏ°í\r
+ÆíÁý±â¸¦ ºüÁ® ³ª¿Í¼ Æ÷½º ¹ÙÅÁº»À» ¿Ã¸®°í ³¹¸»µéÀ» ½ÃÇèÇÒ ¼ö\r
+ÀÖ½À´Ï´Ù. ÀÌ·¸°Ô ÇÒ ¶§´Â Æ÷½º ¹ÙÅÁº»ÀÇ ¸Ç ¾Õ¿¡ 'MARKER Áö¿ì±â'À»\r
+³Ö¾î¼ ³ªÁß¿¡ ³¹¸» 'Áö¿ì±â'¸¦ ½ÃÄѼ ´õÇÑ ³¹¸»µéÀ» ½±°Ô Áö¿ï ¼ö ÀÖ°Ô\r
+ÇÏ´Â °ÍÀÌ ÁÁÀ» °ÍÀÔ´Ï´Ù. LOG.F¿Í DOSEXEC.F ÆÄÀÏ ¾ÕºÎºÐÀÇ ³¹¸» »ç¿ë\r
+¼³¸íÀ» ÂüÁ¶ÇϽʽÿÀ.\r
+\r
+°ÅºÏ ±×¸²(Turtle Graphics) Å뿪±â´Â ÀÌÁ¦ ¾µ¸¸ÇÑ »óÅ°¡ µÇ¾ú½À´Ï´Ù.\r
+\r
+hForth´Â 1990 ³â¿¡ Bill Muench¿Í Dr. C. H. TingÀÌ ¹ßÇ¥ÇÑ\r
+eForth¸¦¹ÙÅÁÀ¸·Î ¸¸µé¾î¼ º»·¡ÀÇ eForthÀÇ Æ¯Â¡µéÀ» ±×´ë·Î\r
+»ì·È½À´Ï´Ù. ¾Æ·¡´Â 8086 eForth ¹ÙÅÁº»¿¡¼ µû ¿Â °ÍÀÔ´Ï´Ù.\r
+\r
+ > °¢°¢ÀÇ ¸¶ÀÌÅ©·ÎÇÁ·Î¼¼¼¿¡ ¸ÂÃá ¸î ¾ÈµÇ´Â CODE ³¹¸»µé°ú ¸ðµç\r
+ > ¸¶ÀÌÅ©·ÎÇÁ·Î¼¼¼¿¡ °øÅëÀÎ °í±Þ (high level) ³¹¸»µé·Î\r
+ > ÀÌ·ç¾îÁ® ÀÖ½À´Ï´Ù.\r
+ > ¿ø½ÃÄÚµå´Â MASM ¾î¼Àºí·¯¿ëÀÔ´Ï´Ù.\r
+ > Á÷Á¢ ²é (direct threaded) ¹æ¹ýÀ» ¾¹´Ï´Ù.\r
+ > »çÀüÀÇ ÄÚµå¿Í À̸§ÀÌ ¸Þ¸ð¸®¿¡ µû·Î ÀÚ¸®ÇÕ´Ï´Ù.\r
+ > ÀÔÃâ·ÂÀº °¡¸®Å´ ³¹¸»À» ÅëÇÏ°í ÁÖ ÄÄÇ»ÅÍ(host computer)¸¦\r
+ > ´Ü¸»±â¿Í ÆÄÀÏ ÀÔÃâ·Â¿¡ ÀÌ¿ëÇÕ´Ï´Ù.\r
+ > Á¦¾ÈµÈ ¹Ì±¹ Ç¥ÁØ Æ÷½º(ANS Forth)ÀÇ ¹æÇâÀ» µû¶ú½À´Ï´Ù.\r
+ > ¾î¶² ¸¶ÀÌÅ©·ÎÇÁ·Î¼¼¼¿¡ ¸ÂÃß¾î ÃÖÀûÈÇϱⰡ ½±½À´Ï´Ù.\r
+\r
+À̰͵éÀº ±×´ë·Î hForthÀÇ ¼ºÁúÀÔ´Ï´Ù. ±×¸®°í hForth ´Â ¾Ø½Ã Ç¥ÁØ\r
+Æ÷½ºÀÇ ¹æÇ⸸À» µû¸£´Â °ÍÀÌ ¾Æ´Ï¶ó ¾Ø½Ã Ç¥ÁØ Æ÷½ºÀÇ ¿ä±¸ Á¶°ÇÀ»\r
+¸ðµÎ ¸¸Á·ÇÏ´Â ¾Ø½Ã Ç¥ÁØ Æ÷½º ½Ã½ºÅÛÀÔ´Ï´Ù.\r
+\r
+¿©·¯ ºÐÀÇ ÀÇ°ß, Á¦¾È, ºñÆòÀ» µé·Á ÁֽʽÿÀ. µµ¿òÀ» ÁÖ½Ç ¼ö ÀÖ´Ù¸é\r
+´õ¿í ÁÁ½À´Ï´Ù.\r
+\r
+1996. 6. 2.\r
+\r
+°í¿ø¿ë\r
+ÀÎÅͳÝ: wykoh@pado.krict.re.kr\r
+ÇÏÀÌÅÚ: wykoh\r
--- /dev/null
+\\r
+\ SAVE.F\r
+\\r
+\ SAVE.EXE is built from HF86EXE.EXE by loading Forth sources\r
+\ in the following order.\r
+\\r
+\ << OPTIONAL.F\r
+\ << ASM8086.F\r
+\ << COREEXT.F\r
+\ << MSDOS.F\r
+\ BL PARSE SAVE.F INCLUDED\r
+\r
+GET-CURRENT\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+: << CR ." Do NOT use '<<'."\r
+ CR ." Use 'BL PARSE filename INCLUDED' or 'INCLUDE filename' instead of '<< filename'."\r
+ ABORT ; IMMEDIATE\r
+\r
+SET-CURRENT\r
+BL PARSE MULTI.F INCLUDED\r
+BL PARSE DOUBLE.F INCLUDED\r
+SAVE-SYSTEM-AS SAVE.EXE\r
--- /dev/null
+\\r
+\ SIO.F\r
+\ Serial input/output words for IBM PC compatiables.\r
+\\r
+\ Adjust the value of CONSTANT words IRQ and COMBASE for your system.\r
+\\r
+\ SIO.F is a example of direct control of hardware.\r
+\ You should not or can not do this in a respectable OS.\r
+\ However, MS-DOS is not one of them :).\r
+\\r
+\ There are two input and output buffers. Serial port output as well as input\r
+\ are driven by interrupts. High-level words simply take or put characters in\r
+\ the buffers. Then the interrupt service routine takes outgoing characters\r
+\ from the output buffer and puts incomming characters in the input buffer.\r
+\\r
+\ 1996. 2. 9.\r
+\ Wonyong Koh\r
+\r
+HEX\r
+\r
+ 3 CONSTANT IRQ \ normally COM1 and COM3 use IRQ4,\r
+ \ COM2 and COM4 use IRQ3\r
+2F8 CONSTANT COMBASE \ base address, 3F8 for COM1, 2F8 for COM2\r
+ \ 3E8 for COM3, 2E8 for COM4\r
+\r
+: BINARY 2 BASE ! ;\r
+\r
+CODE ENABLE\r
+ STI,\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE DISABLE\r
+ CLI,\r
+ NEXT,\r
+END-CODE\r
+\r
+20 CONSTANT CTRL8259_0 \ interrupt control register\r
+21 CONSTANT CTRL8259_1 \ interrupt mask register\r
+20 CONSTANT EOI \ end of interrupt\r
+\r
+COMBASE CONSTANT TXR \ transmission register (WRITE)\r
+COMBASE CONSTANT RXR \ receive register (READ)\r
+COMBASE 1 + CONSTANT IER \ interrupt enable\r
+COMBASE 2 + CONSTANT IIR \ interrupt ID\r
+COMBASE 3 + CONSTANT LCR \ line contril\r
+COMBASE 4 + CONSTANT MCR \ modem control\r
+COMBASE 5 + CONSTANT LSR \ line status\r
+COMBASE 6 + CONSTANT MSR \ modem status\r
+COMBASE CONSTANT DLL \ divisor latch low\r
+COMBASE 1 + CONSTANT DLH \ divisor latch high\r
+\r
+00 CONSTANT NO\r
+18 CONSTANT ODD\r
+08 CONSTANT EVEN\r
+: PARITY ( n -- )\r
+ LCR PC@\r
+ [ BINARY 00011000 INVERT HEX ] LITERAL AND\r
+ OR LCR PC! ;\r
+\r
+: BITS ( n -- ) \ n = 5, 6, 7, or 8\r
+ 5 -\r
+ LCR PC@\r
+ [ BINARY 00000011 INVERT HEX ] LITERAL AND\r
+ OR LCR PC! ;\r
+\r
+: STOPBIT ( n -- ) \ n = 0 or 1\r
+ 2 LSHIFT\r
+ LCR PC@\r
+ [ BINARY 00000100 INVERT HEX ] LITERAL AND\r
+ OR LCR PC! ;\r
+\r
+: BPS ( n -- ) \ set speed\r
+ LCR PC@ SWAP\r
+ 0FF LCR PC! \ set Divisor-Latch Access-Bit\r
+ [ DECIMAL ] 115200.\r
+ [ HEX ] ROT UM/MOD NIP \ calculate divisor\r
+ DUP 0FF AND DLL PC!\r
+ 8 RSHIFT DLH PC!\r
+ LCR PC! ; \ restore original LCR\r
+\r
+: DROP-RTS\r
+ 1 MSR PC! ;\r
+\r
+: DTR-RTS\r
+ 3 MSR PC! ;\r
+\r
+DTR-RTS\r
+\r
+BINARY\r
+: CLEAR-UART\r
+ BEGIN\r
+ RXR PC@ DROP\r
+ LSR PC@ DROP\r
+ MSR PC@ DROP\r
+ EOI CTRL8259_0 PC!\r
+ IIR PC@ 00000001 AND\r
+ UNTIL ;\r
+\r
+: ENABLE-IRQ\r
+ CTRL8259_1 PC@\r
+ [ 1 IRQ LSHIFT INVERT ] LITERAL AND \ clear mask bit\r
+ CTRL8259_1 PC!\r
+\r
+ LCR PC@ 01111111 AND LCR PC! \ clear divisor latch addr.\r
+\r
+ 00001111 IER PC! \ interrupts when data received\r
+ CLEAR-UART\r
+ MCR PC@ 00001000 OR MCR PC! \ allow modem to generate interrupts\r
+ ENABLE ;\r
+\r
+: DISABLE-IRQ\r
+ CTRL8259_1 PC@\r
+ [ 1 IRQ LSHIFT ] LITERAL OR \ set mask bit\r
+ CTRL8259_1 PC!\r
+\r
+ 00000000 IER PC! \ no interrupt allowed\r
+\r
+ MCR PC@ 11110111 AND MCR PC! ;\r
+\r
+DECIMAL\r
+1 10 LSHIFT CONSTANT RxBufSize \ receive buffer size = 2 ^ 10 (1024)\r
+ \ The buffer size should be power of 2.\r
+VARIABLE RxBuffer RxBufSize ALLOT\r
+VARIABLE #Rx\r
+VARIABLE RxHead\r
+VARIABLE RxTail\r
+VARIABLE RxOverflow\r
+\r
+1 8 LSHIFT CONSTANT TxBufSize \ receive buffer size = 2 ^ 8 (256)\r
+ \ The buffer size should be power of 2.\r
+CREATE TxBuffer TxBufSize CHARS ALLOT\r
+VARIABLE #Tx\r
+VARIABLE TxHead\r
+VARIABLE TxTail\r
+\r
+VARIABLE LSR@\r
+VARIABLE MSR@\r
+\r
+HEX\r
+: CLEAR-BUFFER\r
+ DISABLE\r
+ 0 #Rx !\r
+ 0 RxHead !\r
+ 0 RxTail !\r
+ 0 #Tx !\r
+ 0 TxHead !\r
+ 0 TxTail !\r
+ -1 LSR@ !\r
+ -1 MSR@ !\r
+ ENABLE ;\r
+\r
+CODE ModemServ\r
+ MSR # DX MOV,\r
+ DX AL IN,\r
+ AL MSR@ ) MOV,\r
+ RET,\r
+END-CODE\r
+\r
+CODE TxServ\r
+ 0 # #Tx ) WORD CMP,\r
+ 1 L# JNZ,\r
+ IER # DX MOV,\r
+ 01 # AL MOV,\r
+ DX AL OUT, \ Disable TXR empty irpt\r
+ RET,\r
+1 L:\r
+ TxTail ) BX MOV,\r
+ TxBuffer [BX] AL MOV,\r
+ TXR # DX MOV,\r
+ DX AL OUT,\r
+ BX INC,\r
+ TxBufSize 1- # BX AND,\r
+ BX TxTail ) MOV,\r
+ #Tx ) WORD DEC,\r
+ RET,\r
+END-CODE\r
+\r
+CODE RxServ\r
+ RXR # DX MOV,\r
+ DX AL IN,\r
+ RxBufSize # #Rx ) CMP,\r
+ 1 L# JNZ,\r
+ -1 # RxOverflow ) MOV,\r
+ RET,\r
+1 L:\r
+ RxHead ) BX MOV,\r
+ AL RxBuffer [BX] MOV,\r
+ BX INC,\r
+ RxBufSize 1- # BX AND,\r
+ BX RxHead ) MOV,\r
+ #Rx ) WORD INC,\r
+ RET,\r
+END-CODE\r
+\r
+CODE LineServ\r
+ LSR # DX MOV,\r
+ DX AL IN,\r
+ AL LSR@ ) MOV,\r
+ RET,\r
+END-CODE\r
+\r
+CREATE IrptTable\r
+' ModemServ , ' TxServ , ' RxServ , ' LineServ ,\r
+\r
+CODE IrptServ\r
+ STI, \ Enable irpt\r
+ AX PUSH,\r
+ BX PUSH,\r
+ DX PUSH,\r
+ DS PUSH,\r
+ CHAR " PARSE model" ENVIRONMENT? DROP\r
+ CHAR " PARSE ROM Model" COMPARE 0=\r
+ CHAR " PARSE model" ENVIRONMENT? DROP\r
+ CHAR " PARSE RAM Model" COMPARE 0= OR\r
+ [IF]\r
+ DS AX MOV,\r
+ AX DS MOV,\r
+ [THEN]\r
+ CHAR " PARSE model" ENVIRONMENT? DROP\r
+ CHAR " PARSE EXE Model" COMPARE 0=\r
+ [IF]\r
+ CS:\r
+ 0 ) AX MOV, \ CS:0 contains data segment address\r
+ AX DS MOV,\r
+ [THEN]\r
+ IIR # DX MOV, \ identify irpt\r
+ DX AL IN,\r
+ 01 # AL TEST,\r
+ 1 L# JNZ,\r
+ AX BX MOV,\r
+ 0006 # BX AND,\r
+ IrptTable [BX] CALL,\r
+1 L: \ do end of interrupt\r
+ EOI # AL MOV,\r
+ CTRL8259_0 # AL OUT,\r
+ IER # DX MOV,\r
+ DX AL IN,\r
+ AX PUSH,\r
+ 0 # AL MOV,\r
+ DX AL OUT,\r
+ AX POP,\r
+ DX AL OUT,\r
+ DS POP,\r
+ DX POP,\r
+ BX POP,\r
+ AX POP,\r
+ IRET,\r
+END-CODE\r
+\r
+CREATE OLD-VECTOR 2 CELLS ALLOT\r
+CODE ATTACH-IRPT ( -- )\r
+ BX PUSH,\r
+ DS PUSH,\r
+ IRQ 8 + 3500 OR # AX MOV, \ AL = irpt number, AH = 35h\r
+ 21 INT, \ DOS get interrupt vector service\r
+ BX OLD-VECTOR ) MOV, \ save old vector\r
+ ES OLD-VECTOR CELL+ ) MOV,\r
+ IRQ 8 + 2500 OR # AX MOV, \ AL = irpt number, AH = 25h\r
+ CS@ # DX MOV,\r
+ DX DS MOV, \ irpt service roution in CS:IrptServ\r
+ ' IrptServ # DX MOV,\r
+ 21 INT, \ DOS set irpt vector\r
+ DS POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE DETACH-IRPT ( -- ) \ restore old vector\r
+ BX PUSH,\r
+ DS PUSH,\r
+ IRQ 8 + 2500 OR # AX MOV, \ AL = irpt number, AH = 25h\r
+ OLD-VECTOR ) DX MOV,\r
+ OLD-VECTOR CELL+ ) DS MOV, \ DOS set irpt vector\r
+ 21 INT,\r
+ DS POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+: SER-IN? ( -- f ) \ true if char received\r
+ #Rx @ 0<> ;\r
+\r
+: SER-IN ( -- x )\r
+ #Rx @ 0= IF 0 EXIT\r
+ ELSE RxTail @ RxBuffer + C@\r
+ RxTail @ 1+ [ RxBufSize 1 - ] LITERAL AND RxTail !\r
+ -1 #Rx +!\r
+ THEN ;\r
+\r
+VARIABLE TIMEOUT\r
+: SER-OUT ( x -- error_code )\r
+ #Tx @ TxBufSize <>\r
+ IF TxHead @ TxBuffer + C!\r
+ TxHead @ 1+ [ TxBufSize 1- ] LITERAL AND TxHead !\r
+ 1 #Tx +!\r
+ [ HEX ] 0F IER PC!\r
+ THEN ;\r
+\r
+DECIMAL\r
+ 9600 BPS NO PARITY 8 BITS 0 STOPBIT\r
+: TERM\r
+ CLEAR-BUFFER\r
+ ATTACH-IRPT\r
+ ENABLE-IRQ\r
+ CLEAR-BUFFER\r
+ BEGIN\r
+ SER-IN? IF SER-IN EMIT THEN\r
+ EKEY? IF KEY DUP 27 = IF DROP DISABLE-IRQ DETACH-IRPT EXIT THEN\r
+ SER-OUT\r
+ THEN\r
+ AGAIN ;\r
--- /dev/null
+\\r
+\ STACK.F\r
+\ Displaying data stack on screen for Forth beginners.\r
+\ HIOMULTI.F or HIOMULT2.F must be loaded first.\r
+\\r
+\ 1996. 2. 9.\r
+\ Wonyong Koh\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+Ðe\8bi·³Â\89\9db-WORDLIST GET-ORDER 1+ SET-ORDER\r
+\r
+DECIMAL\r
+\r
+Ðe\8bi·³Â\89\9db-WORDLIST SET-CURRENT\r
+\r
+7 CONSTANT SWIDTH\r
+CREATE BLANKS SWIDTH CHARS ALLOT BLANKS SWIDTH CHARS BL FILL\r
+\r
+: #!R ( column row x width )\r
+ >R BASE @ 10 = IF S>D ELSE 0 THEN \ col row d R: width\r
+ SWAP OVER DUP 0< IF DNEGATE THEN\r
+ <# #S ROT SIGN #>\r
+ 2OVER 2OVER NIP R@ SWAP - BLANKS SWAP xySTR!\r
+ DUP R> SWAP - >R 2SWAP SWAP R> + SWAP 2SWAP xySTR! ;\r
+\r
+NONSTANDARD-WORDLIST SET-CURRENT\r
+\r
+0 60 CELLS 60 CELLS HAT \94ᣡ¥¡·¡\88\81 \94ᣡ¥¡·¡\88\81 BUILD\r
+\ 0 60 CELLS 60 CELLS HAT StackDisplayer StackDisplayer BUILD\r
+\r
+:NONAME \94ᣡ¥¡·¡\88\81 ACTIVATE\r
+ BEGIN\r
+ \8cq¤b·± @ 0 DO PAUSE LOOP\r
+ GRAPHIC? SCREEN-UPDATED? AND IF\r
+ BASE @ DUP 10 <> IF HEX THEN\r
+ MAX-X 8 - 0 S" \8b¼·¡:" xySTR!\r
+ SystemTask \ system task's userP\r
+ @ CELL+ @\r
+ SystemTask stackTop 's @ \ sp0 sp@\r
+ 4 CELLS + \ PAUSE pushes 4\r
+ 2DUP - 2/ ( 1 CELLS / ) DUP\r
+ MAX-X 3 - 0 ROT 3 #!R\r
+ 10 MIN\r
+ DUP 1+ MAX-X 8 - SWAP S" " xySTR!\r
+ 0 ?DO\r
+ DUP @ MAX-X SWIDTH - I 1+ ROT SWIDTH #!R CELL+\r
+ LOOP 2DROP\r
+ BASE !\r
+ THEN\r
+ AGAIN\r
+; EXECUTE\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
--- /dev/null
+\\r
+\ TURTLE.F\r
+\ Turtle graphics package for hForth\r
+\\r
+\ English and Korean sources are provided (See [IF] ... [ELSE] ... [THEN]).\r
+\\r
+\ ETURTLE.EXE and HTURTLE.EXE is built from HF86EXE.EXE by loading Forth\r
+\ sources in the following order.\r
+\\r
+\ << OPTIONAL.F\r
+\ << ASM8086.F\r
+\ << COREEXT.F\r
+\ << MSDOS.F\r
+\ BL PARSE MULTI.F INCLUDED\r
+\ BL PARSE HIOMULT2.F INCLUDED\r
+\ BL PARSE TURTLE.F INCLUDED\r
+\ SAVE-SYSTEM-AS ETURTLE.EXE\r
+\ ( or SAVE-SYSTEM-AS HTURTLE.EXE )\r
+\\r
+\ 1996. 2. 21.\r
+\ Wonyong Koh\r
+\r
+BASE @\r
+GET-ORDER GET-CURRENT\r
+WORDLIST WORDLIST-NAME GRAPHIC-WORDLIST\r
+Ðe\8bi·³Â\89\9db-WORDLIST GRAPHIC-WORDLIST GET-ORDER 2 + SET-ORDER\r
+\r
+MARKER ~TURTLE\r
+\r
+DECIMAL\r
+CREATE sin16384\r
+ 0 , 286 , 572 , 857 , 1143 , 1428 , 1713 , 1997 , 2280 , 2563 ,\r
+ 2845 , 3126 , 3406 , 3686 , 3964 , 4240 , 4516 , 4790 , 5063 , 5334 ,\r
+ 5604 , 5872 , 6138 , 6402 , 6664 , 6924 , 7182 , 7438 , 7692 , 7943 ,\r
+ 8192 , 8438 , 8682 , 8923 , 9162 , 9397 , 9630 , 9860 , 10087 , 10311 ,\r
+ 10531 , 10749 , 10963 , 11174 , 11381 , 11585 , 11786 , 11982 , 12176 , 12365 ,\r
+ 12551 , 12733 , 12911 , 13085 , 13255 , 13421 , 13583 , 13741 , 13894 , 14044 ,\r
+ 14189 , 14330 , 14466 , 14598 , 14726 , 14849 , 14968 , 15082 , 15191 , 15296 ,\r
+ 15396 , 15491 , 15582 , 15668 , 15749 , 15826 , 15897 , 15964 , 16026 , 16083 ,\r
+ 16135 , 16182 , 16225 , 16262 , 16294 , 16322 , 16344 , 16362 , 16374 , 16382 ,\r
+ 16384 , 16382 , 16374 , 16362 , 16344 , 16322 , 16294 , 16262 , 16225 , 16182 ,\r
+ 16135 , 16083 , 16026 , 15964 , 15897 , 15826 , 15749 , 15668 , 15582 , 15491 ,\r
+ 15396 , 15296 , 15191 , 15082 , 14968 , 14849 , 14726 , 14598 , 14466 , 14330 ,\r
+ 14189 , 14044 , 13894 , 13741 , 13583 , 13421 , 13255 , 13085 , 12911 , 12733 ,\r
+ 12551 , 12365 , 12176 , 11982 , 11786 , 11585 , 11381 , 11174 , 10963 , 10749 ,\r
+ 10531 , 10311 , 10087 , 9860 , 9630 , 9397 , 9162 , 8923 , 8682 , 8438 ,\r
+ 8192 , 7943 , 7692 , 7438 , 7182 , 6924 , 6664 , 6402 , 6138 , 5872 ,\r
+ 5604 , 5334 , 5063 , 4790 , 4516 , 4240 , 3964 , 3686 , 3406 , 3126 ,\r
+ 2845 , 2563 , 2280 , 1997 , 1713 , 1428 , 1143 , 857 , 572 , 286 ,\r
+ 0 , -286 , -572 , -857 , -1143 , -1428 , -1713 , -1997 , -2280 , -2563 ,\r
+ -2845 , -3126 , -3406 , -3686 , -3964 , -4240 , -4516 , -4790 , -5063 , -5334 ,\r
+ -5604 , -5872 , -6138 , -6402 , -6664 , -6924 , -7182 , -7438 , -7692 , -7943 ,\r
+ -8192 , -8438 , -8682 , -8923 , -9162 , -9397 , -9630 , -9860 , -10087 , -10311 ,\r
+-10531 , -10749 , -10963 , -11174 , -11381 , -11585 , -11786 , -11982 , -12176 , -12365 ,\r
+-12551 , -12733 , -12911 , -13085 , -13255 , -13421 , -13583 , -13741 , -13894 , -14044 ,\r
+-14189 , -14330 , -14466 , -14598 , -14726 , -14849 , -14968 , -15082 , -15191 , -15296 ,\r
+-15396 , -15491 , -15582 , -15668 , -15749 , -15826 , -15897 , -15964 , -16026 , -16083 ,\r
+-16135 , -16182 , -16225 , -16262 , -16294 , -16322 , -16344 , -16362 , -16374 , -16382 ,\r
+-16384 , -16382 , -16374 , -16362 , -16344 , -16322 , -16294 , -16262 , -16225 , -16182 ,\r
+-16135 , -16083 , -16026 , -15964 , -15897 , -15826 , -15749 , -15668 , -15582 , -15491 ,\r
+-15396 , -15296 , -15191 , -15082 , -14968 , -14849 , -14726 , -14598 , -14466 , -14330 ,\r
+-14189 , -14044 , -13894 , -13741 , -13583 , -13421 , -13255 , -13085 , -12911 , -12733 ,\r
+-12551 , -12365 , -12176 , -11982 , -11786 , -11585 , -11381 , -11174 , -10963 , -10749 ,\r
+-10531 , -10311 , -10087 , -9860 , -9630 , -9397 , -9162 , -8923 , -8682 , -8438 ,\r
+ -8192 , -7943 , -7692 , -7438 , -7182 , -6924 , -6664 , -6402 , -6138 , -5872 ,\r
+ -5604 , -5334 , -5063 , -4790 , -4516 , -4240 , -3964 , -3686 , -3406 , -3126 ,\r
+ -2845 , -2563 , -2280 , -1997 , -1713 , -1428 , -1143 , -857 , -572 , -286 ,\r
+ -0 , 286 , 572 , 857 , 1143 , 1428 , 1713 , 1997 , 2280 , 2563 ,\r
+ 2845 , 3126 , 3406 , 3686 , 3964 , 4240 , 4516 , 4790 , 5063 , 5334 ,\r
+ 5604 , 5872 , 6138 , 6402 , 6664 , 6924 , 7182 , 7438 , 7692 , 7943 ,\r
+ 8192 , 8438 , 8682 , 8923 , 9162 , 9397 , 9630 , 9860 , 10087 , 10311 ,\r
+ 10531 , 10749 , 10963 , 11174 , 11381 , 11585 , 11786 , 11982 , 12176 , 12365 ,\r
+ 12551 , 12733 , 12911 , 13085 , 13255 , 13421 , 13583 , 13741 , 13894 , 14044 ,\r
+ 14189 , 14330 , 14466 , 14598 , 14726 , 14849 , 14968 , 15082 , 15191 , 15296 ,\r
+ 15396 , 15491 , 15582 , 15668 , 15749 , 15826 , 15897 , 15964 , 16026 , 16083 ,\r
+ 16135 , 16182 , 16225 , 16262 , 16294 , 16322 , 16344 , 16362 , 16374 , 16382 ,\r
+\r
+CODE sin* ( length theta -- length*sin[theta] )\r
+\ : sin* CELLS sin16384 + @ M* 16384 SM/REM NIP ;\r
+ BX 1 SHL,\r
+ sin16384 [BX] BX MOV,\r
+ AX POP,\r
+ BX IMUL,\r
+ BX BX XOR,\r
+ AX 1 SHL,\r
+ DX 1 RCL,\r
+ AX 1 SHL,\r
+ DX 1 RCL,\r
+ DX BX ADC,\r
+ NEXT,\r
+END-CODE\r
+\r
+CODE cos* ( length theta -- length*cos[theta] )\r
+\ : cos* 90 + CELLS sin16384 + @ M* 16384 SM/REM NIP ;\r
+ 90 # BX ADD,\r
+ BX 1 SHL,\r
+ sin16384 [BX] BX MOV,\r
+ AX POP,\r
+ BX IMUL,\r
+ BX BX XOR,\r
+ AX 1 SHL,\r
+ DX 1 RCL,\r
+ AX 1 SHL,\r
+ DX 1 RCL,\r
+ DX BX ADC,\r
+ NEXT,\r
+END-CODE\r
+\r
+HEX\r
+\ : PLOT ( x y -- )\r
+\ Y>SEG SWAP 8 /MOD SWAP >R \ seg_addr x/8 R: x_mod_8\r
+\ 2DUP LC@ R> CHARS XMASK + C@ OR ROT ROT LC! ;\r
+\r
+CODE PLOT ( x y -- )\r
+ BX 1 SHL,\r
+ Y>SegTable ) BX ADD,\r
+ 0 [BX] ES MOV,\r
+ BX POP,\r
+ BX CX MOV,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ ES: 0 [BX] AL MOV,\r
+ 1 # AH MOV,\r
+ CL NOT,\r
+ 7 # CL AND,\r
+ AH CL ROL,\r
+ AH AL OR,\r
+ ES: AL 0 [BX] MOV,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ : 2ROT\r
+\ >R >R 2SWAP R> R> 2SWAP ;\r
+\\r
+\ : LINE ( x1 y1 x2 y2--)\r
+\ 2OVER 2OVER ROT - ABS >R - ABS R> MAX 2 <\r
+\ IF 2DROP PLOT EXIT THEN\r
+\ 2OVER 2OVER ROT + 1+ 2/ >R + 1+ 2/ R>\r
+\ 2DUP 2ROT RECURSE RECURSE ;\r
+\r
+VARIABLE Delta\r
+VARIABLE Delta/2\r
+\r
+\ y changing faster than x\r
+CODE steep640 \ on entry, ax = delta x, bx = delta y, cx=x1, dx=y1\r
+ BX BP MOV, \ for counter\r
+ BX 1 SHR,\r
+ BX Delta/2 ) MOV, \ halfy\r
+ BX BX XOR, \ clear for cmp\r
+6 L:\r
+ BX PUSH,\r
+ CX PUSH, \ x\r
+ DX BX MOV,\r
+ BX 1 SHL,\r
+ Y>SegTable ) BX ADD,\r
+ 0 [BX] ES MOV,\r
+ CX BX MOV,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ ES: 0 [BX] AL MOV,\r
+ 1 # AH MOV,\r
+ CL NOT,\r
+ 7 # CL AND,\r
+ AH CL ROL,\r
+ AH AL OR,\r
+ ES: AL 0 [BX] MOV,\r
+ CX POP,\r
+ BX POP,\r
+ DX INC, \ y is always increasing\r
+ MAX-Y 16* # DX CMP,\r
+ 8 L# JL,\r
+ DX DX XOR,\r
+8 L:\r
+ Delta ) BX ADD, \ = bx + delta_y\r
+ Delta/2 ) BX CMP, \ bx > halfy ?\r
+ 7 L# JLE,\r
+ SI BX SUB, \ bx - delta_y\r
+ DI CX ADD, \ inc or dec x\r
+ MAX-X 8 * # CX SUB,\r
+ 7 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+ 7 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+7 L:\r
+ BP DEC,\r
+ 6 L# JGE,\r
+ BP POP,\r
+ SI POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ on exit, cx=x1, dx=y1, ax=x2, bx=y2\r
+CODE line640 ( x1 y1 x2 y2 -- ) \ writes to screen directly\r
+ AX POP,\r
+ DX POP,\r
+ CX POP,\r
+ SI PUSH, ( used to hold direction)\r
+ BP PUSH, ( used as counter)\r
+\ see if we'll inc or dec x, y (draws in any direction)\r
+ DX BX SUB, \ bx <- y2-y1 (delta y)\r
+ 2 L# JGE,\r
+ BX DX ADD, \ dx <- y2\r
+ BX NEG, \ abs(delta y)\r
+ CX AX XCHG,\r
+2 L:\r
+ BX SI MOV, \ delta_y(BX) to SI\r
+ CX AX SUB, \ x2 - x1 = delta_x\r
+ 1 # DI MOV, \ di to increment x\r
+ 4 L# JGE,\r
+ -1 # DI MOV, \ di to decrement x\r
+ AX NEG, \ abs(delta x)\r
+4 L:\r
+ \ adjust x1(CX), y1(DX) in proper range\r
+ AX PUSH,\r
+ DX PUSH,\r
+ CX AX MOV,\r
+ CWD,\r
+ MAX-X 8 * # BP MOV,\r
+ BP IDIV,\r
+ DX DX OR,\r
+ 1 L# JNS,\r
+ BP DX ADD,\r
+1 L:\r
+ DX CX MOV,\r
+ DX POP,\r
+ DX AX MOV,\r
+ CWD,\r
+ MAX-Y 16* # BP MOV,\r
+ BP IDIV,\r
+ DX DX OR,\r
+ 8 L# JNS,\r
+ BP DX ADD,\r
+8 L:\r
+ AX POP,\r
+ AX Delta ) MOV, \ abs(delta x)\r
+ BX AX CMP, \ delta_x - delta_y\r
+ 5 L# JGE,\r
+ ' steep640 # JMP, \ y changes faster than x\r
+5 L:\r
+\ x changing faster than y\r
+ AX BP MOV, \ for counter\r
+ AX 1 SHR,\r
+ AX Delta/2 ) MOV, \ halfx\r
+ BX BX XOR, \ clear for cmp\r
+6 L:\r
+ BX PUSH,\r
+ CX PUSH, \ x\r
+ DX BX MOV,\r
+ BX 1 SHL,\r
+ Y>SegTable ) BX ADD,\r
+ 0 [BX] ES MOV,\r
+ CX BX MOV,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ ES: 0 [BX] AL MOV,\r
+ 1 # AH MOV,\r
+ CL NOT,\r
+ 7 # CL AND,\r
+ AH CL ROL,\r
+ AH AL OR,\r
+ ES: AL 0 [BX] MOV,\r
+ CX POP,\r
+ BX POP,\r
+ DI CX ADD, \ inc or dec x\r
+ MAX-X 8 * # CX SUB,\r
+ 9 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+ 9 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+9 L:\r
+ SI BX ADD, \ = bx + delta_y\r
+ Delta/2 ) BX CMP, \ bx > halfx ?\r
+ 7 L# JLE,\r
+ Delta ) BX SUB, \ bx - delta_x\r
+ DX INC, \ y is always increasing\r
+ MAX-Y 16* # DX CMP,\r
+ 7 L# JL,\r
+ DX DX XOR,\r
+7 L:\r
+ BP DEC,\r
+ 6 L# JGE,\r
+ BP POP,\r
+ SI POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ y changing faster than x\r
+CODE xsteep640 \ on entry, ax = delta x, bx = delta y, cx=x1, dx=y1\r
+ BX BP MOV, \ for counter\r
+ BX 1 SHR,\r
+ BX Delta/2 ) MOV, \ halfy\r
+ BX BX XOR, \ clear for cmp\r
+6 L:\r
+ BX PUSH,\r
+ CX PUSH, \ x\r
+ DX BX MOV,\r
+ BX 1 SHL,\r
+ Y>SegTable ) BX ADD,\r
+ 0 [BX] ES MOV,\r
+ CX BX MOV,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ ES: 0 [BX] AL MOV,\r
+ 1 # AH MOV,\r
+ CL NOT,\r
+ 7 # CL AND,\r
+ AH CL ROL,\r
+ AH AL XOR,\r
+ ES: AL 0 [BX] MOV,\r
+ CX POP,\r
+ BX POP,\r
+ DX INC, \ y is always increasing\r
+ MAX-Y 16* # DX CMP,\r
+ 8 L# JL,\r
+ DX DX XOR,\r
+8 L:\r
+ Delta ) BX ADD, \ = bx + delta_y\r
+ Delta/2 ) BX CMP, \ bx > halfy ?\r
+ 7 L# JLE,\r
+ SI BX SUB, \ bx - delta_y\r
+ DI CX ADD, \ inc or dec x\r
+ MAX-X 8 * # CX SUB,\r
+ 7 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+ 7 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+7 L:\r
+ BP DEC,\r
+ 6 L# JGE,\r
+ BP POP,\r
+ SI POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ on exit, cx=x1, dx=y1, ax=x2, bx=y2\r
+CODE xline640 ( x1 y1 x2 y2 -- ) \ writes to screen directly\r
+ AX POP,\r
+ DX POP,\r
+ CX POP,\r
+ SI PUSH, ( used to hold direction)\r
+ BP PUSH, ( used as counter)\r
+\ see if we'll inc or dec x, y (draws in any direction)\r
+ DX BX SUB, \ bx <- y2-y1 (delta y)\r
+ 2 L# JGE,\r
+ BX DX ADD, \ dx <- y2\r
+ BX NEG, \ abs(delta y)\r
+ CX AX XCHG,\r
+2 L:\r
+ BX SI MOV, \ delta_y(BX) to SI\r
+ CX AX SUB, \ x2 - x1 = delta_x\r
+ 1 # DI MOV, \ di to increment x\r
+ 4 L# JGE,\r
+ -1 # DI MOV, \ di to decrement x\r
+ AX NEG, \ abs(delta x)\r
+4 L:\r
+ \ adjust x1(CX), y1(DX) in proper range\r
+ MAX-X 8 * # CX SUB,\r
+ 1 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+ 1 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+1 L:\r
+ MAX-Y 16* # DX SUB,\r
+ 8 L# JNS,\r
+ MAX-Y 16* # DX ADD,\r
+ 8 L# JNS,\r
+ MAX-Y 16* # DX ADD,\r
+8 L:\r
+ AX Delta ) MOV, \ abs(delta x)\r
+ BX AX CMP, \ delta_x - delta_y\r
+ 5 L# JGE,\r
+ ' xsteep640 # JMP, \ y changes faster than x\r
+5 L:\r
+\ x changing faster than y\r
+ AX BP MOV, \ for counter\r
+ AX 1 SHR,\r
+ AX Delta/2 ) MOV, \ halfx\r
+ BX BX XOR, \ clear for cmp\r
+6 L:\r
+ BX PUSH,\r
+ CX PUSH, \ x\r
+ DX BX MOV,\r
+ BX 1 SHL,\r
+ Y>SegTable ) BX ADD,\r
+ 0 [BX] ES MOV,\r
+ CX BX MOV,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ BX 1 SHR,\r
+ ES: 0 [BX] AL MOV,\r
+ 1 # AH MOV,\r
+ CL NOT,\r
+ 7 # CL AND,\r
+ AH CL ROL,\r
+ AH AL XOR,\r
+ ES: AL 0 [BX] MOV,\r
+ CX POP,\r
+ BX POP,\r
+ DI CX ADD, \ inc or dec x\r
+ MAX-X 8 * # CX SUB,\r
+ 9 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+ 9 L# JNS,\r
+ MAX-X 8 * # CX ADD,\r
+9 L:\r
+ SI BX ADD, \ = bx + delta_y\r
+ Delta/2 ) BX CMP, \ bx > halfx ?\r
+ 7 L# JLE,\r
+ Delta ) BX SUB, \ bx - delta_x\r
+ DX INC, \ y is always increasing\r
+ MAX-Y 16* # DX CMP,\r
+ 7 L# JL,\r
+ DX DX XOR,\r
+7 L:\r
+ BP DEC,\r
+ 6 L# JGE,\r
+ BP POP,\r
+ SI POP,\r
+ BX POP,\r
+ NEXT,\r
+END-CODE\r
+\r
+\ Get a 'Y' or 'N' key. Return TURE for 'Y', otherwise return FALSE.\r
+: Y/N? ( -- f )\r
+ TRUE \ leave TRUE flag\r
+ BEGIN KEY\r
+ DUP [CHAR] Y =\r
+ OVER [CHAR] y = OR 0=\r
+ WHILE\r
+ DUP [CHAR] N =\r
+ OVER [CHAR] n = OR 0=\r
+ WHILE DROP\r
+ REPEAT \ 'N' comes hear\r
+ DROP FALSE SWAP\r
+ THEN\r
+ \ 'Y' comes hear\r
+ DROP ;\r
+\r
+CR .( Will you use Turtle Graphics words in Korean? [Y/N] )\r
+Y/N? [IF]\r
+\r
+DECIMAL\r
+10 CONSTANT scale\r
+0 VALUE \90\81\9f¥¦\95?\r
+VARIABLE ¤wз\r
+MAX-X 8 * 2/ VALUE xOffset\r
+MAX-Y 16 * 2/ VALUE yOffset\r
+VARIABLE xCoord xOffset xCoord !\r
+VARIABLE yCoord yOffset yCoord !\r
+\r
+: ¦\95\97i´á ( -- ) FALSE TO \90\81\9f¥¦\95? ;\r
+: ¦\95\90\81\9da ( -- ) TRUE TO \90\81\9f¥¦\95? ;\r
+: º\89ÑÁ¡e ( y -- ) MAX-Y SWAP - TO YTop ;\r
+: µ¥ÑÁ¡e ( -- ) PAGE ;\r
+\r
+: \9d¡.\8ba´á ( x y -- )\r
+ scale / yOffset SWAP - \ x y1\r
+ SWAP scale / xOffset + SWAP \ x1 y1\r
+ \90\81\9f¥¦\95? IF 2DUP xCoord @ yCoord @ line640 THEN\r
+ yCoord ! xCoord ! ;\r
+\r
+: \88á¦\82¥¡µa ( -- )\r
+ xCoord @ 8 ¤wз @ 270 + sin* +\r
+ yCoord @ 8 ¤wз @ 270 + cos* -\r
+ 2DUP xCoord @ yCoord @ xline640 \ x1 y1\r
+ xCoord @ 16 ¤wз @ sin* +\r
+ yCoord @ 16 ¤wз @ cos* - \ x1 y1 x2 y2\r
+ 2SWAP 2OVER xline640 \ x2 y2\r
+ xCoord @ 8 ¤wз @ 90 + sin* +\r
+ yCoord @ 8 ¤wз @ 90 + cos* - \ x2 y2 x3 y3\r
+ 2SWAP 2OVER xline640 \ x3 y3\r
+ xCoord @ yCoord @ xline640 ;\r
+\r
+: ÑÁ¡e»¡¶¡ ( -- ) YTop PAGE 0 OVER AT-XY TO YTop \88á¦\82¥¡µa ;\r
+\r
+HEX\r
+: \88{·e i ( xt 'name2' -- )\r
+ DUP xt>name ?DUP 0= IF -12 THROW THEN\r
+ SWAP head, linkLast\r
+ C@ DUP\r
+ 040 AND IF IMMEDIATE THEN\r
+ 020 AND IF COMPILE-ONLY THEN ;\r
+\r
+DECIMAL\r
+' IMMEDIATE \88{·e i ¤a\9d¡\r
+' RECURSE \88{·e i \96A¦\89\9cá\r
+' IF \88{·e i ¡e\r
+' ELSE \88{·e i ´a\93¡¡e\r
+' THEN \88{·e i \9ca\r
+' BEGIN \88{·e i ·¡¹A¦\81Èá\r
+' UNTIL \88{·e i \8ca»¡\r
+' WHILE \88{·e i \95·´e\r
+' REPEAT \88{·e i \88á\97sÐ\81\r
+' DO \88{·e i \91\r
+' LOOP \88{·e i \95©´a\r
+' I \88{·e i \88a\r
+' CONSTANT \88{·e i \8a\88·e\88t\r
+' VARIABLE \88{·e i ¢\81\9fe\88t\r
+' DUP \88{·e i ¥A\8da\r
+' OVER \88{·e i \88å\90á\r
+' DROP \88{·e i ¤á\9da\r
+' SWAP \88{·e i ¤a\8e¡\r
+' ROT \88{·e i \95©\9da\r
+' >R \88{·e i >\96A\r
+' R> \88{·e i \96A>\r
+' R@ \88{·e i \96A@\r
+' AND \88{·e i \90{Ðq\8dA\r
+' OR \88{·e i \90{´a¶\89\9cá\r
+' XOR \88{·e i \90{\98a\9d¡\r
+' MOD \88{·e i \90a ỡ\r
+' CR \88{·e i \94a·qº\89\r
+' WORDS \88{·e i iÍa\r
+' .S \88{·e i .\94ᣡ\r
+\r
+' BYE \88{·e i \8f{\r
+\r
+¢\81\9fe\88t \88a\9d¡¶áá\r
+¢\81\9fe\88t A\9d¡¶áá\r
+\r
+: ¹A¸a\9f¡\9d¡ ( -- )\r
+ \88á¦\82¥¡µa\r
+ 0 ¤wз !\r
+ 0 \88a\9d¡¶áá !\r
+ 0 A\9d¡¶áá !\r
+ 0 0 \9d¡.\8ba´á\r
+ \88á¦\82¥¡µa ;\r
+\r
+: ÑÁ¡e»¡¶¡ ( -- )\r
+ ¦\95\97i´á ¹A¸a\9f¡\9d¡ ÑÁ¡e»¡¶¡ ¦\95\90\81\9da ;\r
+\r
+: ½¡\88\85ÑÁ¡e ( -- ) 8 º\89ÑÁ¡e ÑÁ¡e»¡¶¡ ;\r
+: µ¥ÑÁ¡e ( -- ) µ¥ÑÁ¡e ÑÁ¡e»¡¶¡ ;\r
+\r
+: \95¡.µ¡\9fe½¢ ( \88b\95¡ -- )\r
+ \88á¦\82¥¡µa\r
+ ¤wз @ +\r
+ ¥A\8da 0 < ¡e ( \88b\95¡\88a 0¥¡\94a ¸b·a¡e)\r
+ ·¡¹A¦\81Èá 360 + ( 0 ·¡¬w·¡ \96I \98\81\8ca»¡ 360·i \94áÐq)\r
+ ¥A\8da -1 > \8ca»¡\r
+ ´a\93¡¡e 360 \90a ỡ ( 0¥¡\94a Ça¡e 360·a\9d¡ \90a\92\85 \90a ỡ\9fi \90q\8b±)\r
+ \9ca\r
+ ¤wз !\r
+ \88á¦\82¥¡µa ;\r
+\r
+: \95¡.¶E½¢ -1 * \95¡.µ¡\9fe½¢ ;\r
+\r
+: eÇq.\88a ( dx dy -- )\r
+ \88á¦\82¥¡µa\r
+ A\9d¡¶áá @ + ( dx y+dy )\r
+ ¥A\8da A\9d¡¶áá ! ( dx y+dy )\r
+ ¤a\8e¡ \88a\9d¡¶áá @ + ( y+dy x+dx )\r
+ ¥A\8da \88a\9d¡¶áá ! ( y+dy x+dx )\r
+ ¤a\8e¡ ( x+dx y+dy )\r
+ \9d¡.\8ba´á\r
+ \88á¦\82¥¡µa ;\r
+\r
+: ´|·a\9d¡ ( l -- )\r
+ ¥A\8da ( l l )\r
+ ¤wз @ sin* ( l dx )\r
+ ¤a\8e¡ ( dx l )\r
+ ¤wз @ cos* ( dx dy )\r
+ eÇq.\88a ;\r
+\r
+: \96á\9d¡ ( \88á\9f¡ -- )\r
+ -1 * ´|·a\9d¡ ;\r
+\r
+: __µ¡\9fe½¢.ÑÉ\8d© ( \88á\9f¡ ÒU®\81 -- )\r
+ 0 \91 5 \95¡.µ¡\9fe½¢ ¥A\8da ´|·a\9d¡ 5 \95¡.µ¡\9fe½¢ \95©´a ¤á\9da ;\r
+\r
+: µ¡\9fe½¢.ÑÉ\8d© ( ¤e»¡\9fq \88b\95¡ -- )\r
+ ¤a\8e¡ 355 2034 */ ( \88b\95¡ \88á\9f¡ ) ( ÑÉ\8d©·i 10\95¡³¢ \90a\92\81´á \8ba\9f± )\r
+ ( 2*pi*r*\88b\95¡/360*10 = pi*r*\88b\95¡/18 )\r
+ ( pi = 355/113 = 3.141593 )\r
+ ¥A\8da >\96A ( \96A\95©·¡ \94ᣡµA \88á\9f¡\9fi \88i¢\81\9f¡)\r
+ \88å\90á 10 / ( \88b\95¡ \88á\9f¡ ÒU®\81 )\r
+ __µ¡\9fe½¢.ÑÉ\8d© ( \88b\95¡ )\r
+ 10 \90a ỡ ( \88b\95¡_\90a ỡ )\r
+ ¥A\8da \96A> ( \88b\95¡_\90a ỡ \88b\95¡_\90a ỡ \88á\9f¡ )\r
+ ( 10·a\9d¡ \90a\92\85 \90a ỡ \88b\95¡µA Ð\81\94wÐa\93e \88á\9f¡ eÇq ´|·a\9d¡ \88q)\r
+ * 10 / ´|·a\9d¡ ( \88b\95¡_\90a ỡ )\r
+ \95¡.µ¡\9fe½¢ ;\r
+\r
+: µ¡\9fe½¢.¶¥ ( ¤e»¡\9fq -- ) 360 µ¡\9fe½¢.ÑÉ\8d© ;\r
+\r
+: __¶E½¢.ÑÉ\8d© ( \88á\9f¡ ÒU®\81 -- )\r
+ 0 \91 5 \95¡.¶E½¢ ¥A\8da ´|·a\9d¡ 5 \95¡.¶E½¢ \95©´a ¤á\9da ;\r
+\r
+: ¶E½¢.ÑÉ\8d© ( ¤e»¡\9fq \88b\95¡ -- )\r
+ ¤a\8e¡ 355 2034 */ ( \88b\95¡ \88á\9f¡ ) ( ÑÉ\8d©·i 10\95¡³¢ \90a\92\81´á \8ba\9f± )\r
+ ( 2*pi*r*\88b\95¡/360*10 = pi*r*\88b\95¡/18 )\r
+ ¥A\8da >\96A ( \96A\95©·¡ \94ᣡµA \88á\9f¡\9fi \88i¢\81\9f¡)\r
+ \88å\90á 10 / ( \88b\95¡ \88á\9f¡ ÒU®\81 )\r
+ __¶E½¢.ÑÉ\8d© ( \88b\95¡ )\r
+ 10 \90a ỡ ( \88b\95¡_\90a ỡ )\r
+ ¥A\8da \96A> ( \88b\95¡_\90a ỡ \88b\95¡_\90a ỡ \88á\9f¡ )\r
+ ( 10·a\9d¡ \90a\92\85 \90a ỡ \88b\95¡µA Ð\81\94wÐa\93e \88á\9f¡ eÇq ´|·a\9d¡ \88q)\r
+ * 10 / ´|·a\9d¡ ( \88b\95¡_\90a ỡ )\r
+ \95¡.¶E½¢ ;\r
+\r
+: ¶E½¢.¶¥ ( ¤e»¡\9fq -- ) 360 ¶E½¢.ÑÉ\8d© ;\r
+\r
+: \91A¡¡ ( Ça\8b¡ -- )\r
+ 4 0 \91 ¥A\8da ´|·a\9d¡ 90 \95¡.µ¡\9fe½¢ \95©´a ¤á\9da ;\r
+\r
+: \89sÃ¥\91A¡¡ ( -- )\r
+ 100 \91A¡¡ 200 \91A¡¡ 300 \91A¡¡ 400 \91A¡¡ ;\r
+\r
+: \94a·¡´a¡¥\97a ( -- )\r
+ 45 \95¡.µ¡\9fe½¢\r
+ 4 0 \91 \89sÃ¥\91A¡¡ 90 \95¡.µ¡\9fe½¢ \95©´a ;\r
+\r
+: \8bµ¤i ( Ça\8b¡ -- )\r
+ ¥A\8da ´|·a\9d¡ ¥A\8da \91A¡¡ \96á\9d¡ ;\r
+\r
+: µa¬õ\8bµ¤i ( Ça\8b¡ -- )\r
+ 6 0 \91 ¥A\8da \8bµ¤i 60 \95¡.µ¡\9fe½¢ \95©´a ;\r
+\r
+: ¤a\9cq\88\81§¡ ( -- )\r
+ 100 µa¬õ\8bµ¤i 400 µa¬õ\8bµ¤i ;\r
+\r
+: \8d¹·¼ ( Ça\8b¡ -- )\r
+ ¥A\8da 90 µ¡\9fe½¢.ÑÉ\8d© 90 \95¡.µ¡\9fe½¢\r
+ 90 µ¡\9fe½¢.ÑÉ\8d© 90 \95¡.µ¡\9fe½¢ ;\r
+\r
+: \8d¹ ( Ça\8b¡ -- )\r
+ 8 0 \91 ¥A\8da \8d¹·¼ 45 \95¡.µ¡\9fe½¢ \95©´a ¤á\9da ;\r
+\r
+: \94a\9fe\8d¹·¼ ( Ça\8b¡ -- )\r
+ ¥A\8da 60 µ¡\9fe½¢.ÑÉ\8d© 120 \95¡.µ¡\9fe½¢\r
+ 60 µ¡\9fe½¢.ÑÉ\8d© 120 \95¡.µ¡\9fe½¢ ;\r
+\r
+: \94a\9fe\8d¹ ( Ça\8b¡ -- )\r
+ 6 0 \91 ¥A\8da \94a\9fe\8d¹·¼ 60 \95¡.µ¡\9fe½¢ \95©´a ¤á\9da ;\r
+\r
+: Ð\95¬i ( Ça\8b¡ -- )\r
+ ¥A\8da 90 ¶E½¢.ÑÉ\8d© ¥A\8da 90 µ¡\9fe½¢.ÑÉ\8d©\r
+ ¥A\8da 90 ¶E½¢.ÑÉ\8d© 90 µ¡\9fe½¢.ÑÉ\8d© ;\r
+\r
+: Ð\81 ( Ça\8b¡ -- )\r
+ 9 0 \91 ¥A\8da Ð\95¬i 160 \95¡.µ¡\9fe½¢ \95©´a ¤á\9da ;\r
+\r
+: \88bÑw ( Ça\8b¡ ¡¡¬á\9f¡®\81 -- )\r
+ 360 \88å\90á / ¤a\8e¡ ( Ça\8b¡ \95©_\88b\95¡ ¡¡¬á\9f¡®\81 )\r
+ 0 \91 \88å\90á ´|·a\9d¡ ¥A\8da \95¡.µ¡\9fe½¢ \95©´a\r
+ ¤á\9da ¤á\9da ;\r
+\r
+: ¥i ( ¥e·\81_®\81 ¡y¤å -- )\r
+ \88å\90á \88å\90á *\r
+ 0 \91 600 ´|·a\9d¡ \88å\90á \88å\90á 360 * ¤a\8e¡ / \95¡.µ¡\9fe½¢ \95©´a\r
+ ¤á\9da ¤á\9da ;\r
+\r
+: \94a\88bÑw ( Ça\8b¡ \88b\95¡ -- )\r
+ ¤wз @ >\96A ( \96A\95©·¡\94ᣡµA Àá·q ¤wз·i \88i¢\81\9f¡)\r
+ ·¡¹A¦\81Èá\r
+ \88å\90á ´|·a\9d¡ ¥A\8da \95¡.µ¡\9fe½¢\r
+ ¤wз @ \96A@ = \8ca»¡ ( ¤wз·¡ Àá·q¤wз\89Á \88{´a»© \98\81\8ca»¡ \96AÎ\89·¡)\r
+ ¤á\9da ¤á\9da \96A> ¤á\9da ; ( \88t\94ᣡµÁ \96A\95©·¡ \94ᣡ\9fi À÷¡ )\r
+\r
+: \94a\88bÑw¸a\9cw5 5 0 \91 450 72 \94a\88bÑw 72 \95¡.µ¡\9fe½¢ \95©´a ;\r
+: \94a\88bÑw¸a\9cw4 4 0 \91 700 135 \94a\88bÑw 90 \95¡.µ¡\9fe½¢ \95©´a ;\r
+: \94a\88bÑw¸a\9cw12 12 0 \91 15 \95¡.µ¡\9fe½¢ ¦\95\97i´á 400 ´|·a\9d¡ ¦\95\90\81\9da\r
+ 200 135 \94a\88bÑw 15 \95¡.µ¡\9fe½¢ \95©´a ;\r
+\r
+: \90a¢\81 ( \88a»¡\88b\95¡ \88a»¡\8b©·¡ \88a»¡Ã¡\8b¡®\81 -- )\r
+ >\96A ( \88a»¡Ã¡\8b¡®\81\9fi \96A\95©·¡\94ᣡµA \88i¢\81\9f¡)\r
+ \96A@ ¡e ( '\96A@ 0 <> ¡e' \89Á \88{·q)\r
+ \88å\90á \95¡.¶E½¢\r
+ ¥A\8da 2 * ´|·a\9d¡\r
+ \88å\90á \88å\90á \96A@ 1 - \96A¦\89\9cá\r
+ ¥A\8da 2 * \96á\9d¡\r
+ \88å\90á 2 * \95¡.µ¡\9fe½¢\r
+ ¥A\8da ´|·a\9d¡\r
+ \88å\90á \88å\90á \96A@ 1 - \96A¦\89\9cá\r
+ \96á\9d¡ \95¡.¶E½¢\r
+ ´a\93¡¡e ¤á\9da ¤á\9da \9ca\r
+ \96A> ¤á\9da ;\r
+\r
+¢\81\9fe\88t §¡\93iÇa\8b¡ 20 §¡\93iÇa\8b¡ !\r
+: ¶w ( \90a·¡ -- )\r
+ ¥A\8da 0 = ¡e §¡\93iÇa\8b¡ @ ´|·a\9d¡\r
+ ´a\93¡¡e ¥A\8da 0 > ¡e ¥A\8da 1 - \96A¦\89\9cá ( \90a·¡-1 ¶w )\r
+ 90 \95¡.µ¡\9fe½¢\r
+ 1 \88å\90á - \96A¦\89\9cá ( 1-\90a·¡ ¶w )\r
+ ´a\93¡¡e -1 \88å\90á - \96A¦\89\9cá ( -1-\90a·¡ ¶w )\r
+ 90 \95¡.¶E½¢\r
+ 1 \88å\90á + \96A¦\89\9cá ( 1+\90a·¡ ¶w )\r
+ \9ca \9ca\r
+ ¤á\9da ;\r
+\r
+: ·¥¬a i\r
+ ½¡\88\85ÑÁ¡e\r
+ ." '\93iÎ\91'·a\9d¡ ¼e \88á¦\82\8ba\9f± Ïa\9d¡\8ba\9c\91·i ¯¡¸bÐs\93¡\94a." \94a·qº\89 \94a·qº\89\r
+ ." ¯¡Ç± i\97i·i ¥¡\9da¡e ' iÍa' \9ca\89¡ ᯡ\89¡" \94a·qº\89\r
+ ." ¯¡Ç± i·i ´á\98ý\89A ³a\93e»¡ ¥¡\9da¡e '\95¡¶\91 i \95¡¶\91 i' Àá\9cñ ᯡ\89¡" \94a·qº\89\r
+ ." DOS\9d¡ \95©´a \88a\9da¡e '\8f{' ·¡\9ca\89¡ ᯳¯¡µ¡." \94a·qº\89\r
+ ." \8ba\9f±\89Á \8bi¸a\9fi \88{·¡ ¥¡\9da¡e 'µ¥ÑÁ¡e' \98a\9d¡ ¥¡\9da¡e '½¡\88\85ÑÁ¡e'·¡\9ca\89¡ ᯳¯¡µ¡"\r
+ \94a·qº\89\r
+ ¦\95\90\81\9da\r
+ 300 \8d¹ 450 \8d¹ 600 \8d¹\r
+ ¦\95\97i´á 90 \95¡.¶E½¢ 2000 ´|·a\9d¡ ¦\95\90\81\9da\r
+ 900 \94a\9fe\8d¹ 700 \94a\9fe\8d¹ 500 \94a\9fe\8d¹\r
+ ¦\95\97i´á 4000 \96á\9d¡ 90 \95¡.µ¡\9fe½¢ ¦\95\90\81\9da\r
+ 300 Ð\r
+ 1 \8bi®A·³\9db¬wÈ\81 ! ; \ Ðe\8bi·³\9db\r
+\r
+·¥¬a i\r
+\r
+: TURTLE-hi\r
+ DOSCommand>PAD\r
+ GET-MODE TO OldMode# HGRAPHIC hi\r
+ ." ·\81\89e\89Á ¹A´e\89Á §¡Íw·i Ða·¡ÉI wykoh\9d¡ ¥¡\90\81 º\81¯³¯¡µ¡." CR\r
+ S" BLOCKS.BLK" MAPPED-TO-BLOCK\r
+ ·¥¬a i QUIT ;\r
+\r
+' TURTLE-hi TO 'boot\r
+\r
+( \94a·q·i Àa\9d\81\9d¡ ¯¡Åa¥¡¯³¯¡µ¡. )\r
+( \94a·¡´a¡¥\97a )\r
+( 400 \8bµ¤i 400 µa¬õ\8bµ¤i ¤a\9cq\88\81§¡ )\r
+( 400 3 \88bÑw 400 5 \88bÑw 400 7 \88bÑw )\r
+( 5 2 ¥i 7 2 ¥i 7 3 ¥i 8 3 ¥i 9 2 ¥i 9 4 ¥i 10 3 ¥i 11 3 ¥i 11 5 ¥i )\r
+( \94a\88bÑw¸a\9cw5 )\r
+( \94a\88bÑw¸a\9cw5 )\r
+( \94a\88bÑw¸a\9cw12 )\r
+( 30 400 4 \90a¢\81 )\r
+( 20 250 5 \90a¢\81 )\r
+( 20 250 6 \90a¢\81 )\r
+( 50 §¡\93iÇa\8b¡ ! 9 ¶w )\r
+( 20 §¡\93iÇa\8b¡ ! 12 ¶w )\r
+\r
+[ELSE]\r
+\r
+DECIMAL\r
+10 CONSTANT scale\r
+0 VALUE PenDown?\r
+VARIABLE Heading\r
+MAX-X 8 * 2/ VALUE xOffset\r
+MAX-Y 16 * 2/ VALUE yOffset\r
+VARIABLE xCoord xOffset xCoord !\r
+VARIABLE yCoord yOffset yCoord !\r
+\r
+: PENUP ( -- ) FALSE TO PenDown? ;\r
+: PENDOWN ( -- ) TRUE TO PenDown? ;\r
+: LINES-SCREEN ( y -- ) MAX-Y SWAP - TO YTop ;\r
+: FULL-SCREEN ( -- ) PAGE ;\r
+\r
+: TODRAW ( x y -- )\r
+ scale / yOffset SWAP - \ x y1\r
+ SWAP scale / xOffset + SWAP \ x1 y1\r
+ PenDown? IF 2DUP xCoord @ yCoord @ line640 THEN\r
+ yCoord ! xCoord ! ;\r
+\r
+: SHOW-TURTLE ( -- )\r
+ xCoord @ 8 Heading @ 270 + sin* +\r
+ yCoord @ 8 Heading @ 270 + cos* -\r
+ 2DUP xCoord @ yCoord @ xline640 \ x1 y1\r
+ xCoord @ 16 Heading @ sin* +\r
+ yCoord @ 16 Heading @ cos* - \ x1 y1 x2 y2\r
+ 2SWAP 2OVER xline640 \ x2 y2\r
+ xCoord @ 8 Heading @ 90 + sin* +\r
+ yCoord @ 8 Heading @ 90 + cos* - \ x2 y2 x3 y3\r
+ 2SWAP 2OVER xline640 \ x3 y3\r
+ xCoord @ yCoord @ xline640 ;\r
+\r
+: CLEAR-SCREEN ( -- ) YTop PAGE 0 OVER AT-XY TO YTop SHOW-TURTLE ;\r
+\r
+DECIMAL\r
+\r
+VARIABLE X-POSITION\r
+VARIABLE Y-POSITION\r
+\r
+: HOME ( -- )\r
+ SHOW-TURTLE\r
+ 0 Heading !\r
+ 0 X-POSITION !\r
+ 0 Y-POSITION !\r
+ 0 0 TODRAW\r
+ SHOW-TURTLE ;\r
+\r
+: CLEAR-SCREEN ( -- )\r
+ PENUP HOME CLEAR-SCREEN PENDOWN ;\r
+\r
+: SPLIT-SCREEN ( -- ) 8 LINES-SCREEN CLEAR-SCREEN ;\r
+: FULL-SCREEN ( -- ) FULL-SCREEN CLEAR-SCREEN ;\r
+\r
+: RIGHT ( angle -- )\r
+ SHOW-TURTLE\r
+ Heading @ +\r
+ DUP 0 < IF\r
+ BEGIN 360 +\r
+ DUP -1 > UNTIL\r
+ ELSE 360 MOD\r
+ THEN\r
+ Heading !\r
+ SHOW-TURTLE ;\r
+\r
+: LEFT -1 * RIGHT ;\r
+\r
+: DELTA-MOVE ( dx dy -- )\r
+ SHOW-TURTLE\r
+ Y-POSITION @ + ( dx y+dy )\r
+ DUP Y-POSITION ! ( dx y+dy )\r
+ SWAP X-POSITION @ + ( y+dy x+dx )\r
+ DUP X-POSITION ! ( y+dy x+dx )\r
+ SWAP ( x+dx y+dy )\r
+ TODRAW\r
+ SHOW-TURTLE ;\r
+\r
+: FORWARD ( length -- )\r
+ DUP ( l l )\r
+ Heading @ sin* ( l dx )\r
+ SWAP ( dx l )\r
+ Heading @ cos* ( dx dy )\r
+ DELTA-MOVE ;\r
+\r
+: BACK ( length -- )\r
+ -1 * FORWARD ;\r
+\r
+: ARCR1 ( step times -- )\r
+ 0 DO 5 RIGHT DUP FORWARD 5 RIGHT LOOP DROP ;\r
+\r
+: ARCR ( radius degrees -- )\r
+ SWAP 355 2034 */\r
+ DUP >R\r
+ OVER 10 /\r
+ ARCR1\r
+ 10 MOD\r
+ DUP R>\r
+ * 10 / FORWARD\r
+ RIGHT ;\r
+\r
+: CIRCLER ( radius -- ) 360 ARCR ;\r
+\r
+: ARCL1 ( step times -- )\r
+ 0 DO 5 LEFT DUP FORWARD 5 LEFT LOOP DROP ;\r
+\r
+: ARCL ( radius degrees -- )\r
+ SWAP 355 2034 */\r
+ DUP >R\r
+ OVER 10 /\r
+ ARCL1\r
+ 10 MOD\r
+ DUP R>\r
+ * 10 / FORWARD\r
+ LEFT ;\r
+\r
+: CIRCLEL ( radius -- ) 360 ARCL ;\r
+\r
+: SQUARE ( size -- )\r
+ 4 0 DO DUP FORWARD 90 RIGHT LOOP DROP ;\r
+\r
+: BOXES ( -- )\r
+ 100 SQUARE 200 SQUARE 300 SQUARE 400 SQUARE ;\r
+\r
+: DIAMONDS ( -- )\r
+ 45 RIGHT\r
+ 4 0 DO BOXES 90 RIGHT LOOP ;\r
+\r
+: FLAG ( size -- )\r
+ DUP FORWARD DUP SQUARE BACK ;\r
+\r
+: 6FLAG ( size -- )\r
+ 6 0 DO DUP FLAG 60 RIGHT LOOP ;\r
+\r
+: SPINFLAG ( -- )\r
+ 100 6FLAG 400 6FLAG ;\r
+\r
+: PETAL1 ( size -- )\r
+ DUP 90 ARCR 90 RIGHT\r
+ 90 ARCR 90 RIGHT ;\r
+\r
+: FLOWER1 ( size -- )\r
+ 8 0 DO DUP PETAL1 45 RIGHT LOOP DROP ;\r
+\r
+: PETAL2 ( size -- )\r
+ DUP 60 ARCR 120 RIGHT\r
+ 60 ARCR 120 RIGHT ;\r
+\r
+: FLOWER2 ( size -- )\r
+ 6 0 DO DUP PETAL2 60 RIGHT LOOP DROP ;\r
+\r
+: RAY ( size -- )\r
+ DUP 90 ARCL DUP 90 ARCR\r
+ DUP 90 ARCL 90 ARCR ;\r
+\r
+: SUN ( size -- )\r
+ 9 0 DO DUP RAY 160 RIGHT LOOP DROP ;\r
+\r
+: REGULAR ( size vertices -- )\r
+ 360 OVER / SWAP\r
+ 0 DO OVER FORWARD DUP RIGHT LOOP\r
+ DROP DROP ;\r
+\r
+: STARS ( vertices times -- )\r
+ OVER OVER *\r
+ 0 DO 600 FORWARD OVER OVER 360 * SWAP / RIGHT LOOP\r
+ DROP DROP ;\r
+\r
+: POLY ( size angle -- )\r
+ Heading @ >R\r
+ BEGIN\r
+ OVER FORWARD DUP RIGHT\r
+ Heading @ R@ = UNTIL\r
+ DROP DROP R> DROP ;\r
+\r
+: POLYDEMO5 5 0 DO 450 72 POLY 72 RIGHT LOOP ;\r
+: POLYDEMO4 4 0 DO 700 135 POLY 90 RIGHT LOOP ;\r
+: POLYDEMO12 12 0 DO 15 RIGHT PENUP 400 FORWARD PENDOWN\r
+ 200 135 POLY 15 RIGHT LOOP ;\r
+\r
+: TREE ( angle length recursion -- )\r
+ >R\r
+ R@ IF\r
+ OVER LEFT\r
+ DUP 2 * FORWARD\r
+ OVER OVER R@ 1 - RECURSE\r
+ DUP 2 * BACK\r
+ OVER 2 * RIGHT\r
+ DUP FORWARD\r
+ OVER OVER R@ 1 - RECURSE\r
+ BACK LEFT\r
+ ELSE DROP DROP THEN\r
+ R> DROP ;\r
+\r
+VARIABLE DRAGON-SIZE 20 DRAGON-SIZE !\r
+: DRAGON ( n -- )\r
+ DUP 0 = IF DRAGON-SIZE @ FORWARD\r
+ ELSE DUP 0 > IF DUP 1 - RECURSE\r
+ 90 RIGHT\r
+ 1 OVER - RECURSE\r
+ ELSE -1 OVER - RECURSE\r
+ 90 LEFT\r
+ 1 OVER + RECURSE\r
+ THEN THEN\r
+ DROP ;\r
+\r
+: HELLO\r
+ SPLIT-SCREEN\r
+ ." Starting Turtle Graphics implemented in hForth." CR CR\r
+ ." Type 'FULL-SCREEN' for full screen text display." CR\r
+ ." Type 'SPLIT-SCREEN' for text display in split screen." CR\r
+ CR\r
+ PENDOWN\r
+ 300 FLOWER1 450 FLOWER1 600 FLOWER1\r
+ PENUP 90 LEFT 2000 FORWARD PENDOWN\r
+ 900 FLOWER2 700 FLOWER2 500 FLOWER2\r
+ PENUP 4000 BACK 90 RIGHT PENDOWN\r
+ 300 SUN ;\r
+\r
+HELLO\r
+\r
+: TURTLE-hi\r
+ DOSCommand>PAD\r
+ GET-MODE TO OldMode# HGRAPHIC hi\r
+ S" BLOCKS.BLK" MAPPED-TO-BLOCK\r
+ HELLO QUIT ;\r
+\r
+' TURTLE-hi TO 'boot\r
+\r
+( Try the followings: )\r
+( DIAMONDS )\r
+( 400 FLAG 400 6FLAG SPINFLAG )\r
+( 400 3 REGULAR 400 5 REGULAR 400 7 REGULAR )\r
+( 5 2 STARS 7 2 STARS 7 3 STARS 8 3 STARS 9 2 STARS 9 4 STARS 10 3 STARS 11 3 STARS 11 5 STARS )\r
+( POLYDEMO5 )\r
+( POLYDEMO5 )\r
+( POLYDEMO12 )\r
+( 30 400 4 TREE )\r
+( 20 250 5 TREE )\r
+( 20 250 6 TREE )\r
+( 50 DRAGON-SIZE ! 9 DRAGON )\r
+( 20 DRAGON-SIZE ! 12 DRAGON )\r
+\r
+[THEN]\r
+\r
+SET-CURRENT SET-ORDER\r
+BASE !\r
--- /dev/null
+ASM sources are greatly polished. More explanations are added as\r
+comments. Split environmental variable 'systemID' into 'CPU' and\r
+'Model'. Most hForth source files can be used with other CPUs\r
+without modification by using conditional compilation (see\r
+COREEXT.F and DOUBLE.F for example). Thanks Neal Crook for comments\r
+and many valuable suggestions. Now all ASM sources can be assembled\r
+by TASM 1.0 and MASM 6.11. Many typographical errors are corrected.\r
+\r
+Control structure words are all revised. Control-flow stack is\r
+implemented on data stack. Control-flow stack item is represented by\r
+two data stack items as below:\r
+\r
+Control-flow stack item Representation (parameter and type)\r
+----------------------- -------------------------------------\r
+ dest control-flow destination 0\r
+ orig control-flow origin 1\r
+ of-sys OF origin 2\r
+ case-sys x (any value) 3\r
+ do-sys ?DO origin DO destination\r
+ colon-sys xt of current definition -1\r
+\r
+hForth can detect a nonsense clause such as "BEGIN IF AGAIN THEN"\r
+easily. CS-ROLL and CS-PICK can be applied to the list of dests and\r
+origs only. This can be verified by checking whether the ORed type\r
+is 1. I can not think of a control-structure-mismatch that current\r
+hForth cannot catch.\r
+\r
+Some bugs are fixed including RESTORE-INPUT.\r
+\r
+\r
+Changes from 0.9.7\r
+\r
+1997. 5. 26.\r
+ MSDOS.F: Fix RESTORE-INPUT to restore BLK correctly.\r
+1997. 2. 28.\r
+ Facelift to be used with other CPUs.\r
+1997. 2. 19.\r
+ Split environmental variable systemID into CPU and Model.\r
+1997. 2. 6.\r
+ Add Neal Crook's microdebugger and comments on assembly definitions.\r
+1997. 1. 25.\r
+ Add $THROWMSG macro and revise accordingly.\r
+1997. 1. 18.\r
+ Remove 'NullString' from assembly source.\r
+1996. 12. 18.\r
+ Revise 'head,'.\r
+1996. 12. 14.\r
+ DOSEXEC.F: Revise (DOSEXEC) in MSDOS.F.\r
+1996. 12. 6.\r
+ OPTIONAL.F: Fix 'compiles>' for colon-sys.\r
+1996. 11. 29.\r
+ OPTIONAL.F: Remove PICK which was added in assembly source.\r
+ OPTIONAL.F: Revise CASE, ENDCASE, OF, ENDOF, RETRY for\r
+ control-flow stack.\r
+ OPTIONAL.F: Revise '.xt' due to the removal of 'do."' and change\r
+ of 'doS"'.\r
+1996. 12. 3.\r
+ Revise PICK to catch stack underflow.\r
+1996. 11. 29.\r
+ Implement control-flow stack on data stack. Control-flow stack\r
+ item consists of two data stack items, one for value\r
+ and one for the type of control-flow stack item.\r
+ control-flow stack item data stack representation\r
+ dest control-flow_destination 0\r
+ orig control-flow_origin 1\r
+ of-sys OF_origin 2\r
+ case-sys x (any value) 3\r
+ do-sys ?DO_origin DO_destination\r
+ colon-sys xt_of_current_definition -1\r
+ Add PICK.\r
+ 'bal' is now the depth of control-flow stack.\r
+ Drop 'lastXT'.\r
+ Introduce 'notNONAME?'\r
+ Add 'bal+' and 'bal-'. Drop 'orig+', 'orig-', 'dest+', 'dest-',\r
+ 'dosys+', and 'dosys-'.\r
+ Revise ':NONAME', ':', ';', 'linkLast', 'head,', RECURSE, 'DOES>',\r
+ CONSTANT, CREATE, VALUE, VARIABLE, and QUIT.\r
+ This change makes RECURSE work properly in ':NONAME ... ;'\r
+ and '... DOES> ... ;'.\r
+ Revise 'rake', AGAIN, AHEAD, IF, THEN, +LOOP, BEGIN, DO, ELSE, LOOP,\r
+ UNTIL, and WHILE.\r
+ Revise SLITERAL, '."', 'doS"' to allow a string larger than\r
+ max char size.\r
+ Revise $INSTR and remove 'do."'.\r
+ Revise 'pack"'.\r
+ ASM8086.F: Revise ';CODE' for control-flow stack.\r
+ COREEXT.F: Provide CODE definition of ROLL.\r
+ COREEXT.F: Revise '?DO' for control-flow stack.\r
+ COREEXT.F: Revise 'C"' to catch exception -24 'parsed string overflow'.\r
+1996. 8. 17.\r
+ HF86EXE.ASM: Revise MAX-UD.\r
+1996. 8. 10.\r
+ HF86EXE.ASM: Replace 'COMPILE,' with 'code,' in the definition of\r
+ 'compileCREATE'.\r
+1996. 7. 19.\r
+ DOUBLE.F: Fix 'M+'. Thanks M. Edward Borasky.\r
+1996. 6. 19.\r
+ Fix '/STRING'.\r
+1996. 4. 15.\r
+ ASM8086.F: ';CODE' is fixed. END-CODE is changed.\r
+1996. 3. 1.\r
+ MSDOS.F: Shift value of 'ior' of FILE words to system THROW code area,\r
+ i.e. -4096..-256 .\r
+ MSDOS.F: Remove subtle bug in 'SAVE-SYSTEM-AS'.\r
+\r
+Changes from 0.9.6\r
+\r
+1996. 2. 10.\r
+ Revise FM/MOD and SM/REM to catch result-out-of-range error in\r
+ '80000. 2 FM/MOD'.\r
+1996. 1. 19.\r
+ Rename 'x,' to 'code,'; 'x@' to 'code@'; 'x!' to 'code!';\r
+ 'xb@' to 'codeB@' and 'xb!' to 'codeB!'.\r
+1996. 1. 7\r
+ Rename non-Standard 'parse-word' to PARSE-WORD.\r
+1995. 12. 2\r
+ Drop '?doLIST' and revise 'optiCOMPILE,'.\r
+1995. 11. 28\r
+ Drop 'LIT,:' all together.\r
+ Return CELLS to non-IMMEDIATE definition.\r
+\r
+Changes from 0.9.5\r
+\r
+1995. 11. 27.\r
+ In ASM8086.F\r
+ ';CODE' is redefined following the change of 'DOES>' and 'doCREATE'.\r
+1995. 11. 25.\r
+ Add RETRY described by Dr. Astle in Forth Dimensions 17(4), 19-21 (1995).\r
+1995. 11. 25.\r
+ Make 'lastXT' VALUE word.\r
+1995. 11. 24.\r
+ For RAM model only\r
+ Replace 'xhere' with HERE.\r
+ Revise doVALUE, VALUE, TO, and all $VALUE macros.\r
+1995. 11. 23.\r
+ Revise doCREATE, CREATE, pipe, DOES>, and >BODY.\r
+ 'pipe' is no longer processor-dependent.\r
+1995. 11. 17.\r
+ Move ERASE to ASM8086.F.\r
--- /dev/null
+´áQ§i\9f¡ ¡¯a\9fi Ça\89A \94a\97q´ö¯s\93¡\94a. \94õ¦\9b·± i\9d¡ ¬é¡w·i \94áÐ\96¯s\93¡\94a.\r
+ÑÅ\89w ¥e®\81 'systemID'\9fi 'CPU'µÁ 'Model'\9d¡ \90a\92\81´ö¯s\93¡\94a. ÑÅ\89w ¥e®\81\9fi\r
+¬a¶wÐe ¹¡\88å¦\81 ¤åµb ¤w¤ó·i °á¬á \94\81¦\81¦\85·\81 hForth ¤aÈw¥¥·i \89¡Ã¡»¡ ´g\89¡\r
+\94a\9fe CPU¶w hForthµA¬á ³i ®\81 ·¶¯s\93¡\94a (COREEXT.FµÁ DOUBLE.F\9fi\r
+¥¡¯³¯¡µ¡). Turbo assemblerª\85 ´a\93¡\9ca a·¡Ça\9d¡¡ÏaËa¬a·\81 MASM 6.11µA¬á\95¡\r
+µA\9cá´ô·¡ ´áQ§i·¡ \96A\95¡\9d¢ ´áQ§i\9f¡ ¤aÈw¥¥·i \89¡Áv¯s\93¡\94a.\r
+\r
+¹A´á \8a\81¹¡ \90{ i·i ¡¡\96\81 \89¡Áv¯s\93¡\94a. ¹A´á Óa\9fq \94ᣡ(control-flow stack)\9fi\r
+·¡¹A ¸a\9ea \94ᣡµA¬á ´a\9c\81Àá\9cñ ¸a\9ea \94ᣡµA¬á \88b\88b \96\81 \88\81·\81 \88t·a\9d¡\r
+ÎaÑeÐs\93¡\94a.\r
+\r
+Control-flow stack item Representation (parameter and type)\r
+----------------------- -------------------------------------\r
+ dest control-flow destination 0\r
+ orig control-flow origin 1\r
+ of-sys OF origin 2\r
+ case-sys x (any value) 3\r
+ do-sys ?DO origin DO destination\r
+ colon-sys xt of current definition -1\r
+\r
+·¡¹A "BEGIN IF AGAIN THEN" \88{·e ¸i¡µ\95¡ ®ó\89A ¸s·i ®\81 ·¶¯s\93¡\94a. \8ba\9f¡\89¡\r
+¸a\9ea Óa\9fq \94ᣡ·\81 \88t·i ¹·\9fA\9fi \91¥\9f¡Ðs(OR) µe¬eÐe \89i\89Á\88a 1·¥»¡\9fi Ñ·¥Ð\81¬á\r
+destµÁ origµA \94\81Ð\81¬á e ¸â¶wÐi ®\81 ·¶\93e CS-ROLL\89Á CS-PICK\9fi ¦\81\9fi ®\81\r
+·¶\93e»¡ ´ô\93e»¡\9fi Ñ·¥Ði ®\81 ·¶¯s\93¡\94a. ·¡¹A hForth\88a ¸s»¡ ¡µÐa\93e ¹A´á\r
+\8a\81¹¡·\81 ¸i¡µ·e ´ô·a\9f¡\9ca\89¡ ¬\97\88bÐs\93¡\94a.\r
+\r
+RESTORE-INPUT·i §¡\9dµÐe ¡y \88a»¡ ¤é\9dA\9fi ¸s´v¯s\93¡\94a.\r
+\r
+\r
+Changes from 0.9.7\r
+\r
+1997. 5. 26.\r
+ MSDOS.F: Fix RESTORE-INPUT to restore BLK correctly.\r
+1997. 2. 28.\r
+ Facelift to be used with other CPUs.\r
+1997. 2. 19.\r
+ Split environmental variable systemID into CPU and Model.\r
+1997. 2. 6.\r
+ Add Neal Crook's microdebugger and comments on assembly definitions.\r
+1997. 1. 25.\r
+ Add $THROWMSG macro and revise accordingly.\r
+1997. 1. 18.\r
+ Remove 'NullString' from assembly source.\r
+1996. 12. 18.\r
+ Revise 'head,'.\r
+1996. 12. 14.\r
+ DOSEXEC.F: Revise (DOSEXEC) in MSDOS.F.\r
+1996. 12. 6.\r
+ OPTIONAL.F: Fix 'compiles>' for colon-sys.\r
+1996. 11. 29.\r
+ OPTIONAL.F: Remove PICK which was added in assembly source.\r
+ OPTIONAL.F: Revise CASE, ENDCASE, OF, ENDOF, RETRY for\r
+ control-flow stack.\r
+ OPTIONAL.F: Revise '.xt' due to the removal of 'do."' and change\r
+ of 'doS"'.\r
+1996. 12. 3.\r
+ Revise PICK to catch stack underflow.\r
+1996. 11. 29.\r
+ Implement control-flow stack on data stack. Control-flow stack\r
+ item consists of two data stack items, one for value\r
+ and one for the type of control-flow stack item.\r
+ control-flow stack item data stack representation\r
+ dest control-flow_destination 0\r
+ orig control-flow_origin 1\r
+ of-sys OF_origin 2\r
+ case-sys x (any value) 3\r
+ do-sys ?DO_origin DO_destination\r
+ colon-sys xt_of_current_definition -1\r
+ Add PICK.\r
+ 'bal' is now the depth of control-flow stack.\r
+ Drop 'lastXT'.\r
+ Introduce 'notNONAME?'\r
+ Add 'bal+' and 'bal-'. Drop 'orig+', 'orig-', 'dest+', 'dest-',\r
+ 'dosys+', and 'dosys-'.\r
+ Revise ':NONAME', ':', ';', 'linkLast', 'head,', RECURSE, 'DOES>',\r
+ CONSTANT, CREATE, VALUE, VARIABLE, and QUIT.\r
+ This change makes RECURSE work properly in ':NONAME ... ;'\r
+ and '... DOES> ... ;'.\r
+ Revise 'rake', AGAIN, AHEAD, IF, THEN, +LOOP, BEGIN, DO, ELSE, LOOP,\r
+ UNTIL, and WHILE.\r
+ Revise SLITERAL, '."', 'doS"' to allow a string larger than\r
+ max char size.\r
+ Revise $INSTR and remove 'do."'.\r
+ Revise 'pack"'.\r
+ ASM8086.F: Revise ';CODE' for control-flow stack.\r
+ COREEXT.F: Provide CODE definition of ROLL.\r
+ COREEXT.F: Revise '?DO' for control-flow stack.\r
+ COREEXT.F: Revise 'C"' to catch exception -24 'parsed string overflow'.\r
+1996. 8. 17.\r
+ HF86EXE.ASM: Revise MAX-UD.\r
+1996. 8. 10.\r
+ HF86EXE.ASM: Replace 'COMPILE,' with 'code,' in the definition of\r
+ 'compileCREATE'.\r
+1996. 7. 19.\r
+ DOUBLE.F: Fix 'M+'. Thanks M. Edward Borasky.\r
+1996. 6. 19.\r
+ Fix '/STRING'.\r
+1996. 4. 15.\r
+ ASM8086.F: ';CODE' is fixed. END-CODE is changed.\r
+1996. 3. 1.\r
+ MSDOS.F: Shift value of 'ior' of FILE words to system THROW code area,\r
+ i.e. -4096..-256 .\r
+ MSDOS.F: Remove subtle bug in 'SAVE-SYSTEM-AS'.\r
+\r
+Changes from 0.9.6\r
+\r
+1996. 2. 10.\r
+ Revise FM/MOD and SM/REM to catch result-out-of-range error in\r
+ '80000. 2 FM/MOD'.\r
+1996. 1. 19.\r
+ Rename 'x,' to 'code,'; 'x@' to 'code@'; 'x!' to 'code!';\r
+ 'xb@' to 'codeB@' and 'xb!' to 'codeB!'.\r
+1996. 1. 7\r
+ Rename non-Standard 'parse-word' to PARSE-WORD.\r
+1995. 12. 2\r
+ Drop '?doLIST' and revise 'optiCOMPILE,'.\r
+1995. 11. 28\r
+ Drop 'LIT,:' all together.\r
+ Return CELLS to non-IMMEDIATE definition.\r
+\r
+Changes from 0.9.5\r
+\r
+1995. 11. 27.\r
+ In ASM8086.F\r
+ ';CODE' is redefined following the change of 'DOES>' and 'doCREATE'.\r
+1995. 11. 25.\r
+ Add RETRY described by Dr. Astle in Forth Dimensions 17(4), 19-21 (1995).\r
+1995. 11. 25.\r
+ Make 'lastXT' VALUE word.\r
+1995. 11. 24.\r
+ For RAM model only\r
+ Replace 'xhere' with HERE.\r
+ Revise doVALUE, VALUE, TO, and all $VALUE macros.\r
+1995. 11. 23.\r
+ Revise doCREATE, CREATE, pipe, DOES>, and >BODY.\r
+ 'pipe' is no longer processor-dependent.\r
+1995. 11. 17.\r
+ Move ERASE to ASM8086.F.\r
--- /dev/null
+¾î¼Àºí¸® ¼Ò½º¸¦ Å©°Ô ´Ùµë¾ú½À´Ï´Ù. µ¡ºÙÀÓ¸»·Î ¼³¸íÀ» ´õÇß½À´Ï´Ù.\r
+ȯ°æ º¯¼ö 'systemID'¸¦ 'CPU'¿Í 'Model'·Î ³ª´©¾ú½À´Ï´Ù. ȯ°æ º¯¼ö¸¦\r
+»ç¿ëÇÑ Á¶°ÇºÎ ¹ø¿ª ¹æ¹ýÀ» ½á¼ ´ëºÎºÐÀÇ hForth ¹ÙÅÁº»À» °íÄ¡Áö ¾Ê°í\r
+´Ù¸¥ CPU¿ë hForth¿¡¼ ¾µ ¼ö ÀÖ½À´Ï´Ù (COREEXT.F¿Í DOUBLE.F¸¦\r
+º¸½Ê½Ã¿À). Turbo assembler»Ó ¾Æ´Ï¶ó ¸¶ÀÌÅ©·Î¼ÒÇÁÆ®»çÀÇ MASM 6.11¿¡¼µµ\r
+¿¡·¯¾øÀÌ ¾î¼ÀºíÀÌ µÇµµ·Ï ¾î¼Àºí¸® ¹ÙÅÁº»À» °íÃƽÀ´Ï´Ù.\r
+\r
+Á¦¾î ±¸Á¶ ³¹¸»À» ¸ðµÎ °íÃƽÀ´Ï´Ù. Á¦¾î È帧 ´õ¹Ì(control-flow stack)¸¦\r
+ÀÌÁ¦ ÀÚ·á ´õ¹Ì¿¡¼ ¾Æ·¡Ã³·³ ÀÚ·á ´õ¹Ì¿¡¼ °¢°¢ µÎ °³ÀÇ °ªÀ¸·Î\r
+Ç¥ÇöÇÕ´Ï´Ù.\r
+\r
+Control-flow stack item Representation (parameter and type)\r
+----------------------- -------------------------------------\r
+ dest control-flow destination 0\r
+ orig control-flow origin 1\r
+ of-sys OF origin 2\r
+ case-sys x (any value) 3\r
+ do-sys ?DO origin DO destination\r
+ colon-sys xt of current definition -1\r
+\r
+ÀÌÁ¦ "BEGIN IF AGAIN THEN" °°Àº À߸øµµ ½±°Ô ÀâÀ» ¼ö ÀÖ½À´Ï´Ù. ±×¸®°í\r
+ÀÚ·á È帧 ´õ¹ÌÀÇ °ªÀ» Á¾·ù¸¦ ³í¸®ÇÕ(OR) ¿¬»êÇÑ °á°ú°¡ 1ÀÎÁö¸¦ È®ÀÎÇؼ\r
+dest¿Í orig¿¡ ´ëÇؼ¸¸ Àû¿ëÇÒ ¼ö ÀÖ´Â CS-ROLL°ú CS-PICK¸¦ ºÎ¸¦ ¼ö\r
+ÀÖ´ÂÁö ¾ø´ÂÁö¸¦ È®ÀÎÇÒ ¼ö ÀÖ½À´Ï´Ù. ÀÌÁ¦ hForth°¡ ÀâÁö ¸øÇÏ´Â Á¦¾î\r
+±¸Á¶ÀÇ À߸øÀº ¾øÀ¸¸®¶ó°í »ý°¢ÇÕ´Ï´Ù.\r
+\r
+RESTORE-INPUTÀ» ºñ·ÔÇÑ ¸î °¡Áö ¹ú·¹¸¦ Àâ¾Ò½À´Ï´Ù.\r
+\r
+\r
+Changes from 0.9.7\r
+\r
+1997. 5. 26.\r
+ MSDOS.F: Fix RESTORE-INPUT to restore BLK correctly.\r
+1997. 2. 28.\r
+ Facelift to be used with other CPUs.\r
+1997. 2. 19.\r
+ Split environmental variable systemID into CPU and Model.\r
+1997. 2. 6.\r
+ Add Neal Crook's microdebugger and comments on assembly definitions.\r
+1997. 1. 25.\r
+ Add $THROWMSG macro and revise accordingly.\r
+1997. 1. 18.\r
+ Remove 'NullString' from assembly source.\r
+1996. 12. 18.\r
+ Revise 'head,'.\r
+1996. 12. 14.\r
+ DOSEXEC.F: Revise (DOSEXEC) in MSDOS.F.\r
+1996. 12. 6.\r
+ OPTIONAL.F: Fix 'compiles>' for colon-sys.\r
+1996. 11. 29.\r
+ OPTIONAL.F: Remove PICK which was added in assembly source.\r
+ OPTIONAL.F: Revise CASE, ENDCASE, OF, ENDOF, RETRY for\r
+ control-flow stack.\r
+ OPTIONAL.F: Revise '.xt' due to the removal of 'do."' and change\r
+ of 'doS"'.\r
+1996. 12. 3.\r
+ Revise PICK to catch stack underflow.\r
+1996. 11. 29.\r
+ Implement control-flow stack on data stack. Control-flow stack\r
+ item consists of two data stack items, one for value\r
+ and one for the type of control-flow stack item.\r
+ control-flow stack item data stack representation\r
+ dest control-flow_destination 0\r
+ orig control-flow_origin 1\r
+ of-sys OF_origin 2\r
+ case-sys x (any value) 3\r
+ do-sys ?DO_origin DO_destination\r
+ colon-sys xt_of_current_definition -1\r
+ Add PICK.\r
+ 'bal' is now the depth of control-flow stack.\r
+ Drop 'lastXT'.\r
+ Introduce 'notNONAME?'\r
+ Add 'bal+' and 'bal-'. Drop 'orig+', 'orig-', 'dest+', 'dest-',\r
+ 'dosys+', and 'dosys-'.\r
+ Revise ':NONAME', ':', ';', 'linkLast', 'head,', RECURSE, 'DOES>',\r
+ CONSTANT, CREATE, VALUE, VARIABLE, and QUIT.\r
+ This change makes RECURSE work properly in ':NONAME ... ;'\r
+ and '... DOES> ... ;'.\r
+ Revise 'rake', AGAIN, AHEAD, IF, THEN, +LOOP, BEGIN, DO, ELSE, LOOP,\r
+ UNTIL, and WHILE.\r
+ Revise SLITERAL, '."', 'doS"' to allow a string larger than\r
+ max char size.\r
+ Revise $INSTR and remove 'do."'.\r
+ Revise 'pack"'.\r
+ ASM8086.F: Revise ';CODE' for control-flow stack.\r
+ COREEXT.F: Provide CODE definition of ROLL.\r
+ COREEXT.F: Revise '?DO' for control-flow stack.\r
+ COREEXT.F: Revise 'C"' to catch exception -24 'parsed string overflow'.\r
+1996. 8. 17.\r
+ HF86EXE.ASM: Revise MAX-UD.\r
+1996. 8. 10.\r
+ HF86EXE.ASM: Replace 'COMPILE,' with 'code,' in the definition of\r
+ 'compileCREATE'.\r
+1996. 7. 19.\r
+ DOUBLE.F: Fix 'M+'. Thanks M. Edward Borasky.\r
+1996. 6. 19.\r
+ Fix '/STRING'.\r
+1996. 4. 15.\r
+ ASM8086.F: ';CODE' is fixed. END-CODE is changed.\r
+1996. 3. 1.\r
+ MSDOS.F: Shift value of 'ior' of FILE words to system THROW code area,\r
+ i.e. -4096..-256 .\r
+ MSDOS.F: Remove subtle bug in 'SAVE-SYSTEM-AS'.\r
+\r
+Changes from 0.9.6\r
+\r
+1996. 2. 10.\r
+ Revise FM/MOD and SM/REM to catch result-out-of-range error in\r
+ '80000. 2 FM/MOD'.\r
+1996. 1. 19.\r
+ Rename 'x,' to 'code,'; 'x@' to 'code@'; 'x!' to 'code!';\r
+ 'xb@' to 'codeB@' and 'xb!' to 'codeB!'.\r
+1996. 1. 7\r
+ Rename non-Standard 'parse-word' to PARSE-WORD.\r
+1995. 12. 2\r
+ Drop '?doLIST' and revise 'optiCOMPILE,'.\r
+1995. 11. 28\r
+ Drop 'LIT,:' all together.\r
+ Return CELLS to non-IMMEDIATE definition.\r
+\r
+Changes from 0.9.5\r
+\r
+1995. 11. 27.\r
+ In ASM8086.F\r
+ ';CODE' is redefined following the change of 'DOES>' and 'doCREATE'.\r
+1995. 11. 25.\r
+ Add RETRY described by Dr. Astle in Forth Dimensions 17(4), 19-21 (1995).\r
+1995. 11. 25.\r
+ Make 'lastXT' VALUE word.\r
+1995. 11. 24.\r
+ For RAM model only\r
+ Replace 'xhere' with HERE.\r
+ Revise doVALUE, VALUE, TO, and all $VALUE macros.\r
+1995. 11. 23.\r
+ Revise doCREATE, CREATE, pipe, DOES>, and >BODY.\r
+ 'pipe' is no longer processor-dependent.\r
+1995. 11. 17.\r
+ Move ERASE to ASM8086.F.\r
public / hf86v099.git / commitdiff