\ ******** ANS-compatible FORmula TRANslator ********
\ see ftrandoc.txt for instructions
\ ---------------------------------------------------
\ © Copyright 2004 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? ( end beg -- f)
C@ [CHAR] ( = SWAP
C@ [CHAR] ) = AND ;
: try_(expr) ( op end beg -- f) \ true => $ was (expr)
LOCALS| beg end op |
end beg enclosed?
IF 0null op $push end 1- beg 1+ BL $push
expr factor TRUE
ELSE FALSE THEN
;
: <do_f^> ( n --)
CASE 1 OF S" " ENDOF
2 OF S" f^2 " ENDOF
3 OF S" f^3 " ENDOF
4 OF S" f^4 " ENDOF
ENDCASE do_id
;
: <do_z^> ( n --)
CASE 1 OF S" " ENDOF
2 OF S" z^2 " ENDOF
3 OF S" z^3 " ENDOF
4 OF S" z^4 " ENDOF
ENDCASE do_id
;
: int<5? ( end beg -- n TRUE | FALSE)
ends->count 0.0 2SWAP >NUMBER ( d adr 0 | d' adr' n)
0= IF 2DROP DUP 1 5 WITHIN ( n f --)
ELSE 2DROP FALSE THEN ;
: try_f1^f2 ( op end beg -- f) \ true => $ was f^f
0 LOCALS| ptr beg end op |
end beg skip- [CHAR] ^ op_find TO ptr
ptr
IF 0null op $push \ push operator
end ptr 1+ int<5? \ is f2 an integer < 5
IF ptr 1- beg skip- \ parse f1^n
BL $push
factor do_^
ELSE DROP \ clear stack
end ptr 1+ [CHAR] ^ $push \ f2
ptr 1- beg skip- BL $push \ push f1
factor factor
THEN factor
beg C@ [CHAR] - = IF neg$ do_fn THEN
THEN ptr 0<> ( flag)
;
: func_lib ( xt -- c-adr)
CASE ['] FABS OF C" FABS " ENDOF
['] FACOS OF C" FACOS " ENDOF
['] FACOSH OF C" FACOSH " ENDOF
['] FASIN OF C" FASIN " ENDOF
['] FASINH OF C" FASINH " ENDOF
['] FATAN OF C" FATAN " ENDOF
['] FATAN2 OF C" FATAN2 " ENDOF
['] FATANH OF C" FATANH " ENDOF
['] FCOS OF C" FCOS " ENDOF
['] FCOSH OF C" FCOSH " ENDOF
['] FEXP OF C" FEXP " ENDOF
['] FLN OF C" FLN " ENDOF
['] FMAX OF C" FMAX " ENDOF
['] FMIN OF C" FMIN " ENDOF
['] FSIN OF C" FSIN " ENDOF
['] FSINH OF C" FSINH " ENDOF
['] FTAN OF C" FTAN " ENDOF
['] FSQRT OF C" FSQRT " ENDOF
['] FTANH OF C" FTANH " ENDOF
ENDCASE
;
[undefined] CAPS-FIND [IF]
: lcase? ( char -- flag=true if lower case)
DUP [CHAR] a MAX ( char max[a,c])
SWAP [CHAR] z MIN ( max[a,c] min[a,z])
= ;
: ucase ( c-adr u --) OVER + SWAP
DO I C@ DUP lcase? 32 AND - I C! LOOP ;
\ assumes ASCII character coding
: CAPS-FIND DUP COUNT ucase FIND ;
[THEN]
: Fname ( end beg -- xt TRUE | c-adr FALSE)
\ add leading F to fn.name and look up
>R 1+ R> ( end+1 beg)
1 PAD C! [CHAR] F PAD 1+ C!
PAD 1+ -ROT ( pad+1 end+1 beg)
DO 1+ I C@ OVER C! \ append char to PAD
1 PAD +c! \ incr. count at PAD
LOOP DROP
PAD CAPS-FIND 0<>
;
: list! ( --)
$pop >R \ defer op
2DUP [CHAR] , op_find ( end beg ptr|0) \ -> )comma(
?DUP IF ROT OVER 1+ ( beg ptr end ptr+1)
BL $push ( beg ptr)
1- SWAP BL $push
expr RECURSE
ELSE BL $push expr \ only 1 arg
THEN
R> .op \ emit op
;
: try_func ( op end beg -- f) \ fn -> id arglist
0 LOCALS| ptr beg end op |
end beg skip- skip_name ( end beg')
DUP TO ptr ( end ptr)
enclosed? DUP \ looks like a function
IF ptr 1- beg skip- ( end' beg|beg+1)
Fname \ look up F+fn.name
beg C@ [CHAR] - = >R \ defer possible NEGATE
IF func_lib $ends ( end beg) \ library fn
ELSE DROP
ptr 1- beg skip- ( end beg) \ other
THEN op $push \ push function name
end 1- ptr 1+ BL $push \ push arg list
list! \ handle arg list
$pop -ROT ends->count do_fn .op
R> IF neg$ do_fn THEN
THEN
;
\ ---------------- end auxiliary words for factor ----------------
: <factor> \ factor -> id | fp# | ( expr ) | f^f | function
$pop LOCALS| op beg end | \ true => success
op end beg try_f1^f2 ?exit
op end beg try_id ?exit
op end beg try_fp# ?exit
op end beg try_(expr) ?exit
op end beg try_func ?exit
." Not a factor!" ABORT
;
\ ---------------------------------------------------- end parsing
\ --------------------------------------------------- output words
: real_op ( op --) [token]
CASE 9 OF S" F+ " ENDOF
10 OF S" F- " ENDOF
11 OF S" F* " ENDOF
12 OF S" F/ " ENDOF
13 OF S" F** " ENDOF
15 OF S" F! " ENDOF
0 OF S" " ENDOF
ENDCASE
do_fn
;
: cmplx_op ( op --) [token]
CASE 9 OF S" z+ " ENDOF
10 OF S" z- " ENDOF
11 OF S" z* " ENDOF
12 OF S" z/ " ENDOF
13 OF S" z^ " ENDOF
15 OF S" z! " ENDOF
0 OF S" " ENDOF
ENDCASE
do_fn
;
' <expr> defines expr \ resolve forward refs
' <term> defines term
' <factor> defines factor
: >out ( c-adr u --) out_pad concat ; \ append to out_pad
FORTH-WORDLIST SET-CURRENT \ definitions to FORTH
[undefined] $ftemp [IF] CREATE $ftemp 32 CHARS ALLOT [THEN]
: f->$ ( f: r --) ( -- c-adr u)
BL $ftemp C!
$ftemp CHAR+ [CHAR] . OVER C! ( $ftemp+1)
CHAR+ PRECISION REPRESENT ( n f1 f2)
INVERT
IF ." Can't convert fp# to string!" ABORT THEN
IF [CHAR] - $ftemp C! THEN ( n)
$ftemp PRECISION 2 + CHARS + ( n adr)
[CHAR] E OVER C! \ add E
CHAR+ ( n adr+1)
SWAP S>D TUCK DABS <# #S ROT SIGN #> ( adr+1 c-adr u)
ROT SWAP DUP >R CMOVE
$ftemp PRECISION 3 + R> + CHARS ( c-adr u)
do_fn
;
: (f") ( --)
['] real_op defines .op \ redirect
['] <try_fp#> defines try_fp#
['] f->$ defines .fp#
['] >out defines do_id
['] >out defines do_fn
['] <do_f@> defines do_@
['] <do_f^> defines do_^
['] $fneg defines neg$
get_formula assign
out_pad DUP CELL+ SWAP @ ( c-adr u)
;
: f" (f") STATE @
IF EVALUATE ELSE CR CR TYPE THEN ; IMMEDIATE
: f$" (f") EVALUATE ;
: z->$ ( f: x y --) FSWAP f->$ 0null ends->count do_fn f->$ ;
: (zz") ( --) \ can't use z" -- Win32Forth uses it!
['] cmplx_op defines .op \ redirect
['] <try_z#> defines try_fp#
['] z->$ defines .fp#
['] >out defines do_id
['] >out defines do_fn
['] <do_z@> defines do_@
['] <do_z^> defines do_^
['] $zneg defines neg$
get_formula assign
out_pad DUP CELL+ SWAP @ ( c-adr u)
;
: zz" (zz") STATE @
IF EVALUATE ELSE CR CR TYPE THEN
; IMMEDIATE
: zz$" (zz") EVALUATE ;
\ ----------------------------------------------- end output words
\ GET-ORDER NIP 1- SET-ORDER \ hide ftran definitions
\ ---------------------------------------------------- end program