summaryrefslogtreecommitdiff
path: root/module/language/elisp/parser.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/elisp/parser.scm')
-rw-r--r--module/language/elisp/parser.scm222
1 files changed, 222 insertions, 0 deletions
diff --git a/module/language/elisp/parser.scm b/module/language/elisp/parser.scm
new file mode 100644
index 000000000..e83f136bb
--- /dev/null
+++ b/module/language/elisp/parser.scm
@@ -0,0 +1,222 @@
+;;; Guile Emacs Lisp
+
+;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
+;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 3 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this library; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (language elisp parser)
+ #:use-module (language elisp lexer)
+ #:export (read-elisp))
+
+;;; The parser (reader) for elisp expressions.
+;;;
+;;; It is hand-written (just as the lexer is) instead of using some
+;;; parser generator because this allows easier transfer of source
+;;; properties from the lexer ((text parse-lalr) seems not to allow
+;;; access to the original lexer token-pair) and is easy enough anyways.
+
+;;; Report a parse error. The first argument is some current lexer
+;;; token where source information is available should it be useful.
+
+(define (parse-error token msg . args)
+ (apply error msg args))
+
+;;; For parsing circular structures, we keep track of definitions in a
+;;; hash-map that maps the id's to their values. When defining a new
+;;; id, though, we immediatly fill the slot with a promise before
+;;; parsing and setting the real value, because it must already be
+;;; available at that time in case of a circular reference. The promise
+;;; refers to a local variable that will be set when the real value is
+;;; available through a closure. After parsing the expression is
+;;; completed, we work through it again and force all promises we find.
+;;; The definitions themselves are stored in a fluid and their scope is
+;;; one call to read-elisp (but not only the currently parsed
+;;; expression!).
+
+(define circular-definitions (make-fluid))
+
+(define (make-circular-definitions)
+ (make-hash-table))
+
+(define (circular-ref token)
+ (if (not (eq? (car token) 'circular-ref))
+ (error "invalid token for circular-ref" token))
+ (let* ((id (cdr token))
+ (value (hashq-ref (fluid-ref circular-definitions) id)))
+ (if value
+ value
+ (parse-error token "undefined circular reference" id))))
+
+;;; Returned is a closure that, when invoked, will set the final value.
+;;; This means both the variable the promise will return and the
+;;; hash-table slot so we don't generate promises any longer.
+
+(define (circular-define! token)
+ (if (not (eq? (car token) 'circular-def))
+ (error "invalid token for circular-define!" token))
+ (let ((value #f)
+ (table (fluid-ref circular-definitions))
+ (id (cdr token)))
+ (hashq-set! table id (delay value))
+ (lambda (real-value)
+ (set! value real-value)
+ (hashq-set! table id real-value))))
+
+;;; Work through a parsed data structure and force the promises there.
+;;; After a promise is forced, the resulting value must not be recursed
+;;; on; this may lead to infinite recursion with a circular structure,
+;;; and additionally this value was already processed when it was
+;;; defined. All deep data structures that can be parsed must be
+;;; handled here!
+
+(define (force-promises! data)
+ (cond
+ ((pair? data)
+ (begin
+ (if (promise? (car data))
+ (set-car! data (force (car data)))
+ (force-promises! (car data)))
+ (if (promise? (cdr data))
+ (set-cdr! data (force (cdr data)))
+ (force-promises! (cdr data)))))
+ ((vector? data)
+ (let ((len (vector-length data)))
+ (let iterate ((i 0))
+ (if (< i len)
+ (let ((el (vector-ref data i)))
+ (if (promise? el)
+ (vector-set! data i (force el))
+ (force-promises! el))
+ (iterate (1+ i)))))))
+ ;; Else nothing needs to be done.
+ ))
+
+;;; We need peek-functionality for the next lexer token, this is done
+;;; with some single token look-ahead storage. This is handled by a
+;;; closure which allows getting or peeking the next token. When one
+;;; expression is fully parsed, we don't want a look-ahead stored here
+;;; because it would miss from future parsing. This is verified by the
+;;; finish action.
+
+(define (make-lexer-buffer lex)
+ (let ((look-ahead #f))
+ (lambda (action)
+ (if (eq? action 'finish)
+ (if look-ahead
+ (error "lexer-buffer is not empty when finished")
+ #f)
+ (begin
+ (if (not look-ahead)
+ (set! look-ahead (lex)))
+ (case action
+ ((peek) look-ahead)
+ ((get)
+ (let ((result look-ahead))
+ (set! look-ahead #f)
+ result))
+ (else (error "invalid lexer-buffer action" action))))))))
+
+;;; Get the contents of a list, where the opening parentheses has
+;;; already been found. The same code is used for vectors and lists,
+;;; where lists allow the dotted tail syntax and vectors not;
+;;; additionally, the closing parenthesis must of course match. The
+;;; implementation here is not tail-recursive, but I think it is clearer
+;;; and simpler this way.
+
+(define (get-list lex allow-dot close-square)
+ (let* ((next (lex 'peek))
+ (type (car next)))
+ (cond
+ ((eq? type (if close-square 'square-close 'paren-close))
+ (begin
+ (if (not (eq? (car (lex 'get)) type))
+ (error "got different token than peeked"))
+ '()))
+ ((and allow-dot (eq? type 'dot))
+ (begin
+ (if (not (eq? (car (lex 'get)) type))
+ (error "got different token than peeked"))
+ (let ((tail (get-list lex #f close-square)))
+ (if (not (= (length tail) 1))
+ (parse-error next
+ "expected exactly one element after dot"))
+ (car tail))))
+ (else
+ ;; Do both parses in exactly this sequence!
+ (let* ((head (get-expression lex))
+ (tail (get-list lex allow-dot close-square)))
+ (cons head tail))))))
+
+;;; Parse a single expression from a lexer-buffer. This is the main
+;;; routine in our recursive-descent parser.
+
+(define quotation-symbols '((quote . quote)
+ (backquote . #{`}#)
+ (unquote . #{,}#)
+ (unquote-splicing . #{,@}#)))
+
+(define (get-expression lex)
+ (let* ((token (lex 'get))
+ (type (car token))
+ (return (lambda (result)
+ (if (pair? result)
+ (set-source-properties!
+ result
+ (source-properties token)))
+ result)))
+ (case type
+ ((eof)
+ (parse-error token "end of file during parsing"))
+ ((integer float symbol character string)
+ (return (cdr token)))
+ ((function)
+ (return `(function ,(get-expression lex))))
+ ((quote backquote unquote unquote-splicing)
+ (return (list (assq-ref quotation-symbols type)
+ (get-expression lex))))
+ ((paren-open)
+ (return (get-list lex #t #f)))
+ ((square-open)
+ (return (list->vector (get-list lex #f #t))))
+ ((circular-ref)
+ (circular-ref token))
+ ((circular-def)
+ ;; The order of definitions is important!
+ (let* ((setter (circular-define! token))
+ (expr (get-expression lex)))
+ (setter expr)
+ (force-promises! expr)
+ expr))
+ ((set-lexical-binding-mode!)
+ (return `(%set-lexical-binding-mode ,(cdr token))))
+ (else
+ (parse-error token "expected expression, got" token)))))
+
+;;; Define the reader function based on this; build a lexer, a
+;;; lexer-buffer, and then parse a single expression to return. We also
+;;; define a circular-definitions data structure to use.
+
+(define (read-elisp port)
+ (with-fluids ((circular-definitions (make-circular-definitions)))
+ (let* ((lexer (get-lexer port))
+ (lexbuf (make-lexer-buffer lexer))
+ (next (lexbuf 'peek)))
+ (if (eq? (car next) 'eof)
+ (cdr next)
+ (let ((result (get-expression lexbuf)))
+ (lexbuf 'finish)
+ result)))))