extra/c/preprocessor/preprocessor.factor

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