\ control.fth provides control words for interpreter mode \ Copyright (C) Gerry Jackson 2009 \ This software is free; you can redistribute it and/or modify it in \ any way provided you acknowledge the original source and copyright \ This program is distributed in the hope that it will be useful, \ but WITHOUT ANY WARRANTY; without even the implied warranty of \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. \ ------------------------------------------------------------------------------ \ Version 1.1 \ It makes use of the K stack (see kstack.fth) \ Words provided are: [begin] [until] [while] [repeat] \ [do] [loop] [+loop] [i] [j] [unloop] [leave] \ [case] [of] [endof] [endcase] \ They behave much the same as the compiled versions, in particular the \ end of loop behaviour of [do] [loop]s is identical to compiled do loops. \ All control structures must be properly nested. \ Also the following which have different behaviour \ [label] ( "name" -- ) \ Parses the following name only. Provides a label is never executed \ \ [exit] ( "name" -- ) ( K: [do]-sys -- ) must be within a [do] \ loop and exits to name which must follow a [loop] or [+loop] .( control.fth loading ...) cr \ ---[ Helpers ]---------------------------------------------------------------- [undefined] ndup [if] : ndup ( xn ... x1 +n -- xn ... x1 xn ... x1 ) dup 0 ?do dup pick swap loop drop ; [then] : dupnstrings ( can un...ca1 u1 +n -- can un...ca1 u1 +n can un...ca1 u1 +n ) dup 2* 1+ ndup ; : dropnstrings ( can un ... ca1 u1 +n -- ) dup 2* 1+ ndrop ; \ ---[ Helpers for skipping text ]---------------------------------------------- char Z char A - constant charZ-A char a char A - constant chara-A : char>lower ( ch1 -- ch2 ) dup [char] A - charZ-A u> if exit then chara-A + ( -- ch2 ) ; : string>lower ( caddr u -- ) 0 ?do dup c@ char>lower over c! char+ ( -- caddr' ) loop drop ; 0 [if] \ Compare string (ca u) with n strings, return true if any of them match : comparestrings ( can un ... ca1 u1 +n ca u -- f ) rot >r 0 -rot r> 0 ( -- can un ... ca1 u1 f1 ca u n 0 ) ?do 2>r -rot 2r@ compare ( -- can un ... ca2 u2 f1 f2 ) 0= or 2r> ( -- can un ... ca2 u2 f1' ca u ) loop 2drop ( -- f ) ; [then] \ Compare string (ca u) with n strings, return k if it matched the kth string \ otherwise 0. Assumes n>0 : comparestrings ( can un ... ca1 u1 +n ca u -- f ) rot >r 0 0 r> 0 ( -- can un ... ca1 u1 ca u k f n 0 ) do ?dup if 2swap 2drop \ Already matched else 1+ >r 2swap 2over compare 0= r> swap then loop and nip nip ; : get-word ( -- caddr u ) begin bl word count dup 0= ( -- caddr u f ) while 2drop refill 0= ( -- f2 ) abort" Premature end of file" repeat ; \ skip over the first of the strings given by can un ... ca1 u1 \ Note these strings must be in lower case to be recognised. \ get-word uses WORD instead of PARSE-NAME so that the input buffer \ is not converted to lower case : skipover ( can un ... ca1 u1 +n -- k ) begin dupnstrings get-word 2dup string>lower comparestrings ?dup ( -- can un ... ca1 u1 n [ k k | 0 ] ) until >r dropnstrings r> ; \ Buffer for storing a name to be skipped over 32 constant sbsize create skipbuf sbsize chars allot \ ---[ Tokens for checking correctness of control structures ]------------------ 1 constant dest-tok 2 constant do-tok 3 constant case-tok 4 constant of-tok : ?tok ( n -- ) \ Check n matches the top of the K stack k@ <> abort" Mismatch in control structure" ; : toknkdrop ( K: x1 ... xn +n tok -- ) kdrop nkdrop ; : ?dest dest-tok ?tok ; : ?do-tok do-tok ?tok ; \ ---[ Interpreter mode control words ]----------------------------------------- \ Unlike [IF] [ELSE] and [THEN] these control words are not made immediate as \ it seems unlikely that they would be used within colon definitions. Is \ this true or not? This may be changed. : [begin] ( K: -- x1 ... xn +n tok ) save-input n>k dest-tok >k ; : [repeat] ( K: x1 ... xn +n tok -- x1 ... xn +n tok ) ?dest k> nk@ restore-input abort" Cannot loop back" >k ; : [until] ( f -- ) ( K: x1 ... xn +n tok -- x1 ... xn +n tok | ) if ?dest toknkdrop else [repeat] then ; : [while] ( f -- ) ( K: x1 ... xn +n tok -- x1 ... xn +n tok | ) ?dest 0= if toknkdrop s" [repeat]" 1 skipover drop then ; : [do] ( n1 n2 -- ) ( K: -- x1 ... xn +n tok n2 n1 2 tok2 ) [begin] 2 n>k do-tok >k ; : exitloop s" [+loop]" s" [loop]" 2 skipover drop ; : [?do] ( n1 n2 -- ) ( K: -- x1 ... xn +n tok n2 n1 2 tok2 ) 2dup = if 2drop exitloop else [do] then ; -1 1 rshift invert constant minint \ hex 80...0 ms bit set : [+loop] ( step -- ) ( K: x1 ... xn +n tok i lim 2 tok2 -- ditto | ) >r ?do-tok kdrop nk> drop ( -- lim i ) ( K: -- x1 ... xn +n tok ) 2dup r@ + 2swap ( -- lim i' lim i ) swap - minint + ( -- lim i' n1 ) dup r@ + ( -- lim i' n1 n2 ) r@ 0> if < r> drop ( -- lim i' f ) else r> 0< if > else 2drop false then ( -- lim i' f ) then if [repeat] 2 n>k do-tok >k else 2drop toknkdrop then ; : [loop] 1 [+loop] ; : [i] ( -- i ) ( K: i lim 2 tok ) ?do-tok k> nk@ drop nip swap >k ; : [j] ( -- j ) ( K: j lim 2 tok2 x1 ... xn +n tok i lim 2 tok2 ) ?do-tok k> nk> k> nk> [i] >r n>k >k n>k >k r> ; : [unloop] ( K: x1 ... xn +n tok i lim 2 tok2 -- ) ?do-tok toknkdrop toknkdrop ; \ Provide a named label, simply ignores the next word : [label] ( "name" -- ) parse-name 2drop ; \ [exit] is used after [unloop] to scan forward in the text file to \ just beyond name which should be outside the [do] loop. [exit] scans past \ the first [loop] or [+loop] before scanning for name \ ?? Should we allow a backward [exit] or [goto] : [exit] ( "name" -- ) parse-name dup sbsize > abort" Destination name too long" skipbuf swap 2dup 2>r move 2r@ string>lower exitloop 2r> 1 skipover drop ; : [leave] [unloop] exitloop ; : [case] ( K: -- tok ) case-tok >k ; \ >[endcase] ensures that nested [case] statements are skipped : (>[endcase]) s" [case]" s" [endcase]" 2 skipover 2 = if recurse then ; : >[endof] begin s" [case]" s" [endof]" 2 skipover 1- while (>[endcase]) repeat ; : [of] ( x1 x2 -- x1 | ) ( K: tok1 -- tok1 tok2 ) case-tok ?tok over = if drop of-tok >k else >[endof] then ; : >[endcase] begin s" [case]" s" [endcase]" 2 skipover 1- while (>[endcase]) repeat ; : [endof] ( K: tok1 tok2 -- ) of-tok ?tok kdrop kdrop >[endcase] ; : [endcase] ( x -- ) ( K: tok -- ) case-tok ?tok kdrop drop ; .( control.fth loaded. ) .s