01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------( Block 1, Info About TinyForth ) ( About TinyFORTH words: NUMBER expects a pointer to a counted string on the stack when called, and leaves a TRUE/FALSE flag on top of the stack, telling wether the string was a valid number with the present BASE. If the flag is TRUE, the actual number is below it on the stack. ' expects a word in the in-stream and leaves the NFA of the word on the stack if the word existed, and causes an error otherwise. FIND expects a pointer to a counted string on the stack when called, and leaves the NFA of the word if it existed, and FALSE if it didn't. More on screen # 2 ) ( Block 2, Info About TinyFORTH, cont'd ) ( More about TinyFORTH: UCASE is a non-standard function, copying the address of a **Counted** string from the stack and converts all lowercase letters a-z to their uppercase equivalents. In TinyFORTH, the normal line editor has been replaced by a screen editor. The screen editor is a word called ED and expects a block number on the stack when called. The special commands in the editor are: CTRL-W,A,S,Z -- Move Cursor Up, Left, Right, Down. CTRL-K or ESC -- Leave Editor CTRL-Y -- Delete One Line CTRL-T -- Insert One Line {Warning: Old 'last' line disappears} Blocks 10..115 are free for the user! ) ( Block 3, Info About TinyFORTH, cont'd ) ( More About TinyFORTH: The special word EXIT-FORTH returns to MS-DOS. [Or where-ever you came from.] The functions INT21H and INT10H makes the corresponding BIOS calls, setting the processor registers according to the FORTH-variables AX, BX, CX, DX, SI and DI. On returning from the BIOS call, TinyFORTH sets the variables to reflect the returned values AND leaves a True/False flag on the stack, indicating the state of the Zero-Flag; True = ZF set. ) ( Block 4, More About TinyFORTH. Definition of DEMO1 ) ( SCR! is used to deposit 16-bit values in the B000-segment, i.e. the screen memory. Here's an example of its use: ) HEX : DEMO1 PAGE CR A0 0 DO 9F2A 8000 i + SCR! 2 +LOOP 4 LIST ; DECIMAL ( The functions INP, OUT, INPC and OUTC are used to access the ports of the 8086/8088/80286 etc... The format is the same as for @, !, C@ and C!, but with port numbers instead of addresses) ( Block 5, Some simple utility words ) DECIMAL ( SET-COLOUR fills the colour memory with the speci- fied value ) : SET-COLOUR 256 * 4000 0 DO DUP 32768 i + SCR! 2 +LOOP ; ( FREE prints out how much TinyFORTH work memory is left ) : FREE cr ." There are about " 62 here 1024 / - . ." K of TinyFORTH work memory left." cr ; ( Block 006, some minor utilities ) ( Block 007 ) ( Block 008 ) ( Block 009 ) ( Block 010 ) ( Block 011 ) ( Block 012 ) ( Block 013 ) ( Block 014 ) ( Block 015 ) ( Block 016 ) ( Block 017 ) ( Block 018 ) ( Block 019 ) ( Block 020 ) ( Block 021 ) ( Block 022 ) ( Block 023 ) ( Block 024 ) ( Block 025 ) ( Block 026 ) ( Block 027 ) ( Block 028 ) ( Block 029 ) ( Block 030 ) ( Block 031 ) ( Block 032 ) ( Block 033 ) ( Block 034 ) ( Block 035 ) ( Block 036 ) ( Block 037 ) ( Block 038 ) ( Block 039 ) ( Block 040 ) ( Block 041 ) ( Block 042 ) ( Block 043 ) ( Block 044 ) ( Block 045 ) ( Block 046 ) ( Block 047 ) ( Block 048 ) ( Block 049 ) ( Block 050 ) ( Block 051 ) ( Block 052 ) ( Block 053 ) ( Block 054 ) ( Block 055 ) ( Block 056 ) ( Block 057 ) ( Block 058 ) ( Block 059 ) ( Block 060 ) ( Block 061 ) ( Block 062 ) ( Block 063 ) ( Block 064 ) ( Block 065 ) ( Block 066 ) ( Block 067 ) ( Block 068 ) ( Block 069 ) ( Block 070 ) ( Block 071 ) ( Block 072 ) ( Block 073 ) ( Block 074 ) ( Block 075 ) ( Block 076 ) ( Block 077 ) ( Block 078 ) ( Block 079 ) ( Block 080 ) ( Block 081 ) ( Block 082 ) ( Block 083 ) ( Block 084 ) ( Block 085 ) ( Block 086 ) ( Block 087 ) ( Block 088 ) ( Block 089 ) ( Block 090 ) ( Block 091 ) ( Block 092 ) ( Block 093 ) ( Block 094 ) ( Block 095 ) ( Block 096 ) ( Block 097 ) ( Block 098 ) ( Block 099 ) ( Block 100 ) ( Block 101 ) ( Block 102 ) ( Block 103 ) ( Block 104 ) ( Block 105 ) ( Block 106 ) ( Block 107 ) ( Block 108 ) ( Block 109 ) ( Block 110 ) ( Block 111 ) ( Block 112 ) ( Block 113 ) ( Block 114 ) ( Block 115 ) ( Block 116 ) ( Block 117 ) ( Block 118 ) : -TRAILING BEGIN 1- DUP 0 < IF DROP 0 EXIT THEN OVER OVER + C@ 32 - IF 1+ EXIT THEN 1- 0 UNTIL ; --> ( Block 119, System, Complete Version of NUMBER ) VARIABLE (NUM1) ( DECODE POSITION ) VARIABLE (NUM2) ( NUMBER ) VARIABLE (NUM3) ( SIGN 1 or -1. 0 Means Invalid Conversion ) : (CVT) (NUM1) @ C@ (CVT1) (NUM1) @ 1+ (NUM1) ! ; : (NUM#) DUP C@ SWAP 1+ (NUM1) ! 1 (NUM3) ! 0 (NUM2) ! BASE @ 2 < IF 2 BASE ! THEN (NUM1) @ C@ 45 = IF (NUM1) @ 1+ (NUM1) ! -1 (NUM3) ! 1- THEN BEGIN DUP 0> WHILE (CVT) DUP -1 = IF 0 (NUM3) ! THEN (NUM3) @ * (NUM2) @ BASE @ * + (NUM2) ! 1- REPEAT DROP (NUM3) @ IF (NUM2) @ -1 ELSE 0 THEN ; ' (num#) ' >number pfa ! ( Activate New NUMBER! ) ( Block 120, System, Various ) DECIMAL ." Loading System Definitions" : HEX 16 BASE ! ; : OCTAL 8 BASE ! ; : BINARY 2 BASE ! ; : HERE DP @ ; : ' GETWORD XFIND DUP 0 = 4 ?ERROR ; : ? @ . ; : 0 0 ; : 1 1 ; : -1 -1 ; : 1+ 1 + ; : 1- 1 - ; : 0= 0 = ; : 0> 0 > ; : 0< 0 < ; : PAD DP @ 68 + ; : IMMEDIATE LATEST C@ 64 OR LATEST C! ; : ROT >R SWAP R> SWAP ; : ?COMP STATE @ 0= 7 ?ERROR ; --> ( Block 121, System, BEGIN-UNTIL / BEGIN-WHILE-REPEAT ) : BEGIN ?COMP HERE 242 ; IMMEDIATE : UNTIL ?COMP 242 - 3 ?ERROR COMPILE 0BRANCH , ; IMMEDIATE : WHILE ?COMP 242 - 3 ?ERROR COMPILE 0BRANCH HERE 0 , 251 ; IMMEDIATE : REPEAT ?COMP 251 - 3 ?ERROR COMPILE BRANCH SWAP , HERE SWAP ! ; IMMEDIATE 126 LOAD VARIABLE FENCE ' LATEST PFA CONSTANT (LATEST) --> ( Block 122, System, IF... ) : IF ?COMP COMPILE 0BRANCH HERE 0 , 948 ; IMMEDIATE : ELSE ?COMP 948 - 3 ?ERROR COMPILE BRANCH HERE 0 , SWAP HERE SWAP ! 948 ; IMMEDIATE : THEN ?COMP 948 - 3 ?ERROR HERE SWAP ! ; IMMEDIATE : DO ?COMP COMPILE (DO) HERE 691 ; IMMEDIATE : +LOOP ?COMP 691 - 3 ?ERROR COMPILE (+LOOP) , ; IMMEDIATE : LOOP ?COMP 691 - 3 ?ERROR COMPILE (LOOP) , ; IMMEDIATE : I R> R> DUP >R SWAP >R ; : LEAVE R> DROP >R DUP >R >R ; : I' R> R> R> DUP >R SWAP >R SWAP >R ; : FORGET ' DUP FENCE @ < IF 5 ERROR ELSE DUP DP ! LFA @ (LATEST) ! THEN ; --> ( Block 123, System ) : . . 8 EMIT ; ( Patch for a minor quirk ) : .H BASE @ SWAP 16 BASE ! . BASE ! ; : .R 1 - OVER BEGIN DUP BASE @ < IF 32 EMIT THEN BASE @ / SWAP 1 - SWAP OVER 1 < UNTIL DROP DROP . ; : MOD OVER OVER / * - ; : J R> R> R> R> DUP >R SWAP >R SWAP >R SWAP >R ; : J' R> R> R> R> R> DUP >R SWAP >R SWAP >R SWAP >R SWAP >R ; --> ( Block 124, System, LIST / L ) : CR 10 EMIT 13 EMIT ; : LIST CR ." Screen # " DUP . BLOCK 0 BEGIN CR DUP 2 .R 58 EMIT 32 EMIT OVER OVER 64 * + 64 TYPE 1 + DUP 15 > UNTIL CR DROP DROP ; : L #BLK @ LIST ; : INDEX CR SWAP BEGIN DUP BLOCK OVER 3 .R 58 EMIT 32 EMIT 64 TYPE CR 1 + OVER OVER < UNTIL ; : TRIAD DUP LIST 1+ DUP LIST 1+ LIST ; --> ( Block 125, System ) 32 CONSTANT BL 1024 CONSTANT BYTES-PER-BLOCK 127 CONSTANT HIGHEST-BLOCK : >UC DUP 96 > IF DUP 97 26 + < IF 32 - THEN THEN ; : >DIGIT DUP 48 < IF DROP -1 EXIT THEN DUP 58 < IF 48 - EXIT THEN >UC DUP 65 < IF DROP -1 EXIT THEN DUP 91 > IF DROP -1 EXIT THEN 55 - ; : (CVT1) >DIGIT DUP BASE @ < IF ELSE DROP -1 THEN ; : FIND XFIND ; ( Block 126, System ) : PFA DUP C@ + 5 + ; : CFA PFA 2 - ; : NFA ; : LFA PFA 4 - ; : ( 41 word drop ; ( System Startup Block ) ." Please wait... " : cr 13 emit 10 emit ; : ABORT NEW ; : --> BLK @ 0 = 6 ?ERROR BLK @ 1 + LOAD ; 120 load 118 load latest constant (empty) : EMPTY (empty) (latest) ! fence @ dp ! ; here fence ! ' (empty) PFA latest swap ! cr ." Type '1 LIST', '2 LIST' etc for info " cr cr ." OK" cr new 01234567890123456789012345678901ABCDEFGHIJKLMNOPQRSTUVWXYZ------