ftran202.f
\ ******** 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