354b7467781df8fe40d1f0956b679c3896556692
[mes.git] / module / nyacc / lex.scm
1 ;;; nyacc/lex.scm
2 ;;;
3 ;;; Copyright (C) 2015,2016 - Matthew R.Wette
4 ;;; 
5 ;;; This library is free software; you can redistribute it and/or modify it
6 ;;; under the terms of the GNU Lesser General Public License as published by
7 ;;; the Free Software Foundation; either version 3 of the License, or (at
8 ;;; your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful, but
11 ;;; 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 License
16 ;;; along with this library; if not, see <http://www.gnu.org/licenses/>
17
18 ;; A module providing procedures for constructing lexical analyzers.
19
20 ;; '$fixed '$float '$string '$chlit '$ident
21
22 ;; todo: change lexer to return @code{cons-source} instead of @code{cons}
23 ;; todo: to be fully compliant, C readers need to deal with \ at end of line
24
25 ;; todo: figure out what readers return atoms and which pairs
26 ;; tokens: read-c-ident 
27 ;; pairs: num-reader read-c-num read-c-string
28 ;; issue: if returning pairs we need this for hashed parsers:
29 ;;    (define (assc-$ pair) (cons (assq-ref symbols (car pair)) (cdr pair)))
30 ;; read-comm changed to (read-comm ch bol) where bol is begin-of-line cond
31 ;; 
32 ;; read-c-ident 
33
34 (define-module (nyacc lex)
35   #:export (make-lexer-generator
36             make-ident-reader
37             make-comm-reader
38             make-string-reader
39             make-chseq-reader
40             make-num-reader
41             eval-reader
42             make-like-ident-p
43             read-c-ident
44             read-c-comm
45             read-c-string
46             read-c-chlit
47             read-c-num
48             read-oct read-hex
49             like-c-ident?
50             filter-mt remove-mt map-mt make-ident-like-p 
51             c:ws c:if c:ir)
52   #:use-module ((srfi srfi-1) #:select (remove append-reverse))
53   #:use-module (ice-9 pretty-print)
54   )
55
56 (cond-expand
57  (guile-2)
58  (guile
59   (use-modules (ice-9 syncase))
60   (use-modules (ice-9 optargs)))
61  (mes))
62
63 ;; @section Constructing Lexical Analyzers
64 ;; The @code{lex} module provides a set of procedures to build lexical
65 ;; analyzers.  The approach is to first build a set of @defn{readers} for 
66 ;; MORE TO COME
67 ;;
68 ;; Readers are procecures that take one character (presumably from the
69 ;; current-input-port) and determine try to make a match.   If a match is
70 ;; made something is returned, with any lookaheads pushed back into the
71 ;; input port.  If no match is made @code{#f} is returned and the input
72 ;; argument is still the character to work on.
73 ;;
74 ;; Here are the procedures used:
75 ;; @table @code
76
77 (define digit "0123456789")
78 (define ucase "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
79 (define lcase "abcdefghijklmnopqrstuvwxyz")
80
81 ;; C lexemes are popular so include those.
82 ;;(define c:ws (list->char-set '(#\space #\tab #\newline #\return )))
83 (define c:ws char-set:whitespace)
84 (define c:if (let ((cs (char-set #\_))) ; ident, first char
85                (string->char-set! ucase cs)
86                (string->char-set! lcase cs)))
87 (define c:ir (string->char-set digit c:if)) ; ident, rest chars
88 (define c:nx (string->char-set "eEdD")) ; number exponent
89 (define c:hx (string->char-set "abcdefABCDEF"))
90
91 ;; @deffn eval-reader reader string => result
92 ;; For test and debug, this procedure will evaluate a reader on a string.
93 ;; A reader is a procedure that accepts a single character argument intended
94 ;; to match a specific character sequence.  A reader will read more characters
95 ;; by evaluating @code{read-char} until it matches or fails.  If it fails, it
96 ;; will pushback all characters read via @code{read-char} and return @code{#f}.
97 ;; If it succeeds the input pointer will be at the position following the
98 ;; last matched character.
99 (define (eval-reader reader string)
100   (with-input-from-string string
101     (lambda () (reader (read-char)))))
102
103 ;; @deffn make-space-skipper chset => proc
104 ;; This routine will generate a reader to skip whitespace.
105 (define (make-space-skipper chset)
106   (lambda (ch)
107     (if (char-set-contains? chset ch)
108         (let iter ((ch (read-char)))
109           (cond
110            ((char-set-contains? chset ch)
111             (iter (read-char)))
112            (else
113             (unread-char ch)
114             #t)))
115         #f)))
116          
117 ;; @deffn skip-c-space ch => #f|#t
118 ;; If @code{ch} is space, skip all spaces, then return @code{#t}, else
119 ;; return @code{#f}.
120 (define skip-c-space (make-space-skipper c:ws))
121
122
123 ;; @deffn make-ident-reader cs-first cs-rest => ch -> #f|string
124 ;; For identifiers, given the char-set for first character and the char-set
125 ;; for following characters, return a return a reader for identifiers.
126 ;; The reader takes a character as input and returns @code{#f} or @code{string}.
127 (define (make-ident-reader cs-first cs-rest)
128   (lambda (ch)
129     (if (char-set-contains? cs-first ch)
130         (let iter ((chl (list ch)) (ch (read-char)))
131           (cond
132            ((eof-object? ch)
133             (if (null? chl) #f
134                 (list->string (reverse chl))))
135            ((char-set-contains? cs-rest ch)
136             (iter (cons ch chl) (read-char)))
137            (else (unread-char ch)
138                  (list->string (reverse chl)))))
139         #f)))
140
141 ;; @deffn read-c-ident ch => #f|string
142 ;; If ident pointer at following char, else (if #f) ch still last-read.
143 (define read-c-ident (make-ident-reader c:if c:ir))
144
145 ;; @deffn make-ident-like-p ident-reader
146 ;; Generate a predicate, from a reader, that determines if a string qualifies
147 ;; as an identifier.
148 (define (make-like-ident-p reader)
149   (lambda (s) (and (string? s) (eval-reader reader s))))
150 (define make-ident-like-p make-like-ident-p)
151 (define like-c-ident? (make-like-ident-p read-c-ident))
152
153
154 ;; @deffn make-string-reader delim
155 ;; Generate a reader that uses @code{delim} as delimiter for strings.
156 ;; TODO: need to handle matlab-type strings.
157 ;; TODO: need to handle multiple delim's (like python)
158 (define (make-string-reader delim) ;; #:xxx
159   (lambda (ch)
160     (if (eq? ch delim)
161         (let iter ((cl '()) (ch (read-char)))
162           (cond ((eq? ch #\\)
163                  (let ((c1 (read-char)))
164                    (if (eq? c1 #\newline)
165                        (iter cl (read-char))
166                        (iter (cons* c1 cl) (read-char)))))
167                 ((eq? ch delim) (cons '$string (list->string (reverse cl))))
168                 (else (iter (cons ch cl) (read-char)))))
169         #f)))
170
171 ;; @deffn read-oct ch => "0123"|#f
172 ;; Read octal number.
173 (define read-oct
174   (let ((cs:oct (string->char-set "01234567")))
175     (lambda (ch)
176       (let iter ((cv 0) (ch ch) (n 1))
177         (cond
178          ((eof-object? ch) cv)
179          ((> n 3) (unread-char ch) cv)
180          ((char-set-contains? cs:oct ch)
181           (iter (+ (* 8 cv) (- (char->integer ch) 48)) (read-char) (1+ n)))
182          (else
183           (unread-char ch)
184           cv))))))
185
186 ;; @deffn read-hex ch => "0x7f"|#f
187 ;; Read octal number.
188 (define read-hex
189   (let ((cs:dig (string->char-set "0123456789"))
190         (cs:uhx (string->char-set "ABCDEF"))
191         (cs:lhx (string->char-set "abcdef")))
192     (lambda (ch) ;; ch == #\x always
193       (let iter ((cv 0) (ch (read-char)) (n 0))
194         (simple-format #t "ch=~S\n" ch)
195         (cond
196          ((eof-object? ch) cv)
197          ((> n 2) (unread-char ch) cv)
198          ((char-set-contains? cs:dig ch)
199           (iter (+ (* 16 cv) (- (char->integer ch) 48)) (read-char) (1+ n)))
200          ((char-set-contains? cs:uhx ch)
201           (iter (+ (* 16 cv) (- (char->integer ch) 55)) (read-char) (1+ n)))
202          ((char-set-contains? cs:lhx ch)
203           (iter (+ (* 16 cv) (- (char->integer ch) 87)) (read-char) (1+ n)))
204          (else (unread-char ch) cv))))))
205         
206 ;; @deffn read-c-string ch => ($string . "foo")
207 ;; Read a C-code string.  Output to code is @code{write} not @code{display}.
208 ;; Return #f if @var{ch} is not @code{"}.
209 (define (read-c-string ch)
210   (if (not (eq? ch #\")) #f
211       (let iter ((cl '()) (ch (read-char)))
212         (cond ((eq? ch #\\)
213                (let ((c1 (read-char)))
214                  (iter
215                   (case c1
216                     ((#\newline) cl)
217                     ((#\\) (cons #\\ cl))
218                     ((#\") (cons #\" cl))
219                     ((#\') (cons #\' cl))
220                     ((#\n) (cons #\newline cl))
221                     ((#\r) (cons #\return cl))
222                     ((#\b) (cons #\backspace cl))
223                     ((#\t) (cons #\tab cl))
224                     ((#\f) (cons #\page cl))
225                     ((#\a) (cons #\alarm cl))
226                     ((#\v) (cons #\vtab cl))
227                     ((#\x) (cons (integer->char (read-hex ch)) cl))
228                     (else
229                      (if (char-numeric? ch)
230                          (cons (integer->char (read-oct ch)) cl)
231                          (cons c1 cl))))
232                   (read-char))))
233               ((eq? ch #\") (cons '$string (list->string (reverse cl))))
234               (else (iter (cons ch cl) (read-char)))))))
235
236 ;; @deffn make-chlit-reader
237 ;; Generate a reader for character literals. NOT DONE.
238 ;; For C, this reads @code{'c'} or @code{'\n'}.
239 (define (make-chlit-reader . rest) (error "NOT IMPLEMENTED"))
240
241 ;; @deffn read-c-chlit ch
242 ;; @example
243 ;; ... 'c' ... => (read-c-chlit #\') => '($ch-lit . #\c)
244 ;; @end example
245 (define (read-c-chlit ch)
246   (if (not (eqv? ch #\')) #f
247       (let ((c1 (read-char)) (c2 (read-char)))
248         (if (eqv? c1 #\\)
249             (let ((c3 (read-char)))
250               (cons '$chlit
251                     (case c2
252                       ((#\0) "\0;")        ; nul U+0000 (#\U+...)
253                       ((#\a) "\a")         ; alert U+0007
254                       ((#\b) "\b")         ; backspace U+0008
255                       ((#\t) "\t")         ; horizontal tab U+0009
256                       ((#\n) "\n")         ; newline U+000A
257                       ((#\v) "\v")         ; verticle tab U+000B
258                       ((#\f) "\f")         ; formfeed U+000C
259                       ((#\\) "\\")         ; backslash
260                       ((#\' #\" #\?) (string c2))
261                       (else (error "bad escape sequence")))))
262             (cons '$chlit (string c1))))))
263
264 ;; @deffn make-num-reader => (proc ch) => #f|($fixed . "1")|($float . "1.0")
265 ;; This routine will clean by adding "0" before or after dot.
266 ;; TODO: add arg to specify alternate syntaxes (e.g. "0x123")
267 ;; may want to replace "eEdD" w/ "e"
268 ;; integer decimal(#t/#f) fraction exponent looking-at
269 ;; i, f and e are lists of characters
270 (define (make-num-reader)
271   ;; 0: start; 1: p-i; 2: p-f; 3: p-e-sign; 4: p-e-d; 5: packup
272   ;; Removed support for leading '.' to be a number.
273   (let ((fix-dot (lambda (l) (if (char=? #\. (car l)) (cons #\0 l) l))))
274     (lambda (ch1)
275       ;; chl: char list; ty: '$fixed or '$float; st: state; ch: input char
276       (let iter ((chl '()) (ty #f) (st 0) (ch ch1))
277         (case st
278           ((0)
279            (cond
280             ((eof-object? ch) (iter chl ty 5 ch))
281             ((char=? #\0 ch) (iter (cons ch chl) '$fixed 10 (read-char))) 
282             ((char-numeric? ch) (iter chl '$fixed 1 ch))
283             (else #f)))
284           ((10) ;; allow x after 0
285            (cond
286             ((eof-object? ch) (iter chl ty 5 ch))
287             ((char=? #\x ch) (iter (cons ch chl) ty 1 (read-char)))
288             (else (iter chl ty 1 ch))))
289           ((1)
290            (cond
291             ((eof-object? ch) (iter chl ty 5 ch))
292             ((char-numeric? ch) (iter (cons ch chl) ty 1 (read-char)))
293             ((char=? #\. ch) (iter (cons #\. chl) '$float 2 (read-char)))
294             ((char-set-contains? c:hx ch)
295              (iter (cons ch chl) ty 1 (read-char)))
296             ((char-set-contains? c:if ch) (error "reading number st=1"))
297             (else (iter chl '$fixed 5 ch))))
298           ((2)
299            (cond
300             ((eof-object? ch) (iter chl ty 5 ch))
301             ((char-numeric? ch) (iter (cons ch chl) ty 2 (read-char)))
302             ((char-set-contains? c:nx ch)
303              (iter (cons ch (fix-dot chl)) ty 3 (read-char)))
304             ((char-set-contains? c:if ch) (error "reading number st=2"))
305             (else (iter (fix-dot chl) ty 5 ch))))
306           ((3)
307            (cond
308             ((eof-object? ch) (iter chl ty 5 ch))
309             ((or (char=? #\+ ch) (char=? #\- ch))
310              (iter (cons ch chl) ty 4 (read-char)))
311             ((char-numeric? ch) (iter chl ty 4 ch))
312             (else (error "syntax3"))))
313           ((4)
314            (cond
315             ((eof-object? ch) (iter chl ty 5 ch))
316             ((char-numeric? ch) (iter (cons ch chl) ty 4 (read-char)))
317             ((char-set-contains? c:if ch) (error "reading number st=4"))
318             (else (iter chl ty 5 ch))))
319           ((5)
320            (unless (eof-object? ch) (unread-char ch))
321            (cons ty (list->string (reverse chl)))))))))
322
323 ;; @deffn read-c-num ch => #f|string
324 ;; Reader for unsigned numbers as used in C (or close to it).
325 (define read-c-num (make-num-reader))
326
327 ;;.@deffn si-map string-list ix => a-list
328 ;; Convert list of strings to alist of char at ix and strings.
329 ;; This is a helper for make-tree.
330 (define (si-map string-list ix)
331   (let iter ((sal '()) (sl string-list))
332     (cond
333      ((null? sl) sal)
334      ((= ix (string-length (car sl)))
335       (iter (reverse (acons 'else (car sl) sal)) (cdr sl)))
336      ((assq (string-ref (car sl) ix) sal) =>
337       (lambda (pair)
338         (set-cdr! pair (cons (car sl) (cdr pair)))
339         (iter sal (cdr sl))))
340      (else ;; Add (#\? . string) to alist.
341       (iter (cons (cons (string-ref (car sl) ix) (list (car sl))) sal)
342             (cdr sl))))))
343
344 ;;.@deffn make-tree strtab -> tree
345 ;; This routine takes an alist of strings and symbols and makes a tree
346 ;; that parses one char at a time and provide @code{'else} entry for
347 ;; signaling sequence found.  That is, if @code{("ab" . 1)} is an entry
348 ;; then a chseq-reader (see below) would stop at @code{"ab"} and
349 ;; return @code{1}.
350 (define (make-tree strtab)
351   (define (si-cnvt string-list ix)
352     (map (lambda (pair)
353            (if (pair? (cdr pair))
354                (cons (car pair) (si-cnvt (cdr pair) (1+ ix)))
355                (cons (car pair) (assq-ref strtab (cdr pair)))))
356          (si-map string-list ix)))
357   (si-cnvt (map car strtab) 0))
358
359 ;; @deffn make-chseq-reader strtab
360 ;; Given alist of pairs (string, token) return a function that eats chars
361 ;; until (token . string) is returned or @code{#f} if no match is found.
362 (define (make-chseq-reader strtab)
363   ;; This code works on the assumption that the else-part is always last
364   ;; in the list of transitions.
365   (let ((tree (make-tree strtab)))
366     (lambda (ch)
367       (let iter ((cl (list ch)) (node tree))
368         (cond
369          ((assq-ref node (car cl)) => ;; accept or shift next character
370           (lambda (n)
371             (if (eq? (caar n) 'else) ; if only else, accept, else read on
372                 (cons (cdar n) (list->string (reverse cl)))
373                 (iter (cons (read-char) cl) n))))
374          ((assq-ref node 'else) => ; else exists, accept
375           (lambda (tok)
376             (unread-char (car cl))
377             (cons tok (list->string (reverse (cdr cl))))))
378          (else ;; reject
379           (let pushback ((cl cl))
380             (unless (null? (cdr cl))
381               (unread-char (car cl))
382               (pushback (cdr cl))))
383           #f))))))
384
385 ;; @deffn make-comm-reader comm-table [#:eat-newline #t] => \
386 ;;   ch bol -> ('$code-comm "..")|('$lone-comm "..")|#f
387 ;; comm-table is list of cons for (start . end) comment.
388 ;; e.g. ("--" . "\n") ("/*" . "*/")
389 ;; test with "/* hello **/"
390 ;; If @code{eat-newline} is specified as true then for read comments 
391 ;; ending with a newline a newline swallowed with the comment.
392 ;; Note: assumes backslash is never part of the end
393 (define* (make-comm-reader comm-table #:key (eat-newline #f))
394
395   (define (mc-read-char)
396     (let ((ch (read-char)))
397       (if (eqv? ch #\\)
398           (let ((ch (read-char)))
399             (if (eqv? ch #\newline)
400                 (read-char)
401                 (begin (unread-char ch) #\\)))
402           ch)))
403     
404   (let ((tree (make-tree comm-table)))
405     (lambda (ch bol)
406       (letrec
407           ((tval (if bol '$lone-comm '$code-comm))
408            (match-beg ;; match start of comment, return end-string
409             (lambda (cl node)
410               (cond
411                ((assq-ref node (car cl)) => ;; shift next character
412                 (lambda (n) (match-beg (cons (mc-read-char) cl) n)))
413                ((assq-ref node 'else) =>
414                 (lambda (res) (unread-char (car cl)) res)) ; yuck?
415                (else
416                 (let pushback ((cl cl))
417                   (unless (null? (cdr cl))
418                     (unread-char (car cl))
419                     (pushback (cdr cl))))
420                 #f))))
421            (find-end ;; find end of comment, return comment
422             ;; cl: comm char list; sl: shift list; il: input list;
423             ;; ps: pattern string; px: pattern index
424             (lambda (cl sl il ps px)
425               (cond
426                ((eq? px (string-length ps))
427                 (if (and (not eat-newline) (eq? #\newline (car sl)))
428                     (unread-char #\newline))
429                 (if (and (pair? cl) (eqv? (car cl) #\return)) ;; rem trailing \r 
430                     (cons tval (list->string (reverse (cdr cl))))
431                     (cons tval (list->string (reverse cl)))))
432                ((null? il) (find-end cl sl (cons (mc-read-char) il) ps px))
433                ((eof-object? (car il)) (error "open comment"))
434                ((eqv? (car il) (string-ref ps px))
435                 (find-end cl (cons (car il) sl) (cdr il) ps (1+ px)))
436                (else
437                 (let ((il1 (append-reverse sl il)))
438                   (find-end (cons (car il1) cl) '() (cdr il1) ps 0)))))))
439         (let ((ep (match-beg (list ch) tree)))
440           (if ep (find-end '() '() (list (mc-read-char)) ep 0) #f))))))
441
442 (define read-c-comm (make-comm-reader '(("/*" . "*/") ("//" . "\n"))))
443
444 ;; @deffn filter-mt p? al => al
445 ;; Filter match-table based on cars of al.
446 (define (filter-mt p? al) (filter (lambda (x) (p? (car x))) al))
447
448 ;; @deffn remove-mt p? al => al
449 ;; Remove match-table based on cars of al.
450 (define (remove-mt p? al) (remove (lambda (x) (p? (car x))) al))
451
452 ;; @deffn map-mt f al => al
453 ;; Map cars of al.
454 (define (map-mt f al) (map (lambda (x) (cons (f (car x)) (cdr x))) al))
455
456 ;; @deffn make-lexer-generator match-table => lexer-generator
457 ;; @example
458 ;; (define gen-lexer (make-lexer-generator #:ident-reader my-id-rdr))
459 ;; (with-input-from-file "foo" (parse (gen-lexer)))
460 ;; @end example
461 ;;
462 ;; Return a thunk that returns tokens.
463 ;; Change this to have user pass the following routines (optionally?)
464 ;; read-num, read-ident, read-comm
465 ;; reztab = reserved ($ident, $fixed, $float ...
466 ;; chrtab = characters
467 ;; comm-reader : if parser does not deal with comments must return #f
468 ;;               but problem with character ..
469 ;; match-table:
470 ;; @enumerate
471 ;; symbol -> (string . symbol)
472 ;; reserved -> (symbol . symbol)
473 ;; char -> (char . char)
474 ;; @end enumerate
475 ;; todo: add bol status
476 (define* (make-lexer-generator match-table
477                                #:key ident-reader num-reader
478                                string-reader chlit-reader
479                                comm-reader comm-skipper
480                                space-chars)
481   (let* ((read-ident (or ident-reader (make-ident-reader c:if c:ir)))
482          (read-num (or num-reader (make-num-reader)))
483          (read-string (or string-reader (make-string-reader #\")))
484          (read-chlit (or chlit-reader (lambda (ch) #f)))
485          (read-comm (or comm-reader (lambda (ch bol) #f)))
486          (skip-comm (or comm-skipper (lambda (ch) #f)))
487          (spaces (or space-chars " \t\r\n"))
488          (space-cs (cond ((string? spaces) (string->char-set spaces))
489                          ((list? spaces) (list->char-set spaces))
490                          ((char-set? spaces) spaces)
491                          (else (error "expecting string list or char-set"))))
492          ;;
493          (ident-like? (make-ident-like-p read-ident))
494          ;;
495          (strtab (filter-mt string? match-table)) ; strings in grammar
496          (kwstab (filter-mt ident-like? strtab))  ; keyword strings =>
497          (keytab (map-mt string->symbol kwstab))  ; keywords in grammar
498          (chrseq (remove-mt ident-like? strtab))  ; character sequences
499          (symtab (filter-mt symbol? match-table)) ; symbols in grammar
500          (chrtab (filter-mt char? match-table))   ; characters in grammar
501          ;;
502          (read-chseq (make-chseq-reader chrseq))
503          (assc-$ (lambda (pair) (cons (assq-ref symtab (car pair)) (cdr pair))))
504          )
505     (lambda ()
506       (let ((bol #f))
507         (lambda ()
508           (let iter ((ch (read-char)))
509             (cond
510              ((eof-object? ch) (assc-$ (cons '$end ch)))
511              ;;((eq? ch #\newline) (set! bol #t) (iter (read-char)))
512              ((char-set-contains? space-cs ch) (iter (read-char)))
513              ((and (eqv? ch #\newline) (set! bol #t) #f))
514              ((read-comm ch bol) =>
515               (lambda (p) (set! bol #f) (assc-$ p)))
516              ((skip-comm ch) (iter (read-char)))
517              ((read-ident ch) =>
518               (lambda (s) (or (and=> (assq-ref keytab (string->symbol s))
519                                      (lambda (tval) (cons tval s)))
520                               (assc-$ (cons '$ident s)))))
521              ((read-num ch) => assc-$)    ; => $fixed or $float
522              ((read-string ch) => assc-$) ; => $string
523              ((read-chlit ch) => assc-$)  ; => $chlit
524              ((read-chseq ch) => identity)
525              ((assq-ref chrtab ch) => (lambda (t) (cons t (string ch))))
526              (else (cons ch ch))))))))) ; should be error
527
528 ;; @end table
529
530 ;; --- last line ---