extra/c/preprocessor/preprocessor.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: sequences.parser io io.encodings.utf8 io.files
   4 io.streams.string kernel combinators accessors io.pathnames
   5 fry sequences arrays locals namespaces io.directories
   6 assocs math splitting make unicode.categories
   7 combinators.short-circuit c.lexer ;
   8 IN: c.preprocessor
   9
  10 : initial-library-paths ( -- seq )
  11     V{ "/usr/include" } clone ;
  12
  13 : initial-symbol-table ( -- hashtable )
  14     H{
  15         { "__APPLE__" "" }
  16         { "__amd64__" "" }
  17         { "__x86_64__" "" }
  18     } clone ;
  19
  20 TUPLE: preprocessor-state library-paths symbol-table
  21 include-nesting include-nesting-max processing-disabled?
  22 ifdef-nesting warnings errors
  23 pragmas
  24 include-nexts
  25 ifs elifs elses ;
  26
  27 : <preprocessor-state> ( -- preprocessor-state )
  28     preprocessor-state new
  29         initial-library-paths >>library-paths
  30         initial-symbol-table >>symbol-table
  31         0 >>include-nesting
  32         200 >>include-nesting-max
  33         0 >>ifdef-nesting
  34         V{ } clone >>warnings
  35         V{ } clone >>errors
  36         V{ } clone >>pragmas
  37         V{ } clone >>include-nexts
  38         V{ } clone >>ifs
  39         V{ } clone >>elifs
  40         V{ } clone >>elses ;
  41
  42 DEFER: preprocess-file
  43
  44 ERROR: unknown-c-preprocessor sequence-parser name ;
  45
  46 ERROR: bad-include-line line ;
  47
  48 ERROR: header-file-missing path ;
  49
  50 :: read-standard-include ( preprocessor-state path -- )
  51     preprocessor-state dup library-paths>>
  52     [ path append-path exists? ] find nip
  53     [
  54         dup [
  55             path append-path
  56             preprocess-file
  57         ] with-directory
  58     ] [
  59         ! path header-file-missing
  60         drop
  61     ] if* ;
  62
  63 :: read-local-include ( preprocessor-state path -- )
  64     current-directory get path append-path dup :> full-path
  65     dup exists? [
  66         [ preprocessor-state ] dip preprocess-file
  67     ] [
  68         ! full-path header-file-missing
  69         drop
  70     ] if ;
  71
  72 : skip-whitespace/comments ( sequence-parser -- sequence-parser )
  73     skip-whitespace
  74     {
  75         { [ dup take-c-comment ] [ skip-whitespace/comments ] }
  76         { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
  77         [ ]
  78     } cond ;
  79
  80 : handle-include ( preprocessor-state sequence-parser -- )
  81     skip-whitespace/comments advance dup previous {
  82         { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
  83         { CHAR: " [ CHAR: " take-until-object read-local-include ] }
  84         [ bad-include-line ]
  85     } case ;
  86
  87 : (readlns) ( -- )
  88     readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
  89
  90 : readlns ( -- string ) [ (readlns) ] { } make concat ;
  91
  92 : take-define-identifier ( sequence-parser -- string )
  93     skip-whitespace/comments
  94     [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
  95
  96 :: handle-define ( preprocessor-state sequence-parser -- )
  97     sequence-parser take-define-identifier :> ident
  98     sequence-parser skip-whitespace/comments take-rest :> def
  99     def "\\" ?tail [ readlns append ] when :> def
 100     def ident preprocessor-state symbol-table>> set-at ;
 101
 102 : handle-undef ( preprocessor-state sequence-parser -- )
 103     take-token swap symbol-table>> delete-at ;
 104
 105 : handle-ifdef ( preprocessor-state sequence-parser -- )
 106     [ [ 1 + ] change-ifdef-nesting ] dip
 107     take-token over symbol-table>> key?
 108     [ drop ] [ t >>processing-disabled? drop ] if ;
 109
 110 : handle-ifndef ( preprocessor-state sequence-parser -- )
 111     [ [ 1 + ] change-ifdef-nesting ] dip
 112     take-token over symbol-table>> key?
 113     [ t >>processing-disabled? drop ]
 114     [ drop ] if ;
 115
 116 : handle-endif ( preprocessor-state sequence-parser -- )
 117     drop [ 1 - ] change-ifdef-nesting drop ;
 118
 119 : handle-if ( preprocessor-state sequence-parser -- )
 120     [ [ 1 + ] change-ifdef-nesting ] dip
 121     skip-whitespace/comments take-rest swap ifs>> push ;
 122
 123 : handle-elif ( preprocessor-state sequence-parser -- )
 124     skip-whitespace/comments take-rest swap elifs>> push ;
 125
 126 : handle-else ( preprocessor-state sequence-parser -- )
 127     skip-whitespace/comments take-rest swap elses>> push ;
 128
 129 : handle-pragma ( preprocessor-state sequence-parser -- )
 130     skip-whitespace/comments take-rest swap pragmas>> push ;
 131
 132 : handle-include-next ( preprocessor-state sequence-parser -- )
 133     skip-whitespace/comments take-rest swap include-nexts>> push ;
 134
 135 : handle-error ( preprocessor-state sequence-parser -- )
 136     skip-whitespace/comments take-rest swap errors>> push ;
 137     ! nip take-rest throw ;
 138
 139 : handle-warning ( preprocessor-state sequence-parser -- )
 140     skip-whitespace/comments
 141     take-rest swap warnings>> push ;
 142
 143 : parse-directive ( preprocessor-state sequence-parser string -- )
 144     {
 145         { "warning" [ handle-warning ] }
 146         { "error" [ handle-error ] }
 147         { "include" [ handle-include ] }
 148         { "define" [ handle-define ] }
 149         { "undef" [ handle-undef ] }
 150         { "ifdef" [ handle-ifdef ] }
 151         { "ifndef" [ handle-ifndef ] }
 152         { "endif" [ handle-endif ] }
 153         { "if" [ handle-if ] }
 154         { "elif" [ handle-elif ] }
 155         { "else" [ handle-else ] }
 156         { "pragma" [ handle-pragma ] }
 157         { "include_next" [ handle-include-next ] }
 158         [ unknown-c-preprocessor ]
 159     } case ;
 160
 161 : parse-directive-line ( preprocessor-state sequence-parser -- )
 162     advance dup take-token
 163     pick processing-disabled?>> [
 164         "endif" = [
 165             drop f >>processing-disabled?
 166             [ 1 - ] change-ifdef-nesting
 167             drop
 168          ] [ 2drop ] if
 169     ] [
 170         parse-directive
 171     ] if ;
 172
 173 : preprocess-line ( preprocessor-state sequence-parser -- )
 174     skip-whitespace/comments dup current CHAR: # =
 175     [ parse-directive-line ]
 176     [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
 177
 178 : preprocess-lines ( preprocessor-state -- )
 179     readln
 180     [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
 181     [ drop ] if* ;
 182
 183 ERROR: include-nested-too-deeply ;
 184
 185 : check-nesting ( preprocessor-state -- preprocessor-state )
 186     [ 1 + ] change-include-nesting
 187     dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
 188         include-nested-too-deeply
 189     ] when ;
 190
 191 : preprocess-file ( preprocessor-state path -- )
 192     [ check-nesting ] dip
 193     [ utf8 [ preprocess-lines ] with-file-reader ]
 194     [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
 195
 196 : start-preprocess-file ( path -- preprocessor-state string )
 197     dup parent-directory [
 198         [
 199             [ <preprocessor-state> dup ] dip preprocess-file
 200         ] with-string-writer
 201     ] with-directory ;