thue.4
· 2.1 KiB · Groff
Ham
Playground
( Thue interpreter for pForth
07.09.2025 )
0 value B 0 value L
10000 constant maxlen
: >B ( i -- a ) B + ;
( : line here dup to B maxlen accept to L ; )
: B. B L type cr ;
( rule layout
- 1 cell - next rule
- 2 cells - pointer to a string and its length for the left-hand side
- 2 cells - pointer to a string and its length for the right-hand side )
0 value first 0 value last
: >side ( r i -- a ) 2* 1+ cells + ;
: length ( r i -- 0 ) >side cell+ @ ;
: side@ ( r i -- s l ) >side dup @ swap cell+ @ ;
0 value S 0 value SL
: rewind ( s l -- n ) to SL to S L SL - dup 0< if drop 0 then 1+ ;
: match ( i -- f ) >B SL S over compare 0= ;
: index ( s l -- 0 | i 1 ) rewind 0 ?do i match if i unloop 1 exit then loop 0 ;
0 value fin
: open r/o open-file throw to fin ;
: close fin close-file throw ;
: whole ( status -- ) throw 0= if abort" Line too long!" then ;
: line here dup to B maxlen fin read-line whole dup to L chars allot align ;
: rule ( r -- ) dup 0 side@ type ." ::=" 1 side@ type cr ;
: list first begin dup while dup rule @ repeat drop ;
: first! first 0= if here to first then ;
: last! last if here last ! then here to last ;
: record ( i -- ) first! last! 0 , B , dup , 3 + dup >B , L swap - , ;
: ::= ( -- i ) s" ::=" index 0= if abort" No rule!" then ;
: rule ( -- f ) line ::= L 3 = if not else record 0 then ;
: parse open begin rule until line close ;
: restrict ( r -- n ) L over 0 length - swap 1 length + dup maxlen > if
abort" Out of space!" then ;
: dir ( r -- f ) dup 0 length swap 1 length < ;
: frame ( r i -- n ) swap 0 length + L swap - ;
: places ( r i -- s d ) >B >r dup 0 length r@ + swap 1 length r> + ;
: by ( r i -- s d l ) 2dup frame >r places r> ;
: adjust ( r i -- ) over dir if by cmove> else by cmove then ;
: put ( r i -- ) >B >r 1 side@ r> swap cmove ;
: replace ( r i -- ) over restrict >r 2dup adjust put r> to L ;
: match ( -- f ) 0 side@ index if replace 1 else 0 then ;
: pass ( -- f ) first begin dup while dup match if 1 exit then @ repeat ;
: eval begin B. pass 0= until ;
: run ( s l -- ) parse eval ;
s" test.thue" run
| 1 | ( Thue interpreter for pForth |
| 2 | 07.09.2025 ) |
| 3 | |
| 4 | 0 value B 0 value L |
| 5 | 10000 constant maxlen |
| 6 | |
| 7 | : >B ( i -- a ) B + ; |
| 8 | ( : line here dup to B maxlen accept to L ; ) |
| 9 | : B. B L type cr ; |
| 10 | |
| 11 | ( rule layout |
| 12 | - 1 cell - next rule |
| 13 | - 2 cells - pointer to a string and its length for the left-hand side |
| 14 | - 2 cells - pointer to a string and its length for the right-hand side ) |
| 15 | 0 value first 0 value last |
| 16 | : >side ( r i -- a ) 2* 1+ cells + ; |
| 17 | : length ( r i -- 0 ) >side cell+ @ ; |
| 18 | : side@ ( r i -- s l ) >side dup @ swap cell+ @ ; |
| 19 | |
| 20 | 0 value S 0 value SL |
| 21 | : rewind ( s l -- n ) to SL to S L SL - dup 0< if drop 0 then 1+ ; |
| 22 | : match ( i -- f ) >B SL S over compare 0= ; |
| 23 | : index ( s l -- 0 | i 1 ) rewind 0 ?do i match if i unloop 1 exit then loop 0 ; |
| 24 | |
| 25 | 0 value fin |
| 26 | : open r/o open-file throw to fin ; |
| 27 | : close fin close-file throw ; |
| 28 | : whole ( status -- ) throw 0= if abort" Line too long!" then ; |
| 29 | : line here dup to B maxlen fin read-line whole dup to L chars allot align ; |
| 30 | |
| 31 | : rule ( r -- ) dup 0 side@ type ." ::=" 1 side@ type cr ; |
| 32 | : list first begin dup while dup rule @ repeat drop ; |
| 33 | |
| 34 | : first! first 0= if here to first then ; |
| 35 | : last! last if here last ! then here to last ; |
| 36 | : record ( i -- ) first! last! 0 , B , dup , 3 + dup >B , L swap - , ; |
| 37 | : ::= ( -- i ) s" ::=" index 0= if abort" No rule!" then ; |
| 38 | : rule ( -- f ) line ::= L 3 = if not else record 0 then ; |
| 39 | : parse open begin rule until line close ; |
| 40 | |
| 41 | : restrict ( r -- n ) L over 0 length - swap 1 length + dup maxlen > if |
| 42 | abort" Out of space!" then ; |
| 43 | : dir ( r -- f ) dup 0 length swap 1 length < ; |
| 44 | : frame ( r i -- n ) swap 0 length + L swap - ; |
| 45 | : places ( r i -- s d ) >B >r dup 0 length r@ + swap 1 length r> + ; |
| 46 | : by ( r i -- s d l ) 2dup frame >r places r> ; |
| 47 | : adjust ( r i -- ) over dir if by cmove> else by cmove then ; |
| 48 | : put ( r i -- ) >B >r 1 side@ r> swap cmove ; |
| 49 | : replace ( r i -- ) over restrict >r 2dup adjust put r> to L ; |
| 50 | : match ( -- f ) 0 side@ index if replace 1 else 0 then ; |
| 51 | : pass ( -- f ) first begin dup while dup match if 1 exit then @ repeat ; |
| 52 | : eval begin B. pass 0= until ; |
| 53 | |
| 54 | : run ( s l -- ) parse eval ; |
| 55 | |
| 56 | s" test.thue" run |
| 57 |