FALSE [IF]
******** ANS-compatible Expression -> CODE parser ********
---------------------------------------------------
(C) Copyright 2000 Julian V. Noble.
Permission is granted by the author to
use this software for any application pro-
vided this copyright notice is preserved,
as per GNU Public License agreement.
---------------------------------------------------
---------------------------------------------------
Environmental dependencies:
ANS CORE, CORE EXT and LOCALS EXT wordsets
Assumes the referencing used in Win32Forth
and the assembler mnemonics of 486asm.f
---------------------------------------------------
Compiler documentation:
----------------------------- Backus-Naur Rules
NOTATION:
| -> "or",
+ -> "unlimited repetitions"
& -> + | -
% -> * | /
Does not recognize numeric literals.
FORMULAS:
assignment -> id = expression
expression -> term | expression & term
term -> factor | term % factor
factor -> id | ( expression )
id -> letter {letter|digit}+
-------------------------- end Backus-Naur Rules
Usage: cf" a = b + c*d" within a CODE definition
compiles fld FSIZE b [edi]
fld FSIZE c [edi]
fmul FSIZE d [edi]
faddp st(1), st fstp
FSIZE a [edi]
For testing, cf." is supplied--outputs above to console.
*** BE CAREFUL NOT TO USE VARIABLE NAMES LIKE dx ***
[THEN]
MARKER -codetran
BL PARSE [undefined] DUP PAD C! PAD CHAR+ SWAP CHARS MOVE PAD FIND NIP 0=
[IF] : [undefined] BL WORD FIND NIP 0= ; [THEN]
[undefined] -ROT [IF]
: -ROT S" ROT ROT" EVALUATE ; IMMEDIATE
[THEN]
[undefined] f" [IF] include ftran111.f
[THEN]
CR CR .( *** BE CAREFUL NOT TO USE VARIABLE NAMES LIKE dx *** ) CR
.( *** that CODE will misconstrue as register names *** )
: a|b ( c1 c2 ) \ defining word for words that find one of two
\ possible characters
CREATE , ,
DOES> ( c -- f) 2@ ROT TUCK = -ROT = OR ;
CREATE Ctran 512 CHARS CELL+ ALLOT \ hold output from cf" "
: init_Ctran 0 Ctran ! ; init_Ctran
: (concat) ( c-adr u --)
>R Ctran CELL+ Ctran @ + R@ CMOVE
R> Ctran @ + Ctran ! ;
\ Note: output from modest expressions can easily exceed 255 chars,
\ hence a long-string buffer was employed
VARIABLE ()level 0 ()level ! \ holds current parens level
: ()level! ( c --) \ increment/decrement ()level
[CHAR] ) OVER = SWAP
[CHAR] ( = - ()level +! ;
: adr>ends ( $adr -- beg end) COUNT OVER + 1- ;
: skip- ( adr -- adr | adr+1) DUP C@ [CHAR] - = - ;
: find2 ( beg end xt -- adr|0 )
LOCALS| xt end beg | \ search right to left
0 ()level ! beg skip- TO beg \ initialize
0 beg end
DO I C@ DUP ()level! \ adjust ()level
xt EXECUTE ( -- f) \ test input
()level @ 0= \ exposed?
AND \ found?
IF DROP I LEAVE THEN ( -- adr)
-1 +LOOP
;
CHAR + CHAR - a|b +|-
CHAR * CHAR / a|b *|/
v: (output) ( initialized to NOOP)
v: expression
: print_op ( .op --)
CASE
[CHAR] _ OF S" fchs " ENDOF
[CHAR] + OF S" faddp st(1), st " ENDOF
[CHAR] - OF S" fsubp st(1), st " ENDOF
[CHAR] * OF S" fmulp st(1), st " ENDOF
[CHAR] / OF S" fdivp st(1), st " ENDOF
ENDCASE
(concat) ;
: (print_id) ( beg end --) OVER - 1+ (concat) ;
: (print_op) ( beg end .op --)
CASE
[CHAR] + OF S" fadd FSIZE " ENDOF
[CHAR] - OF S" fsub FSIZE " ENDOF
[CHAR] * OF S" fmul FSIZE " ENDOF
[CHAR] / OF S" fdiv FSIZE " ENDOF
ENDCASE
(concat) (print_id) S" [edi] " (concat) ;
VARIABLE BLBL 2 BLBL C! BL BLBL CHAR+ C! BL BLBL CHAR+ CHAR+ C!
: 0null BLBL adr>ends ;
: print_id ( beg end .op -- )
0 LOCALS| -? .op end beg |
beg C@ [CHAR] - = TO -? \ leading -?
.op BL = IF
S" fld FSIZE " (concat) \ id preamble
beg -? - end (print_id) \ id
S" [edi] " (concat) \ id index
-? IF S" fchs " (concat) \ handle leading -
THEN
ELSE
beg end 0null D= \ solo operator?
IF .op print_op \ operator ->
ELSE beg end .op (print_op) \ op + id ->
THEN
THEN
;
FALSE [IF] [THEN]
: (<expr>)? ( beg end -- f) \ is it an expression in parens?
C@ [CHAR] ) = SWAP C@ [CHAR] ( = AND ;
: letter? ( c -- f) \ is it a letter?
32 OR [CHAR] a [ CHAR z 1+ ] LITERAL WITHIN ;
: let_or_dig? ( c -- f) \ char = letter or digit?
DUP
[CHAR] 0 [ CHAR 9 1+ ] LITERAL WITHIN
SWAP letter? OR ;
: <id> ( beg end -- f) \ <id> -> letter {letter|digit}*
0 LOCALS| L|D? end beg |
beg skip- TO beg \ ignore leading -
beg C@ letter? TO L|D? \ 1st char a letter?
BEGIN beg 1+ TO beg \ inc ptr
end beg >= \ not done?
WHILE beg C@ let_or_dig? \ char = letter or digit?
L|D? AND TO L|D?
REPEAT L|D? ;
: <factor> ( beg end .op -- ) \ factor -> <id> | (<expr>)
LOCALS| .op end beg |
beg skip- end (<expr>)? \ enclosed?
IF end 1- TO end \ remove )
beg C@ [CHAR] - = \ leading - ?
IF beg 2 + TO beg \ skip- and remove (
0null [CHAR] _ ( 0beg 0end _ )
ELSE beg 1+ TO beg \ remove (
0null .op
THEN
beg end BL ( 0beg 0end ? beg end bl)
expression
RECURSE \ <factor>
EXIT
THEN
beg end 0null D= \ null string ?
.op BL = AND
IF EXIT THEN
beg end <id> \ <id> ?
beg end 0null D= \ null string ?
OR
IF beg end .op print_id \ output it
ELSE ." Incorrect expression!" ABORT
THEN
;
: <term> ( beg end .op -- ) \ term -> factor | term % factor
0 LOCALS| adr .op end beg |
beg skip- end ['] *|/ find2 \ find * or /
TO adr
adr IF \ found?
0null .op
adr 1+ end adr C@
beg adr 1- BL
RECURSE <factor>
ELSE beg end .op
THEN
<factor>
;
: <expression> ( beg end .op -- ) \ expr -> term | expr & term
0 LOCALS| adr .op end beg |
beg skip- end ['] +|- find2 \ find&
TO adr
adr IF \ found?
adr 1+ end adr C@
beg adr 1- .op \ .op should always be bl
RECURSE
ELSE beg end .op THEN <term> ;
' <expression> defines expression \ make forward reference
CHAR = DUP a|b =|= \ to find =
: <assign> ( beg end .op -- )
0 LOCALS| adr .op end beg |
init_Ctran \ initialize output buffer
beg end ['] =|= find2 \ find=
TO adr
adr IF \ found?
beg adr 1- adr C@
adr 1+ end .op ( beg adr-1 '=' adr+1 end bl)
expression \ parse expression
S" fstp FSIZE " (concat) \ lhs prefix
-ROT (print_id) \ lhs id
S" [edi] " (concat) \ lhs suffix
DROP
ELSE beg end .op expression THEN
Ctran CELL+ Ctran @ (output) \ output the code
;
: cf." ( formula, delimited by " -- ) \ for testing
['] TYPE defines (output)
aword"
adr>ends BL CR <assign> ;
: cf" ( formula, delimited by " -- ) \ for use inside definitions
['] EVALUATE defines (output)
aword"
adr>ends BL CR <assign> ;
\ *******************************************************************
\ These macros are used only within CODE definitions
: eval" POSTPONE S" POSTPONE EVALUATE ; IMMEDIATE
: (f!) eval" fstp FSIZE"
BL TEXT COUNT EVALUATE
eval" [edi]" ;
: (f+!) eval" fadd FSIZE "
BL TEXT COUNT 2DUP EVALUATE
eval" [edi] fstp FSIZE "
EVALUATE
eval" [edi] " ;
FVARIABLE two 2e0 two F!
FVARIABLE half 0.5e0 half F!
: (f2*) eval" fmul FSIZE two [edi] " ;
: (f2/) eval" fmul FSIZE half [edi] " ;
: (1/f) eval" fld1 fdiv FSIZE "
BL TEXT COUNT EVALUATE
eval" [edi] " ;
\ *******************************************************************