\ ******** ANS-compatible FORmula TRANslator ********
\ see ftrandoc.txt for instructions
\ ---------------------------------------------------
\ (c) Copyright 2001 Julian V. Noble. \
\ Permission is granted by the author to \
\ use this software for any application pro- \
\ vided this copyright notice is preserved. \
\ ---------------------------------------------------
\ program begins here
MARKER -ftran \ say -ftran to remove all, ANS-ly
S" FLOATING-STACK" ENVIRONMENT? [IF] DROP
[ELSE] .( Separate floating point stack required. ) ABORT
[THEN]
: [undefined] BL WORD FIND NIP 0= ;
[undefined] ?exit [IF]
: ?exit ( flag) POSTPONE IF
POSTPONE EXIT
POSTPONE THEN ; IMMEDIATE
[THEN]
[undefined] OFF [IF]
: OFF ( adr -- ) FALSE SWAP ! ;
: ON ( adr -- ) TRUE SWAP ! ;
[THEN]
FORTH-WORDLIST SET-CURRENT \ a precaution
INCLUDE complex.f
\ complex arithmetic package
INCLUDE vector1.f
\ vectoring package
INCLUDE fsm2.f
\ finite state machine
INCLUDE chr_tbl.f
\ character encoding pkg
\ raising to integer powers
[undefined] f^2 [IF] : f^2 FDUP F* ; [THEN]
: f^3 FDUP FDUP F* F* ;
: f^4 f^2 f^2 ;
\ increment if true ( ptr f -- ptr+1 | ptr)
: ?inc S" 1 AND + " EVALUATE ; IMMEDIATE
WORDLIST CONSTANT ftran \ create separate wordlist
ftran SET-CURRENT \ for FOR...TRAN... def'ns
GET-ORDER ftran SWAP 1+ SET-ORDER \ make ftran findable
\ -------------------------------------------- string manipulation
: $ends ( c-adr -- end beg) \ convert c-adr to ends
COUNT DUP 0> ( beg n f)
-1 AND + ( beg n-1|0)
OVER + SWAP ; ( end beg)
: ends->count ( end beg -- c-adr u) TUCK - 1+ ;
: concat ( src u dst --) \ append u chars from src to dst
LOCALS| dst n src |
src dst CELL+ dst @ + n CMOVE
n dst @ + dst ! ;
\ ---------------------------------------- end string manipulation
\ ------------------------------------------------ data structures
\ 1. String-pointer stack:
\ 3 cells wide, cell at base_adr holds $ptr
16 CONSTANT max_depth \ this seems enough
\ $ stack space + 1 cell for pointer
CREATE $stack max_depth 3 * CELLS CELL+ ALLOT
HERE $stack - 1 CELLS - CONSTANT $max \ max depth (cells)
: $init -3 CELLS $stack ! ; $init
: $ptr ( -- adr offset) $stack DUP @ ;
: $lbound ( offset) 0< ABORT" empty $stack!" ;
: ($pop) ( adr offset -- end beg op)
DUP $lbound \ bounds check
+ CELL+ ( adr[TO$])
DUP >R CELL+ 2@ R> @ ; ( end beg op)
: $pop ( -- end beg op)
$ptr ( adr offset)
($pop) ( end beg op)
-3 CELLS $stack +! ; \ dec $ptr
: $ubound ( offset) $max > ABORT" $stack too deep!" ;
: $push ( end beg op -- )
3 CELLS $stack +! \ inc $ptr
$ptr ( end beg op adr offset)
DUP $ubound \ bounds check
+ CELL+ DUP >R ( end beg op adr[TO$])
! R> CELL+ 2! ;
\ 2. Null string
CREATE bl$ 1 C, BL C,
bl$ $ends 2CONSTANT 0null
\ 3. re-vectorable dummy names
v: expr \ for indirect recursion
v: term
v: factor
v: .op \ for compilation
v: do_id
v: try_fp#
v: .fp#
v: do_@
v: do_^
v: do_fn
\ 4. place to make output string
CREATE out_pad 512 CHARS CELL+ ALLOT \ long output $
\ -------------------------------------------- end data structures
\ -------------------------------------------------- formula input
CREATE in_pad 256 ALLOT
0 in_pad C!
\ Get character from input stream. From Wil Baden's opg .
: get-char ( -- char | 0 for EOL | negative for EOF )
SOURCE ( -- start_of_input #chars)
>IN @ ( -- start_of_input #chars input_ptr)
> IF >IN @ CHARS + C@ 1 >IN +!
ELSE DROP REFILL 0=
THEN ;
: +c! ( n c-adr --) \ add n to the char at c-adr
TUCK C@ + SWAP C! ;
: append_char ( c c-adr --) \ append 1 char to a counted string
1 OVER +c! \ increment count
DUP C@ + C! ; \ get new address and store
VARIABLE {}level
: >0,4 {}level @ 0> 4 AND ; ( -- 0 | 4)
: copy ( c --) in_pad append_char ;
: copy&inc ( c --) copy 1 {}level +! ;
: copy&dec ( c --) copy -1 {}level +! ;
: err0 CR ." right } before left {" ABORT ;
: err1 CR ." left { between right }'s" ABORT ;
: err2 CR ." no chars betw. successive {'s or }'s" ABORT ;
: err3 CR ." last char before 1st } must be blank" ABORT ;
: err4 CR ." first char after last { must be blank" ABORT ;
4 wide fsm: put_char ( c col# --)
\ input other | bl | { | }
\ state -----------------------------------------------------------
( 0) || copy >0 || DROP >0 || copy&inc >1 || err0 >5
( 1) || err4 >6 || copy >2 || copy&inc >1 || err3 >6
( 2) || copy >2 || copy >3 || err2 >5 || err3 >6
( 3) || copy >2 || copy >3 || err2 >5 || copy&dec >0,4
( 4) || err3 >6 || err2 >6 || err1 >5 || copy&dec >0,4
( 5) ( abnormal termination w/ error0 or error1 )
( 6) ( abnormal termination w/ error2 or error3 )
;fsm
: [put_char] ( c -- col#) \ char -> col #: in out
1 OVER BL = AND ( -- c n) \ other 0
OVER [CHAR] { = 2 AND + ( -- c n) \ bl 1
SWAP [CHAR] } = 3 AND + ( -- #) \ { 2
; \ } 3
0 VALUE ()level
: count_parens ( c -- c )
DUP [CHAR] ( = 1 AND
OVER [CHAR] ) = -1 AND + ( -- c n)
()level + TO ()level ;
: get_formula
{}level OFF
in_pad OFF
0 >state put_char
BEGIN get-char count_parens
DUP [CHAR] " <>
WHILE DUP 0>
IF DUP [put_char] put_char
ELSE DROP THEN
REPEAT DROP
()level 0<> ABORT" Unbalanced parentheses!" ;
\ ---------------------------------------------- end formula input
\ ---------------------------------------------- conversion tables
: 'dfa ' >BODY ;
128 char_table: [token] \ convert ASCII char to token
\ "other" -> 0
1 'dfa [token] CHAR Z CHAR A install
1 'dfa [token] CHAR z CHAR a install
\ modified January 8th, 2004
1 'dfa [token] CHAR [ + C! \ for address passing
1 'dfa [token] CHAR ] + C! \ for address passing
2 'dfa [token] CHAR E CHAR D install
2 'dfa [token] CHAR e CHAR d install
3 'dfa [token] CHAR 9 CHAR 0 install
4 'dfa [token] CHAR . + C!
5 'dfa [token] CHAR ( + C!
6 'dfa [token] CHAR { + C!
7 'dfa [token] CHAR } + C!
8 'dfa [token] CHAR ) + C!
9 'dfa [token] CHAR + + C!
10 'dfa [token] CHAR - + C!
11 'dfa [token] CHAR * + C!
12 'dfa [token] CHAR / + C!
13 'dfa [token] CHAR ^ + C!
15 'dfa [token] CHAR = + C!
17 'dfa [token] CHAR , + C!
\ ------------------------------------------ end conversion tables
\ -------------------------------------------------- finding stuff
\ terminology: (end,beg) = pointers to substring
\ op = operator token
: skip_name ( end beg --)
DUP C@ [token] 1 3 WITHIN \ 1st char a letter or [ ?
IF BEGIN DUP C@ [token] 1 4 WITHIN \ skip letters or digits
WHILE 1+ REPEAT
ELSE CR ." A proper name must begin with a letter!" ABORT
THEN ;
: [skip] ( end beg c1 c2 -- end beg')
0 LOCALS| level c2 c1 |
DUP C@ c1 <> ?exit \ 1st char <> c1
BEGIN DUP C@
CASE
c1 OF 1 level + TO level ENDOF
c2 OF -1 level + TO level ENDOF
ENDCASE
1+ ( end beg')
DUP C@ c2 <> \ next char <> c2
level 0> INVERT AND \ and level <= 0
>R 2DUP < R> OR \ or past end of string
UNTIL
;
: skip_{} ( end beg -- end beg') [CHAR] { [CHAR] } [skip] ;
: skip_() ( end beg -- end beg') [CHAR] ( [CHAR] ) [skip] ;
: skip_digits ( adr -- adr') \ skip digits rightward
BEGIN DUP C@ [CHAR] 0 [CHAR] 9 1+ WITHIN
WHILE 1+ REPEAT ;
: skip_dp ( adr -- adr|adr+1) \ skip decimal point
DUP C@ [CHAR] . = ?inc ;
: skip+ ( adr -- adr|adr+1) \ skip + sign
DUP C@ [CHAR] + = ?inc ;
: skip- ( adr -- adr|adr+1) \ skip - sign
DUP C@ [CHAR] - = ?inc ;
: skip_fp# ( adr -- adr') \ skip past a fp#
skip_digits skip_dp skip_digits \ skip mantissa
DUP C@ [token] 2 = \ d,D,e or E ?
IF 1+ ELSE EXIT THEN
skip+ skip- skip_digits ; \ skip exponent
: pass_thru ( end beg -- end beg')
skip- \ ignore leading -
DUP C@ [token] CASE
3 OF skip_fp# ENDOF \ digit
4 OF skip_fp# ENDOF \ dec. pt.
1 OF skip_name \ letter
skip_{}
skip_() ENDOF
2 OF skip_name \ dDeE
skip_{}
skip_() ENDOF
5 OF skip_() ENDOF \ left paren: (
ENDCASE
;
: [op] ( char -- token) \ in out
[token] \ "other" 0
7 - DUP 0> AND 2/ ; \ + or - 1
\ * or / 2
\ ^ 3
\ = 4
\ , 5
: op_find ( end beg c -- adr | 0) \ find exposed operator
[op] >R ( end beg) \ save op token
BEGIN pass_thru \ ignore id's, fp#'s, fn's, (expr)'s
DUP C@ [op] R@ <> \ op not found
>R 2DUP > R> AND \ and not done
WHILE 1+ \ incr. ptr
REPEAT TUCK > AND ( -- adr | 0)
R> DROP \ clean up
;
\ ---------------------------------------------- end finding stuff
\ -------------------------------------------------------- parsing
: assign \ assign -> id = expr | id = | expr
$init
out_pad OFF
in_pad $ends 2DUP [CHAR] = op_find ( end beg ptr|0)
?DUP IF 1- TUCK >R [CHAR] = $push \ id = expr
( end) R> 2 + BL $push expr
ELSE OVER C@ [CHAR] = = \ id =
IF SWAP 1- SWAP [CHAR] =
ELSE BL THEN \ expr
$push
THEN
expr
;
: <expr> \ expr -> term | term & expr
$pop LOCALS| op beg end |
end beg [CHAR] + op_find ( ptr | false)
?DUP IF ( ptr) DUP c@ >R \ save op'
\ $stack:
( ptr) end OVER 1+ R> $push \ expr' op'
( ptr) 1- beg op $push \ term op
term RECURSE
ELSE end beg op $push term \ term op
THEN
;
: <term> \ term -> factor | factor % term
$pop LOCALS| op beg end |
end beg [CHAR] * op_find ( ptr true | false)
?DUP IF ( ptr) DUP c@ >R \ save op'
\ $stack:
0NULL op $push \ null op
end OVER 1+ R> $push \ term' op'
( ptr) 1- beg BL $push \ factor bl
factor RECURSE
ELSE end beg op $push
THEN
factor ;
\ -------------- auxiliary words for parsing factor --------------
: <do_F@> S" F@ " ;
: <do_z@> S" z@ " ;
: <do_id> ( end beg op -- op)
LOCALS| op beg end |
op [CHAR] = = \ op is =
end beg 0null D= \ $ is 0null
OR INVERT \ true if neither
>R \ defer flag
\ modification for address-passing, January 8th, 2004
beg C@ [CHAR] [ = \ enclosed in [] ?
end C@ [CHAR] ] = AND \
>R \ defer flag
R@ IF beg 1+ TO beg \ remove []
end 1- TO end
THEN
R> INVERT \ not in []
end beg ends->count do_id
R> AND \ not =, and not null$
IF do_@ do_id THEN op
;
: leading-? ( adr -- f)
DUP C@ [CHAR] - = SWAP 1+ C@ [token] 3 <> AND ;
: $fneg S" FNEGATE " ;
: $zneg S" znegate " ;
v: neg$ ' $fneg defines neg$
: try_id ( op end beg -- f) \ true => $ was an id
LOCALS| beg end op |
beg skip- C@ [token] 1 3 WITHIN \ begins with letter
beg C@ BL = OR \ or a blank
end C@ [CHAR] ) <> AND \ doesn't end with )
DUP
IF end beg skip- op <do_id> .op \ was an id
beg C@ [CHAR] - =
IF neg$ do_fn THEN
THEN \ wasn't an id
;
: <try_fp#> ( op end beg -- f) \ true => $ was a fp#
ends->count >FLOAT
IF .fp# .op TRUE ELSE DROP FALSE THEN
;
: <try_z#> ( op end beg -- f) \ true => $ was a fp#
ends->count >FLOAT
IF 0e0 .fp# .op TRUE ELSE DROP FALSE THEN
;
: enclosed?