OPG Formula Translation

This is G o o g l e's cache of http://home.earthlink.net/~neilbawd/opg.html.
G o o g l e's cache is the snapshot that we took of the page as we crawled the web.
The page may have changed since that time. Click here for the current page without highlighting.
To link to or bookmark this page, use the following url: http://www.google.com/search?q=cache:6qglZyzTF7sC:home.earthlink.net/~neilbawd/opg.html+&hl=en&ie=UTF-8

Google is not affiliated with the authors of this page nor responsible for its content.

TEXT

Wil Baden 1997-11-04 - 2000-05-15

This is a implementation of Formula Translation. It will translate Fortran-style assignments varname=expr and expressions expr to Forth.

?? Accept-Char-for-Formula Apply-Operators Callable Code-Operation FAILURE Get-Formula Is+or- Is-D-or-E Is-a-Number Is-an-Identifier LET Memorable NEXT-CHAR Op-Code Op-Fetch Op-Literal Op-Pop Op-Push Op-Stack Op-Stack-Size Op-Store Op-Top Operator-Precedence Parenthesis-Count Replace-Last-Char SUCCESS Translate-Expression Translate-Formula Translate-Operand-Operator Translate-Operation Word-Holder

There is just one end-user word LET. The formula is terminated by :. (LET and : have been adopted from Basic.)

It can be used compiling or interpreting. It is not state-smart.

An segment between |bars| will be treated as normal Forth.

The resulting translations are the natural expansions.

LET a-b-c-d: a F@ b F@ F- c F@ F- d F@ F- LET a*b-c*d: a F@ b F@ F* c F@ d F@ F* F- LET (a-b)*(c-d): a F@ b F@ F- c F@ d F@ F- F* LET x = -1: -1.E x F! LET x = (-b - SQRT (b * |FDUP| - 4*a*c)) / (2*a): b F@ FNEGATE b F@ FDUP F* 4.E a F@ F* c F@ F* F- FSQRT F- 2.E a F@ F* F/ x F!

If a function doesn't begin with F it will first look for it with F prefixed.

All numbers are floating point. Variables begin with a letter, continue with letters and digits, and are not followed by a left parenthesis mark. Function-calls have the same form but are followed by a left parenthesis mark.

The operators are:

+ - * / ** or ^

Assignments are made with =. Multiple arguments of a function are separated by commas.

Spaces are deleted before translation, except between | and |.

Variable DEBUG on will show code being translated.

This program uses Julian V. Noble's concept but not his implementation. Thanks to Marcel Hendrix for his ideas for extending the system.

Examples of Use

Operator Precedence goes through the expression putting out operands as it reaches them and saving operators. Operators are put out when an operator of less or equal precedence is reached. Thus higher precedence is performed before lower precedence.

FVARIABLE a FVARIABLE b FVARIABLE c FVARIABLE x FVARIABLE w : TEST0 CR LET b+c: FE. CR LET b-c: FE. CR LET 10000000*(b-c)/(b+c): FE. ; LET b = 3: LET c = 4: TEST0 : TEST1 LET a = b*c-3.17e-5/TANH(w)+ABS(x): CR LET a: F. ; LET w = 1.e-3: LET x = -2.5: CR CR test1 FVARIABLE HALFPI LET HALF PI = 2*ATAN(1): LET HALF PI + |FDUP|: F. FVARIABLE disc ( Used for discriminant ) : QUADRATICROOT ( F: a b c -- r1 r2 ) c F! b F! a F! \ Pickup coefficients. LET disc = SQRT(b*b-4*a*c): \ Set discriminant. LET (-b+disc)/(2*a), (-b-disc)/(2*a): \ Put values on f-stack. ; ( Solve x*x-3*x+2 ) LET QUADRATIC ROOT (1,-3, 2) : F. F. ( Find goldenratio ) LET MAX(QUADRA TICROOT (1,-1,-1)) : F. ( You can also write ) 1.E -1.E -1.E QUADRATICROOT FMAX F. : FACTORIAL ( n -- )( F: -- r ) LET w = 1: LET x = 1: 0 ?DO LET w = w * x: LET x = x + 1: LOOP LET w: ; ( Another way ) : FACTORIAL ( n -- )( F: -- r ) LET w = 1: 0 ?DO LET w = w * | I 1+ S>D D>F |: LOOP LET w: ; 6 FACTORIAL F. ( or ) LET FACTORIAL(|6|): F.
Program Text 1
\ Formula Translation using Operator Precedence Grammar VARIABLE DEBUG 0 DEBUG ! ( This is a common name. ) ( `DEBUG` occurs in one place below. Change it here and there. )

Elementary Tools

FAILURE ( -- ): False exit.
SUCCESS ( -- ): True exit.
?? ( x "aword" -- ): x IF aword THEN

Program Text 2
\ Common usage, especially with me. Comment out what you already have. : /SPLIT ( a m b n -- b n a m-n ) DUP >R 2SWAP R> - ; : ANDIF S" DUP IF DROP " EVALUATE ; IMMEDIATE : BOUNDS ( str len -- str+len str ) over + SWAP ; : IS-ALPHA ( char -- flag ) 32 OR [CHAR] a - 26 U< ; : IS-DIGIT ( char -- flag ) [CHAR] 0 - 10 U< ; : IS-ALNUM ( char -- flag ) DUP IS-ALPHA ORIF DUP IS-DIGIT THEN NIP ; : NOT ( x -- flag ) S" 0= " EVALUATE ; IMMEDIATE : OFF 0 SWAP ! ; : ON TRUE SWAP ! ; : ORIF S" DUP 0= IF DROP " EVALUATE ; IMMEDIATE : PLACE ( str len addr -- ) 2dup 2>R CHAR+ SWAP chars MOVE 2R> C! ; : FAILURE S" FALSE EXIT " EVALUATE ; IMMEDIATE : SUCCESS S" TRUE EXIT " EVALUATE ; IMMEDIATE : ?? ( x "word" -- ) POSTPONE IF BL WORD COUNT EVALUATE POSTPONE THEN ; IMMEDIATE

Character Handling

NEXT-CHAR ( -- char or 0 for EOL or negative for EOF ): Get character from input stream. Used in Get-Formula.
Replace-Last-Char ( str len char -- str len ): Replace last character in a string. Used in Op-Literal and Accept-Char-for-Formula.
Is+or- ( char -- flag ): Test char for + or -. Used in Is-a-Number. [+-]
Is-D-or-E ( char -- flag ): Test char for D, E, d, or e. Used in Is-a-Number and Op-Literal. [DEde]

Program Text 3
: NEXT-CHAR ( -- char or 0 for EOL or negative for EOF ) SOURCE >IN @ > ( addr flag) IF >IN @ CHARS + C@ 1 >IN +! ELSE DROP REFILL 0= ( ) THEN ; : Replace-Last-Char ( str len char -- str len ) >R 2DUP CHARS + R> SWAP C! ; : Is+or- ( char -- flag ) DUP [CHAR] + = SWAP [CHAR] - = OR ; : Is-D-or-E ( char -- flag ) 32 OR [CHAR] d - 2 U< ;

Is-a-Number ( str len -- str' len' flag ): This awful-looking code walks through syntax for a number. Used in Translate-Operand-Operator.

Regular Expression

[+-]?[0-9]*([.][0-9]*)?([DEde](([-+][0-9])?[0-9]*)?
Program Text 4
: Is-a-Number ( str len -- str' len' flag ) DUP 0= ?? FAILURE \ [-+] Any sign. OVER C@ Is+or- IF 1 /STRING DUP 0= ?? FAILURE THEN \ [.]?[0-9] Begins with digit or decimal point and digit. OVER C@ IS-DIGIT ORIF OVER C@ [CHAR] . = THEN 0= ?? FAILURE OVER C@ [CHAR] . = IF DUP 1 = ?? FAILURE OVER CHAR+ C@ IS-DIGIT NOT ?? FAILURE THEN \ [0-9]* Any digits. BEGIN OVER C@ IS-DIGIT WHILE 1 /STRING DUP 0= ?? SUCCESS REPEAT \ [.][0-9]* Decimal point and any digits OVER C@ [CHAR] . = IF BEGIN 1 /STRING DUP 0= ?? SUCCESS OVER C@ IS-DIGIT NOT UNTIL THEN \ [DEde](([-+][0-9])?[0-9]*)? Exponent, sign and digits. OVER C@ Is-D-or-E IF 1 /STRING DUP 0= ?? SUCCESS OVER C@ Is+or- IF 1 /STRING DUP 0= ?? FAILURE OVER C@ IS-DIGIT NOT ?? FAILURE THEN \ [0-9]* BEGIN DUP 0= ?? SUCCESS OVER C@ IS-DIGIT WHILE 1 /STRING REPEAT THEN SUCCESS ;

Is-an-Identifier ( str len -- str' len' flag ): An identifier is a letter followed by letters and digits. Used in Translate-Operand-Operator and Translate-Formula.

Program Text 5
: Is-an-Identifier ( str len -- str' len' flag ) DUP 0= ?? FAILURE OVER C@ IS-ALPHA NOT ?? FAILURE BEGIN 1 /STRING DUP 0= ?? SUCCESS OVER C@ IS-ALNUM NOT UNTIL SUCCESS ;

Op-Stack Operations

Op-Stack-Size ( -- n ): Maximum size of Op-Stack. Used in Op-Push.
Op-Stack ( -- addr): Stack to hold operators.
Op-Push ( op -- ): Push op on top of Op-Stack.
Op-Top ( -- op ): The operator on top of Op-Stack.
Op-Pop ( -- ): Remove top of Op-Stack.

Program Text 6
30 CONSTANT Op-Stack-Size CREATE Op-Stack Op-Stack-Size 1+ CELLS ALLOT : Op-Push ( op -- ) Op-Stack @ Op-Stack-Size CELLS < NOT ABORT" Too Many Elements -- Increase Op-Stack-Size " 1 CELLS Op-Stack +! Op-Stack DUP @ + ! ; : Op-Top ( -- op ) Op-Stack DUP @ + @ ; : Op-Pop ( -- ) -1 CELLS Op-Stack +! ;

Application Tools

Parenthesis-Count ( -- addr ): Tally for parentheses.
Word-Holder ( -- addr ): Buffer for name when modifying it.
Memorable ( str len -- ): Look up variable. Used in Op-Store and Op-Fetch.
Callable ( str len -- str' len' ): Look up function. Used in Code-Operation.
Translate-Operation ( addr len -- ): Translate operation. [Can't think of better explanation.]
Op-Store ( str len -- )( F: r -- ): Make assignment. Used in Translate-Formula.
Op-Fetch ( str len -- )( F: -- r ): Pick up variable. Used in Translate-Operand-Operator.
Op-Literal ( str len -- )( F: -- r ): Take care of literal. Used in Translate-Operand-Operator.

Program Text 7
VARIABLE Parenthesis-Count 1 CONSTANT Left-Paren 2 CONSTANT Right-Paren 8 CONSTANT Negation 9 CONSTANT Function-Call 10 CONSTANT Op-Dummy CREATE Word-Holder 32 CHARS ALLOT : Memorable ( str len -- ) 31 MIN Word-Holder PLACE ( ) Word-Holder FIND 0= IF COUNT TYPE SPACE TRUE ABORT" Not Found " THEN DROP ; : Callable ( str len -- str' len' ) OVER C@ [CHAR] F = NOT IF 2DUP 30 MIN DUP 1+ Word-Holder C! Word-Holder CHAR+ PLACE ( . .) [CHAR] F Word-Holder CHAR+ C! Word-Holder FIND NIP IF 2DROP Word-Holder COUNT THEN THEN ; : Translate-Operation ( addr len -- ) DEBUG @ IF 2DUP TYPE SPACE THEN EVALUATE ; : Op-Store ( str len -- )( F: r -- ) 2DUP Memorable Translate-Operation S" F! " Translate-Operation ; : Op-Fetch ( str len -- )( F: -- r ) 2DUP Memorable Translate-Operation S" F@ " Translate-Operation ; VARIABLE Literal-State : Op-Literal ( str len -- )( F: -- r ) Literal-State OFF Word-Holder 0 2SWAP CHARS BOUNDS ?DO I C@ Is-D-or-E IF Literal-State ON THEN I C@ Replace-Last-Char 1+ 1 CHARS +LOOP Literal-State @ 0= IF [CHAR] E Replace-Last-Char 1+ THEN Translate-Operation ;

Op-Code ( str len -- str len code ): Pick up code for operator. Used in Apply-Operators.
Operator-Precedence ( code -- precedence ): Get the precedence of an operator. Used in Apply-Operators.
Code-Operation ( code -- ): Determine what to do with the operator. Used in Apply-Operators.
Apply-Operators ( str len -- str' len' ): Use operator precedence to select operators. Used in Translate-Operand-Operator.

Program Text 8
: Op-Code ( str len -- str len code ) DUP 0= IF 0 ELSE CASE OVER C@ [CHAR] ) OF 2 ENDOF [CHAR] + OF 3 ENDOF [CHAR] - OF 4 ENDOF [CHAR] * OF 5 ENDOF [CHAR] / OF 6 ENDOF [CHAR] ^ OF 7 ENDOF [CHAR] , OF 0 ENDOF DUP . EMIT TRUE ABORT" Illegal Operator " 0 ENDCASE THEN ; : Operator-Precedence ( code -- precedence ) CASE -1 OF -1 ENDOF \ Bottom Mark 0 OF 2 ENDOF \ Termination or Comma 1 OF 1 ENDOF \ Left Paren 2 OF 1 ENDOF \ Right Paren 3 OF 3 ENDOF \ Plus 4 OF 3 ENDOF \ Minus 5 OF 4 ENDOF \ Times 6 OF 4 ENDOF \ Divide 7 OF 5 ENDOF \ Power 8 OF 3 ENDOF \ Negation 9 OF 1 ENDOF \ Function-Call 10 OF 0 ENDOF \ Dummy DROP TRUE ABORT" Invalid Operation " 0 ENDCASE ; : Code-Operation ( code -- ) CASE 1 OF 0 -1 Parenthesis-Count +! ENDOF 2 OF 0 ENDOF 3 OF S" F+ " ENDOF 4 OF S" F- " ENDOF 5 OF S" F* " ENDOF 6 OF S" F/ " ENDOF 7 OF S" F** " ENDOF 8 OF S" FNEGATE " ENDOF 9 OF Op-Pop Op-Top Op-Pop Op-Top -1 Parenthesis-Count +! Callable ENDOF DROP TRUE ABORT" Invalid Operator " 0 ENDCASE ( addr k) ?DUP ?? Translate-Operation ; : Apply-Operators ( str len -- str' len' ) BEGIN Op-Code ( str len code) DUP 2SWAP 2>R ( code code)( R: str len) >R Operator-Precedence >R ( )( R: . . . precedence) BEGIN Op-Top Operator-Precedence R@ < NOT WHILE Op-Top Code-Operation Op-Pop REPEAT R> DROP R> 2R> ( code str len)( R: ) DUP IF 1 /STRING THEN ROT ( str len code) DUP Right-Paren = WHILE DROP Op-Pop REPEAT ?DUP ?? Op-Push ;

Translate-Operand-Operator ( str len -- str' len' ): Pick up an operand and an operator. Used in Translate-Expression.

Program Text 9
: Translate-Operand-Operator ( str len -- str' len' ) \ Is it a variable or function-call? 2DUP Is-an-Identifier IF ( a n a+k n-k) DUP ANDIF OVER C@ [CHAR] ( = THEN IF \ It's a function-call. Op-Dummy Op-Push /SPLIT ( a+k n-k a k) Op-Push Op-Push Function-Call Op-Push ( a+k n-k) 1 Parenthesis-Count +! 1 /STRING ELSE \ It's a variable. 2>R R@ - Op-Fetch 2R> Apply-Operators THEN EXIT THEN 2DROP ( str len) \ Is it a number? 2DUP Is-a-Number IF ( a n a+k n-k) 2>R R@ - Op-Literal 2R> Apply-Operators EXIT THEN 2DROP ( str len) \ Is it a left paren? OVER C@ [CHAR] ( = IF Op-Dummy Op-Push Left-Paren Op-Push 1 Parenthesis-Count +! 1 /STRING EXIT THEN \ Is it a lonely minus sign? OVER C@ [CHAR] - = IF Negation Op-Push 1 /STRING EXIT THEN \ Is it a lonely plus sign? OVER C@ [CHAR] + = ANDIF DUP 1 > THEN IF 1 /STRING EXIT THEN \ Is it normal Forth? OVER C@ [CHAR] | = IF 1 /STRING 2DUP [CHAR] | SCAN /SPLIT 2SWAP 2>R Translate-Operation 2R> DUP IF 1 /STRING THEN Apply-Operators EXIT THEN \ Oops. CR TYPE CR TRUE ABORT" Illegal Operand " ;

Translate-Formula ( str len -- ): Translate the formula. Used in LET.
Translate-Expression ( str len -- ): Translate the expression. Used in Translate-Formula.

Program Text 10
: Translate-Expression ( str len -- ) BEGIN DUP WHILE Translate-Operand-Operator REPEAT 2DROP Parenthesis-Count @ ABORT" Unmatched Parens " ; : Translate-Formula ( str len -- ) 0 Op-Stack ! 0 Parenthesis-Count ! 2DUP Is-an-Identifier ( str len str' len' flag) ANDIF DUP ANDIF OVER C@ [CHAR] = = THEN THEN IF ( str len str' len') /SPLIT Op-Push Op-Push -1 Op-Push ( str' len') 1 /STRING Translate-Expression ( ) Op-Top -1 = NOT ABORT" Invalid Expression " Op-Pop Op-Top Op-Pop Op-Top Op-Store ELSE 2DROP ( str len) -1 Op-Push Translate-Expression ( ) THEN Op-Stack @ 1 CELLS = NOT ABORT" Invalid Formula " ;

Get-Formula ( "multi-lines<colon>" -- addr len ): Get formula from the input stream. Used in LET.
Accept-Char-for-Formula ( str length char -- str length' ): Accept char for the formula. Used in Get-Formula.

Program Text 11
255 CONSTANT Formula-Length CREATE Formula Formula-Length 1+ CHARS ALLOT VARIABLE Keep-Spaces : Accept-Char-for-Formula ( str length char -- str length' ) OVER Formula-Length > ABORT" Formula Length Overflow " CASE [CHAR] | OF [CHAR] | Replace-Last-Char 1+ Keep-Spaces DUP @ NOT SWAP ! ENDOF [CHAR] * OF DUP ANDIF 2DUP 1- CHARS + C@ [CHAR] * = THEN IF 1- [CHAR] ^ ELSE [CHAR] * THEN Replace-Last-Char 1+ ENDOF Replace-Last-Char 1+ 0 ENDCASE ; : Get-Formula ( "multi-lines<colon>" -- addr len ) Keep-Spaces OFF Formula 0 ( addr len) BEGIN NEXT-CHAR ( addr len char) DUP 0< ABORT" End of File " DUP [CHAR] : = NOT WHILE DUP BL > ORIF DUP BL = Keep-Spaces @ AND THEN IF Accept-Char-for-Formula ELSE DROP THEN ( addr len) REPEAT DROP ;

LET ( "formula:" -- )( F: -- | values ): Translate varname=expr or expr.

Program Text 12
: LET ( "formula:" -- )( F: -- | values ) Get-Formula Translate-Formula ; IMMEDIATE

Go back to home page.