Merge Haddock comment support from ghc.haddock -- big patch
[ghc.git] / compiler / cmm / CmmLex.x
1 -----------------------------------------------------------------------------
2 -- (c) The University of Glasgow, 2004
3 --
4 -- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there
5 -- are a few minor differences:
6 --
7 --   * extra keywords for our macros, and float32/float64 types
8 --   * global registers (Sp,Hp, etc.)
9 --
10 -----------------------------------------------------------------------------
11
12 {
13 module CmmLex (
14    CmmToken(..), cmmlex,
15   ) where
16
17 #include "HsVersions.h"
18
19 import Cmm
20 import Lexer
21
22 import SrcLoc
23 import UniqFM
24 import StringBuffer
25 import FastString
26 import Ctype
27 import Util             ( readRational )
28 --import TRACE
29 }
30
31 $whitechar   = [\ \t\n\r\f\v\xa0]
32 $white_no_nl = $whitechar # \n
33
34 $ascdigit  = 0-9
35 $unidigit  = \x01
36 $digit     = [$ascdigit $unidigit]
37 $octit     = 0-7
38 $hexit     = [$digit A-F a-f]
39
40 $unilarge  = \x03
41 $asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
42 $large     = [$asclarge $unilarge]
43
44 $unismall  = \x04
45 $ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
46 $small     = [$ascsmall $unismall \_]
47
48 $namebegin = [$large $small \_ \. \$ \@]
49 $namechar  = [$namebegin $digit]
50
51 @decimal     = $digit+
52 @octal       = $octit+
53 @hexadecimal = $hexit+
54 @exponent    = [eE] [\-\+]? @decimal
55
56 @floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
57
58 @escape      = \\ ([abfnrt\\\'\"\?] | x @hexadecimal | @octal)
59 @strchar     = ($printable # [\"\\]) | @escape
60
61 cmm :-
62
63 $white_no_nl+           ;
64 ^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output
65
66 ^\# (line)?             { begin line_prag }
67
68 -- single-line line pragmas, of the form
69 --    # <line> "<file>" <extra-stuff> \n
70 <line_prag> $digit+                     { setLine line_prag1 }
71 <line_prag1> \" ($printable # \")* \"   { setFile line_prag2 }
72 <line_prag2> .*                         { pop }
73
74 <0> {
75   \n                    ;
76
77   [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }
78   
79   ".."                  { kw CmmT_DotDot }
80   "::"                  { kw CmmT_DoubleColon }
81   ">>"                  { kw CmmT_Shr }
82   "<<"                  { kw CmmT_Shl }
83   ">="                  { kw CmmT_Ge }
84   "<="                  { kw CmmT_Le }
85   "=="                  { kw CmmT_Eq }
86   "!="                  { kw CmmT_Ne }
87   "&&"                  { kw CmmT_BoolAnd }
88   "||"                  { kw CmmT_BoolOr }
89   
90   R@decimal             { global_regN VanillaReg }
91   F@decimal             { global_regN FloatReg }
92   D@decimal             { global_regN DoubleReg }
93   L@decimal             { global_regN LongReg }
94   Sp                    { global_reg Sp }
95   SpLim                 { global_reg SpLim }
96   Hp                    { global_reg Hp }
97   HpLim                 { global_reg HpLim }
98   CurrentTSO            { global_reg CurrentTSO }
99   CurrentNursery        { global_reg CurrentNursery }
100   HpAlloc               { global_reg HpAlloc }
101   BaseReg               { global_reg BaseReg }
102   
103   $namebegin $namechar* { name }
104   
105   0 @octal              { tok_octal }
106   @decimal              { tok_decimal }
107   0[xX] @hexadecimal    { tok_hexadecimal }
108   @floating_point       { strtoken tok_float }
109   
110   \" @strchar* \"       { strtoken tok_string }
111 }
112
113 {
114 data CmmToken
115   = CmmT_SpecChar  Char
116   | CmmT_DotDot
117   | CmmT_DoubleColon
118   | CmmT_Shr
119   | CmmT_Shl
120   | CmmT_Ge
121   | CmmT_Le
122   | CmmT_Eq
123   | CmmT_Ne
124   | CmmT_BoolAnd
125   | CmmT_BoolOr
126   | CmmT_CLOSURE
127   | CmmT_INFO_TABLE
128   | CmmT_INFO_TABLE_RET
129   | CmmT_INFO_TABLE_FUN
130   | CmmT_INFO_TABLE_CONSTR
131   | CmmT_INFO_TABLE_SELECTOR
132   | CmmT_else
133   | CmmT_export
134   | CmmT_section
135   | CmmT_align
136   | CmmT_goto
137   | CmmT_if
138   | CmmT_jump
139   | CmmT_foreign
140   | CmmT_prim
141   | CmmT_import
142   | CmmT_switch
143   | CmmT_case
144   | CmmT_default
145   | CmmT_bits8
146   | CmmT_bits16
147   | CmmT_bits32
148   | CmmT_bits64
149   | CmmT_float32
150   | CmmT_float64
151   | CmmT_GlobalReg GlobalReg
152   | CmmT_Name      FastString
153   | CmmT_String    String
154   | CmmT_Int       Integer
155   | CmmT_Float     Rational
156   | CmmT_EOF
157 #ifdef DEBUG
158   deriving (Show)
159 #endif
160
161 -- -----------------------------------------------------------------------------
162 -- Lexer actions
163
164 type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
165
166 begin :: Int -> Action
167 begin code _span _str _len = do pushLexState code; lexToken
168
169 pop :: Action
170 pop _span _buf _len = do popLexState; lexToken
171
172 special_char :: Action
173 special_char span buf len = return (L span (CmmT_SpecChar (currentChar buf)))
174
175 kw :: CmmToken -> Action
176 kw tok span buf len = return (L span tok)
177
178 global_regN :: (Int -> GlobalReg) -> Action
179 global_regN con span buf len 
180   = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
181   where buf' = stepOn buf
182         n = parseInteger buf' (len-1) 10 octDecDigit
183
184 global_reg :: GlobalReg -> Action
185 global_reg r span buf len = return (L span (CmmT_GlobalReg r))
186
187 strtoken :: (String -> CmmToken) -> Action
188 strtoken f span buf len = 
189   return (L span $! (f $! lexemeToString buf len))
190
191 name :: Action
192 name span buf len = 
193   case lookupUFM reservedWordsFM fs of
194         Just tok -> return (L span tok)
195         Nothing  -> return (L span (CmmT_Name fs))
196   where
197         fs = lexemeToFastString buf len
198
199 reservedWordsFM = listToUFM $
200         map (\(x, y) -> (mkFastString x, y)) [
201         ( "CLOSURE",            CmmT_CLOSURE ),
202         ( "INFO_TABLE",         CmmT_INFO_TABLE ),
203         ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),
204         ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),
205         ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),
206         ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
207         ( "else",               CmmT_else ),
208         ( "export",             CmmT_export ),
209         ( "section",            CmmT_section ),
210         ( "align",              CmmT_align ),
211         ( "goto",               CmmT_goto ),
212         ( "if",                 CmmT_if ),
213         ( "jump",               CmmT_jump ),
214         ( "foreign",            CmmT_foreign ),
215         ( "prim",               CmmT_prim ),
216         ( "import",             CmmT_import ),
217         ( "switch",             CmmT_switch ),
218         ( "case",               CmmT_case ),
219         ( "default",            CmmT_default ),
220         ( "bits8",              CmmT_bits8 ),
221         ( "bits16",             CmmT_bits16 ),
222         ( "bits32",             CmmT_bits32 ),
223         ( "bits64",             CmmT_bits64 ),
224         ( "float32",            CmmT_float32 ),
225         ( "float64",            CmmT_float64 )
226         ]
227
228 tok_decimal span buf len 
229   = return (L span (CmmT_Int  $! parseInteger buf len 10 octDecDigit))
230
231 tok_octal span buf len 
232   = return (L span (CmmT_Int  $! parseInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
233
234 tok_hexadecimal span buf len 
235   = return (L span (CmmT_Int  $! parseInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
236
237 tok_float str = CmmT_Float $! readRational str
238
239 tok_string str = CmmT_String (read str)
240                  -- urk, not quite right, but it'll do for now
241
242 -- -----------------------------------------------------------------------------
243 -- Line pragmas
244
245 setLine :: Int -> Action
246 setLine code span buf len = do
247   let line = parseInteger buf len 10 octDecDigit
248   setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
249         -- subtract one: the line number refers to the *following* line
250   -- trace ("setLine "  ++ show line) $ do
251   popLexState
252   pushLexState code
253   lexToken
254
255 setFile :: Int -> Action
256 setFile code span buf len = do
257   let file = lexemeToFastString (stepOn buf) (len-2)
258   setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
259   popLexState
260   pushLexState code
261   lexToken
262
263 -- -----------------------------------------------------------------------------
264 -- This is the top-level function: called from the parser each time a
265 -- new token is to be read from the input.
266
267 cmmlex :: (Located CmmToken -> P a) -> P a
268 cmmlex cont = do
269   tok@(L _ tok__) <- lexToken
270   --trace ("token: " ++ show tok__) $ do
271   cont tok
272
273 lexToken :: P (Located CmmToken)
274 lexToken = do
275   inp@(loc1,buf) <- getInput
276   sc <- getLexState
277   case alexScan inp sc of
278     AlexEOF -> do let span = mkSrcSpan loc1 loc1
279                   setLastToken span 0 0
280                   return (L span CmmT_EOF)
281     AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
282     AlexSkip inp2 _ -> do
283         setInput inp2
284         lexToken
285     AlexToken inp2@(end,buf2) len t -> do
286         setInput inp2
287         let span = mkSrcSpan loc1 end
288         span `seq` setLastToken span len len
289         t span buf len
290
291 -- -----------------------------------------------------------------------------
292 -- Monad stuff
293
294 -- Stuff that Alex needs to know about our input type:
295 type AlexInput = (SrcLoc,StringBuffer)
296
297 alexInputPrevChar :: AlexInput -> Char
298 alexInputPrevChar (_,s) = prevChar s '\n'
299
300 alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
301 alexGetChar (loc,s) 
302   | atEnd s   = Nothing
303   | otherwise = c `seq` loc' `seq` s' `seq` Just (c, (loc', s'))
304   where c = currentChar s
305         loc' = advanceSrcLoc loc c
306         s'   = stepOn s
307
308 getInput :: P AlexInput
309 getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
310
311 setInput :: AlexInput -> P ()
312 setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } ()
313 }