6c57fb3c7be663d6d25f1eb074821d5a2d2313ae
[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
44 (define (read-delimited delims port handle-delim)
45      (let ((stop (string->list delims)))
46        (let loop ((c (peek-char)) (lst '()))
47          (if (member c stop)
48              (list->string lst)
49              (begin
50                (read-char)
51                (loop (peek-char) (append lst (list c))))))))
52
53 (define (port-source-location port)
54   (make-source-location (port-filename port)
55                         (port-line port)
56                         (port-column port)
57                         (false-if-exception (ftell port))
58                         #f))
59
60 ;; taken from SSAX, sorta
61 (define (read-until delims loc)
62   (if (eof-object? (peek-char))
63       (syntax-error "EOF while reading a token" loc #f)
64       (let ((token (read-delimited delims (current-input-port) 'peek)))
65         (if (eof-object? (peek-char))
66             (syntax-error "EOF while reading a token" loc token)
67             token))))
68
69 (define (char-hex? c)
70   (and (not (eof-object? c))
71        (or (char-numeric? c)
72            (memv c '(#\a #\b #\c #\d #\e #\f))
73            (memv c '(#\A #\B #\C #\D #\E #\F)))))
74
75 (define (digit->number c)
76   (- (char->integer c) (char->integer #\0)))
77
78 (define (hex->number c)
79   (if (char-numeric? c)
80       (digit->number c)
81       (+ 10 (- (char->integer (char-downcase c)) (char->integer #\a)))))
82
83 (define (read-slash loc div?)
84   (let ((c1 (begin
85               (read-char)
86               (peek-char))))
87     (cond
88      ((eof-object? c1)
89       ;; hmm. error if we're not looking for a div? ?
90       (make-lexical-token '/ loc #f))
91      ((char=? c1 #\/)
92       (read-line)
93       (next-token div?))
94      ((char=? c1 #\*)
95       (read-char)
96       (let lp ((c (read-char)))
97         (cond
98          ((eof-object? c)
99           (syntax-error "EOF while in multi-line comment" loc #f))
100          ((char=? c #\*)
101           (if (eqv? (peek-char) #\/)
102               (begin
103                 (read-char)
104                 (next-token div?))
105               (lp (read-char))))
106          (else
107           (lp (read-char))))))
108      (div?
109       (case c1
110         ((#\=) (read-char) (make-lexical-token '/= loc #f))
111         (else (make-lexical-token '/ loc #f))))
112      (else
113       ;;;(read-regexp loc)
114       (make-lexical-token '/ loc #f)))))
115
116 (define (read-string loc)
117   (let ((c (read-char)))
118     (let ((terms (string c #\\ #\newline #\return)))
119       (define (read-escape)
120         (let ((c (read-char)))
121           (case c
122             ((#\' #\" #\\) c)
123             ((#\b) #\backspace)
124             ((#\f) #\page)
125             ((#\n) #\newline)
126             ((#\r) #\return)
127             ((#\t) #\tab)
128             ((#\v) #\vt)
129             ((#\0)
130              (let ((next (peek-char)))
131                (cond
132                 ((eof-object? next) #\nul)
133                 ((char-numeric? next)
134                  (syntax-error "octal escape sequences are not supported"
135                                loc #f))
136                 (else #\nul))))
137             ((#\x)
138              (let* ((a (read-char))
139                     (b (read-char)))
140                (cond
141                 ((and (char-hex? a) (char-hex? b))
142                  (integer->char (+ (* 16 (hex->number a)) (hex->number b))))
143                 (else
144                  (syntax-error "bad hex character escape" loc (string a b))))))
145             ((#\u)
146              (let* ((a (read-char))
147                     (b (read-char))
148                     (c (read-char))
149                     (d (read-char)))
150                (integer->char (string->number (string a b c d) 16))))
151             (else
152              c))))
153       (let lp ((str (read-until terms loc)))
154         (let ((terminator (peek-char)))
155           (cond
156            ((char=? terminator c)
157             (read-char)
158             (make-lexical-token 'StringLiteral loc str))
159            ((char=? terminator #\\)
160             (read-char)
161             (let ((echar (read-escape)))
162               (lp (string-append str (string echar)
163                                  (read-until terms loc)))))
164            (else
165             (syntax-error "string literals may not contain newlines"
166                           loc str))))))))
167
168 (define *keywords*
169   '(("break" . break)
170     ("case" . case)
171     ("continue" . continue)
172     ("else" . else)
173     ("goto" . goto)
174
175     ("char" . char)
176     ("double" . double)
177     ("float" . float)
178     ("int" . int)
179     ("long" . long)
180     ("short" . short)
181     ("unsigned" . unsigned)
182     
183     ("return" . return)
184     ("void" . void)
185     ("for" . for)
186     ("switch" . switch)
187     ("while" . while)
188     ("continue" . continue)
189     ("default" . default)
190     ("if" . if)
191     ("do" . do)
192
193     ;; these aren't exactly keywords, but hey
194     ("true" . true)
195     ("false" . false)))
196
197 (define (read-identifier loc)
198   (let lp ((c (peek-char)) (chars '()))
199     (if (or (eof-object? c)
200             (not (or (char-alphabetic? c)
201                      (char-numeric? c)
202                      (char=? c #\$)
203                      (char=? c #\_))))
204         (let ((word (list->string (reverse chars))))
205           (cond ((assoc-ref *keywords* word)
206                  (make-lexical-token (assoc-ref *keywords* word) loc #f))
207                 (else (make-lexical-token 'Identifier loc
208                                           (string->symbol word)))))
209         (begin (read-char)
210                (lp (peek-char) (cons c chars))))))
211
212 (define (read-numeric loc)
213   (let* ((c0 (if (char=? (peek-char) #\.)
214                  #\0
215                  (read-char)))
216          (c1 (peek-char)))
217     (cond
218      ((eof-object? c1) (digit->number c0))
219      ((and (char=? c0 #\0) (or (char=? c1 #\x) (char=? c1 #\X)))
220       (read-char)
221       (let ((c (peek-char)))
222         (if (not (char-hex? c))
223             (syntax-error "bad digit reading hexadecimal number"
224                           loc c))
225         (let lp ((c c) (acc 0))
226           (cond ((char-hex? c)
227                  (read-char)
228                  (lp (peek-char)
229                      (+ (* 16 acc) (hex->number c))))
230                 (else
231                  acc)))))
232      ((and (char=? c0 #\0) (char-numeric? c1))
233       (let lp ((c c1) (acc 0))
234         (cond ((eof-object? c) acc)
235               ((char-numeric? c)
236                (if (or (char=? c #\8) (char=? c #\9))
237                    (syntax-error "invalid digit in octal sequence"
238                                  loc c))
239                (read-char)
240                (lp (peek-char)
241                    (+ (* 8 acc) (digit->number c))))
242               (else
243                acc))))
244      (else
245       (let lp ((c1 c1) (acc (digit->number c0)))
246         (cond
247          ((eof-object? c1) acc)
248          ((char-numeric? c1)
249           (read-char)
250           (lp (peek-char)
251               (+ (* 10 acc) (digit->number c1))))
252          ((or (char=? c1 #\e) (char=? c1 #\E))
253           (read-char)
254           (let ((add (let ((c (peek-char)))
255                        (cond ((eof-object? c)
256                               (syntax-error "error reading exponent: EOF"
257                                             loc #f))
258                              ((char=? c #\+) (read-char) +)
259                              ((char=? c #\-) (read-char) -)
260                              ((char-numeric? c) +)
261                              (else
262                               (syntax-error "error reading exponent: non-digit"
263                                             loc c))))))
264             (let lp ((c (peek-char)) (e 0))
265               (cond ((and (not (eof-object? c)) (char-numeric? c))
266                      (read-char)
267                      (lp (peek-char) (add (* 10 e) (digit->number c))))
268                     (else
269                      (* (if (negative? e) (* acc 1.0) acc) (expt 10 e)))))))
270          ((char=? c1 #\.)
271           (read-char)
272           (let lp2 ((c (peek-char)) (dec 0.0) (n -1))
273             (cond ((and (not (eof-object? c)) (char-numeric? c))
274                    (read-char)
275                    (lp2 (peek-char)
276                         (+ dec (* (digit->number c) (expt 10 n)))
277                         (1- n)))
278                   (else
279                    ;; loop back to catch an exponential part
280                    (lp c (+ acc dec))))))
281          (else
282           acc)))))))
283            
284 (define *punctuation*
285   '(("{" . lbrace)
286     ("}" . rbrace)
287     ("(" . lparen)
288     (")" . rparen)
289     ("[" . lbracket)
290     ("]" . rbracket)
291     ("." . dot)
292     (";" . semicolon)
293     ("," . comma)
294     ("<" . <)
295     (">" . >)
296     ("<=" . <=)
297     (">=" . >=)
298     ("==" . ==)
299     ("!=" . !=)
300     ("===" . ===)
301     ("!==" . !==)
302     ("+" . +)
303     ("-" . -)
304     ("*" . *)
305     ("%" . %)
306     ("++" . ++)
307     ("--" . --)
308     ("<<" . <<)
309     (">>" . >>)
310     (">>>" . >>>)
311     ("&" . &)
312     ("|" . bor)
313     ("^" . ^)
314     ("!" . !)
315     ("~" . ~)
316     ("&&" . &&)
317     ("||" . or)
318     ("?" . ?)
319     (":" . colon)
320     ("=" . =)
321     ("+=" . +=)
322     ("-=" . -=)
323     ("*=" . *=)
324     ("%=" . %=)
325     ("<<=" . <<=)
326     (">>=" . >>=)
327     (">>>=" . >>>=)
328     ("&=" . &=)
329     ("|=" . bor=)
330     ("^=" . ^=)))
331
332 (define *div-punctuation*
333   '(("/" . /)
334     ("/=" . /=)))
335
336 ;; node ::= (char (symbol | #f) node*)
337 (define read-punctuation
338   (let ((punc-tree (let lp ((nodes '()) (puncs *punctuation*))
339                      (cond ((null? puncs)
340                             nodes)
341                            ((assv-ref nodes (string-ref (caar puncs) 0))
342                             (let ((node-tail (assv-ref nodes (string-ref (caar puncs) 0))))
343                               (if (= (string-length (caar puncs)) 1)
344                                   (set-car! node-tail (cdar puncs))
345                                   (set-cdr! node-tail
346                                             (lp (cdr node-tail)
347                                                 `((,(substring (caar puncs) 1)
348                                                    . ,(cdar puncs))))))
349                               (lp nodes (cdr puncs))))
350                            (else
351                             (lp (cons (list (string-ref (caar puncs) 0) #f) nodes)
352                                 puncs))))))
353     (lambda (loc)
354       (let lp ((c (peek-char)) (tree punc-tree) (candidate #f))
355         ;;(display "read-punctuation c=") (display c) (newline)
356         (cond
357          ((assv-ref tree c)
358           (let ((node-tail (assv-ref tree c)))
359             (read-char)
360             (lp (peek-char) (cdr node-tail) (car node-tail))))
361          (candidate
362           (make-lexical-token candidate loc #f))
363          (else
364           (syntax-error "bad syntax: character not allowed" loc c)))))))
365
366 (define (next-token div?)
367   (let ((c   (peek-char))
368         (loc (port-source-location (current-input-port))))
369     ;;(display "next-token c=") (display c) (newline)
370
371     (case c
372       ((#\tab #\vt #\page #\space ;;#\x00A0
373         ) ; whitespace
374        (read-char)
375        (next-token div?))
376       ((#\newline #\return)                 ; line break
377        (read-char)
378        (next-token div?))
379       ((#\/)
380        ;; division, single comment, double comment, or regexp
381        (read-slash loc div?))
382       ((#\" #\')                        ; string literal
383        (read-string loc))
384       (else
385        (cond
386         ((eof-object? c)
387          '*eoi*)
388         ((or (char-alphabetic? c)
389              (char=? c #\$)
390              (char=? c #\_))
391          ;; reserved word or identifier
392          (read-identifier loc))
393         ((char-numeric? c)
394          ;; numeric -- also accept . FIXME, requires lookahead
395          (make-lexical-token 'NumericLiteral loc (read-numeric loc)))
396         (else
397          ;; punctuation
398          (read-punctuation loc)))))))
399
400 (define (c-lexer errorp)
401   (let ((div? #f))
402     (lambda ()
403       (let ((tok (next-token div?)))
404         (set! div? (and (lexical-token? tok)
405                         (let ((cat (lexical-token-category tok)))
406                           (or (eq? cat 'Identifier)
407                               (eq? cat 'NumericLiteral)
408                               (eq? cat 'StringLiteral)))))
409         tok))))