mescc: mes parses simplest main with lalr.
[mes.git] / c-lexer.scm
1 ;;; ECMAScript for Guile
2
3 ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
4
5 ;;;; This library is free software; you can redistribute it and/or
6 ;;;; modify it under the terms of the GNU Lesser General Public
7 ;;;; License as published by the Free Software Foundation; either
8 ;;;; version 3 of the License, or (at your option) any later version.
9 ;;;; 
10 ;;;; This library is distributed in the hope that it will be useful,
11 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13 ;;;; Lesser General Public License for more details.
14 ;;;; 
15 ;;;; You should have received a copy of the GNU Lesser General Public
16 ;;;; License along with this library; if not, write to the Free Software
17 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19 ;;; Code:
20
21 ;; (define-module (language ecmascript tokenize)
22 ;;   #:use-module (ice-9 rdelim)
23 ;;   #:use-module ((srfi srfi-1) #:select (unfold-right))
24 ;;   #:use-module (system base lalr)
25 ;;   #:export (next-token make-tokenizer make-tokenizer/1 tokenize tokenize/1))
26
27 (cond-expand
28   (guile
29    (use-modules ((ice-9 rdelim)))
30
31    (define (syntax-error what loc form . args)
32      (throw 'syntax-error #f what
33             ;;(and=> loc source-location->source-properties)
34             loc
35             form #f args))
36    
37    )
38   (mes
39
40    )
41   )
42
43 (define (port-source-location port)
44   (make-source-location (port-filename port)
45                         (port-line port)
46                         (port-column port)
47                         (false-if-exception (ftell port))
48                         #f))
49
50 ;; taken from SSAX, sorta
51 (define (read-until delims loc)
52   (if (eof-object? (peek-char))
53       (syntax-error "EOF while reading a token" loc #f)
54       (let ((token (read-delimited delims (current-input-port) 'peek)))
55         (if (eof-object? (peek-char))
56             (syntax-error "EOF while reading a token" loc token)
57             token))))
58
59 (define (char-hex? c)
60   (and (not (eof-object? c))
61        (or (char-numeric? c)
62            (memv c '(#\a #\b #\c #\d #\e #\f))
63            (memv c '(#\A #\B #\C #\D #\E #\F)))))
64
65 (define (digit->number c)
66   (- (char->integer c) (char->integer #\0)))
67
68 (define (hex->number c)
69   (if (char-numeric? c)
70       (digit->number c)
71       (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
72
73 (define (read-slash loc div?)
74   (let ((c1 (begin
75               (read-char)
76               (peek-char))))
77     (cond
78      ((eof-object? c1)
79       ;; hmm. error if we're not looking for a div? ?
80       (make-lexical-token '/ loc #f))
81      ((char=? c1 #\/)
82       (read-line)
83       (next-token div?))
84      ((char=? c1 #\*)
85       (read-char)
86       (let lp ((c (read-char)))
87         (cond
88          ((eof-object? c)
89           (syntax-error "EOF while in multi-line comment" loc #f))
90          ((char=? c #\*)
91           (if (eqv? (peek-char) #\/)
92               (begin
93                 (read-char)
94                 (next-token div?))
95               (lp (read-char))))
96          (else
97           (lp (read-char))))))
98      (div?
99       (case c1
100         ((#\=) (read-char) (make-lexical-token '/= loc #f))
101         (else (make-lexical-token '/ loc #f))))
102      (else
103       ;;;(read-regexp loc)
104       (make-lexical-token '/ loc #f)))))
105
106 (define (read-string loc)
107   (let ((c (read-char)))
108     (let ((terms (string c #\\ #\newline #\return)))
109       (define (read-escape)
110         (let ((c (read-char)))
111           (case c
112             ((#\' #\" #\\) c)
113             ((#\b) #\backspace)
114             ((#\f) #\page)
115             ((#\n) #\newline)
116             ((#\r) #\return)
117             ((#\t) #\tab)
118             ((#\v) #\vt)
119             ((#\0)
120              (let ((next (peek-char)))
121                (cond
122                 ((eof-object? next) #\nul)
123                 ((char-numeric? next)
124                  (syntax-error "octal escape sequences are not supported"
125                                loc #f))
126                 (else #\nul))))
127             ((#\x)
128              (let* ((a (read-char))
129                     (b (read-char)))
130                (cond
131                 ((and (char-hex? a) (char-hex? b))
132                  (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
133                 (else
134                  (syntax-error "bad hex character escape" loc (string a b))))))
135             ((#\u)
136              (let* ((a (read-char))
137                     (b (read-char))
138                     (c (read-char))
139                     (d (read-char)))
140                (integer->char (string->number (string a b c d) 16))))
141             (else
142              c))))
143       (let lp ((str (read-until terms loc)))
144         (let ((terminator (peek-char)))
145           (cond
146            ((char=? terminator c)
147             (read-char)
148             (make-lexical-token 'StringLiteral loc str))
149            ((char=? terminator #\\)
150             (read-char)
151             (let ((echar (read-escape)))
152               (lp (string-append str (string echar)
153                                  (read-until terms loc)))))
154            (else
155             (syntax-error "string literals may not contain newlines"
156                           loc str))))))))
157
158 (define *keywords*
159   '(("break" . break)
160     ("case" . case)
161     ("continue" . continue)
162     ("else" . else)
163     ("goto" . goto)
164
165     ("char" . char)
166     ("double" . double)
167     ("float" . float)
168     ("int" . int)
169     ("long" . long)
170     ("short" . short)
171     ("unsigned" . unsigned)
172     
173     ("return" . return)
174     ("void" . void)
175     ("for" . for)
176     ("switch" . switch)
177     ("while" . while)
178     ("continue" . continue)
179     ("default" . default)
180     ("if" . if)
181     ("do" . do)
182
183     ;; these aren't exactly keywords, but hey
184     ("true" . true)
185     ("false" . false)))
186
187 (define (read-identifier loc)
188   (let lp ((c (peek-char)) (chars '()))
189     (if (or (eof-object? c)
190             (not (or (char-alphabetic? c)
191                      (char-numeric? c)
192                      (char=? c #\$)
193                      (char=? c #\_))))
194         (let ((word (list->string (reverse chars))))
195           (cond ((assoc-ref *keywords* word)
196                  (make-lexical-token (assoc-ref *keywords* word) loc #f))
197                 (else (make-lexical-token 'Identifier loc
198                                           (string->symbol word)))))
199         (begin (read-char)
200                (lp (peek-char) (cons c chars))))))
201
202 (define (read-numeric loc)
203   (let* ((c0 (if (char=? (peek-char) #\.)
204                  #\0
205                  (read-char)))
206          (c1 (peek-char)))
207     (cond
208      ((eof-object? c1) (digit->number c0))
209      ((and (char=? c0 #\0) (or (char=? c1 #\x) (char=? c1 #\X)))
210       (read-char)
211       (let ((c (peek-char)))
212         (if (not (char-hex? c))
213             (syntax-error "bad digit reading hexadecimal number"
214                           loc c))
215         (let lp ((c c) (acc 0))
216           (cond ((char-hex? c)
217                  (read-char)
218                  (lp (peek-char)
219                      (+ (* 16 acc) (hex->number c))))
220                 (else
221                  acc)))))
222      ((and (char=? c0 #\0) (char-numeric? c1))
223       (let lp ((c c1) (acc 0))
224         (cond ((eof-object? c) acc)
225               ((char-numeric? c)
226                (if (or (char=? c #\8) (char=? c #\9))
227                    (syntax-error "invalid digit in octal sequence"
228                                  loc c))
229                (read-char)
230                (lp (peek-char)
231                    (+ (* 8 acc) (digit->number c))))
232               (else
233                acc))))
234      (else
235       (let lp ((c1 c1) (acc (digit->number c0)))
236         (cond
237          ((eof-object? c1) acc)
238          ((char-numeric? c1)
239           (read-char)
240           (lp (peek-char)
241               (+ (* 10 acc) (digit->number c1))))
242          ((or (char=? c1 #\e) (char=? c1 #\E))
243           (read-char)
244           (let ((add (let ((c (peek-char)))
245                        (cond ((eof-object? c)
246                               (syntax-error "error reading exponent: EOF"
247                                             loc #f))
248                              ((char=? c #\+) (read-char) +)
249                              ((char=? c #\-) (read-char) -)
250                              ((char-numeric? c) +)
251                              (else
252                               (syntax-error "error reading exponent: non-digit"
253                                             loc c))))))
254             (let lp ((c (peek-char)) (e 0))
255               (cond ((and (not (eof-object? c)) (char-numeric? c))
256                      (read-char)
257                      (lp (peek-char) (add (* 10 e) (digit->number c))))
258                     (else
259                      (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
260          ((char=? c1 #\.)
261           (read-char)
262           (let lp2 ((c (peek-char)) (dec 0.0) (n -1))
263             (cond ((and (not (eof-object? c)) (char-numeric? c))
264                    (read-char)
265                    (lp2 (peek-char)
266                         (+ dec (* (digit->number c) (expt 10 n)))
267                         (1- n)))
268                   (else
269                    ;; loop back to catch an exponential part
270                    (lp c (+ acc dec))))))
271          (else
272           acc)))))))
273            
274 (define *punctuation*
275   '(("{" . lbrace)
276     ("}" . rbrace)
277     ("(" . lparen)
278     (")" . rparen)
279     ("[" . lbracket)
280     ("]" . rbracket)
281     ("." . dot)
282     (";" . semicolon)
283     ("," . comma)
284     ("<" . <)
285     (">" . >)
286     ("<=" . <=)
287     (">=" . >=)
288     ("==" . ==)
289     ("!=" . !=)
290     ("===" . ===)
291     ("!==" . !==)
292     ("+" . +)
293     ("-" . -)
294     ("*" . *)
295     ("%" . %)
296     ("++" . ++)
297     ("--" . --)
298     ("<<" . <<)
299     (">>" . >>)
300     (">>>" . >>>)
301     ("&" . &)
302     ("|" . bor)
303     ("^" . ^)
304     ("!" . !)
305     ("~" . ~)
306     ("&&" . &&)
307     ("||" . or)
308     ("?" . ?)
309     (":" . colon)
310     ("=" . =)
311     ("+=" . +=)
312     ("-=" . -=)
313     ("*=" . *=)
314     ("%=" . %=)
315     ("<<=" . <<=)
316     (">>=" . >>=)
317     (">>>=" . >>>=)
318     ("&=" . &=)
319     ("|=" . bor=)
320     ("^=" . ^=)))
321
322 (define *div-punctuation*
323   '(("/" . /)
324     ("/=" . /=)))
325
326 ;; node ::= (char (symbol | #f) node*)
327 (define read-punctuation
328   (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
329                      (cond ((null? puncs)
330                             nodes)
331                            ((assv-ref nodes (string-ref (caar puncs) 0))
332                             (let ((node-tail (assv-ref nodes (string-ref (caar puncs) 0))))
333                               (if (= (string-length (caar puncs)) 1)
334                                   (set-car! node-tail (cdar puncs))
335                                   (set-cdr! node-tail
336                                             (lp (cdr node-tail)
337                                                 `((,(substring (caar puncs) 1)
338                                                    . ,(cdar puncs))))))
339                               (lp nodes (cdr puncs))))
340                            (else
341                             (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
342                                 puncs))))))
343     (lambda (loc)
344       (let lp ((c (peek-char)) (tree punc-tree) (candidate #f))
345         ;;(display "read-punctuation c=") (display c) (newline)
346         (cond
347          ((assv-ref tree c)
348           (let ((node-tail (assv-ref tree c)))
349             (read-char)
350             (lp (peek-char) (cdr node-tail) (car node-tail))))
351          (candidate
352           (make-lexical-token candidate loc #f))
353          (else
354           (syntax-error "bad syntax: character not allowed" loc c)))))))
355
356 (define (next-token div?)
357   (let ((c   (peek-char))
358         (loc (port-source-location (current-input-port))))
359     ;;(display "next-token c=") (display c) (newline)
360
361     (case c
362       ((#\tab #\vt #\page #\space ;;#\x00A0
363         ) ; whitespace
364        (read-char)
365        (next-token div?))
366       ((#\newline #\return)                 ; line break
367        (read-char)
368        (next-token div?))
369       ((#\/)
370        ;; division, single comment, double comment, or regexp
371        (read-slash loc div?))
372       ((#\" #\')                        ; string literal
373        (read-string loc))
374       (else
375        (cond
376         ((eof-object? c)
377          '*eoi*)
378         ((or (char-alphabetic? c)
379              (char=? c #\$)
380              (char=? c #\_))
381          ;; reserved word or identifier
382          (read-identifier loc))
383         ((char-numeric? c)
384          ;; numeric -- also accept . FIXME, requires lookahead
385          (make-lexical-token 'NumericLiteral loc (read-numeric loc)))
386         (else
387          ;; punctuation
388          (read-punctuation loc)))))))
389
390 (define (c-lexer errorp)
391   (let ((div? #f))
392     (lambda ()
393       (let ((tok (next-token div?)))
394         (set! div? (and (lexical-token? tok)
395                         (let ((cat (lexical-token-category tok)))
396                           (or (eq? cat 'Identifier)
397                               (eq? cat 'NumericLiteral)
398                               (eq? cat 'StringLiteral)))))
399         tok))))