Welcome to the CHICKEN Scheme pasting service

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