Rewriting of recognizer stack tool

parent af5ef0a4
...@@ -766,6 +766,8 @@ Plugin endcase, ( x1 .. xn n -- ) ...@@ -766,6 +766,8 @@ Plugin endcase, ( x1 .. xn n -- )
Plugin do, ( -- do-token ) Plugin do, ( -- do-token )
Plugin ?do, ( -- ?do-token ) Plugin ?do, ( -- ?do-token )
Plugin +do, ( -- ?do-token )
Plugin -do, ( -- ?do-token )
Plugin for, ( -- for-token ) Plugin for, ( -- for-token )
Plugin loop, ( do-token / ?do-token -- ) Plugin loop, ( do-token / ?do-token -- )
Plugin +loop, ( do-token / ?do-token -- ) Plugin +loop, ( do-token / ?do-token -- )
...@@ -1749,6 +1751,7 @@ T has? relocate H ...@@ -1749,6 +1751,7 @@ T has? relocate H
>CROSS >CROSS
Ghost (do) Ghost (?do) 2drop Ghost (do) Ghost (?do) 2drop
Ghost (+do) Ghost (-do) 2drop
Ghost (for) drop Ghost (for) drop
Ghost (loop) Ghost (+loop) Ghost (-loop) 2drop drop Ghost (loop) Ghost (+loop) Ghost (-loop) 2drop drop
Ghost (next) drop Ghost (next) drop
...@@ -3613,6 +3616,14 @@ Cond: ENDCASE endcase, ;Cond ...@@ -3613,6 +3616,14 @@ Cond: ENDCASE endcase, ;Cond
0 compile (?do) ?domark, (leave) 0 compile (?do) ?domark, (leave)
branchtomark, 2 to1 ; ' (?do,) plugin-of ?do, branchtomark, 2 to1 ; ' (?do,) plugin-of ?do,
: (+do,) ( -- target-addr )
0 compile (+do) ?domark, (leave)
branchtomark, 2 to1 ; ' (+do,) plugin-of +do,
: (-do,) ( -- target-addr )
0 compile (-do) ?domark, (leave)
branchtomark, 2 to1 ; ' (-do,) plugin-of -do,
: (for,) ( -- target-addr ) : (for,) ( -- target-addr )
compile (for) branchtomark, ; ' (for,) plugin-of for, compile (for) branchtomark, ; ' (for,) plugin-of for,
...@@ -3633,6 +3644,8 @@ Cond: ENDCASE endcase, ;Cond ...@@ -3633,6 +3644,8 @@ Cond: ENDCASE endcase, ;Cond
Cond: DO do, ;Cond Cond: DO do, ;Cond
Cond: ?DO ?do, ;Cond Cond: ?DO ?do, ;Cond
Cond: +DO +do, ;Cond
Cond: -DO -do, ;Cond
Cond: FOR for, ;Cond Cond: FOR for, ;Cond
Cond: LOOP 1 ncontrols? loop, ;Cond Cond: LOOP 1 ncontrols? loop, ;Cond
......
...@@ -905,7 +905,7 @@ Defer 'cold ( -- ) \ gforth tick-cold ...@@ -905,7 +905,7 @@ Defer 'cold ( -- ) \ gforth tick-cold
\G Hook (deferred word) for things to do right before interpreting the \G Hook (deferred word) for things to do right before interpreting the
\G OS command-line arguments. Normally does some initializations that \G OS command-line arguments. Normally does some initializations that
\G you also want to perform. \G you also want to perform.
' noop IS 'cold :noname default-recognizer $boot ; IS 'cold
[THEN] [THEN]
: cold ( -- ) \ gforth : cold ( -- ) \ gforth
......
...@@ -71,40 +71,40 @@ AConstant r:dnum ...@@ -71,40 +71,40 @@ AConstant r:dnum
THEN THEN
drop r:fail ; drop r:fail ;
\ generic stack get/set \ generic deque get/set
$10 Constant max-stack# : deque@ ( deque -- x1 .. xn n )
\G fetch everything from the generic deque to the data stack
$@ dup cell/ >r bounds cell- swap cell- -DO I @ cell -LOOP r> ;
: deque! ( x1 .. xn n deque -- )
\G set the generic deque with values from the data stack
>r cells r@ $!len
r> $@ bounds DO I ! cell +LOOP ;
: get-stack ( rec-addr -- xt1 .. xtn n ) : deque: ( n "name" -- )
dup @ dup >r cells bounds swap ?DO \G create a named deque with n cells space
I @ drop Variable ;
cell -LOOP r> ;
: set-stack ( xt1 .. xtn n rec-addr -- ) AVariable default-recognizer
over max-stack# u>= abort" Too many items"
2dup ! cell+ swap cells bounds ?DO
I !
cell +LOOP ;
Variable forth-recognizer
\G The system recognizer \G The system recognizer
' rec:word A, ' rec:num A, max-stack# 2 - cells allot here default-recognizer !
2 forth-recognizer ! 2 cells , ' rec:word A, ' rec:num A,
\ ' num-recognizer ' word-recognizer 2 forth-recognizer set-recognizers
default-recognizer AValue forth-recognizer
: get-recognizers ( -- xt1 .. xtn n ) : get-recognizers ( -- xt1 .. xtn n )
\G push the content on the recognizer stack \G push the content on the recognizer stack
forth-recognizer get-stack ; forth-recognizer deque@ ;
: set-recognizers ( xt1 .. xtn n ) : set-recognizers ( xt1 .. xtn n )
\G set the recognizer stack from content on the stack \G set the recognizer stack from content on the stack
forth-recognizer set-stack ; forth-recognizer deque! ;
\ recognizer loop \ recognizer loop
: map-recognizer ( addr u rec-addr -- tokens table ) : map-recognizer ( addr u rec-addr -- tokens table )
\G apply a recognizer stack to a string, delivering a token \G apply a recognizer stack to a string, delivering a token
dup cell+ swap @ cells bounds ?DO $@ bounds ?DO
2dup I -rot 2>r 2dup I -rot 2>r
perform dup r:fail <> IF 2rdrop UNLOOP EXIT THEN drop perform dup r:fail <> IF 2rdrop UNLOOP EXIT THEN drop
2r> 2r>
......
...@@ -71,6 +71,13 @@ ...@@ -71,6 +71,13 @@
\G initializes a string to empty (doesn't look at what was there before). \G initializes a string to empty (doesn't look at what was there before).
>r r@ off s" " r> $! ; >r r@ off s" " r> $! ;
: $boot ( addr -- )
\G take string from dictionary to allocated memory
dup >r $@ r@ off r> $! ;
: $save ( addr -- )
\G push string to dictionary for savesys
dup >r $@ here r> ! dup , here swap dup aligned allot move ;
\ dynamic string handling 12dec99py \ dynamic string handling 12dec99py
: $split ( addr u char -- addr1 u1 addr2 u2 ) \ gforth-string string-split : $split ( addr u char -- addr1 u1 addr2 u2 ) \ gforth-string string-split
......
...@@ -47,6 +47,7 @@ ...@@ -47,6 +47,7 @@
w/o bin create-file throw >r w/o bin create-file throw >r
update-image-included-files update-image-included-files
update-image-order update-image-order
default-recognizer $save
update-maintask update-maintask
here forthstart - forthstart 2 cells + ! here forthstart - forthstart 2 cells + !
forthstart forthstart
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment