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