Plan 9 from Bell Labs’s /usr/web/sources/contrib/fgb/root/sys/src/cmd/4th/examples/pp4th.4th

Copyright © 2021 Plan 9 Foundation.
Distributed under the MIT License.
Download the Plan 9 distribution.


\ 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

Bell Labs OSI certified Powered by Plan 9

(Return to Plan 9 Home Page)

Copyright © 2021 Plan 9 Foundation. All Rights Reserved.
Comments to [email protected].