From: Ulrich Hoffmann Date: Wed, 23 Oct 2019 10:31:55 +0000 (+0200) Subject: Cleanup new tokenizer and seedForth demo X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=8a9bbda88e7a17d6f9182daeef439c6d69852d80;p=preForth.git Cleanup new tokenizer and seedForth demo --- diff --git a/preForth/seedForth-tokenizer.fs b/preForth/seedForth-tokenizer.fs index cd84ed9..2901db8 100644 --- a/preForth/seedForth-tokenizer.fs +++ b/preForth/seedForth-tokenizer.fs @@ -4,17 +4,20 @@ 2166136261 >r BEGIN dup WHILE over c@ r> xor 16777619 um* drop $FFFFFFFF and >r 1 /string REPEAT 2drop r> ; -19 Constant #hashbits \ 0 < #hashbits < 16 - +15 Constant #hashbits 1 #hashbits lshift Constant #hashsize -\ #hashsize 1 - Constant tinymask -#hashsize 1 - Constant mask cr .( mask=) mask hex u. decimal +#hashbits 16 < [IF] + + #hashsize 1 - Constant tinymask + : fold ( x1 -- x2 ) dup #hashbits rshift xor tinymask and ; -\ : fold ( x1 -- x2 ) dup #hashbits rshift xor tinymask and ; +[ELSE] \ #hasbits has 16 bits or more -: fold ( x1 -- x2 ) dup #hashbits rshift swap mask and xor ; + #hashsize 1 - Constant mask + : fold ( x1 -- x2 ) dup #hashbits rshift swap mask and xor ; +[THEN] Create tokens #hashsize cells allot tokens #hashsize cells 0 fill @@ -25,8 +28,6 @@ Create tokens #hashsize cells allot tokens #hashsize cells 0 fill : ?token ( c-addr u -- x ) 2dup 'token dup @ IF >r cr type ." collides with token " r> @ name-see abort THEN nip nip ; - - VARIABLE OUTFILE : SUBMIT ( c -- ) @@ -39,7 +40,7 @@ Variable #tokens 0 #tokens ! :noname #tokens @ postpone LITERAL postpone SUBMIT postpone ; - cr #tokens @ 3 .r space 2dup type + \ cr #tokens @ 3 .r space 2dup type \ tell user about used tokens ?token ! 1 #tokens +! ; : Macro ( -- ) @@ -219,33 +220,6 @@ Macro \ ( -- ) postpone \ end-macro -0 [if] - -Macro Token ( -- ) - postpone Token -end-macro - -Macro Macro ( -- ) - Macro -end-macro - -Macro end-macro ( -- ) - postpone end-macro -end-macro - -Macro seed ( -- ) - postpone seed -end-macro - -[then] - -\ Macro Definer ( -- ) -\ Macro -\ postpone Token -\ postpone seed -\ postpone end-macro -\ end-macro - Macro Definer ( -- ) Macro postpone Token @@ -255,6 +229,3 @@ Macro Definer ( -- ) seed fun postpone end-macro end-macro - -Macro see ( -- ) - token@ ?dup 0= Abort" see cannot find name" name-see end-macro diff --git a/preForth/seedForthDemo.seedsource b/preForth/seedForthDemo.seedsource index 8d2f95b..fd003e3 100644 --- a/preForth/seedForthDemo.seedsource +++ b/preForth/seedForthDemo.seedsource @@ -9,103 +9,89 @@ \ cat seedForthDemo.seed | ./seedForth \ - PROGRAM seedForthDemo.seed +Definer Variable create 0 , ; -'o' 'k' \ push stack marker. Used eventually below. - -: ?ok ( o k -- o k ) 10 emit >r dup emit r> dup emit ; - -?ok - -10 emit '*' dup emit emit \ interpret numbers and words - -: 3* dup dup + + ; \ definitions -: 1- 1 - ; \ compile number and words +\ Missing primitives +: over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ; +: /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ; +: 2drop ( x1 x2 -- ) drop drop ; \ output utilities : cr ( -- ) 10 emit ; -: space ( -- ) 32 emit ; -: .digit ( n -- ) '0' + emit ; +: type ( c-addr u -- ) + BEGIN dup WHILE over c@ emit 1 /string REPEAT 2drop ; -: star ( -- ) '*' emit ; +\ Tester +: empty-stack ( i*x -- ) + BEGIN depth 0< WHILE 0 REPEAT + BEGIN depth WHILE drop REPEAT ; -: stars ( n -- ) - ?dup IF BEGIN star 1- ?dup 0= UNTIL THEN ; \ standard Forth control structures +Variable actual-depth ( actual-results ) 20 cells allot -: dash ( -- ) '-' emit ; +: nth-result ( n -- addr ) + cells actual-depth + ; -: dashes ( n -- ) BEGIN ?dup WHILE dash 1- REPEAT ; +: error ( i*x c-addr u -- ) + cr type empty-stack ; -: --- ( -- ) cr 80 dashes ; +: t{ ( i*x -- ) + '.' emit empty-stack ; -: spaces ( n -- ) - BEGIN ?dup 0= ?exit space 1- AGAIN ; \ another loop variation +: -> ( -- ) + depth actual-depth ! + BEGIN depth WHILE depth nth-result ! REPEAT ; ---- +: }t ( i*x -- ) + depth actual-depth @ - IF s" wrong number of results" error unnest THEN + BEGIN depth WHILE depth nth-result @ - IF s" incorrect result" error unnest THEN REPEAT ; -: countdown ( n -- ) - ?dup 0= ?exit dup cr .digit 1- countdown ; \ recursion +\ Test basics +t{ 10 '*' + -> 52 }t +t{ 0 0< -> 0 }t +t{ 1 0< -> 0 }t +t{ 2 0< -> 0 }t +t{ 1 negate 0< -> -1 }t +t{ 2 negate 0< -> -1 }t -cr '2' emit '*' emit '3' emit '=' emit 2 3* .digit \ interpret new definitions -9 countdown +\ output utilities +: space ( -- ) 32 emit ; ---- +: spaces ( n -- ) + BEGIN ?dup WHILE space 1 - AGAIN ; \ another loop variation -: another-count-down ( n -- ) - BEGIN dup WHILE dup cr .digit 1- REPEAT drop ; \ standard Forth control structures +: .digit ( n -- ) '0' + emit ; -5 another-count-down ---- +\ test conditionals : yes? ( f -- ) - IF 'Y' ELSE 'N' THEN emit ; \ standard Forth conditionals - -cr 0 yes? -1 yes? 1 yes? + IF 'Y' ELSE 'N' THEN ; \ standard Forth conditionals -?ok \ display ok again (for error analysis) +t{ 1 yes? -> 'Y' }t +t{ 0 yes? -> 'N' }t ---- \ utility words : 1+ ( x1 -- x2 ) 1 + ; - -: over ( x1 x2 -- x1 x2 x1 ) >r dup r> swap ; - -: 2drop ( x1 x2 -- ) drop drop ; - +: 1- ( x1 -- x2 ) 1 - ; : nip ( x1 x2 -- x2 ) swap drop ; - \ : c, ( c -- ) here 1 allot c! ; - -: /string ( x1 x2 x3 -- x4 x5 ) swap over - >r + r> ; - : count ( addr -- c-addr u ) dup 1+ swap c@ ; - -: type ( c-addr u -- ) - BEGIN dup WHILE over c@ emit 1 /string REPEAT 2drop ; - -here 5 c, 'H' c, 'e' c, 'l' dup c, c, 'o' c, - -cr count type - -\ more utility words - : < ( n1 n2 -- f ) - 0< ; : > ( n1 n2 -- f ) swap < ; : = ( x1 x2 -- f ) - 0= ; +: 2* ( x1 -- x2 ) dup + ; + +t{ here 5 c, count -> here 5 }t \ hex number output : .hexdigit ( n -- ) dup 9 > IF lit [ 'A' 10 - , ] ELSE '0' THEN + emit ; -: 2* ( x1 -- x2 ) dup + ; - - \ if we don't have u2/ but only 2* and 0< we need to implement u2/ with a loop. Candidate for primitive : u2/ ( x1 -- x2 ) 0 8 cells 1- BEGIN ?dup WHILE >r 2* over 0< IF 1+ THEN >r 2* r> r> 1- REPEAT nip ; @@ -131,217 +117,69 @@ cr count type : . ( n -- ) dup 0< IF '-' emit negate THEN u. ; -cr 42 . -43 . 44 . 45 . 46 . 47 . 48 . 49 . 50 . 51 . 52 . 53 . 54 . 55 . 56 . 57 . 58 . -cr 100 . -: hundred 100 ; - -cr 100 negate . \ display negative number - -cr here u. \ display larger number -cr - -?ok - ---- - -\ create and defining words - -\ Token V create 4 , \ new token for tokenizer and new variable like definition - -\ cr V @ u. \ get value: 4 - -\ ?ok - ---- +: .s ( i*x -- i*x ) + depth 0= ?exit >r .s r> dup . ; +\ Defining words +Definer Create ( -- ) create ; -\ We must split defining words into two parts. -\ 1) Build up the new word with function index in seedForth -\ 2) Let the tokenizer create its symbol table entry (then invoke 1) +Create dada 17 , +t{ dada @ -> 17 }t -\ : _value ( x -- ) create , does> @ ; \ a seedForth defining word 1) -\ Definer Value _value ( x -- ) Definer Value ( x -- ) create , does> @ ; -10 Value ten cr ten . - - -?ok - +10 Value ten +t{ ten -> 10 }t -( -- ) -\ : _variable create 0 , does> ; \ a seedForth defining word -\ Definer Variable _variable ( x -- ) - -Definer Variable ( -- ) create 0 , does> ; - -\ : _const create , does> @ ; -\ Definer Constant _const ( x -- ) Definer Constant ( x -- ) create , does> @ ; -0 Constant zero - -cr zero . \ constants are similar to values here: 0 - +5 Constant five +t{ five -> 5 }t -Variable v 5 v ! v @ . - -20 Constant twenty twenty . - - -?ok ---- \ structured data -\ : _field ( addr -- addr' ) create over , + does> @ + ; -\ Definer Field _field ( offset size -- offset' ) - -Definer Field ( offset size -- offset' ) create over , + does> @ + ; +Definer Field ( offset size -- offset' ) + create over , + does> @ + ; \ define structure 0 - -1 cells Field >name -2 cells Field >date - -Value person - -Definer Create ( -- ) create ; + 1 cells Field >name + 2 cells Field >date +Constant person Create p1 person allot +t{ p1 0 cells + -> p1 >name }t \ address calculation +t{ p1 1 cells + -> p1 >date }t \ address calculation +t{ person -> 3 cells }t \ size of structure -cr p1 u. \ start of structure - -p1 >name u. \ address calculation - -p1 >date u. \ address calculation - -cr person u. \ size of structure - -?ok ---- - - -\ Defered words +\ Deferred words : ' ( -- x ) key ; -' star Constant 'star cr 'star . - -\ : _defer create 'star , does> @ execute ; -\ Definer Defer _defer ( -- ) - -\ see Defer - -\ Macro defr Token seed _defer end-macro -\ see defr - - -Definer Defer ( -- ) create 'star , does> @ execute ; -see Defer +: uninitialized ( -- ) cr s" uninitialized execution vector" type ; +' uninitialized Constant 'uninitialized +Definer Defer ( -- ) create 'uninitialized , does> @ execute ; : >body ( xt -- body ) h@ 1 cells + ; : is ( xt -- ) ' >body ! ; -cr ' dash dup . execute \ get execution token of definition -cr - -Defer d1 +Defer d1 +' ten is d1 +t{ d1 d1 d1 -> ten ten ten }t +' five is d1 +t{ d1 d1 d1 -> five five five }t -\ ' star is d1 +t{ 3 4 + -> 7 }t -cr d1 d1 d1 \ display stars - - -' dash is d1 \ set behaviour of deferred word - -cr d1 d1 d1 \ now display dashes - -?ok - ---- - -cr 80 stars - -\ Tester - -: empty-stack ( i*x -- ) - BEGIN depth 0< WHILE 0 REPEAT - BEGIN depth WHILE drop REPEAT ; - -Variable actual-depth -( actual-results ) -20 cells allot - -: nth-result ( n -- addr ) - cells actual-depth + ; - -: error ( i*x c-addr u -- ) - cr type empty-stack ; - -: t{ ( i*x -- ) - '.' emit empty-stack ; - -: -> ( -- ) - depth actual-depth ! - BEGIN depth WHILE depth nth-result ! REPEAT ; - -Create wrong ( -- addr ) - ," wrong number of results" - -Create incorrect ( -- addr ) - ," incorrect result" - -: }t ( i*x -- ) - depth actual-depth @ - IF wrong count error unnest THEN - BEGIN depth WHILE depth nth-result @ - IF incorrect count error unnest THEN REPEAT ; - -?ok 2drop - -Create testing ( -- addr ) - ," testing" - -cr testing count type cr - -\ cr 't' emit 'e' emit 's' emit 't' emit 'i' emit 'n' emit 'g' emit cr - -\ t{ 3 4 + -> 7 }t -\ t{ 3 4 + -> 8 }t -\ t{ 3 4 + -> 1 2 }t - -\ fun: twice -\ new key dup compile, key + compile, key unnest compile, - -: twice ( x -- 2x ) - dup + ; - -t{ 2 twice -> 4 }t - -\ cr 2 twice . - -Create area 1 , - -t{ area @ -> 1 }t -t{ area 2 cells - @ -> 0 }t \ extract the dummy Does> field. - -t{ 1 2 couple -> 129 dup + }t -t{ 258 -> 129 dup + }t -t{ -1 2 + -> 1 }t - -: large 12345 ; -t{ large -> 12340 5 + }t - -: negative -12345 ; -t{ negative -> -12340 5 - }t +\ catch and throw tests t{ 10 ' dup catch -> 10 10 0 }t @@ -350,26 +188,27 @@ t{ 10 ' dup catch -> 10 10 0 }t t{ 1 ' err99 catch -> 2 0 }t t{ 5 9 ' err99 catch nip -> 5 99 }t + +\ Test for sp! + : rot ( a b c -- b c a ) >r swap r> swap ; t{ 10 sp@ 20 30 rot sp! -> 10 }t +\ Test for rp! : rp!-test ( -- ) rp@ 10 >r 20 >r 30 >r rp! ; t{ 99 rp!-test -> 99 }t -t{ 0 0< -> 0 }t -t{ 1 0< -> 0 }t -t{ 2 0< -> 0 }t -t{ 1 negate 0< -> -1 }t -t{ 2 negate 0< -> -1 }t +\ Test string Literals : greeting ( -- ) s" a string literal" ; - t{ greeting nip -> 16 }t +\ String comparison + : compare ( c-addr1 u1 c-addr2 u2 -- n ) rot BEGIN \ ( c-addr1 c-addr2 u1 u2 ) @@ -386,13 +225,17 @@ t{ greeting nip -> 16 }t dup 0= IF 0 ELSE 1 THEN THEN >r 2drop 2drop r> ; -t{ wrong count wrong count compare -> 0 }t -t{ wrong count incorrect count compare -> 1 }t +: abc ( -- c-addr u ) s" abc" ; +: def ( -- c-addr u ) s" def" ; -: .s ( i*x -- i*x ) - depth 0= ?exit >r .s r> dup . ; +t{ abc abc compare -> 0 }t +t{ def def compare -> 0 }t +t{ abc def compare -> -1 }t +t{ def abc compare -> 1 }t +\ Some general memory allocation words + : alloc ( u -- addr ) here swap allot ; @@ -400,7 +243,6 @@ t{ wrong count incorrect count compare -> 1 }t drop ; - \ ----------------------------------------------- : done ( -- ) cr s" done" type cr ; done