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