(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"))))