summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-12-10 11:41:39 +0100
committerIan Price <ianprice90@googlemail.com>2013-09-09 17:01:23 +0100
commit48f7c66a40f9357e10691caafac87355a17a3dec (patch)
tree13c07beffcfd040d7b5b91b51b6a9a95b46729c4
parenta0cecd8ff2b98cac4864aacadd28747558d14973 (diff)
downloadguile-48f7c66a40f9357e10691caafac87355a17a3dec.tar.gz
lua/parser tweaks
* module/language/lua/parser.scm (define-record, define-ast): Simplify these macros. (make-parser): A number of small idiomatic changes.
-rw-r--r--module/language/lua/parser.scm908
1 files changed, 436 insertions, 472 deletions
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
index 94e2a7895..875903b72 100644
--- a/module/language/lua/parser.scm
+++ b/module/language/lua/parser.scm
@@ -26,16 +26,13 @@
;; compiling the source.
(define-module (language lua parser)
-
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-9)
#:use-module (rnrs control)
-
#:use-module (language lua common)
#:use-module (language lua lexer)
#:use-module (language lua runtime)
-
#:export (make-parser read-lua))
;; Implicitly named records
@@ -43,16 +40,17 @@
((define-record
(lambda (stx)
(define (id template-id . rest)
- (datum->syntax template-id (string->symbol (apply string-append (map (lambda (x) (if (string? x) x (symbol->string (syntax->datum x)))) rest)))))
+ (datum->syntax template-id
+ (apply symbol-append (map syntax->datum rest))))
(syntax-case stx ()
((_ name field ...)
(with-syntax
- ((constructor (id #'name "make-" #'name))
- (predicate (id #'name #'name "?"))
+ ((constructor (id #'name 'make- #'name))
+ (predicate (id #'name #'name '?))
((setter ...)
- (map (lambda (x) (id #'name #'name "-" x "!")) #'(field ...)))
+ (map (lambda (x) (id #'name #'name '- x '!)) #'(field ...)))
((getter ...)
- (map (lambda (x) (id #'name #'name "-" x)) #'(field ...))))
+ (map (lambda (x) (id #'name #'name '- x)) #'(field ...))))
#'(begin
(define-record-type name
@@ -71,11 +69,12 @@
(define-ast
(lambda (stx)
(define (id template-id . rest)
- (datum->syntax template-id (string->symbol (apply string-append (map (lambda (x) (if (string? x) x (symbol->string (syntax->datum x)))) rest)))))
+ (datum->syntax template-id
+ (apply symbol-append (map syntax->datum rest))))
(syntax-case stx ()
((_ "aux" name field ...)
- #`(define-record #,(id #'name "ast-" #'name) #,(id #'name "src") field ...))
+ #`(define-record #,(id #'name 'ast- #'name) #,(id #'name 'src) field ...))
((_ (name field ...) ...)
#`(begin
@@ -123,17 +122,19 @@
"Returns true if TOKEN denotes the end of a grammatical chunk."
(or (memq token '(#:else #:elseif #:end #:until)) (eof-object? token)))
+(define *special-tokens*
+ '(#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\#
+ #:function #:end #:if #:return #:elseif #:then #:else #:true #:false
+ #:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in))
+
(define (token/type t)
- (cond ((number? t) 'NUMBER)
- ((eof-object? t) 'EOS)
- ((symbol? t) 'NAME)
- ((string? t) 'STRING)
- (else
- (case t
- ((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\#
-#:function #:end #:if #:return #:elseif #:then #:else #:true #:false
-#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in) t)
- (else (error 'TOKEN/TYPE t))))))
+ (cond
+ ((number? t) 'NUMBER)
+ ((eof-object? t) 'EOS)
+ ((symbol? t) 'NAME)
+ ((string? t) 'STRING)
+ ((memv t *special-tokens*) t)
+ (else (error 'TOKEN/TYPE t))))
;; infix operator parsing
(define (binary-operator? t)
@@ -161,22 +162,37 @@
(define (make-lua-assignment left right)
"Generate an assignment from a variable and an expression"
- (cond ((ast-global-ref? left)
- (make-ast-global-set (ast-global-ref-src left) (ast-global-ref-name left) right))
- ((ast-local-ref? left)
- (make-ast-local-set (ast-local-ref-src left) (ast-local-ref-name left) (ast-local-ref-gensym left) right))
- ((ast-table-ref? left)
- (make-ast-table-set (ast-table-ref-src left) (ast-table-ref-table left) (ast-table-ref-key left) right))
- (else
- (error 'MAKE-LUA-ASSIGNMENT "should not happen"))))
+ (cond
+ ((ast-global-ref? left)
+ (make-ast-global-set (ast-global-ref-src left)
+ (ast-global-ref-name left)
+ right))
+ ((ast-local-ref? left)
+ (make-ast-local-set (ast-local-ref-src left)
+ (ast-local-ref-name left)
+ (ast-local-ref-gensym left)
+ right))
+ ((ast-table-ref? left)
+ (make-ast-table-set (ast-table-ref-src left)
+ (ast-table-ref-table left)
+ (ast-table-ref-key left)
+ right))
+ (else
+ (error 'MAKE-LUA-ASSIGNMENT "should not happen"))))
(define (wrap-expression-in-environment src e x)
"Wrap an expression in an enclosing lexical environment if necessary"
- (let* ((bindings (map cdr (environment-bindings e)))
- (locals (filter-map (lambda (b) (if (eq? (binding-type b) 'local) b #f)) bindings)))
+ (let ((locals (filter-map (lambda (binding)
+ (let ((b (cdr binding)))
+ (and (eq? (binding-type b) 'local) b)))
+ (environment-bindings e))))
(if (null? locals)
x
- (make-ast-local-block src (map binding-name locals) (map binding-gensym locals) (map (lambda (c) *nil-literal*) locals) x))))
+ (make-ast-local-block src
+ (map binding-name locals)
+ (map binding-gensym locals)
+ (map (lambda (c) *nil-literal*) locals)
+ x))))
;;;;; PARSER
@@ -216,46 +232,37 @@
(define (environment-define! name type)
"Define a new variable with NAME and TYPE"
(if (not (member name (environment-bindings environment)))
- (environment-bindings! environment (alist-cons name
- (make-binding
- name
- (gensym (string-append " " (symbol->string name)))
- type)
- (environment-bindings environment)))))
+ (environment-bindings!
+ environment
+ (acons name
+ (make-binding
+ name
+ (gensym (string-append " " (symbol->string name)))
+ type)
+ (environment-bindings environment)))))
;; Environment lookup procedures -- these fail silently and return #f,
;; because Lua allows global variables to be referenced without being
;; predefined
- (define (environment-lookup-aux name . e)
+ (define* (environment-lookup-aux name #:optional (e environment))
"Given a variable's NAME, look up its binding."
- (set! e (if (null? e) environment (car e )))
- (if e
- (let ((binding (assq-ref (environment-bindings e) name)))
- (if binding
- binding
- (environment-lookup-aux name (environment-parent e))))
- #f))
-
+ (and e (or (assq-ref (environment-bindings e) name)
+ (environment-lookup-aux name (environment-parent e)))))
+
(define (environment-lookup-gensym name)
"Given a variable's NAME, look up its gensym"
- (define binding (environment-lookup-aux name))
- (if binding
- (binding-gensym binding)
- #f))
-
+ (and=> (environment-lookup-aux name) binding-gensym))
+
(define (environment-lookup-type name)
"Given a variable's NAME, look up its global"
- (define binding (environment-lookup-aux name))
- (if binding
- (binding-type binding)
- #f))
+ (and=> (environment-lookup-aux name) binding-type))
(define (resolve-ref src name)
"Determine whether a variable reference is global or local"
- (let* ((binding (environment-lookup-gensym name)))
- (if binding
- (make-ast-local-ref src name binding)
+ (let ((sym (environment-lookup-gensym name)))
+ (if sym
+ (make-ast-local-ref src name sym)
(make-ast-global-ref src name))))
;;;;; LEXER INTERACTION
@@ -270,7 +277,7 @@
(define-syntax advance!
(syntax-rules ()
- ((_ x) (begin (advance-aux) x))
+ ((_ x) (let ((t x)) (advance-aux) t))
((_) (advance-aux))))
(define (assert-token-type type)
@@ -280,9 +287,7 @@
(define (maybe-skip-next! c)
"Skip a token"
- (if (equal? token c)
- (advance! #t)
- #f))
+ (and (equal? token c) (advance! #t)))
(define (enforce-next! expect)
"Throw an error if the current token is not the expected token"
@@ -292,124 +297,119 @@
;;;;; GRAMMAR
;; single-name -> NAME
- (define (single-name . return-src?)
- (define save token)
- (define src (get-source-info))
- (assert-token-type 'NAME)
- (advance!)
- (if (not (null? return-src?))
- (values src save)
- save))
+ (define (single-name)
+ (let ((save token))
+ (assert-token-type 'NAME)
+ (advance!)
+ save))
;; single-variable -> single-name
(define (single-variable)
- (receive (src save)
- (single-name #:return-src #t)
- (resolve-ref src save)))
+ (let* ((src (get-source-info))
+ (save (single-name)))
+ (resolve-ref src save)))
;; application-arguments -> '(' [ expression-list ] ')' | STRING | TABLE
(define (application-arguments)
- (cond ((eq? (token/type token) 'STRING)
- (let* ((string token))
- (advance!)
- (list (make-ast-literal #f string))))
- ((eq? token #\{)
- ;; TODO: table constructor
- ;; '('
- (list (table-literal)))
- ((eq? token #\()
- (advance!)
- (if (eq? token #\))
- ;; ')'
- (advance! '())
- ;; [ expression-list ]
- (let* ((arguments (expression-list)))
- ;; ')'
- (enforce-next! #\))
- arguments)))
- (else (error 'APPLICATION-ARGUMENTS "should not happen"))))
+ (case (token/type token)
+ ((STRING)
+ (let ((string token))
+ (advance!)
+ (list (make-ast-literal #f string))))
+ ((#\{)
+ ;; TODO: table constructor
+ ;; '('
+ (list (table-literal)))
+ ((#\()
+ (advance!)
+ (if (eqv? token #\))
+ ;; ')'
+ (advance! '())
+ ;; [ expression-list ]
+ (let* ((arguments (expression-list)))
+ ;; ')'
+ (enforce-next! #\))
+ arguments)))
+ (else
+ (error 'APPLICATION-ARGUMENTS "should not happen"))))
;; prefix-expression -> NAME | '(' expression ')'
(define (prefix-expression)
- (cond
+ (case (token/type token)
;; NAME
- ((eq? (token/type token) 'NAME) (single-variable))
+ ((NAME) (single-variable))
;; '('
- ((eq? token #\()
- (begin
- (advance!)
- ;; expression
- (let* ((save (expression)))
- ;; ')'
- (enforce-next! #\))
- ;; finished
- save)))
+ ((#\()
+ (advance!)
+ ;; expression
+ (let ((save (expression)))
+ ;; ')'
+ (enforce-next! #\))
+ ;; finished
+ save))
(else (syntax-error (get-source-info) "unexpected symbol ~a" token))))
;; index -> '[' expression ']'
(define (index)
(enforce-next! #\[)
- (let* ((indice (expression)))
+ (let ((index (expression)))
(enforce-next! #\])
- indice))
+ index))
;; field-selector -> '.' NAME
(define (field-selector src prefix)
- (make-ast-table-ref src prefix (make-ast-literal src (symbol->string (single-name)))))
+ (make-ast-table-ref src prefix
+ (make-ast-literal src (symbol->string (single-name)))))
;; primary-expression -> prefix-expression { field-selector [ application-arguments ] | index | application-arguments }
(define (primary-expression)
- (define src (get-source-info))
- ;; prefix-expression
- (define prefix (prefix-expression))
- (let lp ((expr prefix))
- (case (token/type token)
+ (let ((src (get-source-info)))
+ ;; prefix-expression
+ (let lp ((expr (prefix-expression)))
+ (case (token/type token)
;; field-selector
((#\.) (advance!) (lp (field-selector src expr)))
;; index
- ((#\[)
- (let* ((indice (index)))
- (lp (make-ast-table-ref src expr indice))))
+ ((#\[) (lp (make-ast-table-ref src expr (index))))
;; ':' NAME application-arguments
((#\:)
(advance!)
- (assert-token-type 'NAME)
- (let* ((name (single-name)))
- (lp
- (make-ast-function-call src
- (make-ast-table-ref src expr (make-ast-literal src (symbol->string name)))
- (cons expr (application-arguments))))))
+ ;; FIXME: double-evaluation of expr
+ (let* ((name (single-name))
+ (args (application-arguments)))
+ (lp (make-ast-function-call
+ src
+ (make-ast-table-ref
+ src expr (make-ast-literal src (symbol->string name)))
+ (cons expr args)))))
;; application-arguments
((#\( STRING #\{)
(lp (make-ast-function-call src expr (application-arguments))))
- (else expr))))
+ (else expr)))))
;; expression-statement -> function | assignment
(define (expression-statement)
- (define primary (primary-expression))
- (if (ast-function-call? primary)
- primary
- (assignment primary)))
-
+ (let ((primary (primary-expression)))
+ (if (ast-function-call? primary)
+ primary
+ (assignment primary))))
;; record-field -> (NAME | index) '=' expression
(define (record-field)
- (let* ((indice
- (cond
- ;; NAME
- ((eq? (token/type token) 'NAME)
- (let ((tmp (make-ast-literal #f (symbol->string token))))
- (advance!)
- tmp))
- ;; index
- (else (index))))
- (value
- (begin
- ;; '='
- (enforce-next! #:=)
- ;; expression
- (expression))))
- (values indice value)))
+ (let* ((index (cond
+ ;; NAME
+ ((eq? (token/type token) 'NAME)
+ (let ((tmp (make-ast-literal #f (symbol->string token))))
+ (advance!)
+ tmp))
+ ;; index
+ (else (index))))
+ (value (begin
+ ;; '='
+ (enforce-next! #:=)
+ ;; expression
+ (expression))))
+ (values index value)))
;; field -> expression | record-field
(define (field)
@@ -425,84 +425,87 @@
;; field-separator -> ',' | ';'
;; table-fields -> [ field { field-separator field } [ field-separator ] ]
(define (table-fields src)
- (if (eq? token #\})
- '()
- (let loop ((implicit-indice 1)
- (tree '()))
- (if (eq? token #\})
- (reverse! tree)
- (receive
- (indice expr)
- (field)
- ;; field-separator
- (maybe-skip-next! #\,)
- (maybe-skip-next! #\;)
-
- (loop
- (if (not indice) (+ implicit-indice 1) implicit-indice)
- (cons
- (cons (or indice (make-ast-literal src implicit-indice)) expr)
- tree)))))))
+ (let loop ((implicit-index 1)
+ (tree '()))
+ (if (eqv? token #\})
+ (reverse! tree)
+ (receive (index expr) (field)
+ ;; field-separator
+ (maybe-skip-next! #\,)
+ (maybe-skip-next! #\;)
+ (loop
+ (if (not index) (+ implicit-index 1) implicit-index)
+ (cons
+ (cons (or index (make-ast-literal src implicit-index)) expr)
+ tree))))))
;; table-literal -> '{' table-fields '}'
(define (table-literal)
- (define src (get-source-info))
- ;; '{'
- (enforce-next! #\{)
- ;; bind the table to a temporary variable with LET as it's needed in order to initialize the table
- (let* ((result (make-ast-table-literal src (table-fields src))))
- result
- (enforce-next! #\})
- result))
+ (let ((src (get-source-info)))
+ ;; '{'
+ (enforce-next! #\{)
+ ;; bind the table to a temporary variable with LET as it's needed
+ ;; in order to initialize the table
+ (let ((result (make-ast-table-literal src (table-fields src))))
+ (enforce-next! #\})
+ result)))
;; parameter-list -> [ parameter { ',' parameter } ]
(define (parameter-list function-name)
- (if (eq? token #\))
- (values '() #f)
- (let lp ((parameters '()))
- ;; parameter
- (let* ((parameters
- (if (eq? (token/type token) 'NAME)
- (append! parameters (list token))
- (if (eq? token #:dots)
- (values parameters #f)
- (syntax-error (get-source-info) "expected either a name or ... in the parameter list of '~a', but got ~a" function-name token))))
- (last-token token))
- (advance!)
- (if (eq? token #\,)
- (if (eq? last-token #:dots)
- (syntax-error (get-source-info) "expected ')' after ... in the parameter list of '~a'" function-name)
- (advance! (lp parameters)))
- (values parameters (eq? last-token #:dots)))))))
+ (let lp ((parameters '()))
+ (case (token/type token)
+ ((NAME)
+ (let ((parameters (cons token parameters)))
+ (advance!)
+ (if (maybe-skip-next! #\,)
+ (lp parameters)
+ (values (reverse! parameters) #f))))
+ ((#\))
+ (values (reverse! parameters) #f))
+ ((#:dots)
+ (advance!)
+ (values (reverse! parameters) #t))
+ (else
+ (syntax-error
+ (get-source-info)
+ "expected either a name or ... in the parameter list of '~a', but got ~a"
+ function-name token)))))
;; function-body -> '(' parameter-list ')' chunk END
- (define* (function-body #:optional (src (get-source-info)) (implicit-self? #f) (name 'anonymous))
+ (define* (function-body #:optional (src (get-source-info)) (implicit-self? #f)
+ (name 'anonymous))
;; '('
(enforce-next! #\()
;; parameter-list
- (receive (parameters variable-arguments?)
- (parameter-list name)
- (let* ((old-vararg-function *vararg-function*))
- (set! *vararg-function* variable-arguments?)
- (enforce-next! #\))
- ;; create function
- (enter-environment!)
- (when implicit-self?
- (environment-define! 'self 'parameter))
- (for-each (lambda (p) (environment-define! p 'parameter)) parameters)
- ;; chunk
- (let* ((body (chunk))
- (parameter-gensyms (map environment-lookup-gensym parameters))
- (result
- (make-ast-function src (if (eq? name 'anonymous) #f name)
- (if implicit-self? (append parameters '(self)) parameters)
- (if implicit-self? (append parameter-gensyms (list (environment-lookup-gensym 'self))) parameter-gensyms)
- variable-arguments? (if (null? body) *void-literal* body))))
- (leave-environment!)
- ;; END
- (enforce-next! #:end)
- (set! *vararg-function* old-vararg-function)
- result))))
+ (receive (parameters variable-arguments?) (parameter-list name)
+ (let* ((old-vararg-function *vararg-function*))
+ (set! *vararg-function* variable-arguments?)
+ (enforce-next! #\))
+ ;; create function
+ (enter-environment!)
+ (when implicit-self?
+ (environment-define! 'self 'parameter))
+ (for-each (lambda (p) (environment-define! p 'parameter)) parameters)
+ ;; chunk
+ (let* ((body (chunk))
+ (parameter-gensyms (map environment-lookup-gensym parameters))
+ (result
+ (make-ast-function
+ src (if (eq? name 'anonymous) #f name)
+ (if implicit-self?
+ (append parameters '(self))
+ parameters)
+ (if implicit-self?
+ (append parameter-gensyms
+ (list (environment-lookup-gensym 'self)))
+ parameter-gensyms)
+ variable-arguments?
+ (if (null? body) *void-literal* body))))
+ (leave-environment!)
+ ;; END
+ (enforce-next! #:end)
+ (set! *vararg-function* old-vararg-function)
+ result))))
;; expression-list -> expression { ',' expression }
(define (expression-list)
@@ -515,60 +518,48 @@
;; simple-expression -> (nil | true | false | NUMBER | STRING) | table-literal | FUNCTION function-body
(define (simple-expression)
- (define src (get-source-info))
- (receive
- (advance? result)
- (case (token/type token)
- ;; (nil | true | false | NUMBER | STRING)
- ((#:true #:false #:nil NUMBER STRING)
- (values
- #t
- (make-ast-literal
- src
- (cond ((eq? token #:true) #t)
- ((eq? token #:false) #f)
- ((eq? token #:nil) #nil)
- (else token)))))
- ;; table-literal
- ((#\{) (values #f (table-literal)))
- ;; ...
- ((#:dots)
- (unless *vararg-function*
- (syntax-error src "cannot use '...' outside of a variable arguments function"))
- (values #t (make-ast-variable-arguments src)))
- ;; FUNCTION function-body
- ((#:function) (advance!) (values #f (function-body src)))
- ;; primary-expression
- (else (values #f (primary-expression))))
- (if advance?
- (advance!))
- result))
+ (let ((src (get-source-info)))
+ (case (token/type token)
+ ;; (nil | true | false | NUMBER | STRING)
+ ((#:nil) (advance! (make-ast-literal src #nil)))
+ ((#:true) (advance! (make-ast-literal src #t)))
+ ((#:false) (advance! (make-ast-literal src #f)))
+ ((NUMBER STRING) (advance! (make-ast-literal src token)))
+ ;; table-literal
+ ((#\{) (table-literal))
+ ;; ...
+ ((#:dots)
+ (unless *vararg-function*
+ (syntax-error src "cannot use '...' outside of a variable arguments function"))
+ (advance! (make-ast-variable-arguments src)))
+ ;; FUNCTION function-body
+ ((#:function) (advance!) (function-body src))
+ ;; primary-expression
+ (else (primary-expression)))))
;; subexpression -> (simple-expression | unary-operator subexpression) { binary-operator subexpression }
(define (subexpression limit)
- (define left)
- ;; test for preceding unary operator
- (set! left
- ;; (simple-expression | unary-operator subexpression)
- (if (unary-operator? token)
- ;; unary-operator subexpression
- (let* ((src (get-source-info))
- (operator token))
- (advance!)
- (make-ast-unary-operation src operator (subexpression *unary-priority*)))
- ;; simple-expression
- ;; note: simple-expression may advance the current token
- (simple-expression)))
-
- (let loop ((left left))
+ (let loop ((left
+ ;; (simple-expression | unary-operator subexpression)
+ (if (unary-operator? token)
+ ;; unary-operator subexpression
+ (let* ((src (get-source-info))
+ (operator token))
+ (advance!)
+ (make-ast-unary-operation
+ src operator (subexpression *unary-priority*)))
+ ;; simple-expression
+ ;; note: simple-expression may advance the current token
+ (simple-expression))))
;; { binary-operator subexpression }
(if (and (binary-operator? token) (> (priority token) limit))
(let* ((src (get-source-info))
(operator token))
(advance!)
- ;; read next expression with higher priorities
- (let* ((right (subexpression (priority operator))))
- (loop (make-ast-binary-operation src operator left right))))
+ (loop (make-ast-binary-operation
+ src operator left
+ ;; read next expression with higher priorities
+ (subexpression (priority operator)))))
;; finished
left)))
@@ -578,59 +569,61 @@
;; while-statement -> WHILE expression DO chunk END
(define (while-statement)
- (define src (get-source-info))
- ;; WHILE
- (advance!)
- ;; expression
- (let* ((condition (expression)))
- ;; DO
- (enforce-next! #:do)
- ;; chunk
- (let* ((body (chunk)))
- ;; END
- (enforce-next! #:end)
- (make-ast-while-loop src condition body))))
+ (let ((src (get-source-info)))
+ ;; WHILE
+ (advance!)
+ ;; expression
+ (let ((condition (expression)))
+ ;; DO
+ (enforce-next! #:do)
+ ;; chunk
+ (let ((body (chunk)))
+ ;; END
+ (enforce-next! #:end)
+ (make-ast-while-loop src condition body)))))
;; return-statement -> RETURN expression-list
(define (return-statement)
- (define src (get-source-info))
-
- ;; RETURN
- (advance!)
-
- (make-ast-return src (if (or (end-of-chunk? token) (eq? token #\;))
- *void-literal*
- (expression-list))))
-
+ (let ((src (get-source-info)))
+ ;; RETURN
+ (advance!)
+ (make-ast-return src
+ (if (or (end-of-chunk? token) (eqv? token #\;))
+ *void-literal*
+ (expression-list)))))
+
+ ;; FIXME: does a left-to-right assignment, so x, y = y, x probably
+ ;; doesn't work. Also does not appear to handle the x, y = foo() case.
+ ;;
(define (parse-assignment src left right)
- ;; and then parses it, branching to handle overflows on either side if necessary
- (make-ast-sequence
- src
- (let loop ((left left)
- (right right)
- (tree '()))
- (cond
- ;; no overflows, and finished
- ((and (null? left) (null? right))
- (reverse! tree))
- ;; no overflows, not finished
- ((and (not (null? left)) (not (null? right)))
- (loop (cdr left)
- (cdr right)
- (cons (make-lua-assignment (car left) (car right)) tree)))
- ;; overflow on right, evaluate extra expressions on the right
- ((and (null? left) (not (null? right)))
- (reverse! (append! right tree)))
- ;; overflow on left, set all overflowed expressions to nil
- ((and (not (null? left)) (null? right))
- (let loop ((tree tree)
- (rest left))
- (let* ((il (make-lua-assignment (car rest) *nil-literal*))
- (rest (cdr rest)))
- (if (null? rest)
- (reverse! (cons il tree))
- (loop (cons il tree) (cdr rest))))))
- (else (error 'PARSE-ASSIGNMENT "should not happen"))))))
+ ;; and then parses it, branching to handle overflows on either side if necessary
+ (make-ast-sequence
+ src
+ (let loop ((left left)
+ (right right)
+ (tree '()))
+ (cond
+ ;; no overflows, and finished
+ ((and (null? left) (null? right))
+ (reverse! tree))
+ ;; no overflows, not finished
+ ((and (not (null? left)) (not (null? right)))
+ (loop (cdr left)
+ (cdr right)
+ (cons (make-lua-assignment (car left) (car right)) tree)))
+ ;; overflow on right, evaluate extra expressions on the right
+ ((and (null? left) (not (null? right)))
+ (reverse! (append! right tree)))
+ ;; overflow on left, set all overflowed expressions to nil
+ ((and (not (null? left)) (null? right))
+ (let loop ((tree tree)
+ (rest left))
+ (let* ((il (make-lua-assignment (car rest) *nil-literal*))
+ (rest (cdr rest)))
+ (if (null? rest)
+ (reverse! (cons il tree))
+ (loop (cons il tree) (cdr rest))))))
+ (else (error 'PARSE-ASSIGNMENT "should not happen"))))))
;; assignment -> '=' expression-list | ',' primary-expression assignment
(define (assignment first)
@@ -640,20 +633,17 @@
;; so this function accumulates the entire assignment
(let* ((src (get-source-info))
- (left (let loop ((x first)
- (tree '()))
- (set! tree (cons x tree))
- (if (eq? token #\,)
- (advance! (loop (primary-expression) tree))
+ (left (let loop ((tree (list first)))
+ (if (eqv? token #\,)
+ (begin
+ (advance!)
+ (loop (cons (primary-expression) tree)))
(reverse! tree))))
(right (begin
(enforce-next! #:=)
(expression-list))))
- (parse-assignment src left right)
-
- ) ; let*
- ) ; assignment
+ (parse-assignment src left right)))
;; then-chunk -> (IF | ELSEIF) expression THEN chunk
(define (then-chunk)
@@ -664,219 +654,194 @@
;; THEN
(enforce-next! #:then)
;; chunk
- (let* ((body (chunk)))
- (values condition body))))
+ (values condition (chunk))))
;; if-statement -> then-chunk { then-chunk } [ELSE chunk] END
(define (if-statement)
- (define if-src (get-source-info))
- (define x
- (receive (test then)
- (then-chunk)
- (make-ast-condition
- if-src test then
- (let lp ()
- (define src (get-source-info))
- (if (eq? token #:elseif)
- (receive (test then)
- (then-chunk)
- (make-ast-condition src test then (lp)))
- (if (eq? token #:else)
- (advance! (chunk))
- *void-literal*))))))
- (enforce-next! #:end)
- x)
-
+ (let ((src (get-source-info)))
+ (receive (test then) (then-chunk)
+ (let ((x (make-ast-condition
+ src test then
+ (let lp ()
+ (let ((src (get-source-info)))
+ (if (eq? token #:elseif)
+ (receive (test then) (then-chunk)
+ (make-ast-condition src test then (lp)))
+ (if (eq? token #:else)
+ (begin (advance!) (chunk))
+ *void-literal*)))))))
+ (enforce-next! #:end)
+ x))))
+
;; repeat-statement -> REPEAT chunk UNTIL expression
(define (repeat-statement)
- (define src (get-source-info))
- ;; REPEAT
- (advance!)
- ;; chunk
- (let* ((body (chunk)))
- ;; UNTIL
- (enforce-next! #:until)
- ;; expression
- (let* ((condition (expression)))
- (make-ast-while-loop
- src
- (make-ast-unary-operation src 'not condition)
- body))))
+ (let ((src (get-source-info)))
+ ;; REPEAT
+ (advance!)
+ ;; chunk
+ (let ((body (chunk)))
+ ;; UNTIL
+ (enforce-next! #:until)
+ ;; expression
+ (let ((condition (expression)))
+ (make-ast-while-loop
+ src
+ (make-ast-unary-operation src 'not condition)
+ body)))))
;; function-statement -> FUNCTION NAME { field-selector } [ ':' NAME ] function-body
(define (function-statement)
- (define src (get-source-info))
- ;; FUNCTION NAME
- (define name (advance! (single-name)))
-
- (receive (prefix type)
- (let lp ((last-expr (resolve-ref src name)))
- (if (eq? token #\.)
- ;; { '.' NAME }
- (let* ((name (advance! (single-name))))
- (if (eq? token #\()
- (values (cons name last-expr) 'table-function)
- (lp (make-ast-table-ref src last-expr name))))
- ;; [ ':' NAME ]
- (if (eq? token #\:)
- (let* ((name (advance! (single-name))))
- (values (cons name last-expr) 'table-method))
- (values last-expr 'function))))
- (define body (function-body src (eq? type 'table-method) name))
- (case type
- ((table-function table-method)
- (make-ast-table-set src (cdr prefix) (make-ast-literal src (symbol->string (car prefix))) body))
- ((function) (make-lua-assignment prefix body))
- (else (error 'FUNCTION-STATEMENT "should not happen")))))
+ (let* ((src (get-source-info))
+ ;; FUNCTION NAME
+ (name (begin (advance!) (single-name))))
+ (receive (prefix type)
+ (let lp ((last-expr (resolve-ref src name)))
+ (if (eqv? token #\.)
+ ;; { '.' NAME }
+ (let ((name (begin (advance!) (single-name))))
+ (if (eq? token #\()
+ (values (cons name last-expr) 'table-function)
+ (lp (make-ast-table-ref src last-expr name))))
+ ;; [ ':' NAME ]
+ (if (eqv? token #\:)
+ (let ((name (begin (advance!) (single-name))))
+ (values (cons name last-expr) 'table-method))
+ (values last-expr 'function))))
+ (let ((body (function-body src (eq? type 'table-method) name)))
+ (case type
+ ((table-function table-method)
+ (make-ast-table-set
+ src (cdr prefix)
+ (make-ast-literal src (symbol->string (car prefix))) body))
+ ((function)
+ (make-lua-assignment prefix body))
+ (else (error 'FUNCTION-STATEMENT "should not happen")))))))
;; local-statement -> LOCAL NAME { ',' NAME } [ '=' expression-list ]
(define (local-statement)
- (define src (get-source-info))
- ;; LOCAL
- ;; (already advanced by calling function)
-
- (let lp ((names '()))
- ;; NAME
- (assert-token-type 'NAME)
- (set! names (cons token names))
- (advance!)
- (if (maybe-skip-next! #\,)
- ;; { ',' NAME }
- (lp names)
- (begin
- (for-each (lambda (n) (environment-define! n 'local)) names)
- (if (maybe-skip-next! #:=)
- ;; [ '=' expression-list ]
- (let* ((left (map (lambda (x) (resolve-ref src x)) names))
- (right (expression-list)))
- (parse-assignment src left (reverse! right)))
- ;; otherwise, it's not a declaration, not an assignment, and evaluates to nothing
- *void-literal*)))))
+ (let ((src (get-source-info)))
+ ;; LOCAL
+ ;; (already advanced by calling function)
+ (let lp ((names '()))
+ ;; NAME
+ (assert-token-type 'NAME)
+ (let ((names (advance! (cons token names))))
+ (if (maybe-skip-next! #\,)
+ ;; { ',' NAME }
+ (lp names)
+ (begin
+ (for-each (lambda (n) (environment-define! n 'local)) names)
+ (if (maybe-skip-next! #:=)
+ ;; [ '=' expression-list ]
+ (let ((left (map (lambda (x) (resolve-ref src x))
+ (reverse! names))))
+ (parse-assignment src left (expression-list)))
+ ;; otherwise, it's not a declaration, not an
+ ;; assignment, and evaluates to nothing
+ *void-literal*)))))))
(define (local-function-statement)
(assert-token-type 'NAME)
- (let* ((name token))
+ (let ((name token))
(environment-define! name 'local)
(advance!)
- (make-ast-local-set (get-source-info) name (environment-lookup-gensym name) (function-body))))
+ (make-ast-local-set (get-source-info) name
+ (environment-lookup-gensym name)
+ (function-body))))
;; for-body
(define (for-body)
(enforce-next! #:do)
- (let* ((body (chunk)))
+ (let ((body (chunk)))
(enforce-next! #:end)
body))
;; numeric-for -> FOR NAME '=' expression ',' expression ',' expression DO chunk END
(define (numeric-for src name)
- (define step *default-for-step*)
- (advance!)
(enforce-next! #:=)
(enter-environment!)
(environment-define! name 'local)
- (let* ((initial (expression)))
+ (let ((initial (expression)))
(enforce-next! #\,)
- (let* ((limit (expression)))
- (when (eq? token #\,)
- (advance!)
- (set! step (expression)))
- (let* ((result (make-ast-numeric-for-loop src name initial limit step (for-body))))
- (leave-environment!)
- result))))
+ (let* ((limit (expression))
+ (step (if (maybe-skip-next! #\,)
+ (expression)
+ *default-for-step*))
+ (result (make-ast-numeric-for-loop src name initial limit step
+ (for-body))))
+ (leave-environment!)
+ result)))
;; list-for -> FOR NAME { ',' NAME } IN expression-list DO chunk END
(define (list-for src name)
- (let* ((names
- (let lp ((names (list name)))
- (advance!)
- (if (eq? token #\,)
- (begin
- (advance!)
- (assert-token-type 'NAME)
- (lp (cons token names)))
- (reverse! names)))))
+ (let ((names (let lp ((names (list name)))
+ (if (maybe-skip-next! #\,)
+ (lp (cons (single-name) names))
+ (reverse! names)))))
(enforce-next! #:in)
- (let* ((exps (expression-list)))
+ (let ((exps (expression-list)))
(enforce-next! #:do)
(for-each
(lambda (name)
(environment-define! name 'hidden))
names)
- (let* ((body (chunk)))
+ (let ((body (chunk)))
(enforce-next! #:end)
- (make-ast-list-for-loop src names (map environment-lookup-gensym names) exps body)))))
+ (make-ast-list-for-loop
+ src names (map environment-lookup-gensym names) exps body)))))
;; for-statement -> FOR (numeric-for | list-for) END
(define (for-statement)
- (define src (get-source-info))
- (enforce-next! #:for)
- (assert-token-type 'NAME)
- (let* ((name token)
- (result
- (begin
- (lookahead!)
- (if (eq? token2 #:=)
- (numeric-for src name)
- (if (memv token2 '(#:in #\,))
- (list-for src name)
- (syntax-error src "expected = or in after for variable"))))))
- result))
+ (let ((src get-source-info))
+ (enforce-next! #:for)
+ (let ((name (single-name)))
+ (if (eq? token #:=)
+ (numeric-for src name)
+ (if (memv token '(#:in #\,))
+ (list-for src name)
+ (syntax-error src "expected = or in after for variable"))))))
;; break-statement -> BREAK
(define (break-statement)
- (enforce-next! #:break)
- (make-ast-break (get-source-info)))
+ (let ((src (get-source-info)))
+ (enforce-next! #:break)
+ (make-ast-break src)))
;; statement
(define (statement)
(case token
((#\;) (advance!) (statement))
;; statement -> return
- ((#:return #:break)
- (values
- #t
- (case token
- ((#:return) (return-statement))
- ((#:break) (break-statement)))))
- ((#:if #:function #:do #:while #:repeat #:local #:for)
- (values
- #f
- (case token
- ((#:repeat) (repeat-statement))
- ((#:while) (while-statement))
- ((#:if) (if-statement))
- ((#:function) (function-statement))
- ((#:local)
- (advance!)
- (if (maybe-skip-next! #:function)
- (local-function-statement)
- (local-statement)))
- ((#:for) (for-statement))
- ((#:do)
- (begin
- (advance!)
- (let* ((body (chunk)))
- (enforce-next! #:end)
- body))))))
+ ((#:return) (values #t (return-statement)))
+ ((#:break) (values #t (break-statement)))
+ ((#:repeat) (values #f (repeat-statement)))
+ ((#:while) (values #f (while-statement)))
+ ((#:if) (values #f (if-statement)))
+ ((#:function) (values #f (function-statement)))
+ ((#:local) (advance!) (if (maybe-skip-next! #:function)
+ (values #f (local-function-statement))
+ (values #f (local-statement))))
+ ((#:for) (values #f (for-statement)))
+ ((#:do) (advance!) (let ((body (chunk)))
+ (enforce-next! #:end)
+ (values #f body)))
;; statement -> function | assignment
(else (values #f (expression-statement)))))
;; chunk -> { statement [ ';' ] }
(define (chunk)
- (define src (get-source-info))
- (let loop ((is-last (end-of-chunk? token))
- (tree '()))
- (if is-last
- (begin
- (maybe-skip-next! #\;)
- (wrap-expression-in-environment
- src
- environment
- (make-ast-sequence src (reverse! tree))))
- (receive
- (is-last node)
- (statement)
- (loop (or (end-of-chunk? token) is-last) (cons node tree))))))
+ (let ((src (get-source-info)))
+ (let loop ((is-last (end-of-chunk? token))
+ (tree '()))
+ (if is-last
+ (begin
+ (maybe-skip-next! #\;)
+ (wrap-expression-in-environment
+ src
+ environment
+ (make-ast-sequence src (reverse! tree))))
+ (receive (is-last node) (statement)
+ (loop (or (end-of-chunk? token) is-last) (cons node tree)))))))
(initialize-lua-lexer! port get-source-info lexer)
@@ -888,5 +853,4 @@
chunk)
(define (read-lua port)
- (define parser (make-parser port))
- (parser))
+ ((make-parser port)))