\ 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