Adding infix and parsing example.

examples/infix/infix_generic.fs

@@ -0,0 +1,24 @@
+#! /usr/bin/env ueforth
+
+vocabulary infix   infix definitions
+
+variable pending
+: token ( -- a ) >in @ tib + ;
+: full? ( -- f ) >in @ #tib @ < ;
+: (   token 0
+      begin full? over 0< 0= and while
+        token c@ [char] ( = if 1+ then
+        token c@ [char] ) = if 1- then
+        1 >in +!
+      repeat
+      drop token over - 1- 0 max
+      dup 0= pending ! evaluate ; immediate
+: scarf   bl parse evaluate
+          pending @ if postpone ( then ;
+: enact   state @ if , else execute then ;
+: +   scarf ['] + enact ; immediate
+: -   scarf ['] - enact ; immediate
+: *   scarf ['] * enact ; immediate
+: /   scarf ['] / enact ; immediate
+
+forth definitions

examples/infix/infix_parsing.fs

@@ -0,0 +1,87 @@
+#! /usr/bin/env ueforth
+
+needs parsing.fs
+also internals
+
+: space? ( ch -- f )
+   dup bl =  over nl = or  over 10 = or  swap 9 = or ;
+
+kind <SPACE>
+  {{ }}
+  {{ @token space? 0= throw +token <SPACE> }}
+
+: st'  postpone <SPACE> postpone t' postpone <SPACE> ; immediate
+: st"  postpone <SPACE> postpone t" postpone <SPACE> ; immediate
+
+kind <DIGIT>
+  {{ [char] 0 [char] 9 []token [char] 0 - }}
+
+: letnum? ( ch -- f )
+   dup [char] 0 [char] 9 within
+   over [char] A [char] Z within or
+   over [char] a [char] z within or
+   swap [char] _ = or ;
+
+kind <IDENTIFIER>
+  {{ >in @ tib + 0 begin @token letnum? while 1+ +token repeat dup 0= throw }}
+
+kind <NUMBER'>
+  {{ <DIGIT> 1 }}
+  {{ <DIGIT> <NUMBER'> rot over 0 do 10 * loop -rot 1+ >r + r> }}
+kind <NUMBER>
+  {{ <NUMBER'> drop aliteral }}
+
+kind <FORTH>
+  {{ [char] ] parse evaluate }}
+ 
+kind <EXPRESSION'>
+
+kind <IDENTIFIERS>
+  {{ }}
+  {{ <SPACE> <IDENTIFIER> <SPACE> evaluate <IDENTIFIERS> }}
+
+kind <FACTOR>
+  {{ <SPACE> <IDENTIFIER> <SPACE> evaluate <IDENTIFIERS> }}
+  {{ <SPACE> <NUMBER> <SPACE> }}
+  {{ st' ( <EXPRESSION'> st' ) }}
+  {{ st' [ <FORTH> }}
+
+kind <TERM>
+  {{ <FACTOR> }}
+  {{ <FACTOR> st' * <TERM> postpone * }}
+  {{ <FACTOR> st' / <TERM> postpone / }}
+  {{ <FACTOR> st" mod" <TERM> postpone mod }}
+  {{ <FACTOR> st" and" <TERM> postpone and }}
+
+kind <SIMPLE-EXPRESSION>
+  {{ <TERM> }}
+  {{ <TERM> st' + <SIMPLE-EXPRESSION> postpone + }}
+  {{ <TERM> st' - <SIMPLE-EXPRESSION> postpone - }}
+  {{ <TERM> st" or" <SIMPLE-EXPRESSION> postpone or }}
+  {{ st' + <SIMPLE-EXPRESSION> }}
+  {{ st' - <SIMPLE-EXPRESSION> postpone negate }}
+
+kind <EXPRESSION>
+  {{ <SIMPLE-EXPRESSION> }}
+  {{ <SIMPLE-EXPRESSION> st' = <EXPRESSION> postpone = }}
+  {{ <SIMPLE-EXPRESSION> st" <>" <EXPRESSION> postpone <> }}
+  {{ <SIMPLE-EXPRESSION> st' < <EXPRESSION> postpone < }}
+  {{ <SIMPLE-EXPRESSION> st" <=" <EXPRESSION> postpone <= }}
+  {{ <SIMPLE-EXPRESSION> st" >=" <EXPRESSION> postpone >= }}
+  {{ <SIMPLE-EXPRESSION> st' > <EXPRESSION> postpone > }}
+
+' <EXPRESSION'> :{{ <EXPRESSION> }}
+
+kind <STATEMENTS>
+  {{ <EXPRESSION> <STATEMENTS> }}
+  {{ st' } }}
+
+kind def
+  {{ : st' { postpone { st' { <STATEMENTS> postpone ; }}
+
+kind on
+  {{ ' :{{ st' { <STATEMENTS> postpone }} }}
+
+kind expr
+  {{ :noname <EXPRESSION> postpone ; execute }}
+

examples/infix/infix_ueforth.fs

@@ -0,0 +1,22 @@
+#! /usr/bin/env ueforth
+
+vocabulary infix   infix definitions   also internals
+
+: token ( -- a ) >in @ tib + ;
+: full? ( -- f ) >in @ #tib @ < ;
+: (   token 0
+      begin full? over 0< 0= and while
+        token c@ [char] ( = if 1+ then
+        token c@ [char] ) = if 1- then
+        1 >in +!
+      repeat
+      drop token over - 1- 0 max
+      evaluate ; immediate
+: scarf   +evaluate1 ;
+: enact   state @ if , else execute then ;
+: +   scarf ['] + enact ; immediate
+: -   scarf ['] - enact ; immediate
+: *   scarf ['] * enact ; immediate
+: /   scarf ['] / enact ; immediate
+
+previous forth definitions

examples/infix/parsing.fs

@@ -0,0 +1,21 @@
+: kind ( "name" -- )
+   create 0 ,
+   does> @ begin dup while
+             state @ >r   here >r   >in @ >r
+             dup >r @ catch 0= if rdrop rdrop rdrop rdrop exit then
+             r> cell+ @
+             r> >in !   r> here - allot    r> state !
+         repeat
+         -1 throw ;
+: :{{   >body :noname ;
+: {{   latestxt :{{ ;
+: }}   postpone ; here >r , dup @ , r> swap ! ; immediate
+: @token ( -- ch ) >in @ tib + c@ ;
+: +token   1 >in +! ;
+: =token ( ch -- ) @token <> throw +token ;
+: within ( ch a b ) >r over <= swap r> <= and ;
+: []token ( a b -- ch ) @token -rot within 0= throw @token +token ;
+: t'   postpone [char] postpone =token ; immediate
+: stoken ( a n -- ) 0 ?do dup c@ =token 1+ loop drop ;
+: t"   postpone s" postpone stoken ; immediate
+