diff --git a/examples/infix/infix_generic.fs b/examples/infix/infix_generic.fs new file mode 100755 index 0000000..6b7312f --- /dev/null +++ b/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 diff --git a/examples/infix/infix_parsing.fs b/examples/infix/infix_parsing.fs new file mode 100755 index 0000000..81930e4 --- /dev/null +++ b/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 + {{ }} + {{ @token space? 0= throw +token }} + +: st' postpone postpone t' postpone ; immediate +: st" postpone postpone t" postpone ; immediate + +kind + {{ [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 + {{ >in @ tib + 0 begin @token letnum? while 1+ +token repeat dup 0= throw }} + +kind + {{ 1 }} + {{ rot over 0 do 10 * loop -rot 1+ >r + r> }} +kind + {{ drop aliteral }} + +kind + {{ [char] ] parse evaluate }} + +kind + +kind + {{ }} + {{ evaluate }} + +kind + {{ evaluate }} + {{ }} + {{ st' ( st' ) }} + {{ st' [ }} + +kind + {{ }} + {{ st' * postpone * }} + {{ st' / postpone / }} + {{ st" mod" postpone mod }} + {{ st" and" postpone and }} + +kind + {{ }} + {{ st' + postpone + }} + {{ st' - postpone - }} + {{ st" or" postpone or }} + {{ st' + }} + {{ st' - postpone negate }} + +kind + {{ }} + {{ st' = postpone = }} + {{ st" <>" postpone <> }} + {{ st' < postpone < }} + {{ st" <=" postpone <= }} + {{ st" >=" postpone >= }} + {{ st' > postpone > }} + +' :{{ }} + +kind + {{ }} + {{ st' } }} + +kind def + {{ : st' { postpone { st' { postpone ; }} + +kind on + {{ ' :{{ st' { postpone }} }} + +kind expr + {{ :noname postpone ; execute }} + diff --git a/examples/infix/infix_ueforth.fs b/examples/infix/infix_ueforth.fs new file mode 100755 index 0000000..4f00f39 --- /dev/null +++ b/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 diff --git a/examples/infix/parsing.fs b/examples/infix/parsing.fs new file mode 100644 index 0000000..823bb7b --- /dev/null +++ b/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 +