\ 4tH Preprocessor - Copyright 2009 J.L. Bezemer
\ You can redistribute this file and/or modify it under
\ the terms of the GNU General Public License
79 constant RMARGIN \ for PRINT
include lib/parsname.4th \ for PARSE-NAME
include lib/print.4th \ for PRINT
include lib/row.4th \ for ROW
include lib/ncoding.4th \ for NELL, N!, N@
include lib/stack.4th \ for >A A>
include lib/getenv.4th \ for GETENV
255 constant $ \ marking a literal string
32 constant #case \ depth of CASE stack
128 constant #macro \ maximum number of macros
32 constant #include \ maximum number of include files
256 constant /dir4th \ maximum size of DIR4TH path
/dir4th string dir4th \ allocate DIR4TH buffer
dir4th value 'dir4th \ DIR4TH terminator address
#macro 256 [*] constant /macro-buffer \ calculate size of macro buffer
/macro-buffer buffer: macro-buffer \ allocate macro buffer
struct \ structure for macro
width +field name \ name of the macro
nell +field buf-addr \ start in macro buffer
end-struct /macro \ size of macro structure
#macro /macro [*] buffer: macro \ allocate macro array
:this macro does> swap /macro * + ; \ define runtime behavior
struct \ structure for include files
128 +field sourcename \ name of the source file
/tib +field terminalinput \ save contents of TIB
nell +field in \ save >IN
nell +field position \ save current file position
end-struct /include \ size of include structure
#include /include [*] buffer: includes \ allocate include array
:this includes does> swap /include * + ;
#case array case-stack \ CASE control stack
variable tob \ top of buffer
variable macro# \ number of defined macros
variable include#
false value state? \ are we defining a macro
\ add a word to macro space
: >macro ( a n --)
tob @ over over over >r + macro-buffer /macro-buffer chars + < 0=
abort" Macro space exhausted" place r> 1+ tob +!
; \ check if it fits in macro space
\ a few helper words
: tib@ tib >in @ chars + c@ ; ( -- c)
: eol? tib@ 0= dup if nl then ; ( -- f)
: ?emit dup bl < if drop else show then ;
: >delimiter >r print r@ parse ?space (print) r> ?emit ;
: delimiter| parse 2drop ; ( c --)
: +macro -1 tob +! >macro ; ( a n --)
: sliteral $ pad tuck c! 1 >macro ; ( --)
: c>macro dup bl < if drop else pad tuck c! 1 +macro then ;
: write dup if state? if >macro else print then else 2drop then ;
: delimiter! >r sliteral +macro bl c>macro r@ parse +macro r> c>macro ;
: (delimiter) state? if delimiter! else >delimiter then ;
: .word over c@ $ = if chop ?space (print) else print then ;
: next-token parse-name dup 0= abort" Unexpected end of line" ;
: !dir4th 0 'dir4th c! ; \ terminate DIR4TH
: dir4th! s" DIR4TH" dir4th /dir4th getenv chars + to 'dir4th !dir4th ;
\ prints out an entire macro
: .macro ( n --)
macro -> buf-addr n@ \ get the address from the macro
begin count dup while 2dup .word 1+ chars + repeat 2drop
; \ print it out until null string
: macro? ( a n -- a n f)
false -rot macro# @ 0 ?do \ setup flag, for all macros..
2dup i macro -> name count compare \ check the name
0= if i .macro rot drop true -rot leave then
loop rot \ if it is a macro print it and signal
;
\ check if it is a macro
: macro|word ( a n --)
macro? if 2drop state? abort" Macro not allowed here" else write then
; \ embedded macros not allowed
\ save filename in NEW record
: filename! ( c -- a n)
dup bl = if drop next-token else parse then 2dup
include# @ dup #include < 0= abort" Include file nested too deep"
includes -> sourcename place 1 include# +!
; \ abort if includes nested too deep
\ save position info in prev. record
: position! ( h -- h)
include# @ 1- 1- \ get pointer to PREVIOUS record
over tell over includes -> position n!
tib over includes -> terminalinput /tib cmove
>in @ swap includes -> in n! \ save contents of TIB and >IN
; \ and increment include pointer
\ open an INCLUDE file
: open-include ( a n -- h)
2dup input open error? \ try to open it normally
if \ did that work?
drop dir4th +place \ if not, add DIR4TH path
dir4th count input open error? \ and try again
abort" Cannot open include file" \ abort on error
!dir4th \ remove filename from string
else \ if it did work
>r 2drop r> \ get rid of the filename copy
then dup use \ use the open file immediately
;
\ process an INCLUDE or [NEEDS
: >include ( hi ho c -- hi ho)
state? abort" Include file not allowed here"
filename! 2>r swap position! close 2r> open-include swap
refill 0= abort" Cannot read include file"
; \ close previous file and open include
\ convert a number postfix
: number% ( a n --)
next-token s| S" | \ get number string and put on stack
state? if sliteral +macro +macro +macro else print (print) (print) then
; \ set appropriate behavior
\ behavior of several delimiters
: (EOL) 0 (delimiter) ; ( a n --)
: (") [char] " (delimiter) ; ( a n --)
: (|) [char] | (delimiter) ; ( a n --)
: ()) [char] ) (delimiter) ; ( a n --)
\ behavior of ;
: (;) state? if 2drop pad 0 >macro false to state? else print then ;
: EOL| 2drop 0 delimiter| ; \ delete until end of line
: )| 2drop [char] ) delimiter| ; \ delete until )
: .INIT next-token 2dup write 2dup write ;
: .THIS s" :THIS" write write ; ( a n --)
: (INCLUDE) 2drop bl >include ; \ resolve INCLUDE behavior
: (NEEDS) 2drop [char] ] >include ; \ resolve [NEEDS behavior
: (CHAR) 2drop next-token drop c@ <# #s #> write ;
: (OF) 2drop s" OVER" write s" =" write s" IF" write s" DROP" write ;
: (ACTION-OF) 2drop s" [']" write next-token write s" DEFER@" write ;
: (FVARIABLE) 2drop s" FLOAT" write s" ARRAY" write ;
: (2VARIABLE) 2drop s" 2" write s" ARRAY" write ;
: (2CONSTANT) (2VARIABLE) .INIT s" 2!" write .THIS s" 2@" write s" ;" write ;
: (FCONSTANT) (FVARIABLE) .INIT s" F!" write .THIS s" F@" write s" ;" write ;
: (D%) 2drop s| " S>DOUBLE| number% ; \ create double number expression
: (F%) 2drop s| " S>FLOAT| number% ; \ create floating point expression
\ replace OF with OVER = IF DROP
: (CASE) \ initialize control stack
2drop case-stack adepth #case -1 [+] = abort" Nesting too deep"
0 case-stack >a \ abort when stack overflows
; \ put counter on stack
: (ENDOF) \ replace ENDOF with ELSE
2drop s" ELSE" write \ abort if case-stack empty
case-stack adepth 0= abort" Missing CASE"
case-stack a> 1+ case-stack >a \ increment top of case-stack
;
\ replace ENDCASE with DROP
: (ENDCASE) \ abort if case-stack empty
2drop s" DROP" write \ write as many THENs as ELSEs
case-stack adepth 0= abort" Missing CASE"
case-stack a> 0 ?DO s" THEN" write LOOP
; \ remove top of case-stack
: (WHITE) \ resolve whitespace behavior
state? if \ are we defining? get word, name
>macro bl c>macro next-token +macro
else \ and save in macro buffer
print ?space next-token (print) \ if not, print word and next term
then
;
\ resolve behavior :MACRO keyword
: (:MACRO) \ forget the keyword and check
2drop state? abort" Unexpected macro"
macro# @ dup #macro = abort" Too many macros"
>r next-token r@ macro -> name place \ save the macro name
tob @ r> macro -> buf-addr n! \ save the current macro buffer address
1 macro# +! true to state? \ increment number of macros and set
; \ defining state accordingly
\ keywords with associated behaviors
create keyword
," \" ' EOL| ,
," (" ' )| ,
," #!" ' (EOL) ,
,| ,"| ' (") ,
," ,|" ' (|) ,
,| ."| ' (") ,
," .(" ' ()) ,
," .|" ' (|) ,
,| S"| ' (") ,
," S|" ' (|) ,
," CHAR" ' (CHAR) ,
," @GOTO" ' (EOL) ,
," [NEEDS" ' (NEEDS) ,
,| ABORT"| ' (") ,
," [CHAR]" ' (CHAR) ,
," INCLUDE" ' (INCLUDE) ,
," [DEFINED]" ' (WHITE) ,
," [UNDEFINED]" ' (WHITE) ,
," :MACRO" ' (:MACRO) ,
," ;" ' (;) ,
," F%" ' (F%) ,
," D%" ' (D%) ,
," CASE" ' (CASE) ,
," OF" ' (OF) ,
," ENDOF" ' (ENDOF) ,
," ENDCASE" ' (ENDCASE) ,
," FVARIABLE" ' (FVARIABLE) ,
," FCONSTANT" ' (FCONSTANT) ,
," 2VARIABLE" ' (2VARIABLE) ,
," 2CONSTANT" ' (2CONSTANT) ,
," ACTION-OF" ' (ACTION-OF) ,
NULL ,
:this keyword does> \ standard behavior of keyword
2 string-key row if cell+ @c execute else drop macro|word then ;
\ prerequisites of CONVERT.4TH
: Read-file ( -- f)
refill \ get a line
if
true \ if we got it, ok
else \ if we didn't get it..
include# -1 over +! @ dup \ decrement the include stack
if \ if we're not at the original source
1- >r swap close \ get the previous include file
r@ includes -> sourcename count open-include
r@ includes -> position n@ over seek abort" Seek failed"
r@ includes -> terminalinput tib /tib cmove
r> includes -> in n@ >in ! \ open it and restore everything
swap true \ signal we're ready for business
else \ if we're at the original source file
drop false \ signal we're done and let CONVERT.4TH
then \ handle the rest
then
;
: PreProcess \ initialize all variables
macro-buffer tob ! 0 macro# ! 1 include# ! dir4th!
1 args 0 includes -> sourcename place case-stack stack
; \ and the include file entry
\ of the original source file
: Usage abort" Usage: pp4th infile outfile" ;
: PostProcess case-stack adepth abort" Unmatched CASE" ;
: Process begin parse-name keyword eol? until ;
include lib/convert.4th
|
