partial lalr parser for M-zilti (eolian) added by sytse on Sun Jan 7 16:06:01 2018
(use lalr lalr-driver)
(define eolian-parser
(eval (lalr-parser
;; (output: eolian-parser "eolian.yy.scm")
(out-table: "eolian.out")
(PERIOD COMMA SEMICOLON : = < >
LPAREN RPAREN LBR RBR
CLASS IMPLEMENTS @EMPTY @AUTO
value docstring)
(unit (CLASS class-hdr LBR docstring? class-body* RBR)
: (cons* 'class $4 $5))
(docstring? (docstring) : $1
() : #f)
(name-ns (value) : (list $1)
(value PERIOD name-ns) : (cons $1 $3))
(local-name-ns (PERIOD name-ns) : (cons 'local $2))
(class-hdr (name-ns class-hdr-inherits))
(class-hdr-inherits
(LPAREN class-hdr-inherits-body RPAREN) : $2
() : #f)
(class-hdr-inherits-body
(name-ns COMMA class-hdr-inherits-body) : (cons $1 $3)
(name-ns) : (list $1))
(class-body* (class-body class-body*) : (cons $1 $2)
() : '())
(class-body (class-body-impls) : $1)
(class-body-impls (IMPLEMENTS LBR impl* RBR)
: (cons 'implements $3))
(impl* (impl impl*) : (cons $1 $2)
() : '())
;; value must be either "constructor" or "destructor".
(impl-common (CLASS PERIOD value SEMICOLON) : (let ((str $3))
(if (member str '("constructor"
"destructor"))
(list 'class str)
(error (format #f "Bad: class.~a" str)))))
(impl-keyword (@AUTO) : 'auto
(@EMPTY) : 'empty
() : #f)
(impl (impl-common) : (list #f $1)
(impl-keyword impl-name SEMICOLON) : (list $1 $2))
(impl-name (name-ns) : $1
(local-name-ns) : $1))))
(use ports lalr-driver (srfi 13))
(define (port-line port)
(let-values (((line _) (port-position port)))
line))
(define (port-column port)
(let-values (((_ column) (port-position port)))
column))
(define (make-lexer errorp)
(lambda ()
(letrec ((skip-whitespace
(lambda ()
(let loop ((c (peek-char)))
(if (and (not (eof-object? c))
(memq c '(#\space #\tab #\newline)))
(begin
(read-char)
(loop (peek-char)))))))
(skip-comment
(lambda ()
(let ((start-char (read-char)))
(case start-char
((#\*)
(let loop ((c (peek-char)))
(unless (eof-object? c)
(if (char=? c #\*)
(begin
(read-char)
(let ((c (peek-char)))
(if (char=? c #\/)
(read-char)
(loop c))))
(begin
(read-char)
(loop (peek-char)))))))
(else (errorp "Bad start of comment"))))))
(read-docstring
(lambda (location)
(let ((start-char (read-char)))
(case start-char
((#\[)
(let loop ((c (peek-char))
(out '()))
(unless (eof-object? c)
(if (char=? c #\])
(begin
(read-char)
(let ((next (read-char)))
(if (char=? next #\])
(make-lexical-token 'docstring location
(apply string (reverse! out)))
(loop (peek-char)
(cons next (cons c out))))))
(begin
(read-char)
(loop (peek-char)
(cons c out)))))))
(else (errorp "Bad docstring"))))))
(value-char?
(lambda (c)
(or (char-alphabetic? c)
(char-numeric? c)
(char=? c #\_))))
(read-value
(lambda (l)
(let ((c (peek-char)))
(if (value-char? c)
(read-value (cons (read-char) l))
(apply string (reverse! l))))))
(make-value-token
(lambda (location str)
(if (member str '("class" "implements"
"@empty" "@auto"))
(make-lexical-token (string->symbol (string-upcase str)) location #f)
(make-lexical-token 'value location str)))))
(skip-whitespace)
(let loop ()
(let* ((location (make-source-location "*stdin*" (port-line (current-input-port)) (port-column (current-input-port)) -1 -1))
(c (read-char)))
(cond ((eof-object? c)
'*eoi*)
((or (value-char? c)
(char=? c #\@))
(make-value-token location (read-value (list c))))
(else
(case c
((#\/) (skip-comment)
(skip-whitespace)
(loop))
((#\[) (read-docstring location))
((#\!) (case (peek-char)
((#\=) (read-char)
(make-lexical-token '!= location #f))
(else (make-lexical-token '! location #f))))
((#\=) (case (peek-char)
((#\=) (read-char)
(make-lexical-token '== location #f))
(else (make-lexical-token '= location #f))))
((#\+) (make-lexical-token '+ location #f))
((#\-) (make-lexical-token '- location #f))
((#\*) (make-lexical-token '* location #f))
((#\,) (make-lexical-token 'COMMA location #f))
((#\;) (make-lexical-token 'SEMICOLON location #f))
((#\.) (make-lexical-token 'PERIOD location #f))
((#\() (make-lexical-token 'LPAREN location #f))
((#\)) (make-lexical-token 'RPAREN location #f))
((#\{) (make-lexical-token 'LBR location #f))
((#\}) (make-lexical-token 'RBR location #f))
(else
(errorp "PARSE ERROR : illegal character: " c)
(skip-whitespace)
(loop))))))))))
(define (eo-parse)
(letrec ((errorp
(lambda (message . args)
(display message)
(if (and (pair? args)
(lexical-token? (car args)))
(let ((token (car args)))
(write (or (lexical-token-value token)
(lexical-token-category token)))
(let ((source (lexical-token-source token)))
(when (source-location? source)
(let ((line (source-location-line source))
(column (source-location-column source)))
(if (and (number? line) (number? column))
(begin
(display " (at line ")
(display line)
(display ", column ")
(display (+ 1 column))
(display ")")))))))
(for-each display args))
(newline))))
(eolian-parser (make-lexer errorp) errorp)))
(define example-eo
"
class Elm.Button (Elm.Layout, Evas.Interface.Clickable) {
implements {
class.constructor; /* Class constructor. */
Eo.Base.constructor; /* Default constructor. */
Elm.Widget.activate;
Evas.Smart.add;
.corner_coords_get; /* Name starting with . implies local class. */
@empty Bla.foo.get; /* Provides an empty implementation.
* Either to block calls to the super functions,
* or to have a base implementation people can \"super\" to.
*/
@auto Bla.foobar.get; /* Only works on properties (set and get),
* will automatically implement the foo_get function as:
* \"return pd->foo;\".
*/
/* If there's no modifier (@empty or @auto), it assumed that methods/properties
* declared in this eo file are implemented, e.g some_part_text_set.
*/
}
}
")
(with-input-from-string example-eo (lambda () (eo-parse)))
;; =>
;; (class #f
;; (implements
;; (#f (class "constructor"))
;; (#f ("Eo" "Base" "constructor"))
;; (#f ("Elm" "Widget" "activate"))
;; (#f ("Evas" "Smart" "add"))
;; (#f (local "corner_coords_get"))
;; (empty ("Bla" "foo" "get"))
;; (auto ("Bla" "foobar" "get"))))