thue.4 - Opengist

thue.4 · 2.1 KiB · Groff Raw 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