kapunta revidoval tento gist . Přejít na revizi
1 file changed, 1 insertion, 1 deletion
thue.4
| @@ -48,7 +48,7 @@ | |||
| 48 | 48 | : put ( r i -- ) >B >r 1 side@ r> swap cmove ; | |
| 49 | 49 | : replace ( r i -- ) over restrict >r 2dup adjust put r> to L ; | |
| 50 | 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 ; | |
| 51 | + | : pass ( -- f ) first begin dup while dup match if 1 exit then @ repeat ; | |
| 52 | 52 | : eval begin B. pass 0= until ; | |
| 53 | 53 | ||
| 54 | 54 | : run ( s l -- ) parse eval ; | |
kapunta revidoval tento gist . Přejít na revizi
1 file changed, 1 insertion, 1 deletion
thue.4
| @@ -1,4 +1,4 @@ | |||
| 1 | - | ( Thue interpreter | |
| 1 | + | ( Thue interpreter for pForth | |
| 2 | 2 | 07.09.2025 ) | |
| 3 | 3 | ||
| 4 | 4 | 0 value B 0 value L | |
kapunta revidoval tento gist . Přejít na revizi
1 file changed, 56 insertions
thue.4(vytvořil soubor)
| @@ -0,0 +1,56 @@ | |||
| 1 | + | ( Thue interpreter | |
| 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 | |