mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-09 23:40:29 +02:00
Code Activity

lua/parser tweaks

Browse source 
* module/language/lua/parser.scm (define-record, define-ast): Simplify
  these macros.
  (make-parser): A number of small idiomatic changes.
This commit is contained in:
Andy Wingo 2010-12-10 11:41:39 +01:00 • committed by Ian Price
parent a0cecd8ff2
commit 48f7c66a40
1 changed files with 435 additions and 471 deletions
Download patch file Download diff file Expand all files Collapse all files

520
module/language/lua/parser.scm
View file

@ -26,16 +26,13 @@
;; compiling the source. ;; compiling the source.
(define-module (language lua parser) (define-module (language lua parser)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-8) #:use-module (srfi srfi-8)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (rnrs control) #:use-module (rnrs control)
#:use-module (language lua common) #:use-module (language lua common)
#:use-module (language lua lexer) #:use-module (language lua lexer)
#:use-module (language lua runtime) #:use-module (language lua runtime)
#:export (make-parser read-lua)) #:export (make-parser read-lua))
;; Implicitly named records ;; Implicitly named records
@ -43,16 +40,17 @@
((define-record ((define-record
(lambda (stx) (lambda (stx)
(define (id template-id . rest) (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 () (syntax-case stx ()
((_ name field ...) ((_ name field ...)
(with-syntax (with-syntax
((constructor (id #'name "make-" #'name)) ((constructor (id #'name 'make- #'name))
(predicate (id #'name #'name "?")) (predicate (id #'name #'name '?))
((setter ...) ((setter ...)
(map (lambda (x) (id #'name #'name "-" x "!")) #'(field ...))) (map (lambda (x) (id #'name #'name '- x '!)) #'(field ...)))
((getter ...) ((getter ...)
(map (lambda (x) (id #'name #'name "-" x)) #'(field ...)))) (map (lambda (x) (id #'name #'name '- x)) #'(field ...))))
#'(begin #'(begin
(define-record-type name (define-record-type name
@ -71,11 +69,12 @@
(define-ast (define-ast
(lambda (stx) (lambda (stx)
(define (id template-id . rest) (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 () (syntax-case stx ()
((_ "aux" name field ...) ((_ "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 ...) ...) ((_ (name field ...) ...)
#`(begin #`(begin
@ -123,17 +122,19 @@
"Returns true if TOKEN denotes the end of a grammatical chunk." "Returns true if TOKEN denotes the end of a grammatical chunk."
(or (memq token '(#:else #:elseif #:end #:until)) (eof-object? token))) (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) (define (token/type t)
(cond ((number? t) 'NUMBER) (cond
((number? t) 'NUMBER)
((eof-object? t) 'EOS) ((eof-object? t) 'EOS)
((symbol? t) 'NAME) ((symbol? t) 'NAME)
((string? t) 'STRING) ((string? t) 'STRING)
(else ((memv t *special-tokens*) t)
(case t (else (error 'TOKEN/TYPE t))))
((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\#
#:function #:end #:if #:return #:elseif #:then #:else #:true #:false
#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in) t)
(else (error 'TOKEN/TYPE t))))))
;; infix operator parsing ;; infix operator parsing
(define (binary-operator? t) (define (binary-operator? t)
@ -161,22 +162,37 @@
(define (make-lua-assignment left right) (define (make-lua-assignment left right)
"Generate an assignment from a variable and an expression" "Generate an assignment from a variable and an expression"
(cond ((ast-global-ref? left) (cond
(make-ast-global-set (ast-global-ref-src left) (ast-global-ref-name left) right)) ((ast-global-ref? left)
(make-ast-global-set (ast-global-ref-src left)
(ast-global-ref-name left)
right))
((ast-local-ref? left) ((ast-local-ref? left)
(make-ast-local-set (ast-local-ref-src left) (ast-local-ref-name left) (ast-local-ref-gensym left) right)) (make-ast-local-set (ast-local-ref-src left)
(ast-local-ref-name left)
(ast-local-ref-gensym left)
right))
((ast-table-ref? left) ((ast-table-ref? left)
(make-ast-table-set (ast-table-ref-src left) (ast-table-ref-table left) (ast-table-ref-key left) right)) (make-ast-table-set (ast-table-ref-src left)
(ast-table-ref-table left)
(ast-table-ref-key left)
right))
(else (else
(error 'MAKE-LUA-ASSIGNMENT "should not happen")))) (error 'MAKE-LUA-ASSIGNMENT "should not happen"))))
(define (wrap-expression-in-environment src e x) (define (wrap-expression-in-environment src e x)
"Wrap an expression in an enclosing lexical environment if necessary" "Wrap an expression in an enclosing lexical environment if necessary"
(let* ((bindings (map cdr (environment-bindings e))) (let ((locals (filter-map (lambda (binding)
(locals (filter-map (lambda (b) (if (eq? (binding-type b) 'local) b #f)) bindings))) (let ((b (cdr binding)))
(and (eq? (binding-type b) 'local) b)))
(environment-bindings e))))
(if (null? locals) (if (null? locals)
x 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 ;;;;; PARSER
@ -216,7 +232,9 @@
(define (environment-define! name type) (define (environment-define! name type)
"Define a new variable with NAME and TYPE" "Define a new variable with NAME and TYPE"
(if (not (member name (environment-bindings environment))) (if (not (member name (environment-bindings environment)))
(environment-bindings! environment (alist-cons name (environment-bindings!
environment
(acons name
(make-binding (make-binding
name name
(gensym (string-append " " (symbol->string name))) (gensym (string-append " " (symbol->string name)))
@ -227,35 +245,24 @@
;; because Lua allows global variables to be referenced without being ;; because Lua allows global variables to be referenced without being
;; predefined ;; predefined
(define (environment-lookup-aux name . e) (define* (environment-lookup-aux name #:optional (e environment))
"Given a variable's NAME, look up its binding." "Given a variable's NAME, look up its binding."
(set! e (if (null? e) environment (car e ))) (and e (or (assq-ref (environment-bindings e) name)
(if e (environment-lookup-aux name (environment-parent e)))))
(let ((binding (assq-ref (environment-bindings e) name)))
(if binding
binding
(environment-lookup-aux name (environment-parent e))))
#f))
(define (environment-lookup-gensym name) (define (environment-lookup-gensym name)
"Given a variable's NAME, look up its gensym" "Given a variable's NAME, look up its gensym"
(define binding (environment-lookup-aux name)) (and=> (environment-lookup-aux name) binding-gensym))
(if binding
(binding-gensym binding)
#f))
(define (environment-lookup-type name) (define (environment-lookup-type name)
"Given a variable's NAME, look up its global" "Given a variable's NAME, look up its global"
(define binding (environment-lookup-aux name)) (and=> (environment-lookup-aux name) binding-type))
(if binding
(binding-type binding)
#f))
(define (resolve-ref src name) (define (resolve-ref src name)
"Determine whether a variable reference is global or local" "Determine whether a variable reference is global or local"
(let* ((binding (environment-lookup-gensym name))) (let ((sym (environment-lookup-gensym name)))
(if binding (if sym
(make-ast-local-ref src name binding) (make-ast-local-ref src name sym)
(make-ast-global-ref src name)))) (make-ast-global-ref src name))))
;;;;; LEXER INTERACTION ;;;;; LEXER INTERACTION
@ -270,7 +277,7 @@
(define-syntax advance! (define-syntax advance!
(syntax-rules () (syntax-rules ()
((_ x) (begin (advance-aux) x)) ((_ x) (let ((t x)) (advance-aux) t))
((_) (advance-aux)))) ((_) (advance-aux))))
(define (assert-token-type type) (define (assert-token-type type)
@ -280,9 +287,7 @@
(define (maybe-skip-next! c) (define (maybe-skip-next! c)
"Skip a token" "Skip a token"
(if (equal? token c) (and (equal? token c) (advance! #t)))
(advance! #t)
#f))
(define (enforce-next! expect) (define (enforce-next! expect)
"Throw an error if the current token is not the expected token" "Throw an error if the current token is not the expected token"
@ -292,34 +297,32 @@
;;;;; GRAMMAR ;;;;; GRAMMAR
;; single-name -> NAME ;; single-name -> NAME
(define (single-name . return-src?) (define (single-name)
(define save token) (let ((save token))
(define src (get-source-info))
(assert-token-type 'NAME) (assert-token-type 'NAME)
(advance!) (advance!)
(if (not (null? return-src?))
(values src save)
save)) save))
;; single-variable -> single-name ;; single-variable -> single-name
(define (single-variable) (define (single-variable)
(receive (src save) (let* ((src (get-source-info))
(single-name #:return-src #t) (save (single-name)))
(resolve-ref src save))) (resolve-ref src save)))
;; application-arguments -> '(' [ expression-list ] ')' | STRING | TABLE ;; application-arguments -> '(' [ expression-list ] ')' | STRING | TABLE
(define (application-arguments) (define (application-arguments)
(cond ((eq? (token/type token) 'STRING) (case (token/type token)
(let* ((string token)) ((STRING)
(let ((string token))
(advance!) (advance!)
(list (make-ast-literal #f string)))) (list (make-ast-literal #f string))))
((eq? token #\{) ((#\{)
;; TODO: table constructor ;; TODO: table constructor
;; '(' ;; '('
(list (table-literal))) (list (table-literal)))
((eq? token #\() ((#\()
(advance!) (advance!)
(if (eq? token #\)) (if (eqv? token #\))
;; ')' ;; ')'
(advance! '()) (advance! '())
;; [ expression-list ] ;; [ expression-list ]
@ -327,75 +330,73 @@
;; ')' ;; ')'
(enforce-next! #\)) (enforce-next! #\))
arguments))) arguments)))
(else (error 'APPLICATION-ARGUMENTS "should not happen")))) (else
(error 'APPLICATION-ARGUMENTS "should not happen"))))
;; prefix-expression -> NAME | '(' expression ')' ;; prefix-expression -> NAME | '(' expression ')'
(define (prefix-expression) (define (prefix-expression)
(cond (case (token/type token)
;; NAME ;; NAME
((eq? (token/type token) 'NAME) (single-variable)) ((NAME) (single-variable))
;; '(' ;; '('
((eq? token #\() ((#\()
(begin
(advance!) (advance!)
;; expression ;; expression
(let* ((save (expression))) (let ((save (expression)))
;; ')' ;; ')'
(enforce-next! #\)) (enforce-next! #\))
;; finished ;; finished
save))) save))
(else (syntax-error (get-source-info) "unexpected symbol ~a" token)))) (else (syntax-error (get-source-info) "unexpected symbol ~a" token))))
;; index -> '[' expression ']' ;; index -> '[' expression ']'
(define (index) (define (index)
(enforce-next! #\[) (enforce-next! #\[)
(let* ((indice (expression))) (let ((index (expression)))
(enforce-next! #\]) (enforce-next! #\])
indice)) index))
;; field-selector -> '.' NAME ;; field-selector -> '.' NAME
(define (field-selector src prefix) (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 } ;; primary-expression -> prefix-expression { field-selector [ application-arguments ] | index | application-arguments }
(define (primary-expression) (define (primary-expression)
(define src (get-source-info)) (let ((src (get-source-info)))
;; prefix-expression ;; prefix-expression
(define prefix (prefix-expression)) (let lp ((expr (prefix-expression)))
(let lp ((expr prefix))
(case (token/type token) (case (token/type token)
;; field-selector ;; field-selector
((#\.) (advance!) (lp (field-selector src expr))) ((#\.) (advance!) (lp (field-selector src expr)))
;; index ;; index
((#\[) ((#\[) (lp (make-ast-table-ref src expr (index))))
(let* ((indice (index)))
(lp (make-ast-table-ref src expr indice))))
;; ':' NAME application-arguments ;; ':' NAME application-arguments
((#\:) ((#\:)
(advance!) (advance!)
(assert-token-type 'NAME) ;; FIXME: double-evaluation of expr
(let* ((name (single-name))) (let* ((name (single-name))
(lp (args (application-arguments)))
(make-ast-function-call src (lp (make-ast-function-call
(make-ast-table-ref src expr (make-ast-literal src (symbol->string name))) src
(cons expr (application-arguments)))))) (make-ast-table-ref
src expr (make-ast-literal src (symbol->string name)))
(cons expr args)))))
;; application-arguments ;; application-arguments
((#\( STRING #\{) ((#\( STRING #\{)
(lp (make-ast-function-call src expr (application-arguments)))) (lp (make-ast-function-call src expr (application-arguments))))
(else expr)))) (else expr)))))
;; expression-statement -> function | assignment ;; expression-statement -> function | assignment
(define (expression-statement) (define (expression-statement)
(define primary (primary-expression)) (let ((primary (primary-expression)))
(if (ast-function-call? primary) (if (ast-function-call? primary)
primary primary
(assignment primary))) (assignment primary))))
;; record-field -> (NAME | index) '=' expression ;; record-field -> (NAME | index) '=' expression
(define (record-field) (define (record-field)
(let* ((indice (let* ((index (cond
(cond
;; NAME ;; NAME
((eq? (token/type token) 'NAME) ((eq? (token/type token) 'NAME)
(let ((tmp (make-ast-literal #f (symbol->string token)))) (let ((tmp (make-ast-literal #f (symbol->string token))))
@ -403,13 +404,12 @@
tmp)) tmp))
;; index ;; index
(else (index)))) (else (index))))
(value (value (begin
(begin
;; '=' ;; '='
(enforce-next! #:=) (enforce-next! #:=)
;; expression ;; expression
(expression)))) (expression))))
(values indice value))) (values index value)))
;; field -> expression | record-field ;; field -> expression | record-field
(define (field) (define (field)
@ -425,63 +425,59 @@
;; field-separator -> ',' | ';' ;; field-separator -> ',' | ';'
;; table-fields -> [ field { field-separator field } [ field-separator ] ] ;; table-fields -> [ field { field-separator field } [ field-separator ] ]
(define (table-fields src) (define (table-fields src)
(if (eq? token #\}) (let loop ((implicit-index 1)
'()
(let loop ((implicit-indice 1)
(tree '())) (tree '()))
(if (eq? token #\}) (if (eqv? token #\})
(reverse! tree) (reverse! tree)
(receive (receive (index expr) (field)
(indice expr)
(field)
;; field-separator ;; field-separator
(maybe-skip-next! #\,) (maybe-skip-next! #\,)
(maybe-skip-next! #\;) (maybe-skip-next! #\;)
(loop (loop
(if (not indice) (+ implicit-indice 1) implicit-indice) (if (not index) (+ implicit-index 1) implicit-index)
(cons (cons
(cons (or indice (make-ast-literal src implicit-indice)) expr) (cons (or index (make-ast-literal src implicit-index)) expr)
tree))))))) tree))))))
;; table-literal -> '{' table-fields '}' ;; table-literal -> '{' table-fields '}'
(define (table-literal) (define (table-literal)
(define src (get-source-info)) (let ((src (get-source-info)))
;; '{' ;; '{'
(enforce-next! #\{) (enforce-next! #\{)
;; bind the table to a temporary variable with LET as it's needed in order to initialize the table ;; bind the table to a temporary variable with LET as it's needed
(let* ((result (make-ast-table-literal src (table-fields src)))) ;; in order to initialize the table
result (let ((result (make-ast-table-literal src (table-fields src))))
(enforce-next! #\}) (enforce-next! #\})
result)) result)))
;; parameter-list -> [ parameter { ',' parameter } ] ;; parameter-list -> [ parameter { ',' parameter } ]
(define (parameter-list function-name) (define (parameter-list function-name)
(if (eq? token #\))
(values '() #f)
(let lp ((parameters '())) (let lp ((parameters '()))
;; parameter (case (token/type token)
(let* ((parameters ((NAME)
(if (eq? (token/type token) 'NAME) (let ((parameters (cons token parameters)))
(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!) (advance!)
(if (eq? token #\,) (if (maybe-skip-next! #\,)
(if (eq? last-token #:dots) (lp parameters)
(syntax-error (get-source-info) "expected ')' after ... in the parameter list of '~a'" function-name) (values (reverse! parameters) #f))))
(advance! (lp parameters))) ((#\))
(values parameters (eq? last-token #:dots))))))) (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 ;; 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! #\() (enforce-next! #\()
;; parameter-list ;; parameter-list
(receive (parameters variable-arguments?) (receive (parameters variable-arguments?) (parameter-list name)
(parameter-list name)
(let* ((old-vararg-function *vararg-function*)) (let* ((old-vararg-function *vararg-function*))
(set! *vararg-function* variable-arguments?) (set! *vararg-function* variable-arguments?)
(enforce-next! #\)) (enforce-next! #\))
@ -494,10 +490,17 @@
(let* ((body (chunk)) (let* ((body (chunk))
(parameter-gensyms (map environment-lookup-gensym parameters)) (parameter-gensyms (map environment-lookup-gensym parameters))
(result (result
(make-ast-function src (if (eq? name 'anonymous) #f name) (make-ast-function
(if implicit-self? (append parameters '(self)) parameters) src (if (eq? name 'anonymous) #f name)
(if implicit-self? (append parameter-gensyms (list (environment-lookup-gensym 'self))) parameter-gensyms) (if implicit-self?
variable-arguments? (if (null? body) *void-literal* body)))) (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!) (leave-environment!)
;; END ;; END
(enforce-next! #:end) (enforce-next! #:end)
@ -515,60 +518,48 @@
;; simple-expression -> (nil | true | false | NUMBER | STRING) | table-literal | FUNCTION function-body ;; simple-expression -> (nil | true | false | NUMBER | STRING) | table-literal | FUNCTION function-body
(define (simple-expression) (define (simple-expression)
(define src (get-source-info)) (let ((src (get-source-info)))
(receive
(advance? result)
(case (token/type token) (case (token/type token)
;; (nil | true | false | NUMBER | STRING) ;; (nil | true | false | NUMBER | STRING)
((#:true #:false #:nil NUMBER STRING) ((#:nil) (advance! (make-ast-literal src #nil)))
(values ((#:true) (advance! (make-ast-literal src #t)))
#t ((#:false) (advance! (make-ast-literal src #f)))
(make-ast-literal ((NUMBER STRING) (advance! (make-ast-literal src token)))
src
(cond ((eq? token #:true) #t)
((eq? token #:false) #f)
((eq? token #:nil) #nil)
(else token)))))
;; table-literal ;; table-literal
((#\{) (values #f (table-literal))) ((#\{) (table-literal))
;; ... ;; ...
((#:dots) ((#:dots)
(unless *vararg-function* (unless *vararg-function*
(syntax-error src "cannot use '...' outside of a variable arguments function")) (syntax-error src "cannot use '...' outside of a variable arguments function"))
(values #t (make-ast-variable-arguments src))) (advance! (make-ast-variable-arguments src)))
;; FUNCTION function-body ;; FUNCTION function-body
((#:function) (advance!) (values #f (function-body src))) ((#:function) (advance!) (function-body src))
;; primary-expression ;; primary-expression
(else (values #f (primary-expression)))) (else (primary-expression)))))
(if advance?
(advance!))
result))
;; subexpression -> (simple-expression | unary-operator subexpression) { binary-operator subexpression } ;; subexpression -> (simple-expression | unary-operator subexpression) { binary-operator subexpression }
(define (subexpression limit) (define (subexpression limit)
(define left) (let loop ((left
;; test for preceding unary operator
(set! left
;; (simple-expression | unary-operator subexpression) ;; (simple-expression | unary-operator subexpression)
(if (unary-operator? token) (if (unary-operator? token)
;; unary-operator subexpression ;; unary-operator subexpression
(let* ((src (get-source-info)) (let* ((src (get-source-info))
(operator token)) (operator token))
(advance!) (advance!)
(make-ast-unary-operation src operator (subexpression *unary-priority*))) (make-ast-unary-operation
src operator (subexpression *unary-priority*)))
;; simple-expression ;; simple-expression
;; note: simple-expression may advance the current token ;; note: simple-expression may advance the current token
(simple-expression))) (simple-expression))))
(let loop ((left left))
;; { binary-operator subexpression } ;; { binary-operator subexpression }
(if (and (binary-operator? token) (> (priority token) limit)) (if (and (binary-operator? token) (> (priority token) limit))
(let* ((src (get-source-info)) (let* ((src (get-source-info))
(operator token)) (operator token))
(advance!) (advance!)
(loop (make-ast-binary-operation
src operator left
;; read next expression with higher priorities ;; read next expression with higher priorities
(let* ((right (subexpression (priority operator)))) (subexpression (priority operator)))))
(loop (make-ast-binary-operation src operator left right))))
;; finished ;; finished
left))) left)))
@ -578,30 +569,32 @@
;; while-statement -> WHILE expression DO chunk END ;; while-statement -> WHILE expression DO chunk END
(define (while-statement) (define (while-statement)
(define src (get-source-info)) (let ((src (get-source-info)))
;; WHILE ;; WHILE
(advance!) (advance!)
;; expression ;; expression
(let* ((condition (expression))) (let ((condition (expression)))
;; DO ;; DO
(enforce-next! #:do) (enforce-next! #:do)
;; chunk ;; chunk
(let* ((body (chunk))) (let ((body (chunk)))
;; END ;; END
(enforce-next! #:end) (enforce-next! #:end)
(make-ast-while-loop src condition body)))) (make-ast-while-loop src condition body)))))
;; return-statement -> RETURN expression-list ;; return-statement -> RETURN expression-list
(define (return-statement) (define (return-statement)
(define src (get-source-info)) (let ((src (get-source-info)))
;; RETURN ;; RETURN
(advance!) (advance!)
(make-ast-return src
(make-ast-return src (if (or (end-of-chunk? token) (eq? token #\;)) (if (or (end-of-chunk? token) (eqv? token #\;))
*void-literal* *void-literal*
(expression-list)))) (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) (define (parse-assignment src left right)
;; and then parses it, branching to handle overflows on either side if necessary ;; and then parses it, branching to handle overflows on either side if necessary
(make-ast-sequence (make-ast-sequence
@ -640,20 +633,17 @@
;; so this function accumulates the entire assignment ;; so this function accumulates the entire assignment
(let* ((src (get-source-info)) (let* ((src (get-source-info))
(left (let loop ((x first) (left (let loop ((tree (list first)))
(tree '())) (if (eqv? token #\,)
(set! tree (cons x tree)) (begin
(if (eq? token #\,) (advance!)
(advance! (loop (primary-expression) tree)) (loop (cons (primary-expression) tree)))
(reverse! tree)))) (reverse! tree))))
(right (begin (right (begin
(enforce-next! #:=) (enforce-next! #:=)
(expression-list)))) (expression-list))))
(parse-assignment src left right) (parse-assignment src left right)))
) ; let*
) ; assignment
;; then-chunk -> (IF | ELSEIF) expression THEN chunk ;; then-chunk -> (IF | ELSEIF) expression THEN chunk
(define (then-chunk) (define (then-chunk)
@ -664,82 +654,78 @@
;; THEN ;; THEN
(enforce-next! #:then) (enforce-next! #:then)
;; chunk ;; chunk
(let* ((body (chunk))) (values condition (chunk))))
(values condition body))))
;; if-statement -> then-chunk { then-chunk } [ELSE chunk] END ;; if-statement -> then-chunk { then-chunk } [ELSE chunk] END
(define (if-statement) (define (if-statement)
(define if-src (get-source-info)) (let ((src (get-source-info)))
(define x (receive (test then) (then-chunk)
(receive (test then) (let ((x (make-ast-condition
(then-chunk) src test then
(make-ast-condition
if-src test then
(let lp () (let lp ()
(define src (get-source-info)) (let ((src (get-source-info)))
(if (eq? token #:elseif) (if (eq? token #:elseif)
(receive (test then) (receive (test then) (then-chunk)
(then-chunk)
(make-ast-condition src test then (lp))) (make-ast-condition src test then (lp)))
(if (eq? token #:else) (if (eq? token #:else)
(advance! (chunk)) (begin (advance!) (chunk))
*void-literal*)))))) *void-literal*)))))))
(enforce-next! #:end) (enforce-next! #:end)
x) x))))
;; repeat-statement -> REPEAT chunk UNTIL expression ;; repeat-statement -> REPEAT chunk UNTIL expression
(define (repeat-statement) (define (repeat-statement)
(define src (get-source-info)) (let ((src (get-source-info)))
;; REPEAT ;; REPEAT
(advance!) (advance!)
;; chunk ;; chunk
(let* ((body (chunk))) (let ((body (chunk)))
;; UNTIL ;; UNTIL
(enforce-next! #:until) (enforce-next! #:until)
;; expression ;; expression
(let* ((condition (expression))) (let ((condition (expression)))
(make-ast-while-loop (make-ast-while-loop
src src
(make-ast-unary-operation src 'not condition) (make-ast-unary-operation src 'not condition)
body)))) body)))))
;; function-statement -> FUNCTION NAME { field-selector } [ ':' NAME ] function-body ;; function-statement -> FUNCTION NAME { field-selector } [ ':' NAME ] function-body
(define (function-statement) (define (function-statement)
(define src (get-source-info)) (let* ((src (get-source-info))
;; FUNCTION NAME ;; FUNCTION NAME
(define name (advance! (single-name))) (name (begin (advance!) (single-name))))
(receive (prefix type) (receive (prefix type)
(let lp ((last-expr (resolve-ref src name))) (let lp ((last-expr (resolve-ref src name)))
(if (eq? token #\.) (if (eqv? token #\.)
;; { '.' NAME } ;; { '.' NAME }
(let* ((name (advance! (single-name)))) (let ((name (begin (advance!) (single-name))))
(if (eq? token #\() (if (eq? token #\()
(values (cons name last-expr) 'table-function) (values (cons name last-expr) 'table-function)
(lp (make-ast-table-ref src last-expr name)))) (lp (make-ast-table-ref src last-expr name))))
;; [ ':' NAME ] ;; [ ':' NAME ]
(if (eq? token #\:) (if (eqv? token #\:)
(let* ((name (advance! (single-name)))) (let ((name (begin (advance!) (single-name))))
(values (cons name last-expr) 'table-method)) (values (cons name last-expr) 'table-method))
(values last-expr 'function)))) (values last-expr 'function))))
(define body (function-body src (eq? type 'table-method) name)) (let ((body (function-body src (eq? type 'table-method) name)))
(case type (case type
((table-function table-method) ((table-function table-method)
(make-ast-table-set src (cdr prefix) (make-ast-literal src (symbol->string (car prefix))) body)) (make-ast-table-set
((function) (make-lua-assignment prefix body)) src (cdr prefix)
(else (error 'FUNCTION-STATEMENT "should not happen"))))) (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 ] ;; local-statement -> LOCAL NAME { ',' NAME } [ '=' expression-list ]
(define (local-statement) (define (local-statement)
(define src (get-source-info)) (let ((src (get-source-info)))
;; LOCAL ;; LOCAL
;; (already advanced by calling function) ;; (already advanced by calling function)
(let lp ((names '())) (let lp ((names '()))
;; NAME ;; NAME
(assert-token-type 'NAME) (assert-token-type 'NAME)
(set! names (cons token names)) (let ((names (advance! (cons token names))))
(advance!)
(if (maybe-skip-next! #\,) (if (maybe-skip-next! #\,)
;; { ',' NAME } ;; { ',' NAME }
(lp names) (lp names)
@ -747,123 +733,104 @@
(for-each (lambda (n) (environment-define! n 'local)) names) (for-each (lambda (n) (environment-define! n 'local)) names)
(if (maybe-skip-next! #:=) (if (maybe-skip-next! #:=)
;; [ '=' expression-list ] ;; [ '=' expression-list ]
(let* ((left (map (lambda (x) (resolve-ref src x)) names)) (let ((left (map (lambda (x) (resolve-ref src x))
(right (expression-list))) (reverse! names))))
(parse-assignment src left (reverse! right))) (parse-assignment src left (expression-list)))
;; otherwise, it's not a declaration, not an assignment, and evaluates to nothing ;; otherwise, it's not a declaration, not an
*void-literal*))))) ;; assignment, and evaluates to nothing
*void-literal*)))))))
(define (local-function-statement) (define (local-function-statement)
(assert-token-type 'NAME) (assert-token-type 'NAME)
(let* ((name token)) (let ((name token))
(environment-define! name 'local) (environment-define! name 'local)
(advance!) (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 ;; for-body
(define (for-body) (define (for-body)
(enforce-next! #:do) (enforce-next! #:do)
(let* ((body (chunk))) (let ((body (chunk)))
(enforce-next! #:end) (enforce-next! #:end)
body)) body))
;; numeric-for -> FOR NAME '=' expression ',' expression ',' expression DO chunk END ;; numeric-for -> FOR NAME '=' expression ',' expression ',' expression DO chunk END
(define (numeric-for src name) (define (numeric-for src name)
(define step *default-for-step*)
(advance!)
(enforce-next! #:=) (enforce-next! #:=)
(enter-environment!) (enter-environment!)
(environment-define! name 'local) (environment-define! name 'local)
(let* ((initial (expression))) (let ((initial (expression)))
(enforce-next! #\,) (enforce-next! #\,)
(let* ((limit (expression))) (let* ((limit (expression))
(when (eq? token #\,) (step (if (maybe-skip-next! #\,)
(advance!) (expression)
(set! step (expression))) *default-for-step*))
(let* ((result (make-ast-numeric-for-loop src name initial limit step (for-body)))) (result (make-ast-numeric-for-loop src name initial limit step
(for-body))))
(leave-environment!) (leave-environment!)
result)))) result)))
;; list-for -> FOR NAME { ',' NAME } IN expression-list DO chunk END ;; list-for -> FOR NAME { ',' NAME } IN expression-list DO chunk END
(define (list-for src name) (define (list-for src name)
(let* ((names (let ((names (let lp ((names (list name)))
(let lp ((names (list name))) (if (maybe-skip-next! #\,)
(advance!) (lp (cons (single-name) names))
(if (eq? token #\,)
(begin
(advance!)
(assert-token-type 'NAME)
(lp (cons token names)))
(reverse! names))))) (reverse! names)))))
(enforce-next! #:in) (enforce-next! #:in)
(let* ((exps (expression-list))) (let ((exps (expression-list)))
(enforce-next! #:do) (enforce-next! #:do)
(for-each (for-each
(lambda (name) (lambda (name)
(environment-define! name 'hidden)) (environment-define! name 'hidden))
names) names)
(let* ((body (chunk))) (let ((body (chunk)))
(enforce-next! #:end) (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 ;; for-statement -> FOR (numeric-for | list-for) END
(define (for-statement) (define (for-statement)
(define src (get-source-info)) (let ((src get-source-info))
(enforce-next! #:for) (enforce-next! #:for)
(assert-token-type 'NAME) (let ((name (single-name)))
(let* ((name token) (if (eq? token #:=)
(result
(begin
(lookahead!)
(if (eq? token2 #:=)
(numeric-for src name) (numeric-for src name)
(if (memv token2 '(#:in #\,)) (if (memv token '(#:in #\,))
(list-for src name) (list-for src name)
(syntax-error src "expected = or in after for variable")))))) (syntax-error src "expected = or in after for variable"))))))
result))
;; break-statement -> BREAK ;; break-statement -> BREAK
(define (break-statement) (define (break-statement)
(let ((src (get-source-info)))
(enforce-next! #:break) (enforce-next! #:break)
(make-ast-break (get-source-info))) (make-ast-break src)))
;; statement ;; statement
(define (statement) (define (statement)
(case token (case token
((#\;) (advance!) (statement)) ((#\;) (advance!) (statement))
;; statement -> return ;; statement -> return
((#:return #:break) ((#:return) (values #t (return-statement)))
(values ((#:break) (values #t (break-statement)))
#t ((#:repeat) (values #f (repeat-statement)))
(case token ((#:while) (values #f (while-statement)))
((#:return) (return-statement)) ((#:if) (values #f (if-statement)))
((#:break) (break-statement))))) ((#:function) (values #f (function-statement)))
((#:if #:function #:do #:while #:repeat #:local #:for) ((#:local) (advance!) (if (maybe-skip-next! #:function)
(values (values #f (local-function-statement))
#f (values #f (local-statement))))
(case token ((#:for) (values #f (for-statement)))
((#:repeat) (repeat-statement)) ((#:do) (advance!) (let ((body (chunk)))
((#: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) (enforce-next! #:end)
body)))))) (values #f body)))
;; statement -> function | assignment ;; statement -> function | assignment
(else (values #f (expression-statement))))) (else (values #f (expression-statement)))))
;; chunk -> { statement [ ';' ] } ;; chunk -> { statement [ ';' ] }
(define (chunk) (define (chunk)
(define src (get-source-info)) (let ((src (get-source-info)))
(let loop ((is-last (end-of-chunk? token)) (let loop ((is-last (end-of-chunk? token))
(tree '())) (tree '()))
(if is-last (if is-last
@ -873,10 +840,8 @@
src src
environment environment
(make-ast-sequence src (reverse! tree)))) (make-ast-sequence src (reverse! tree))))
(receive (receive (is-last node) (statement)
(is-last node) (loop (or (end-of-chunk? token) is-last) (cons node tree)))))))
(statement)
(loop (or (end-of-chunk? token) is-last) (cons node tree))))))
(initialize-lua-lexer! port get-source-info lexer) (initialize-lua-lexer! port get-source-info lexer)
@ -888,5 +853,4 @@
chunk) chunk)
(define (read-lua port) (define (read-lua port)
(define parser (make-parser port)) ((make-parser port)))
(parser))