webforth
Version:
Forth implemented in Javascript
1,129 lines (989 loc) • 146 kB
JavaScript
/*
* See README.md and for references see FORTH.md an
*/
/* Naming conventions and abbreviations
* xt: execution token, points at the token field of a definition
* na: Name Address, points to the name, (first byte count+flags, then that number of characters, max 31)
* ca: Is ambiguous, sometimes it is used to refer to the xt, and sometimes to the Codefield Address, the field 2 cells below na that holds the xt
* la: Linkfield Address, field holding the na of the previously defined word in this vocabulary
* u: unsigned 16 bit
* c: character
* w: word - 16 bit signed
* n: word - 16 bit signed
*
* For routines defined in Javascript there are typically
* this.jsFunctions[tok] = func // An array that maps the tokens used in the Forth space to the addresses of the function in JS address space
* jsFunctionsAttributes[tok] = { n, defer} // Some attributes to allow management of the functions
* Name Dictionary: na-2*CELLL: <xt><link><name> // In the name directory it looks like any other word
* Code Dictionary: xt: <tok> // In the code directory its a single cell with the token.
*/
//eslint-env node
/*
This table maps the functions that go in the dictionary to the function names in the instance.
'foo': Create a forth word foo linked to Forth.prototype.foo
{ n: 'foo' Name of forth word
f: bar Links to Forth.prototype.bar (defaults to same as 'n'
token: true Create a token word that can be used as first cell of a definition - order must match constants below
defer: true Build a DEFER structure and point at the definition, typically replaced later by Forth word
jsNeeds: true The execution address of this word is needed by the JS o will be stored in js2xt[n]
*/
// it is used to build the dictionary in each instance.
const jsFunctionAttributes = [
0, // 0 is not a valid token
// This next list of token's must match in order the constants defined for tokenCreate etc.
{ n: 'tokenVocabulary', token: true }, // Token used for Vocabularies must be first 1
{ n: 'tokenNextVal', token: true }, // Token used for Constants must be next (2)
{ n: 'tokenDoList', token: true },
{ n: 'tokenUser', token: true },
{ n: 'tokenVar', token: true },
{ n: 'tokenCreate', token: true },
{ n: 'tokenDefer', token: true }, // Execute payload (like DoList but just one)
{ n: 'tokenValue', token: true }, // Returns value from a user variable.
// Note the number of tokens goes in xc.js NumTokens //
'ALIGNED',
{ n: 'FIND-NAME-IN', f: 'findNameIn' }, // Fast version of find
{ n: 'OVERT', defer: true },
{ n: '$,n', f: 'dollarCommaN', defer: true },
'ms', 'BYE', { n: 'EXIT', jsNeeds: true }, 'EXECUTE',
{ n: '?RX', f: 'QRX' }, { n: 'TX!', f: 'TXstore' }, { n: '!IO', f: 'storeIO' },
{ n: '(literal)', f: 'literal', jsNeeds: true }, { n: 'DOES>', f: 'DOES' }, { n: '(next)', f: 'next' }, { n: '?branch', f: 'qBranch' }, 'branch',
{ n: '!', f: 'store' }, { n: '@', f: 'fetch' }, { n: 'C@', f: 'CFetch' }, { n: 'C!', f: 'CStore' },
{ n: 'RP@', f: 'RPat' }, { n: 'RP!', f: 'RPStore' }, { n: 'R>', f: 'Rfrom' }, { n: 'R@', f: 'Rat' }, { n: '>R', f: 'toR' },
{ n: '2R>', f: 'TwoRfrom' }, { n: '2R@', f: 'TwoRFetch' }, { n: '2>R', f: 'TwotoR' },
{ n: 'SP@', f: 'SPat' }, { n: 'SP!', f: 'SPbang' },
'DROP', 'DUP', 'SWAP', 'OVER', 'ROLL', 'ROT',
{ n: '0<', f: 'zeroLess' }, 'AND', 'OR', 'XOR', { n: 'UM+', f: 'UMplus' },
'RSHIFT', 'LSHIFT', { n: '2/', f: 'TwoDiv' },
'userAreaInit', 'userAreaSave',
{ n: 'PARSE', defer: true }, { n: '(', f: 'parenthesis', defer: true, immediate: true }, { n: 'TOKEN', defer: true }, { n: 'NUMBER?', f: 'NUMBERQ', defer: true },
{ n: '$COMPILE', f: 'dCOMPILE', defer: true }, { n: '$INTERPRET', f: 'dINTERPRET', jsNeeds: true, defer: true },
{ n: '[', f: 'openBracket', immediate: true, defer: true }, { n: ']', f: 'closeBracket', defer: true },
{ n: ':', f: 'colon', defer: true }, { n: ';', f: 'semicolon', immediate: true, defer: true }, { n: "'", f: 'tick', defer: true },
'debugNA', 'Fbreak', 'stringBuffer', 'TYPE',
'I', 'RDrop', { n: '2RDrop', f: 'TwoRDrop' }, { n: 'immediate?', f: 'immediateQ' },
{ n: 'ALIGN', f: 'vpAlign' }, { n: '>BODY', f: 'toBODY' }, { n: 'DEFER', defer: true }, { n: '(of)', f: 'of' },
{ n: 'T{', f: 'Tbrace', defer: true }, { n: 'DEPTH', defer: true }, { n: '}T', f: 'Tunbrace', defer: true }, { n: '->', f: 'Tarrow', defer: true },
];
// Define the tokens used in the first cell of each word.
// Order must match the order of functions defined above with token: true
// 0 is an invalid token so that a 0 is never indirected through.
const tokenVocabulary = 1;
const tokenNextVal = 2;
const tokenDoList = 3;
const tokenUser = 4;
const tokenVar = 5;
const tokenCreate = 6;
const tokenDefer = 7;
const tokenValue = 8;
// ported to Arduino below to L.115
// === Memory Map - Zen pg26
const l = {}; // Constants that will get compiled into the dictionary
l.COMP = 0x40; // bit in first char of name field to indicate 'COMPILE-ONLY' ERRATA Zen uses this but its not defined
l.IMED = 0x80; // bit in first char of name field to indicate 'immediate' ERRATA Zen uses this but its not defined
const bitsSPARE = 0x20; // Unused spare bit in names
l.BYTEMASK = 0xFF - l.COMP - l.IMED - bitsSPARE; // bits to mask out of a call with count and first char. ERRATA Zen uses this but its not defined
//l.TRUE = (2 ** (l.CELLL * 8)) - 1; // Also used to mask numbers
l.TRUE = -1; // Not quite correct, should be masked BUT when pushed that it is done underneath
l.FALSE = 0;
const nameMaxLength = 31; // Max number of characters in a name, length needs to be representable after BitMask (we have one spare bit here)
console.assert(nameMaxLength === l.BYTEMASK); // If this isn't true then check each of the usages below
l.BL = 32;
// === Data table used to build users.
// later the FORTH word 'USER' is defined but unlike this function it doesn't setup initialization, nor does it auto-increment to next available user slot.
// These definitions can refer to v: 'foo' to be initialized to a Forth word (which must be in jsFunctionAttributes)
// or the contents of a property of the forth instance (e.g. Forth.prototype.TIB0
const jsUsers = []; // Note 4 cells skipped for multitasking but that is in init of _USER to 4*CELLL
function USER(n, v) { jsUsers.push([n, v]); return (jsUsers.length - 1); }
USER('_USER', 0); // Size of user area
USER(undefined, 0); // Used for multitasking
USER(undefined, 0); // Used for multitasking
USER(undefined, 0); // Used for multitasking
const SP0offset = USER('SP0', undefined); // (--a) Pointer to bottom of the data stack.
const RP0offset = USER('RP0', undefined); // (--a) Pointer to bottom of the return stack.
USER("'?KEY", '?RX'); // Execution vector of ?KEY. Default to ?rx.
USER("'EMIT", 'TX!'); // Execution vector of EMIT. Default to TX!
// eForth difference - this next one is 'EXPECT in EFORTH )
USER('SPARE', 0);
// TODO-34-FILES consider if still want vectored I/O or prefer decision based on SOURCE-ID
USER("'TAP", 0); // Execution vector of TAP. Default to kTAP.
USER("'ECHO", 'TX!'); // Execution vector of ECHO. Default to tx! but changed to ' EMIT later.
const PROMPToffset = USER("'PROMPT", 0); // Execution vector of PROMPT. Default to '.ok'.
const BASEoffset = USER('BASE', 10);
USER('temp', 0); // A temporary storage location used in parse and find. EFORTH-ZEN-ERRATA its uses as 'temp', listing says 'tmp'
USER('SPAN', 0); // Hold character count received by EXPECT (TODO strangely it is stored, but not accessed and EXPECT never used )
const INoffset = USER('>IN', 0); // Hold the character pointer while parsing input stream.
const nTIBoffset = USER('#TIB', 0); // Hold the current count of the terminal input buffer.
const TIBoffset = USER(undefined, 'TIB0'); // Hold current address of Terminal Input Buffer (must be cell after #TIB.)
USER('CSP', 0); // Hold the stack pointer for error checking.
// eFORTH diff - eFORTH uses EVAL as vector to either $INTERPRET or $COMPILE, ANS uses a variable called STATE
const STATEoffset = USER('STATE', l.FALSE); // True if compiling - only changed by [ ] : ; ABORT QUIT https://forth-standard.org/standard/core/STATE
USER('SPARE2', 0);
USER('HLD', 0); // Hold a pointer in building a numeric output string.
USER('HANDLER', 0); // Hold the return stack pointer for error handling.
// this is set to result of currentFetch
const CONTEXToffset = USER('CONTEXT', undefined); // A area to specify vocabulary search order. Default to FORTH. Vocabulary stack, 8 cells following CONTEXT.
USER(undefined, 0);
USER(undefined, 0);
USER(undefined, 0);
USER(undefined, 0);
USER(undefined, 0);
USER(undefined, 0);
USER(undefined, 0);
USER(undefined, 0); // Always 0 to indicate no more valid Vocabularies
const CURRENToffset = USER('CURRENT', undefined); // Point to the vocabulary to be extended. Default to FORTH.
// this is set to result of currentFetch
USER(undefined, undefined); // Vocabulary link uses one cell after CURRENT (not clear how this is used)
// Not e there is a (hidden) assumption that CP and NP are consecutive - used to check free space
const CPoffset = USER('CP', undefined); // eForth initializes to CTOP but we have to use this during compilation
const NPoffset = USER('NP', undefined); // normally set on Zen pg106 but we are using it live. Its the bottom of what compiled in name space.
const LASToffset = USER('LAST', undefined); // normally set on Zen pg106 but using live
const VPoffset = USER('VP', undefined); // not part of eForth, pointer into Data space for EPROMability
USER('source-id', 0); // Variable holding 0 for terminal, -1 for string, fd for files
const testFlagsOffset = USER('testFlags', 0); // bit field: 1 trace interpreter 2 trace threading 4 safety checks 8 tests TODO-67-TESTING - see unreadFile above //TODO-2ARDUINO
const testDepthOffset = USER('testDepth', 0); // Needs to autoadjust //TODO-2ARDUINO
// ported to Arduino above
const forthInForth = `
T{ -> }T
T{ FORTH -> }T
: 2DROP DROP DROP ;
T{ 1 2 2DROP -> }T
: setHeaderBits LAST @ C@ OR LAST @ C! ;
: COMPILE-ONLY COMP setHeaderBits ;
: IMMEDIATE IMED setHeaderBits ;
( Note - above is both definition and the first use of the comment )
( Below may also be the first execution of a word - IMMEDIATE - defined with a colon )
( Note this is the first execution of an immediate word '(' inside a compilation )
: \\ ( -- ; Ignore following text till the end of line.)
#TIB @ >IN ! ( store the length of TIB in >IN )
; IMMEDIATE ( in effect ignore the rest of a line )
( Now these are defined we can use both kinds of comments below here )
T{ 1 2 ( 3 ) 4 -> 1 2 4 }T
( Uncomment first for production, 2nd for testing )
( TODO add a test here, or elsewhere for things like: CP+PAD+StringBuffer > NP)
( === Test as many of the words defined in code as possible)
( EXIT & EXECUTE tested with ' )
( (literal implicitly tested by all literals )
( next, ?branch, branch implicitly tested by control structures )
T{ 123 HLD ! HLD @ -> 123 }T ( Also tests user variables )
T{ 222 HLD C! HLD C@ -> 222 }T
( R> >R R@ SP@ SP! tested after arithmetic operators )
T{ 30 20 DROP -> 30 }T
T{ 30 20 DUP -> 30 20 20 }T
T{ 10 20 SWAP -> 20 10 }T
T{ 10 20 OVER -> 10 20 10 }T
T{ 123 0< -123 0< -> 0 -1 }T
T{ 16 BASE ! 5050 6060 AND 5050 6060 OR 5050 6060 XOR -> 4040 7070 3030 0A BASE ! }T
T{ 12 34 UM+ -> 46 0 }T
( Next test is contrived to work with any CELLL size )
T{ -1 -1 UM+ -> -2 1 }T
( IMMEDIATE implicitly tested )
T{ BL PARSE ABC SWAP DROP -> 3 }T
T{ !IO 62 TX! -> }T ( Should output > )
T{ : FOO 10 EXIT 20 ; FOO -> 10 }T
T{ ' FOO EXECUTE 30 -> 10 30 }T
( === First section is words moved earlier than they appear in eForth as they are needed for other words )
( they are mostly still in the same order as in eForth )
T{ BL -> 32 }T
: NIP SWAP DROP ;
: TUCK SWAP OVER ; ( w1 w2 -- w2 w1 w2 ; tuck top of stack under 2nd )
T{ 1 2 NIP -> 2 }T
T{ 1 2 TUCK -> 2 1 2 }T
: HERE ( -- a; return top of code dictionary; Zen pg60) CP @ ;
( test is non-obvious )
: + UM+ DROP ;
: CELL+ CELLL + ;
T{ 1 2 SP@ CELL+ SP! -> 1 }T
( ERRATA - Zen pg57 presumes CELLL==2 and need to align, not case with JS and byte Buffer, moved to code )
( ERRATA v5 skips ALIGNED form this definition)
: , ( w --; Compile an integer into the code dictionary. Zen pg 89)
HERE ALIGNED DUP CELL+ CP ! ! ;
: COMPILE, , ; ( Forth2012 version of ',')
: [COMPILE] ( -- ; <string> ) ' , ; IMMEDIATE
T{ : foo [COMPILE] ( ; foo 2 ) -> }T
: COMPILE ( --; Compile the next address in colon list to code dictionary. Zen pg 90)
R> DUP @ , CELL+ >R ; COMPILE-ONLY
: LITERAL ( w -- ) ( Compile tos to code dictionary as an integer literal.)
COMPILE (literal) ( compile (literal to head lit )
, ; IMMEDIATE ( compile literal itself )
: create TOKEN $,n OVERT , 0 , ;
( Create a new word that doesnt allocate any space, but will push address of that space. )
( redefines definitions moved up so that they will use new TOKEN etc)
: CREATE tokenCreate create ; ( Note the extra field for DOES> to patch - redefines definition moved up so that it will use new TOKEN etc)
T{ : foo CREATE 123 , DOES> @ ; foo BAR BAR -> 123 }T
( === Control structures - were on Zen pg91 but needed earlier Zen pg 91-92 but moved early )
( this version comes from EFORTH-V5 which introduced MARK> >MARK )
( FOR-I-NEXT FOR-AFT-I-THEN-NEXT BEGIN-AGAIN BEGIN-WHILE-REPEAT BEGIN-UNTIL IF-ELSE-THEN ?WHEN DO-I-LOOP)
: <MARK ( -- a ) HERE ; \\ Leave an address suitable for <RESOLVE
: <RESOLVE ( a -- ) , ; \\ Resolve a link back to start of structure (e.g. in a loop)
: >MARK ( -- A ) HERE 0 , ; \\ Leave a space to put a jump destination
: >RESOLVE ( A -- ) <MARK SWAP ! ; \\ Resolve a forward jump destination
: FOR ( -- a ) COMPILE >R <MARK ; IMMEDIATE
: BEGIN ( -- a ) <MARK ; IMMEDIATE
: NEXT ( a -- ) COMPILE (next) <RESOLVE ; IMMEDIATE
: UNTIL ( a -- ) COMPILE ?branch <RESOLVE ; IMMEDIATE
: AGAIN ( a -- ) COMPILE branch <RESOLVE ; IMMEDIATE
: IF ( -- A ) COMPILE ?branch >MARK ; IMMEDIATE
: AHEAD ( -- A ) COMPILE branch >MARK ; IMMEDIATE
: REPEAT ( A a -- ) [COMPILE] AGAIN >RESOLVE ; IMMEDIATE
: THEN ( A -- ) >RESOLVE ; IMMEDIATE
( ERRATA ZEN - doesnt mark this as immediate)
: AFT ( a -- a A ) DROP [COMPILE] AHEAD [COMPILE] BEGIN SWAP ; IMMEDIATE
: ELSE ( A -- A ) [COMPILE] AHEAD SWAP [COMPILE] THEN ; IMMEDIATE
: WHEN ( a -- a A a ) [COMPILE] IF OVER ; IMMEDIATE ( Cannot find documentation on how this is used )
: WHILE ( a -- A a ) [COMPILE] IF SWAP ; IMMEDIATE
: ?DUP DUP IF DUP THEN ; ( w--ww|0) ( Dup top of stack if its is not zero.)
: >RESOLVES ( 0 A* -- ) BEGIN ?DUP WHILE >RESOLVE REPEAT ; ( Resolve zero or more forward branches e.g. from multiple LEAVE )
: >MARKSTART 0 ;
: >MARKTHREAD ( A -- A' ) HERE SWAP , ; \\ Leave a space for a jump destination, but mark a jump back
: >RESOLVETHREAD ( A -- ) \\ Resolve a set of forward jumps
BEGIN ?DUP WHILE DUP @ SWAP >RESOLVE REPEAT ;
: CASE >MARKSTART ; IMMEDIATE \\ Leave head of >MARKTHREAD chain
: OF COMPILE (of) >MARK ; IMMEDIATE
: ENDOF COMPILE branch SWAP >MARKTHREAD SWAP >RESOLVE ; IMMEDIATE
: ENDCASE COMPILE DROP >RESOLVETHREAD ; IMMEDIATE
( TODO-TEST of above group non-obvious as writing to dictionary. )
( IF-THEN tested in ?DUP; )
: 0= IF FALSE ELSE TRUE THEN ;
: 0<> 0= 0= ;
: D0= OR 0= ;
: ?\\ ( f -- ; Conditional compilation/interpretation - comment out if f is 0 )
0= IF [COMPILE] \\ THEN ; IMMEDIATE
: ?safe\\ ( compilation/interpretation line if checking for safety - overflows etc )
testFlags @ 4 AND [COMPILE] ?\\ ; IMMEDIATE
: ?test\\ ( compilation/interpretation line if running compile time tests ) \\ TODO-OBSOLETE maybe
testFlags @ 8 AND [COMPILE] ?\\ ; IMMEDIATE
( === Multitasking Zen pg48 - not implemented in eForth TODO )
( === More Stack Words Zen pg49 TODO-OPTIMIZE )
: -ROT SWAP >R SWAP R> ; ( w1, w2, w3 -- w3 w1 w2; Rotate top item to third)
: 2DUP OVER OVER ; ( w1 w2 -- w1 w2 w1 w2;)
: 2OVER >R >R 2DUP R> -ROT R> -ROT ; ( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 )
: 2SWAP >R -ROT R> -ROT ; ( w1 w2 w3 w4 -- w3 w4 w1 w2 )
( 2DROP & NIP moved earlier )
T{ 1 ?DUP 0 ?DUP -> 1 1 0 }T
T{ 1 2 3 ROT -> 2 3 1 }T
T{ 1 2 2DUP -> 1 2 1 2 }T
( === More Arithmetic operators Zen pg50 and a few not in eForth but widely used )
T{ 1 2 + -> 3 }T
: D+ >R SWAP >R UM+ R> R> + + ; ( d1 d2 -- d1+d2)
T{ -1 1 -1 3 D+ -> -2 5 }T ( Test contrived to be CELLL independent )
: INVERT -1 XOR ; ( w -- w; 1's compliment)
T{ 257 INVERT -> -258 }T ( 257 is 0x101 65278 is 0xFEFE )
( NOT's meaning is deprecated use 0= logical or INVERT bitwise see http://lars.nocrew.org/forth2012/core/INVERT.html)
: 1+ 1 + ;
: NEGATE INVERT 1+ ; ( w -- w; 2's complement)
T{ 53 NEGATE 53 + -> 0 }T
: DNEGATE INVERT >R INVERT 1 UM+ R> + ;
: - NEGATE + ; ( n1 n2 -- n1-n2)
T{ 456 123 - 456 -123 - -> 333 579 }T
: 1- 1 - ;
: ?negate ( n1 n2 -- n1|-n1 ; negate n1 if n2 negative)
0< IF NEGATE THEN ;
: ABS DUP ?negate ; ( n -- n; Absolute value of w)
T{ -456 ABS 456 ABS - -> 0 }T
: CHAR+ 1+ ;
: C, ( c --; Compile a single character into code dictionary and advance pointer 1 character )
HERE DUP CHAR+ CP ! C! ;
T{ -> }T
T{ : foo 111 >R R> ; foo -> 111 }T \\ Tests >R R@ RP@ R> but needs '-'
T{ : foo 111 >R R@ R> ; foo -> 111 111 }T \\ Tests >R R@ RP@ R> but needs '-'
T{ : foo 111 >R R@ RP@ R> SWAP RP@ SWAP - ; foo -> 111 111 CELLL }T \\ Tests >R R@ RP@ R> but needs '-'
T{ 111 >R R@ RP@ R> SWAP RP@ SWAP - -> 111 111 CELLL }T \\ Tests >R R@ RP@ R> but needs '-'
( === More comparison Zen pg51-52 - ud< is added)
: = XOR IF FALSE EXIT THEN TRUE ; ( w w -- t)
T{ 123 123 = 123 124 = -> -1 0 }T
: <> XOR IF TRUE EXIT THEN FALSE ; ( w w -- t; from ANS not eForth)
: U< 2DUP XOR 0< IF NIP 0< EXIT THEN - 0< ;
T{ 123 100 U< 100 123 U< 123 -100 U< -100 123 U< -> 0 -1 -1 0 }T
: U> SWAP U< ;
: ud< ( ud ud -- f ) ROT SWAP U< IF 2DROP TRUE ELSE U< THEN ;
: < 2DUP XOR 0< IF DROP 0< EXIT THEN - 0< ;
T{ 123 100 < 100 123 < 123 -100 < -100 123 < -> 0 -1 0 -1 }T
: > SWAP < ;
: MAX 2DUP < IF SWAP THEN DROP ;
T{ 100 200 MAX 300 100 MAX -> 200 300 }T
: MIN 2DUP SWAP < IF SWAP THEN DROP ;
T{ 100 200 MIN 300 100 MIN -> 100 100 }T
: WITHIN OVER - >R - R> U< ;
T{ 200 100 300 WITHIN 300 100 200 WITHIN 100 -100 200 WITHIN -> -1 0 -1 }T
: S>D DUP 0< ; ( n -- d)
T{ 111 S>D -111 S>D -> 111 0 -111 -1 }T
( === More Math Words Zen pg53-55 UM/MOD M/MOD /MOD MOD / UM+ * M* )
: UM/MOD ( udl udh u -- ur uq ) ( needs FOR-NEXT from 91)
( Unsigned divide of a double by a single. Return mod and quotient)
2DUP U<
IF NEGATE ( negate u for subtraction )
CELLbits FOR ( repeat 16 times for 16 bits)
AFT (
>R ( save -u)
DUP UM+ ( left shift udh)
>R >R DUP UM+ ( left shift udl)
R> + DUP ( add carry to udh)
R> R@ SWAP ( retrieve -u)
>R UM+ ( subtract u from udh)
R> OR ( a borrow?)
IF >R DROP ( yes add a bit to quotient)
1+ R>
ELSE DROP ( no borrow)
THEN R> ( retrieve -u)
THEN
NEXT ( repeat for CELLbits bits)
DROP SWAP EXIT ( return remainder and quotient)
THEN DROP 2DROP ( overflow, return -1's)
-1 DUP
;
T{ -1 1 2 UM/MOD -> 1 -1 }T
T{ 9 0 4 UM/MOD -> 1 2 }T
: M/MOD ( d n -- r q)
( Signed floored divide of double by single. Return mod and quotient.)
DUP 0< ( n negative)
DUP >R ( save a copy of flag)
IF NEGATE >R ( take abs of n)
DNEGATE R> ( negative d also)
THEN >R
DUP 0< ( if d is negative)
IF R@ + THEN ( floor it)
R> UM/MOD ( now divide)
R> ( if n is negative)
IF SWAP NEGATE SWAP THEN ( negative remainder also )
;
T{ -1 1 2 M/MOD -> 1 -1 }T
: FM/MOD ( d n -- r q) M/MOD ; \\ Forth2012 https://github.com/NieDzejkob/2klinux.git
: /MOD ( n1 n2 -- r q)
( Signed divide. Return mod and quotient)
>R S>D R> ( d1 n2 ; sign extend n1)
M/MOD ( floored divide)
;
T{ 9 4 /MOD -> 1 2 }T
: MOD ( n n -- r)
( Signed divide. Return mod only)
/MOD DROP ; ( discard quotient)
T{ 9 4 MOD -> 1 }T
: / ( n n -- q)
( Signed divide. Return quotient only)
/MOD NIP ; ( discard remainder)
: UM* ( u1 u2 -- ud)
( Unsigned multiply. Return double product.)
0 SWAP ( u1 sum u2)
CELLbits FOR ( repeat for 16 bits)
AFT
DUP UM+ >R >R ( left shift u2)
DUP UM+ ( left shift sum)
R> + ( add carry to u2)
R> ( carry shifted out of u2?)
IF >R OVER UM+ ( add u1 to sum)
R> + ( carry into u2)
THEN
THEN
NEXT ( repeat 16 time to form ud)
ROT DROP ; ( discard u1)
: * ( n n -- n)
( Signed multiply. Return single product)
UM* DROP ; ( retain only low part)
: M* ( n1 n2 -- d)
( Signed multiply. Return double product)
2DUP XOR 0< >R ( n2 n2 have same sign?)
ABS SWAP ABS UM* ( multiply absolutes)
R> IF DNEGATE THEN ; ( negate if signs are different)
T{ 9 4 / -> 2 }T
T{ 2 -1 UM* -> -2 1 }T
T{ 3 4 * -> 12 }T
T{ -2 -3 M* -> 6 0 }T
( === Scaling Words Zen pg56 */MOD */ )
: */MOD ( n1 n2 n3 -- r q )
( Multiply n1 and n2, then divide by n3. Return mod and quotient)
>R M* ( n1*n2)
R> M/MOD ; ( n1*n2/n3 with remainder)
T{ 5 7 2 */MOD -> 1 17 }T
: */ ( n1 n2 n3 -- q )
( Multiple by n1 by n2, then divide by n3. Return quotient only)
*/MOD NIP ; ( n1*n2/n3 and discard remainder)
T{ 5 7 2 */ -> 17 }T
( === More arithmetic needed for ANS compliance ==== )
\\ TODO-DOUBLE word set https://forth-standard.org/standard/double
\\ implemented: D0< D0= DABS
\\ not implemented yet: 2CONSTANT 2LITERAL D+ D- D. D.R D2* D2/ D< D= D>S DMAX DMIN DNEGATE M * / M+
: D0< ( d -- f ; check if d is negative ) NIP 0< ;
: DABS ( d -- abs d ; https://forth-standard.org/standard/double/DABS )
2DUP D0< IF DNEGATE THEN ;
: SM/REM ( d1 n1 -- n2 n3 ; copied from FlashForth)
2DUP XOR >R
OVER >R
ABS >R DABS R> UM/MOD
SWAP R> ?negate
SWAP R> ?negate
;
( === Memory Alignment words Zen pg57 CELL+ CELL- CELLS ALIGNED )
( ERRATA Zen & v5 use 2 which is wrong unless CELL is '2' )
: CELL- ( a -- a)
( Subtract cell size in byte from address)
CELLL - ;
T{ 123 CELL- CELLL + -> 123 }T
: CELLS ( n - n )
( Multiply n by cell size in bytes)
CELLL * ;
T{ 123 CELLS CELLL / -> 123 }T
: CHARS ; \\ A noop since 1 address unit per char - note this is ANS CHARS, eFORTH CHARS is now emits
: 2* 2 * ; \\ TODO-83 This should be optimized to a left shift and then find where used
: ($,n) ( na -- )
( na) DUP LAST ! ( save na for vocabulary link for OVERT)
( na) HERE ALIGNED
( na cp') DUP CP ! SWAP ( align code address )
( cp' na) CELL- ( link address )
( cp' la) CURRENT @ @ ( find last definition )
( cp' la na') OVER ! ( cp' na- ; link to last definition )
( cp' la) CELL- DUP NP ! ( cp' na-- ; adjust name pointer )
( cp' ca) ! ( save aligned code pointer in definition )
;
: :NONAME ( -- xt ) ( TODO this appears to waste 3 cells in name dict, maybe rework)
NP @ CELL- 0 OVER ! DUP NP !
($,n)
HERE \\ Returns xt
tokenDoList ,
]
;
( Words associated with DEFER - from Forth2012)
: DEFER@ ( xt -- a; ) >BODY @ ;
: >BODY! >BODY ! ;
: DEFER! ( xt1 xt2 --; ) >BODY! ;
: >CHAR ( c -- c; filter non printing characters, replace by _)
127 AND DUP ( mask off the MSB bit)
127 BL WITHIN ( if its a control character)
IF DROP 95 THEN ; ( replace with an underscore)
T{ 41 >CHAR 23 >CHAR BL >CHAR -> 41 95 BL }T
( === Managing Data Stack Zen pg59 DEPTH PICK )
( ERRATA Staapl, v5, zen, has 2/ )
:NONAME ( -- n ; : DEPTH)
( Return the depth of the data stack)
SP@ ( current stack pointer)
SP0 @ SWAP - ( distance from stack origin)
CELLL / ; ( divide by bytes/cell)
' DEPTH DEFER!
T{ 1 2 3 DEPTH -> 1 2 3 3 }T
: PICK ( ... +n -- ... w)
( Copy the nth stack item to tos)
1+ CELLS ( bytes below tos)
SP@ + @ ; ( fetch directly from stack)
T{ 11 22 33 1 PICK -> 11 22 33 22 }T
( === Memory Access Zen pg60 +! 2! 2@ HERE PAD TIB @EXECUTE )
( Note 2! 2@ presume big-endian which is a Forth assumption (high word at low address)
: +! ( n a -- ; Add n to the contents at address a)
SWAP OVER @ + SWAP ! ;
T{ HLD @ 2 HLD +! HLD @ SWAP - -> 2 }T
: ++ 1 SWAP +! ;
: -- -1 SWAP +! ;
: 2! ( d a -- ; Store double integer to address a, high part at low address)
SWAP OVER ! CELL+ ! ;
T{ 1 2 3 SP@ 4 5 ROT 2! -> 1 4 5 }T
: 2@ ( a -- d; Fetch double integer from address a, high part from low address)
DUP CELL+ @ SWAP @ ;
T{ 1 2 3 SP@ 2@ -> 1 2 3 2 3 }T
( Support Data separation from Code TODO rethink this as always having some code)
: vHERE ( -- a; top of data space - code space if none or after back in Ram) VP @ ?DUP IF EXIT THEN HERE ;
: v, ( w --; Compile an integer into the data area if used, else code dictionary (not part of eForth)
VP @ ?DUP IF ALIGNED DUP CELL+ VP ! ! ELSE , THEN ;
( vCREATE is like CREATE but if VP is set it makes space in the writable DATA area)
: vALIGN VP @ ALIGNED VP ! ;
( vCREATE is like CREATE but if VP is set it makes space in the writable DATA area)
: vCREATE ( -- ; <string> ) VP @ ?DUP IF tokenVar create vALIGN , ELSE CREATE THEN ; ( Compile pointer to data area )
: PAD ( -- a; Return address of a temporary buffer above code dic)
HERE 80 + ;
: TIB ( -- a; Return address of terminal input buffer)
#TIB CELL+ @ ; ( 1 cell after #TIB)
T{ >IN @ BL PARSE XXX SWAP TIB - ROT - -> 3 9 }T
: @EXECUTE ( a -- ; execute vector -if any- stored in address a)
@ ?DUP IF EXECUTE THEN ;
( === Memory Array and String Zen pg61-62: COUNT CMOVE FILL -TRAILING PACK$ )
: COUNT ( b -- b+1 +n; return count byte of string and add 1 to byte address)
DUP 1+ SWAP C@ ;
T{ NP @ CELL+ CELL+ COUNT NIP -> 5 }T \\ Note works because COUNT is last word defined
: CMOVE ( b1 b2 u -- ; Copy u bytes from b1 to b2)
FOR ( repeat u+1 times)
AFT ( skip to THEN first time)
>R DUP C@ ( fetch from source )
R@ C! ( store to destination)
1+ ( increment source address)
R> 1+ ( increment destination address)
THEN
NEXT 2DROP ; ( done discard addresses)
: CMOVE> ( b1 b2 u -- ; Copy u bytes from b1 to b2 starting high)
>R SWAP R@ 1- + SWAP R@ 1- + R>
FOR ( repeat u+1 times)
AFT ( skip to THEN first time)
>R DUP C@ ( fetch from source )
R@ C! ( store to destination)
1- ( increment source address)
R> 1- ( increment destination address)
THEN
NEXT 2DROP ; ( done discard addresses)
: MOVE ( a a' u -- ; https://forth-standard.org/standard/core/MOVE ; TODO redefine in terms of CMOVE or CMOVE> depending on overlaps)
>R 2DUP > R> SWAP IF CMOVE ELSE CMOVE> THEN ;
: FILL ( b u c --; Fill u bytes of character c to area beginning at b.)
SWAP ( b c u)
FOR ( loop u+1 times)
SWAP ( c b )
AFT ( skip to THEN)
2DUP C! ( c b; store c to b)
1+ ( c b+1; increment b)
THEN
NEXT 2DROP ; ( done, discard c and b)
: ERASE 0 FILL ; ( https://forth-standard.org/standard/core/ERASE )
( DIFF: Staapl has FOR AFT DUP R@ + C@ BL XOR IF R> 1 + EXIT THEN THEN NEXT 0; which only strips BL )
: -TRAILING ( b u -- b u ; Adjust the count to eliminate trailing white space.)
FOR ( scan u+1 characters)
AFT ( skip the first loop)
BL ( blank for comparison)
OVER R@ + C@ < ( compare char at the end)
IF R> 1+ ( non-white space, exit loop)
EXIT ( with adjusted count)
THEN
THEN ( else continue scanning)
NEXT 0 ; ( reach the beginning of b)
T{ NP @ CELL+ CELL+ COUNT OVER PAD ROT CMOVE C@ -> PAD C@ }T ( Check first character copied - expect pad="PACK$")
T{ PAD 3 + 5 BL FILL PAD 7 + C@ -> BL }T
T{ PAD 8 -TRAILING -> PAD 3 }T
( Note there is code in this.TOKEN which does this )
( DIFF: V5 version used; Zen&Staapl: DUP >R 2DUP C! 1 + 2DUP + 0 SWAP ! SWAP CMOVE R> )
: PACK$ ( b u a -- a; Build a counted string with u characters from b. Null fill.)
ALIGNED ( noop on JS celll=2 where not requiring alignment)
DUP >R OVER ( b u a u ; save address of word buffer )
DUP 0 CELLL UM/MOD DROP ( b y a u r; find remainder of chars if not exact number of cells)
- OVER + 0 SWAP ! ( b y a ; Store 0 in last cell)
2DUP C! ( store the character count first )
1+ SWAP CMOVE ( ; store characters in cells - 0 padded to end of cell)
R> ; ( leave only word buffer address )
( === TEXT INTERPRETER === Zen pg63 )
( === Numeric Output Zen pg64 DIGIT EXTRACT )
: DIGIT ( u -- c ; Convert digit u to a character.)
9 OVER < ( if u is greater than 9)
7 AND + ( add 7 to make it A-F)
48 + ; ( add ASCII 0 for offset)
: EXTRACT ( d base -- d c ; Extract least significant digit from d)
>R
0 R@ FM/MOD ( S: l rh qh R: b )
R> SWAP >R ( S: l rh b R: qh )
FM/MOD ( S: r ql R: qh )
R> ROT ( S: ql qh r )
DIGIT
;
T{ 123 0 10 EXTRACT -> 12 0 51 }T
( === Number formatting Zen pg65 <# HOLD #S SIGN #> )
: <# ( -- ; Initiate the numeric output process.)
PAD HLD ! ; ( use PAD as the number buffer)
: HOLD ( c -- ; Insert a character into the numeric output string.)
HLD @ ( get the digit pointer in HLD)
1- DUP HLD ! ( decrement HLD)
C! ; ( store c where HLD pointed to)
: HOLDS ( c u -- ; https://forth-standard.org/standard/core/HOLDS; prepend string to buffer )
BEGIN DUP WHILE 1- 2DUP + C@ HOLD REPEAT 2DROP ;
: # ( u -- u; Extract one digit from u and append the digit to output string.- ANS/eForth conflict eForth used single, ANS double )
\\ eFORTH: BASE @ EXTRACT HOLD
BASE @ ( get current base)
EXTRACT ( EXTRACT one digit from u)
HOLD ; ( save digit to number buffer)
: #S ( u -- 0 0 ; Convert u until all digits are added to the output string. - ANS/eForth conflict eForth used single, ANS double )
\\ eFORTH BEGIN # DUP WHILE REPEAT
BEGIN ( begin converting all digits)
# ( convert one digit)
2DUP OR WHILE ( repeat until u is divided to 0)
REPEAT ;
: SIGN ( n-- ; Add a minus sign to the numeric output string.)
0< ( if n is negative)
IF 45 HOLD THEN ; ( add a - sign to number string)
: #> ( d -- b u ; Prepare the output string to be TYPEed. - ANS/eForth conflict eForth used single, ANS double )
2DROP ( discard w)
HLD @ ( address of last digit)
PAD OVER - ; ( return address of 1st digit and length)
T{ 123 0 <# OVER SIGN #S #> SWAP COUNT SWAP COUNT SWAP COUNT NIP -> 3 49 50 51 }T ( hold="123" )
T{ -123 DUP ABS 0 <# #S ROT SIGN #> SWAP COUNT SWAP COUNT SWAP COUNT SWAP COUNT NIP -> 4 45 49 50 51 }T ( hold="-123" )
: EMIT ( c--; Send a character to the output device. Zen pg69)
'EMIT @EXECUTE ;
: SPACE ( -- ; Send the blank character to the output device. Zen pg70)
BL EMIT ; ( send out blank character)
: emits ( +n c -- ; Send n characters to output device)
SWAP 0 MAX FOR AFT DUP EMIT THEN NEXT DROP ; ( From Staapl and V5, not in Zen) ( TODO-ANS flagged as possible conflict)
: SPACES ( n -- ; Send n spaces to the output device. Zen pg70) ( ERRATA Zen has bad initial SWAP)
BL emits ;
T{ 60 EMIT SPACE 2 SPACES 61 EMIT -> }T
\\ use JS definition (hand coded on Arduino etc)
\\ : TYPE ( b u -- ; Output u characters from b)
\\ FOR AFT DUP C@ EMIT 1+ THEN NEXT DROP ;
: .$ ( a -- ) COUNT TYPE ; ( from Staapl, not in eForth)
( .$ is tested by ."| and others )
( === Number output Zen pg66 str HEX DECIMAL .R U.R U. . ? )
: str ( n -- b u ; Convert a signed integer to a numeric string)
DUP >R ( save a copy for sign)
ABS ( use absolute of n)
0 <# #S ( convert all digits)
R> SIGN ( add sign from n)
#> ; ( return number string addr and length)
( Set radix as base for numeric conversions)
: HEX ( --) 16 BASE ! ;
: DECIMAL ( --) 10 BASE ! ;
: .R ( n +n -- ; Display an integer in a field of n columns, right justified.)
>R str ( convert n to a number string)
R> OVER - SPACES ( print leading spaces)
TYPE ; ( print number in +n column format)
: U.R ( u+ n -- ; Display an unsigned integer in n column, right justified.)
>R ( save column number)
0 <# #S #> R> ( convert unsigned number)
OVER - SPACES ( print leading spaces)
TYPE ; ( print number in +n columns)
: U. ( u -- ; Display an unsigned integer in free format.)
0 <# #S #> ( convert unsigned number)
SPACE ( print one leading space)
TYPE ; ( print number)
: . ( w--; Display an integer in free format, preceded by a space.)
BASE @ 10 XOR ( if not in decimal mode)
IF U. EXIT THEN ( print unsigned number)
str SPACE TYPE ; ( print signed number if decimal)
: ? ( a -- ; Display the contents in a memory cell.)
@ . ; ( very simple but useful command)
T{ -123 5 .R 123 5 U.R 123 U. 123 . BASE ? -> }T
( === Numeric input Zen pg67-68 DIGIT? NUMBER? )
( ERRATA Zen NIP is used but not defined )
: DIGIT? ( c base -- u t ; Convert a character to its numeric value. A flag indicates success.)
>R ( save radix )
48 - ( character offset from digit 0 - would be better as '[ CHAR 0 ] LITERAL' but dont have '[')
42 OVER <
IF
32 - ( convert lower case to upper case )
THEN
9 OVER < ( is offset greater than 9? )
IF 7 - ( yes. offset it from digit A )
DUP ( n n )
10 < ( if n<10, the flag will be -1, and )
OR ( OR with n, result will be -1 )
THEN ( if n>10, the flag will be 0 and )
DUP ( OR result will still be n )
R> U< ; ( if n=/>radix, the digit is not valid )
T{ 50 10 DIGIT? -> 2 -1 }T
( TODO Note the EFORTH-ZEN-ERRATA in the docs v. code for NUMBER? means we drop testing the flag will reconsider when see how used )
( === Derived I/O Zen pg70 PACE SPACE SPACES TYPE CR )
( ERRATA Staapl calls it "KEY?" )
: ?KEY ( -- c T | F) ( Return input character and true, or a false if no input.)
'?KEY @EXECUTE ;
: KEY ( -- c ) ( Wait for and return an input character.)
0 ( Initial delay )
BEGIN
ms ( Introduce a delay, drops CPU from 100% to insignificant)
200 ( wait 0.5S if no keys w )
?KEY ( delay c T | delay F; Check for key )
UNTIL
NIP ; ( Drop delay )
( ERRATA Staapl has different flow, probably wrong)
: NUF? ( -- t) ( Return false if no input, else pause and if CR return true)
?KEY DUP ( -- c T T | F F; wait for a key-stroke)
IF 2DROP KEY
13 = ( return true if key is CR)
THEN ;
( TODO-TEST test ?KEY KEY NUF? )
: PACE ( --) ( Send a pace character for the file downloading process.)
11 EMIT ; ( 11 is the pace character)
( SPACE and SPACES and TYPE and CHARS, now emits moved earlier)
( ERRATA Zen has 15 instead of 13 and 11 instead of 10)
: CR ( --) ( Output carriage return line feed)
13 EMIT 10 EMIT ;
( CR tested after .( )
( === Moved up as needed for PARSE-NAME )
: ['] ' [COMPILE] LITERAL ; IMMEDIATE
: SOURCE TIB #TIB @ ; ( Repurposing TIB and #TIB for the pointer to buffer and length whatever input source )
( === Word Parser Zen pg72-73 PARSE parse )
( ERRATA Zen PARSE doesnt set >IN past the string, but the callers clearly assume it does.)
( ERRATA Zen pg72 is obviously broken as it doesn't even increment the pointer in the FOR loop)
( This version is based on v5, Staapl is significantly different )
( Also adapting to use code in https://forth-standard.org/standard/core/PARSE-NAME )
: /STRING ( a u n -- a'+n u-n ) TUCK - >R + R> ;
( See https://forth-standard.org/standard/core/PARSE-NAME)
: isspace? ( c -- f ) BL 1+ U< ;
: isnotspace? isspace? 0= ;
\\ TODO merge code from https://forth-standard.org/standard/core/PARSE-NAME note double WHILE
: xt-skip ( a n xt -- a' n'; Skip over any characters satisfying xt)
>R
BEGIN DUP
WHILE OVER C@ R@ EXECUTE
WHILE 1 /STRING
REPEAT THEN
R> DROP ;
: skip-till ( a n c -- a' n' )
>R BEGIN DUP
WHILE OVER C@ R@ = 0=
WHILE 1 /STRING
REPEAT THEN R> DROP ;
:NONAME ( delim <string> -- c-addr u : PARSE )
>R
SOURCE >IN @ /STRING ( a u ret: delim )
R@ BL = IF ['] isspace? xt-skip THEN ( a' u' ret: delim )
OVER SWAP ( a' a' u' ret: delim )
R@ BL = IF ['] isnotspace? xt-skip ELSE R@ skip-till THEN R> DROP ( a' a" u")
2DUP 1 MIN + SOURCE DROP - >IN !
DROP OVER - ;
' PARSE DEFER! \\ IS PARSE
: PARSE-NAME BL PARSE ;
( === Parsing Words Zen pg74 .( ( \\ CHAR TOKEN WORD )
: CHAR PARSE-NAME DROP C@ ; ( Parse a word and return its first character )
T{ CHAR ) -> 41 }T
: [CHAR] ( "name" <spaces> -- ) CHAR [COMPILE] LITERAL ; IMMEDIATE
: CTRL CHAR 31 AND ; ( Parse a word, return first character as a control )
T{ CTRL H -> 8 }T
: .( ( -- ) ( Output following string up to next )
[ CHAR ) ] LITERAL PARSE
( parse the string until next )
TYPE ; IMMEDIATE ( type the string to terminal )
T{ .( on consecutive ) CR .( lines )
T{ : foo .( output at compile time) ; -> }T
:NONAME ( -- a ; <string> ; Parse a word from input stream and copy it to name dictionary. : TOKEN )
PARSE-NAME ( parse out next space delimited string )
BYTEMASK MIN ( truncate it to 31 characters = nameMaxLength )
NP @ ( word buffer below name dictionary )
OVER - CELLL - PACK$ ; ( copy parsed string to word buffer )
' TOKEN DEFER!
T{ : foo TOKEN C@ ; foo xxx -> 3 }T
: WORD ( c -- a ; <string> ) ( Parse a word from input stream and copy it to code dictionary. Not if not in definition it will be overwritten by next)
PARSE ( parse out a string delimited by c )
HERE PACK$ ; ( copy the string into the word buffer )
T{ BL WORD yyyy DUP C@ SWAP CP @ - -> 4 0 }T
( === Dictionary Search Zen pg75-77 NAME>INTERPRET SAME? NAME? )
: NAME>INTERPRET ( na -- xt )
( Return a code address given a name address.)
2 CELLS - ( move to code pointer field )
@ ; ( get code field address )
: SAME? ( a1 a2 u -- a1 a2 f \\ -0+ ) ( See JS sameq )
( Compare u cells in two strings. Return 0 if identical.)
( NOTICE THIS IS CELLS NOT BYTES )
FOR ( scan u+1 cells ) ( a1 a2 ; R: u)
AFT ( skip the loop the first time ) ( a1 a2; R: u-n)
OVER ( copy a1 ) ( a1 a2 a1; R: u-n)
R@ CELLS + @ ( fetch one cell from a1) ( a1 a2 a1[u-n] R: u-n)
OVER ( copy a2 ) ( a1 a2 a1[u-n] a2 R: u-n)
R@ CELLS + @ ( fetch one cell from a2) ( a1 a2 a1[u-n] a2[u-n] R: u-n)
- ( compare two cells ) ( a1 a2 match=0 R: u-n)
?DUP ( a1 a2 0 | a1 a2 T T R: u-n)
IF ( if they are not equal ) ( a1 a2 T R: u-n)
R> DROP ( drop loop count ) ( a1 a2 T )
EXIT ( and exit with the difference as a flag )
THEN ( a1 a2 )
THEN ( a1 a2 R: u-n)
NEXT ( loop u times if strings are the same ) ( a1 a2; R: u-n-1)
FALSE ; ( then push the 0 flag on the stack ) ( a1 a2 0)
( This can replace the code definition of find, however it is approx 8x slower )
T{ BL WORD xxx DUP C@ 1+ PAD SWAP CMOVE PAD BL WORD xxx 4 SAME? >R 2DROP R> -> 0 }T
T{ BL WORD xxx DUP C@ 1+ PAD SWAP CMOVE PAD BL WORD xzx 4 SAME? >R 2DROP R> 0= -> 0 }T
: FIND-NAME ( caddr u -- na | F; see https://forth-standard.org/proposals/find-name#contribution-58)
( Note this ONLY currently works if caddr-- is a counted string )
( Search all context vocabularies for a string.)
CONTEXT ( address of context vocabulary stack )
DUP 2@ XOR ( are two top vocabularies the same? )
IF ( if not same )
CELL- ( backup the vocab address for looping )
THEN
>R ( save the prior vocabulary address )
BEGIN ( caddr u R: va )
R> CELL+ >R ( caddr u R: va'; get the next vocabulary address and save)
R@ @ ( is this a valid vocabulary? )
WHILE ( caddr u R: va' ; yes)
2DUP R@ @ ( caddr u caddr u va' R: va' )
FIND-NAME-IN ( caddr u na R: va' | caddr u F R: va')
?DUP ( word found here? )
UNTIL ( if not, go searching next vocabulary )
( caddr u na R: va)
R> DROP NIP NIP EXIT ( word is found, exit with na )
THEN ( caddr u R: va' ; goes here from the WHILE )
R> DROP 2DROP ( ; word is not found in all vocabularies )
FALSE ; ( F ; exit with a false flag )
: NAME? ( a -- ca na, a F )
( Search all context vocabularies for a string.)
DUP COUNT ( a caddr u )
FIND-NAME ( a na | a F)
?DUP
IF ( a na; word found)
NIP DUP NAME>INTERPRET SWAP ( ca na )
ELSE ( a )
FALSE ( a F )
THEN ;
( NAME>INTERPRET implicitly tested by find )
\\ TODO replace: T{ BL WORD TOKEN CONTEXT @ find -> BL WORD TOKEN CONTEXT @ FORTHfind }T
\\ TODO replace: T{ BL WORD TOKEN CONTEXT @ find NIP -> BL WORD TOKEN COUNT CONTEXT @ FIND-NAME-IN }T
\\ TODO replace: T{ BL WORD TOKEN CONTEXT @ find NIP -> BL WORD TOKEN COUNT FIND-NAME }T ( FIND-NAME searches all vocabs)
\\ TODO replace: T{ BL WORD TOKEN CONTEXT @ find -> BL WORD TOKEN NAME? }T ( Name searches all vocabs )
: FIND ( caddr -- c-addr 0 | xt 1 | xt -1 ; https://forth-standard.org/standard/core/FIND )
DUP COUNT ( caddr caddr' u )
FIND-NAME ( caddr na | caddr F )
?DUP IF
NIP DUP NAME>INTERPRET ( na xt )
SWAP immediate? ( xt b )
IF 1 ELSE -1 THEN
ELSE ( caddr )
0
THEN ;
\\ TODO-35-VOCAB this will definitely need attention
: MARKER NP @ CP @ CONTEXT @ DUP @ SWAP CURRENT @ DUP @ SWAP CREATE , , , , , ,
DOES> DUP @ CURRENT ! CELL+ DUP @ CURRENT @ !
CELL+ DUP @ CONTEXT ! CELL+ DUP @ CONTEXT @ !
CELL+ DUP @ CP ! CELL+ @ NP ! ;
\\ TODO replace: T{ BL WORD TOKEN CONTEXT @ find DROP ( xt ) -1 -> BL WORD TOKEN FIND ( xt -1 ) }T ( not immediate )
\\ TODO replace: T{ BL WORD XYZZY 0 OVER FIND }T ( failure case)
\\ TODO replace: T{ BL WORD THEN CONTEXT @ find DROP ( xt ) 1 -> BL WORD THEN FIND }T ( immediate)
( === Error Handling Zen pg80-82 CATCH THROW = moved in front of Text input )
: CATCH ( ca -- err#/0 )
( Execute word at ca and set up an error frame for it.)
SP@ >R ( save current stack pointer on return stack )
HANDLER @ >R ( save the handler pointer on return stack )
RP@ HANDLER ! ( save the handler frame pointer in HANDLER )
( ca ) EXECUTE ( execute the assigned word over this safety net )
R> HANDLER ! ( normal return from the executed word )
( restore HANDLER from the return stack )
R> DROP ( discard the saved data stack pointer )
0 ; ( push a no-error flag on data stack )
( EFORTH DIFFERENCE - eForth always THROWs, but Forth2012 doesnt throw if non-zero, since eForth use cases always have a err# )
( the Forth2012 definition servers both and is used)
: THROW ( err# -- err# )
( Reset system to current local error frame and update error flag.)
?DUP IF
HANDLER @ RP! ( expose latest error handler frame on return stack )
R> HANDLER ! ( restore previously saved error handler frame )
R> SWAP >R ( retrieve the data stack pointer saved )
SP! ( restore the data stack )
DROP
R>
THEN ; ( retrieved err# )
( Test is tricky - the "3" in bar is thrown away during hte "THROW" while 5 is argument to THROW )
T{ : bar 3 5 THROW 4 ; : foo 1 [ ' bar ] LITERAL CATCH 2 ; foo -> 1 5 2 }T
T{ : bar 3 ; : foo 1 [ ' bar ] LITERAL CATCH 2 ; foo -> 1 3 0 2 }T
( === Text input from terminal Zen pg 78: ^H TAP kTAP )
( EFORTH-ZEN-ERRATA CTRL used here but not defined. )
: ^H ( bot eot cur -- bot eot cur)
( Backup the cursor by one character.)
>R OVER ( bot eot bot --)
R@ < DUP ( bot<cur ? )
IF
( This should probably be vectored , on JS it needs BS BL BS to erase a char and position cursor )
[ CTRL H ] LITERAL 'ECHO @EXECUTE
BL 'ECHO @EXECUTE
[ CTRL H ] LITERAL 'ECHO @EXECUTE
THEN ( bot eot cur F|T -- )
R> + ; ( decrement cur, but not passing bot )
: TAP ( bottom eot current key -- bottom eot current )
( Accept and echo the key stroke and bump the cursor.)
DUP ( duplicate character )
'ECHO @EXECUTE ( echo it to display )
OVER C! ( store at current location )
1+ ; ( increment current pointer )
( Diff - Staapl doesnt check for 10 - crlf? split out as used by READ-LINE )
: crlf? ( c -- f; is key a return or line feed?)
DUP 10 = SWAP 13 = OR ;
: skipCRLF ( caddr u -- caddr' u' )
BEGIN
DUP IF OVER C@ crlf? ELSE FALSE THEN ( caddr u bool)
WHILE ( caddr u )
1- SWAP 1+ SWAP ( caddr' u')
REPEAT
;
: skipToCRLF ( caddr u -- caddr' u' ; caddr should point at first crlf and u' is size removed from end )
BEGIN
DUP IF OVER C@ crlf? 0= ELSE FALSE THEN ( caddr u bool)
WHILE ( caddr u )
1- SWAP 1+ SWAP ( caddr' u')
REPEAT
;
( ERRATA - Zen & V5 just check 13 and Ctrl-H, backspace can also be DEL and end of line can be 10 )
: kTAP ( bot eot cur key -- bot eot cur )
( Process a key stroke, CR or backspace.)
DUP crlf? 0=
IF ( bot eot cur key )
DUP [ CTRL H ] LITERAL = SWAP 127 = OR 0= ( bot eot cur f ; is key a backspace or DEL ? )
IF BL TAP ( bot eot cur' ; none of above, replace by space )
ELSE ^H ( bot eot cur' ; backup current pointer )
THEN
EXIT ( done this part )
THEN ( key is a return)
DROP ( discard bot and eot )
NIP DUP ; ( bot cur cur; duplicate cur to force ACCEPT to exit, Key not stored )
\\ ==== STRING HANDLING =====
\\ See docs/strings.md for documentation.
\\
\\ In order to handle Forth2012 strings which are typically addr+count, and traditional Forth (addr pointing to length)
\\ We define:
\\ $," that compiles a string into a dictionary
\\ do$ that pulls the string out of the dictionary,
\\ $"| S"| ."| abort" handlers that do something with a compiled string that immediately follows
\\ $"(C") S" ." ABORT" which compile a string, plus the handler
\\ See Zen pg71 and 93 and abort",ABORT" further down.
: do$ ( --a)
( Return the address of a compiled string.)
( Relies on assumption that do$ is part of definition of something e.g. $"| or ."| that is run time code for the string )
R> ( this return address must be preserved S: R0; R: R1... )
R@ ( get address of the compiled string S: R0 R1; R: R1... )
R> ( get another copy S: R0 R1 R1; R: R2... )
COUNT + ALIGNED >R ( replace it with addr after string; S: R0 R1; R: R1' R2... )
SWAP ( get saved address to top; S: R1 R0; R: R1' R2...)
>R ; ( restore the saved return address S: R1; R: R0 R1' R2 ...)
( Staapl has alternate definition: : $," [ CHAR " ] LITERAL PARSE HERE PACK$ C@ 1 + ALLOT ;)
( ERRATA v5 has obvious errata missing the + after COUNT; Zen ok; Staapl different )
: $," ( --) ( Moved earlier from Zen pg90)
( Compile a literal string up to next " .)
34 WORD ( move string to code dictionary)
COUNT + ALIGNED ( calculate aligned end of string)
CP ! ; ( adjust the code pointer)
: $"| ( -- a) do$ ; ( return string address only)
: ."| ( -- ) do$ .$ ; ( print compiled string )
: S"| ( -- caddr u) do$ COUNT ; ( Forth2012 version )
: $" ( -- addr) COMPILE $"| $," ; IMMEDIATE ( counted string)
T{ : foo $" hello" COUNT NIP ; foo -> 5 }T
: C" [COMPILE] $" ; IMMEDIATE ( Forth2012 name for $")
: ." ( -- ) COMPILE ."| $," ; IMMEDIATE ( compile string that will be printed )
T{ : foo ." hello" ; foo -> }T
( S" is more complex as it can compile, or just return a string )
: S" ( compile time: <string> ; interpret time: -- caddr u ; ANS version puts address and length )
STATE @
IF COMPILE S"| $,"
ELSE 34 PARSE stringBuffer PACK$ COUNT \\ Buffer is above used memory but always in Ram
THEN
; IMMEDIATE
T{ S" foo" TUCK + 1- C@ -> 3 CHAR o }T
: bu+@ ( b1 u -- b' u' c ) 1- >R COUNT R> SWAP ;
: c+! ( c a -- a+1 ) TUCK C! 1+ ;
: cmove\\ ( a b u -- u' ; Copy u bytes from a to b)
SWAP DUP >R >R ( a u r:b b )
BEGIN ( a' u' ret: b' b" )
?DUP WHILE ( a' u' r: b' b )
bu+@ ( a'++ u'-- c ret: b' b )
DUP [CHAR] " <> WHILE
CASE
[CHAR] \\ OF
bu+@ ( a' u' c' ret: b' b )
CASE
[CHAR] m OF 13 R> c+! 10 SWAP c+! >R ENDOF
[CHAR] x OF bu+@ 16 DIGIT? DROP 16 * >R bu+@ 16 DIGIT? DROP R> + R> c+! >R ENDOF
\\ Now the default group that add a single character
CASE
[CHAR] a OF 7 ENDOF
[CHAR] b OF 8 ENDOF
[CHAR] e OF 27 ENDOF
[CHAR] f OF 12 ENDOF
[CHAR] l OF 10 ENDOF
[CHAR] n OF 10 ENDOF
[CHAR] q OF [CHAR] " ENDOF
[CHAR] r OF 13 ENDOF
[CHAR] t OF 9 ENDOF
[CHAR] v OF 11 ENDOF
[CHAR] z OF 0 ENDOF
[CHAR] " OF [CHAR] " ENDOF
[CHAR] \\ OF [CHAR] \\ ENDOF
DUP ( default ambiguous condition but dont barf )
ENDCASE ( a' u' c ret: b' b)
DUP R> c+! >R
ENDCASE ( a' u' ret: b' b" )
ENDOF
DUP R> c+! >R ( normal character)
ENDCASE ( a' u' ret b' b" )
REPEAT
( a' u' c ret: b' b ; Ended because matched " )
2DROP
THEN ( a' r: b' b )
R> R> -
;
: pack\\$ ( b u a -- b' a; Build a counted and escaped string with u characters from b. Null fill.)
ALIGNED ( noop on JS celll=2 where not requiring alignment)
>R R@ ( b u a ret: a)
1+ SWAP cmove\\ ( b' u' ret: a; Pack in above count either u characters or terminated by " )
DUP R@ C! ( b'