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] : ()? ( 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 ; : ( beg end -- f) \ -> 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? ; : ( beg end .op -- ) \ factor -> | () LOCALS| .op end beg | beg skip- end ()? \ 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 \ EXIT THEN beg end 0null D= \ null string ? .op BL = AND IF EXIT THEN beg end \ ? beg end 0null D= \ null string ? OR IF beg end .op print_id \ output it ELSE ." Incorrect expression!" ABORT THEN ; : ( 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 ELSE beg end .op THEN ; : ( 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 ; ' defines expression \ make forward reference CHAR = DUP a|b =|= \ to find = : ( 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 ; : cf" ( formula, delimited by " -- ) \ for use inside definitions ['] EVALUATE defines (output) aword" adr>ends BL CR ; \ ******************************************************************* \ These macros are used only within CODE definitions : eval" POSTPONE S" POSTPONE EVALUATE ; IMMEDIATE : (f!) eval" fstp FSIZE" BL TEXT COUNT EVALUATE eval" [edi]" ; : (fnp!) eval" fst 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] " ; \ *******************************************************************