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     dup exists? [ preprocess-file ] [ 2drop ] if ;
  65
  66 : skip-whitespace/comments ( sequence-parser -- sequence-parser )
  67     skip-whitespace
  68     {
  69         { [ dup take-c-comment ] [ skip-whitespace/comments ] }
  70         { [ dup take-c++-comment ] [ skip-whitespace/comments ] }
  71         [ ]
  72     } cond ;
  73
  74 : handle-include ( preprocessor-state sequence-parser -- )
  75     skip-whitespace/comments advance dup previous {
  76         { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
  77         { CHAR: " [ CHAR: " take-until-object read-local-include ] }
  78         [ bad-include-line ]
  79     } case ;
  80
  81 : (readlns) ( -- )
  82     readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
  83
  84 : readlns ( -- string ) [ (readlns) ] { } make concat ;
  85
  86 : take-define-identifier ( sequence-parser -- string )
  87     skip-whitespace/comments
  88     [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
  89
  90 :: handle-define ( preprocessor-state sequence-parser -- )
  91     sequence-parser take-define-identifier :> ident
  92     sequence-parser skip-whitespace/comments take-rest :> def
  93     def "\\" ?tail [ readlns append ] when :> def
  94     def ident preprocessor-state symbol-table>> set-at ;
  95
  96 : handle-undef ( preprocessor-state sequence-parser -- )
  97     take-token swap symbol-table>> delete-at ;
  98
  99 : handle-ifdef ( preprocessor-state sequence-parser -- )
 100     [ [ 1 + ] change-ifdef-nesting ] dip
 101     take-token over symbol-table>> key?
 102     [ drop ] [ t >>processing-disabled? drop ] if ;
 103
 104 : handle-ifndef ( preprocessor-state sequence-parser -- )
 105     [ [ 1 + ] change-ifdef-nesting ] dip
 106     take-token over symbol-table>> key?
 107     [ t >>processing-disabled? drop ]
 108     [ drop ] if ;
 109
 110 : handle-endif ( preprocessor-state sequence-parser -- )
 111     drop [ 1 - ] change-ifdef-nesting drop ;
 112
 113 : handle-if ( preprocessor-state sequence-parser -- )
 114     [ [ 1 + ] change-ifdef-nesting ] dip
 115     skip-whitespace/comments take-rest swap ifs>> push ;
 116
 117 : handle-elif ( preprocessor-state sequence-parser -- )
 118     skip-whitespace/comments take-rest swap elifs>> push ;
 119
 120 : handle-else ( preprocessor-state sequence-parser -- )
 121     skip-whitespace/comments take-rest swap elses>> push ;
 122
 123 : handle-pragma ( preprocessor-state sequence-parser -- )
 124     skip-whitespace/comments take-rest swap pragmas>> push ;
 125
 126 : handle-include-next ( preprocessor-state sequence-parser -- )
 127     skip-whitespace/comments take-rest swap include-nexts>> push ;
 128
 129 : handle-error ( preprocessor-state sequence-parser -- )
 130     skip-whitespace/comments take-rest swap errors>> push ;
 131     ! nip take-rest throw ;
 132
 133 : handle-warning ( preprocessor-state sequence-parser -- )
 134     skip-whitespace/comments
 135     take-rest swap warnings>> push ;
 136
 137 : parse-directive ( preprocessor-state sequence-parser string -- )
 138     {
 139         { "warning" [ handle-warning ] }
 140         { "error" [ handle-error ] }
 141         { "include" [ handle-include ] }
 142         { "define" [ handle-define ] }
 143         { "undef" [ handle-undef ] }
 144         { "ifdef" [ handle-ifdef ] }
 145         { "ifndef" [ handle-ifndef ] }
 146         { "endif" [ handle-endif ] }
 147         { "if" [ handle-if ] }
 148         { "elif" [ handle-elif ] }
 149         { "else" [ handle-else ] }
 150         { "pragma" [ handle-pragma ] }
 151         { "include_next" [ handle-include-next ] }
 152         [ unknown-c-preprocessor ]
 153     } case ;
 154
 155 : parse-directive-line ( preprocessor-state sequence-parser -- )
 156     advance dup take-token
 157     pick processing-disabled?>> [
 158         "endif" = [
 159             drop f >>processing-disabled?
 160             [ 1 - ] change-ifdef-nesting
 161             drop
 162          ] [ 2drop ] if
 163     ] [
 164         parse-directive
 165     ] if ;
 166
 167 : preprocess-line ( preprocessor-state sequence-parser -- )
 168     skip-whitespace/comments dup current CHAR: # =
 169     [ parse-directive-line ]
 170     [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
 171
 172 : preprocess-lines ( preprocessor-state -- )
 173     readln
 174     [ <sequence-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
 175     [ drop ] if* ;
 176
 177 ERROR: include-nested-too-deeply ;
 178
 179 : check-nesting ( preprocessor-state -- preprocessor-state )
 180     [ 1 + ] change-include-nesting
 181     dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
 182         include-nested-too-deeply
 183     ] when ;
 184
 185 : preprocess-file ( preprocessor-state path -- )
 186     [ check-nesting ] dip
 187     [ utf8 [ preprocess-lines ] with-file-reader ]
 188     [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
 189
 190 : start-preprocess-file ( path -- preprocessor-state string )
 191     dup parent-directory [
 192         [
 193             [ <preprocessor-state> dup ] dip preprocess-file
 194         ] with-string-writer
 195     ] with-directory ;