[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-37-gcee15
|
From: |
No Itisnt |
|
Subject: |
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-37-gcee1530 |
|
Date: |
Sun, 13 Jun 2010 20:42:22 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=cee1530a1e4d0c45e4ada7aa1c05bd5eabf0d7b5
The branch, lua has been updated
via cee1530a1e4d0c45e4ada7aa1c05bd5eabf0d7b5 (commit)
from a6b5038020fea90d245dd0476ce3486eaed9b990 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cee1530a1e4d0c45e4ada7aa1c05bd5eabf0d7b5
Author: No Itisnt <address@hidden>
Date: Sun Jun 13 15:40:51 2010 -0500
Add partial implementations of assignments, while loops, and tables to Lua.
-----------------------------------------------------------------------
Summary of changes:
lua.scm | 773 +++++++++++++++++++++++++++++++++++++++++++++++++--------------
1 files changed, 610 insertions(+), 163 deletions(-)
diff --git a/lua.scm b/lua.scm
index 24029cc..dd24c0e 100644
--- a/lua.scm
+++ b/lua.scm
@@ -1,8 +1,33 @@
+;; note: everything is stuffed into one file for now. it will be split up
after reaching stability
+
+;; organization:
+
+;; - common utilities
+
+;; - lexer
+
+;; - parser
+;; -- parser utilities
+;; -- actual grammar, expressed as functions
+
+;; - global-environment
+;;
+;; currently the global environment is expressed as a module. it will
+;; probably remain so because it needs to be somewhat reflective to support
_G,
+;; a lua global variable that is set to a table representing the global
environment
+;;
+;; -- standard builtin functions
+
+;; - runtime
+;; -- misc. runtime functions, operator implementations (which will need to
support metatable events and lua's semantics, and so cannot simply be the
equivalent scheme functions)
+
+;; - tests
+
(define-module (language lua common)
#:use-module (ice-9 format)
- #:export (syntax-error))
+ #:export (syntax-error runtime-error))
(define (syntax-error src string . arguments)
(throw
@@ -14,6 +39,9 @@
(cdr (or (assq 'column src) '(#f . #f))))
arguments))))
+(define (runtime-error src . rest)
+ (apply throw (cons 'lua-runtime rest)))
+
(define-module (language lua lexer)
#:use-module (srfi srfi-14)
#:use-module (srfi srfi-39)
@@ -36,9 +64,9 @@
(define (is-name? c) (or (is-name-first? c) (is-digit? c)))
(define (possible-keyword k)
- "Convert a symbol to a keyword if it is a reserved word in Lua."
+ "Convert a symbol to a keyword if it is a reserved word in Lua"
(case k
- ((return function end if then elseif else true false nil) (symbol->keyword
k))
+ ((return function end if then elseif else true false nil or and do while)
(symbol->keyword k))
(else k)))
(define (make-lexer port)
@@ -77,6 +105,13 @@ of an identifier"
(else (consume (read-char)))))
;; it is a -
#\-))
+
+ ;; ~=
+ ((#\~)
+ (read-char)
+ (if (eq? (peek-char) #\=)
+ (begin (read-char) #:~=)
+ (syntax-error (get-source-info) "expected = after ~ but got ~c"
c)))
;; = and ==
((#\=)
(read-char)
@@ -84,11 +119,12 @@ of an identifier"
(begin (read-char) #:==)
#:=))
;; TODO: ...
-
+ ;; floating point number or table indice
+ ((#\.) (read-char))
;; characters that are allowed directly through
- ((#\; #\( #\, #\)
+ ((#\; #\( #\) #\,
#\+ #\/ #\*
- #\< #\^) (read-char))
+ #\< #\^ #\{ #\} #\[ #\]) (read-char))
;; numbers
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(write-char (read-char))
@@ -96,6 +132,13 @@ of an identifier"
(while (is-digit? (peek-char))
(write-char (read-char)))
(string->number (clear-buffer)))
+ ((#\")
+ (read-char)
+ (while (not (or (eq? (peek-char) #\") (eof-object? (peek-char))))
+ (write-char (read-char)))
+ (clear-buffer))
+
+ ;; strings
(else
(cond ((eof-object? c) c)
;; identifier or keyword
@@ -118,52 +161,76 @@ of an identifier"
(define (print . arguments)
(for-each
(lambda (x)
- (write x)
- (write-char #\tab)
- arguments))
- (newline))
+ (cond ((eq? x #f) (display "false"))
+ ((eq? x #t) (display "true"))
+ ((eq? x #nil) (display "nil"))
+ (else (write x)))
+ (write-char #\tab))
+ arguments)
+ (newline)
+ #nil)
+
+(define* (assert v #:optional (message "assertion failed!") #:rest rest)
+ (if ((@ (language lua runtime) false?) v)
+ (runtime-error message)
+ (apply values (cons v (cons message rest)))))
-;; define-values
-(define-syntax define-values
- (lambda (x)
- (syntax-case x ()
- [(_ (x* ...) e)
- (with-syntax ([(y* ...) (generate-temporaries #'(x* ...))])
- #'(begin
- (define x*) ...
- (call-with-values (lambda () e)
- (lambda (y* ...)
- (set! x* y*) ...))))])))
+(define-module (language lua runtime)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-69)
-(define-syntax define-values
- (syntax-rules ()
- ((_ (var ...) expr)
- (define-values-aux (var ...) (var ...) expr))))
+ #:export (
+ ;; semantics
+ false? true?
+ ;; operators
+ unm eq lt le gt ge add sub mul div pow
+ neq
+ ;; tables
+ make-table
+ table-get
+ table-set!
+ dispatch-metatable-event
+ ))
+;;;;; SEMANTICS
-(define-module (language lua runtime)
+(define (false? x)
+ "Wrapper for Scheme's false semantics that considers #nil to be false"
+ (or (eq? x #f) (eq? x #nil)))
- #:export (unm eq lt le gt ge add sub mul div pow))
+(define (true? x)
+ "Inversion of false?"
+ (not (false? x)))
+
+;;;;; OPERATORS
(define (unm a)
"A function backing the unary - (negation) operator"
(- a))
(define (eq a b)
- "A function backing the == operator")
+ "A function backing the == operator"
+ (equal? a b))
-(define (le a b)
- "A function backing the < and > operators"
+(define (neq a b)
+ "An inversion of eq"
+ (not (eq a b)))
+
+(define (lt a b)
+ "A function backing the < (less-than) operator"
(< a b))
-(define (ge a b)
- "A function translating > to <")
+(define (le a b)
+ "A function backing the <= (less-than-or-equal-to) operator"
+ (or (lt a b) (eq a b)))
-(define (lt a b)
- "A function backing the <= and >= operators")
+(define (ge a b)
+ "A function backing the >= (greater-than-or-equal-to) operator"
+ (not (lt a b)))
(define (gt a b)
- "A function translating >= to <=")
+ "A function backing the > (greater-than) operator"
+ (not (le a b)))
(define (add a b)
"A function backing the + operator"
@@ -185,6 +252,30 @@ of an identifier"
"A function backing the ^ operator"
(expt a b))
+;;;;; TABLES
+
+(define-record-type table
+ (%make-table metatable slots)
+ table?
+ (metatable table/metatable table/metatable!)
+ (slots table/slots table/slots!))
+
+(define (make-table)
+ (%make-table #f (make-hash-table equal?)))
+
+(define (dispatch-metatable-event key default table . arguments)
+ (apply
+ (if (table/metatable table)
+ (hash-table-ref (table/metatable table) key)
+ default)
+ arguments))
+
+(define (table-get table key)
+ (hash-table-ref/default (table/slots table) key #nil))
+
+(define (table-set! table key value)
+ (hash-table-set! (table/slots table) key value))
+
(define-module (language lua parser)
#:use-module (language tree-il)
@@ -195,11 +286,10 @@ of an identifier"
#:use-module (language lua common)
#:use-module (language lua lexer)
- #:export (make-parser read-lua))
+ #:export (make-parser))
-;; This parser is based heavily on Lua's parser. I attempted to hand-write an
-;; operator precedence parser, then tried lalr-scm, but Lua's grammar appears
to
-;; be a little bit plucky for those options.
+;; This parser is based heavily on Lua's parser. Lua's grammar is a little
+;; plucky for lalr-scm or another parser generator option
;; Unlike Lua's parser, it:
;; - does not track syntax nesting levels
@@ -216,6 +306,9 @@ of an identifier"
((#:else #:elseif #:end #:until) #t)
(else (eof-object? k))))
+;; TODO: this is here mainly to ensure that no unwanted values are propagated
+;; through the parser -- it will be removed and replaced with the informal
+;; equivalents later
(define (token/type t)
(cond ((number? t) 'NUMBER)
((eof-object? t) 'EOS)
@@ -223,16 +316,23 @@ of an identifier"
((string? t) 'STRING)
(else
(case t
- ((#\( #\) #\, #\- #\< #:function #:end #:if #:elseif #:then #:else
#:true #:false) t)
+ ((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #:function #:end
#:if #:elseif #:then #:else #:true #:false #:nil #:== #:~= #:=) t)
(else (error #:TOKEN/TYPE t))))))
+;; name of global environment module
+(define *global-env-name* '(language lua global-environment))
+(define *global-env* (resolve-module *global-env-name*))
+
+(define *runtime-name* '(language lua runtime))
+
+(define (ref-runtime src name) (make-module-ref src *runtime-name* name #t))
+
;; infix operator parsing
(define (binary-operator? t)
(case t
- ((#\+ #\* #\/ #\- #\^ #\< #\> >= <= == ~= #:and #:or) #t)
+ ((#\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or) #t)
(else #f)))
-;; TODO: length operator cannot be represented as a keyword
(define (unary-operator? t)
(case t
((#\- #:not) #t)
@@ -245,44 +345,89 @@ of an identifier"
(case o
((#:or) 10)
((#:and) 20)
- ((== ~= <= >= #\< #\>) 30)
+ ((#:== #:~= <= >= #\< #\>) 30)
((#\+ #\-) 60)
((#\* #\/ #\%) 70)
((#\^ #:concat) 99)))
(define (operator->tree-il src operator . arguments)
- (make-application src (make-module-ref #f '(language lua runtime) operator
#t) arguments))
+ (make-runtime-application src operator arguments))
+
+;;;;; TREE-IL UTILITIES
(define (make-unary-operation src operator a)
+ "Convert parsed unary operation to tree-il"
(operator->tree-il src
(case operator
((#\-) 'unm)
(else (error #:MAKE-UNARY-OPERATION "should not happen" a)))
a))
-
-;; convert parsed infix operation to tree-il
+
(define (make-binary-operation src operator a b)
- (operator->tree-il src
- (case operator
- ((#\+) 'add)
- ((#\-) 'sub)
- ((#\*) 'mul)
- ((#\/) 'div)
- ((#\^) 'pow)
- ((#\<) 'le)
- (else (error #:MAKE-BINARY-OPERATION "should not happen" a)))
- a b))
+ "Convert parsed infix operation to tree-il"
+ (case operator
+ ((#\+ #\- #\* #\/ #\^ #\< #:== #:~=)
+ (operator->tree-il
+ src
+ (case operator
+ ((#\+) 'add)
+ ((#\-) 'sub)
+ ((#\*) 'mul)
+ ((#\/) 'div)
+ ((#\^) 'pow)
+ ((#\<) 'lt)
+ ((#:==) 'eq)
+ ((#:~=) 'neq)
+ (else (error #:MAKE-BINARY-OPERATION "should not happen" operator a
b)))
+ a b))
+ ((#:or)
+ (make-lua-conditional
+ src
+ a
+ a
+ b))
+ ((#:and)
+ (make-lua-conditional
+ src
+ a
+ b
+ a))))
+
+(define (make-lua-assignment left right)
+ "Generate an assignment from a variable and an expression"
+ (cond ((module-ref? left)
+ (make-module-set (module-ref-src left) (module-ref-mod left)
(module-ref-name left) (module-ref-public? left) right))
+ ((lexical-ref? left)
+ (make-lexical-ref (lexical-ref-src left) (lexical-ref-name left)
(lexical-ref-gensym left) right))))
+
+(define (make-runtime-application src name arguments)
+ "Apply a function in the (language lua runtime) module"
+ (make-application src (ref-runtime src name) arguments))
+
+(define (make-lua-conditional src condition then else)
+ "Generate a conditional with (@ (language lua runtime) true?)"
+ (make-conditional src (make-runtime-application src 'true? (list condition))
then else))
+
+(define (make-table-ref src table index)
+ (make-runtime-application src 'table-get (list table index)))
(define (make-parser port)
+ ;; functions that will be retrieved from make-lexer
(define get-source-info)
(define lexer)
- ;; parser state
+
+ ;;;;; PARSER STATE
+ (define token2 #f)
+
+ (define (lookahead!)
+ (set! token2 (lexer)))
+
+ ;; current token
(define token)
+ ;; lexical environment
(define environment #f)
-
- ;; auxilliary functions
- ;; environments
+ ;;;;; ENVIRONMENTS
(define (enter-environment!)
(set! environment
(make-environment environment '())))
@@ -293,9 +438,9 @@ of an identifier"
(set! environment
(environment/parent environment)))
- (define (environment-define! name)
+ (define (environment-define! name )
(if (not (member name (environment/names environment)))
- (environment/names! environment (alist-cons name (gensym
(string-append (symbol->string name) " ")) (environment/names environment)))))
+ (environment/names! environment (alist-cons name (gensym
(string-append " " (symbol->string name))) (environment/names environment)))))
(define (environment-lookup name . e)
(set! e (if (null? e) environment (car e )))
@@ -306,71 +451,223 @@ of an identifier"
(environment-lookup name (environment/parent e))))
#f))
- ;; tokens
- (define (advance!) (set! token (lexer)))
+ ;;;;; TREE-IL UTILITIES
+ ;; tree-il utilities that need access to this closure
+ (define (make-lua-function src parameters body-promise)
+ "Generate a function"
+ ;; create a new environment and populate it with the function's parameters
+ (enter-environment!)
+
+ (for-each environment-define! parameters)
+
+ (let* ((body (force body-promise))
+ (parameter-gensyms (map environment-lookup parameters)))
+ (leave-environment!)
+ (make-lambda
+ src '()
+ (make-lambda-case src parameters #f #f #f '() parameter-gensyms (if
(null? body) (make-void src) body) #f))))
+
+ (define (apply-named-lua-function src get-body)
+ (let* ((name (gensym " named"))
+ (parameters (list name)))
+ (make-let
+ src
+ parameters parameters
+ (list (make-lambda src '() (get-body name)))
+ (make-application src (make-lexical-ref src name name) '()))))
+
+ ;;;;; LEXER INTERACTION
+
+ (define (advance!)
+ "Read a new token and store it in TOKEN"
+ (if token2
+ (begin
+ (set! token token2)
+ (set! token2 #f))
+ (set! token (lexer))))
(define* (assert-token-type type #:optional (token token))
+ "Throw an error if the current token does not have the expected type"
(if (not (equal? (token/type token) type))
(syntax-error (get-source-info) "expected ~a" type)))
- (define (test-next! c)
+ (define (maybe-skip-next! c)
+ "Skip a token"
(if (equal? token c)
(begin (advance!) #t)
#f))
(define (enforce-next! expect)
- (if (not (test-next! expect))
+ "Throw an error if the current token is not the expected token"
+ (if (not (maybe-skip-next! expect))
(syntax-error (get-source-info) "expected ~a but got ~a" expect
token)))
- ;; grammar
+ ;;;;; GRAMMAR
- (define (single-name)
- ;; single-name -> NAME
+ ;; single-name -> NAME
+ (define (single-name . return-src?)
(define save token)
(define src (get-source-info))
(assert-token-type 'NAME)
(advance!)
- (values src save))
+ (if (not (null? return-src?))
+ (values src save)
+ save))
;; single-variable -> single-name
(define (single-variable)
(receive (src save)
- (single-name)
+ (single-name #:return-src #t)
(let* ((binding (environment-lookup save)))
(if binding
(make-lexical-ref src save binding)
- (make-module-ref src '(language lua global-environment)
save #f)))))
+ ;; TODO: Consider _G
+ (begin
+ (if (not (module-defined? *global-env* save))
+ (module-define! *global-env* save #nil))
+ (make-module-ref src *global-env-name* save #f))))))
;; application-arguments -> '(' [ expression-list ] ')'
(define (application-arguments)
(case token
+ ;; '('
((#\()
(advance!)
(if (eq? token #\))
+ ;; ')'
(begin (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 ((eq? (token/type token) 'NAME) (single-variable))
- (else (syntax-error (get-source-info) "unexpected symbol ~a"
token))))
-
- ;; primary-expression -> prefix-expression { '.' NAME | '[' expression ']' |
':' application-arguments | application-arguments }
+ (cond
+ ;; NAME
+ ((eq? (token/type token) 'NAME) (single-variable))
+ ;; '('
+ ((eq? token #\()
+ (begin
+ (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)))
+ (enforce-next! #\])
+ indice))
+
+ ;; 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* ((result
(case (token/type token)
+ ;; field-selector
+ ((#\.)
+ (enforce-next! #\.)
+ (make-table-ref src prefix (make-const src (symbol->string
(single-name))))
+ )
+ ;; index
+ ((#\[)
+ (let* ((indice (index)))
+ (make-table-ref src prefix indice)))
+ ;; application-arguments
((#\()
(make-application src prefix (application-arguments)))
(else prefix))))
+ ;; finished
result))
+ ;; expression-statement -> function | assignment
(define (expression-statement)
- (primary-expression))
+ (define primary (primary-expression))
+ (if (application? primary)
+ primary
+ (assignment primary)))
+
+
+ ;; record-field -> (NAME | index) '=' expression
+ (define (record-field)
+ (let* ((indice
+ (cond
+ ;; NAME
+ ((eq? (token/type token) 'NAME)
+ (let ((tmp (make-const #f (symbol->string token))))
+ (advance!)
+ tmp))
+ ;; index
+ (else (index))))
+ (value
+ (begin
+ ;; '='
+ (enforce-next! #:=)
+ ;; expression
+ (expression))))
+ (values indice value)))
+
+ ;; field -> expression | record-field
+ (define (field)
+ (case (token/type token)
+ ((NAME)
+ (lookahead!)
+ (if (eq? token2 #:=)
+ (record-field)
+ (values #f (expression))))
+ ((#\[) (record-field))
+ (else (values #f (expression)))))
+
+ ;; field-separator -> ',' | ';'
+ ;; table-fields -> [ field { field-separator field } [ field-separator ] ]
+ (define (table-fields src table-var-name)
+ (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)
+ (append!
+ (list (make-runtime-application src 'table-set!
+ (list (make-lexical-ref src table-var-name
table-var-name) (or indice (make-const src implicit-indice)) 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* ((temp-name (gensym " table"))
+ (names (list temp-name))
+ (result
+ (make-let
+ src
+ names names
+ (list (make-runtime-application src 'make-table '()))
+ ;; table-fields
+ (make-sequence src (reverse! (append! (list (make-lexical-ref src
temp-name temp-name)) (table-fields src temp-name)))))))
+ (enforce-next! #\})
+ result))
;; parameter-list -> [ parameter { ',' parameter } ]
(define (parameter-list function-name)
@@ -389,44 +686,50 @@ of an identifier"
;; function-body -> '(' parameter-list ')' chunk END
(define* (function-body #:optional (src (get-source-info)))
+ ;; '('
(enforce-next! #\()
+ ;; parameter-list
(let* ((parameters (parameter-list "anonymous function")))
+ ;; ')'
(enforce-next! #\))
-
- ;; create a new environment and populate it with function arguments
- (enter-environment!)
- (if (not (null? parameters))
- (let loop ((parameter (car parameters))
- (rest (cdr parameters)))
- (environment-define! parameter)
- (if (not (null? rest))
- (loop (car rest) (cdr rest)))))
-
- (let* ((body (chunk))
- (parameter-gensyms (map (lambda (s) (environment-lookup s))
parameters)))
-
+ (let* ((result
+ (make-lua-function
+ src
+ parameters
+ (delay (chunk)))))
(enforce-next! #:end)
- (leave-environment!)
- (make-lambda src '()
- (make-lambda-case src parameters #f #f #f '()
- parameter-gensyms
- (if (null? body) (make-void #f) body) #f)))))
+ result)))
+ ;; expression-list -> expression { ',' expression }
(define (expression-list)
(let loop ((tree (list (expression))))
- (if (test-next! #\,)
- (loop (append tree (list (expression))))
- tree)))
+ ;; { ',' expression }
+ (if (maybe-skip-next! #\,)
+ (loop (append! (list (expression)) tree))
+ ;; finished
+ (reverse! tree))))
- ;; simple-expression -> NUMBER | FUNCTION function-body
+ ;; simple-expression -> (nil | true | false | NUMBER | STRING) |
table-literal | FUNCTION function-body | primary-expression
(define (simple-expression)
+ (define src src)
(receive
(advance? result)
(case (token/type token)
- ((NUMBER) (values #t (make-const (get-source-info) token)))
- ((#:true) (values #t (make-const (get-source-info) #t)))
- ((#:false) (values #t (make-const (get-source-info) #f)))
- ((#:function) (advance!) (values #f (function-body (get-source-info))))
+ ;; (nil | true | false | NUMBER | STRING)
+ ((#:true #:false #:nil NUMBER STRING)
+ (values
+ #t
+ (make-const
+ src
+ (cond ((eq? token #:true) #t)
+ ((eq? token #:false) #f)
+ ((eq? token #:nil) #nil)
+ (else token)))))
+ ;; table-literal
+ ((#\{) (values #f (table-literal)))
+ ;; FUNCTION function-body
+ ((#:function) (advance!) (values #f (function-body src)))
+ ;; primary-expression
(else (values #f (primary-expression))))
(if advance?
(advance!))
@@ -435,18 +738,21 @@ of an identifier"
;; subexpression -> (simple-expression | unary-operator subexpression) {
binary-operator subexpression }
(define (subexpression limit)
(define left)
- ;; test for preceding unary operator
+ ;; 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-unary-operation src operator (subexpression
*unary-priority*)))
- ;; note that simple-expression may also call advance!
+ ;; simple-expression
+ ;; note: simple-expression may advance the current token
(simple-expression)))
(let loop ((left left))
- ;; if this is a binary operation, read the second argument
+ ;; { binary-operator subexpression }
(if (and (binary-operator? token) (> (priority token) limit))
(let* ((src (get-source-info))
(operator token))
@@ -454,37 +760,122 @@ of an identifier"
;; read next expression with higher priorities
(let* ((right (subexpression (priority operator))))
(loop (make-binary-operation src operator left right))))
- ;; otherwise, return the first expression
+ ;; finished
left)))
(define (expression)
(subexpression 0))
+
+ ;; while-statement -> WHILE expression DO chunk END
+ (define (while-statement)
+ (define src (get-source-info))
+ ;; WHILE
+ (enforce-next! #:while)
+ ;; expression
+ (let* ((condition (expression)))
+ ;; DO
+ (enforce-next! #:do)
+ ;; chunk
+ (let* ((body (chunk)))
+ ;; END
+ (define result (apply-named-lua-function
+ src
+ (lambda (loop)
+ (make-lua-conditional
+ src
+ condition
+ (make-sequence
+ src
+ (list body (make-application src (make-lexical-ref src loop loop)
'())))
+ (make-void src)))))
+ (enforce-next! #:end)
+ result)))
+ ;; return-statement -> RETURN expression-list
(define (return-statement)
(define src (get-source-info))
- ;; skip 'return'
- (advance!)
+
+ ;; RETURN
+ (enforce-next! #:return)
(make-application src (make-primitive-ref src 'return)
- ;; if followed by END or ';', the return has no
arguments, otherwise
- (if (or (end-of-block? token) (eq? token #\;)) (list
(make-void src)) (expression-list))))
+ ;; if followed by END or ';', the return has no
arguments, otherwise
+ (if (or (end-of-block? token) (eq? token #\;))
+ (list (make-void src))
+ ;; expression-list
+ (expression-list))))
- ;; then-chunk -> THEN chunk
+ ;; then-chunk -> (IF | ELSEIF) expression THEN chunk
(define (then-chunk)
- ;; skip IF or ELSEIF
+ ;; IF | ELSEIF
(advance!)
+ ;; expression
(let* ((condition (expression)))
+ ;; THEN
(enforce-next! #:then)
+ ;; chunk
(let* ((body (chunk)))
(values condition body))))
- ;; if-statement -> IF condition then-chunk { ELSEIF condition then-chunk }
[ELSE chunk] END
+ ;; assignment -> '=' expression-list | ',' primary-expression assignment
+ (define (assignment first)
+ ;; assignments are unfortunately complicated because multiple variables may
+ ;; be assigned to multiple expressions in a single assignment, and the
+ ;; number of variables and expressions need not match
+
+ ;; so this function accumulates the entire assignment
+ (let* ((src (get-source-info))
+ (left (let loop ((x first)
+ (tree '()))
+ (set! tree (append! (list x) tree))
+ (if (eq? token #\,)
+ (begin (advance!) (loop (primary-expression) tree))
+ (reverse! tree))))
+
+ (right (begin
+ (enforce-next! #:=)
+ (expression-list))))
+
+ ;; and then parses it, branching to handle overflows on either side if
necessary
+ (make-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)
+ (append! (list (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) (make-const #f #nil)))
+ (rest (cdr rest)))
+ (if (null? rest)
+ (reverse! (append! (list il) tree))
+ (loop (append! (list il) tree) (cdr rest))))))
+ (else (error #:ASSIGNMENT "should not happen")))))
+
+ ) ; let*
+ ) ; assignment
+
+
+ ;; 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-conditional
+ (make-lua-conditional
if-src
test
then
@@ -493,7 +884,7 @@ of an identifier"
(if (eq? token #:elseif)
(receive (test then)
(then-chunk)
- (make-conditional src test then (loop)))
+ (make-lua-conditional src test then (loop)))
(if (eq? token #:else)
(begin (advance!) (chunk))
(make-void #f)))))))
@@ -506,30 +897,39 @@ of an identifier"
;; skip FUNCTION
(advance!)
;; TODO: table functions e.g. function table:name()
- (receive (_ name)
- (single-name)
- (begin
- (module-define! (resolve-module '(language lua
global-environment)) name *unspecified*)
- (make-module-set src '(language lua global-environment) name #f
(function-body)))))
+ (let* ((name (single-name)))
+ (module-define! (resolve-module '(language lua global-environment)) name
*unspecified*)
+ (make-module-set src '(language lua global-environment) name #f
(function-body))))
;; statement
(define (statement)
(case token
+ ((#\;) (advance!) (statement))
;; statement -> return
((#:return) (values #t (return-statement)))
- ((#:if) (values #f (if-statement)))
- ((#:function) (values #f (function-statement)))
-
+ ((#:if #:function #:do #:while)
+ (values
+ #f
+ (case token
+ ((#:while) (while-statement))
+ ((#:if) (if-statement))
+ ((#:function) (function-statement))
+ ((#:do)
+ (begin
+ (advance!)
+ (let* ((body (chunk)))
+ (enforce-next! #:end)
+ body))))))
;; statement -> function | assignment
(else (values #f (expression-statement)))))
-
+
;; chunk -> { statement [ ';' ] }
(define (chunk)
(define src (get-source-info))
(let loop ((is-last (end-of-block? token))
(tree '()))
(if is-last
- (make-sequence src (reverse! tree))
+ (begin (maybe-skip-next! #\;) (make-sequence src (reverse! tree)))
(receive
(is-last node)
(statement)
@@ -537,9 +937,8 @@ of an identifier"
(receive (get-source-info% lexer%)
(make-lexer port)
- (begin
- (set! get-source-info get-source-info%)
- (set! lexer lexer%)))
+ (set! get-source-info get-source-info%)
+ (set! lexer lexer%))
;; toplevel local environment
(enter-environment!)
;; read first token
@@ -547,14 +946,6 @@ of an identifier"
;; return parser
chunk)
-(define (read-lua port)
- (define parse (make-parser port))
- (let loop ((tree '())
- (expr (parse)))
- (if (or (null? expr)(eof-object? expr))
- (reverse! tree)
- (loop (append! (list expr) tree) (parse)))))
-
(define-module (language lua spec)
#:use-module (system base language)
@@ -563,7 +954,7 @@ of an identifier"
(define-language lua
#:title "Lua"
- #:reader (lambda (port _) (read-lua port))
+ #:reader (lambda (port _) #f)
#:compilers `((tree-il . ,(lambda (x e o) (values x e e))))
#:printer write)
@@ -605,7 +996,10 @@ of an identifier"
))
-(define (tree-il? x) (or (application? x) (module-ref? x) (primitive-ref? x)
(lexical-ref? x) (sequence? x) (void? x) (const? x) (lambda? x)))
+(define (tree-il? x) (or (application? x) (module-ref? x) (primitive-ref? x)
+(lexical-ref? x) (sequence? x) (void? x) (const? x) (lambda? x) (module-set? x)
+(toplevel-ref? x) (toplevel-set? x) (toplevel-define? x) (conditional? x)
+(lambda-case? x) (letrec? x) (let? x) (lexical-set? x)))
(define (strip-tree-il! x)
(cond ((list? x) (map! strip-tree-il! x))
@@ -613,7 +1007,6 @@ of an identifier"
(else x)))
(with-test-prefix "lua-parser"
- (define (from-string string) (strip-tree-il! ((make-parser
(open-input-string string)))))
(let-syntax
;; Note on parser tests:
;; Lua does not allow standalone expressions, only statements.
@@ -625,21 +1018,10 @@ of an identifier"
(let* ((real-string (string-append "return " string))
(real-expect `(begin (apply (primitive return) ,@`expect)))
(result (from-string real-string)))
- (pass-if (format "~S => ~A" real-string real-expect) (equal? result
real-expect))))))
- (test
- (syntax-rules ()
- ((_ string . expect)
- (pass-if (format "~S => ~A" string 'expect) (equal? (from-string
string) 'expect)))))
- (print-test
- (syntax-rules ()
- ((_ string . expect)
- (let* ((real-string string)
- (real-expect `(begin (apply (primitive return) ,@`expect)))
- (result (from-string real-string)))
- (format #t "~a\n" result)
(pass-if (format "~S => ~A" real-string real-expect) (equal? result
real-expect)))))))
;; shortcuts
+ (define (from-string string) (strip-tree-il! ((make-parser
(open-input-string string)))))
(define (op x) `(@ (language lua runtime) ,x))
(define (global x) `(@@ (language lua global-environment) ,x))
@@ -660,7 +1042,6 @@ of an identifier"
(test-return "print(1,2)" (apply ,(global 'print) (const 1) (const 2)))
(test-return "print(1+2,3*4)" (apply ,(global 'print) (apply ,(op 'add)
(const 1) (const 2)) (apply ,(op 'mul) (const 3) (const 4))))
- #;(print-test "function identity(x) return x end end")
))
(with-test-prefix "lua-eval"
@@ -668,11 +1049,22 @@ of an identifier"
(compile ((make-parser (open-input-string string)))
#:from 'lua
#:to 'value))
- (let-syntax
+ (letrec-syntax
((test
(syntax-rules ()
((_ string expect)
- (pass-if (format "~S => ~A" string expect) (equal? (from-string
string) expect))))))
+ (pass-if (format "~S => ~A" string expect) (equal? (from-string
string) expect)))
+ ((_ string)
+ (test string #t)))))
+
+ (test "return true")
+ (test "return false" #f)
+ (test "return nil" #nil)
+ (test "return 12345" 12345)
+ #;(test "return 12345.6789" 12345.6789)
+ (test "return \"string\"" "string")
+ (test "return (true)")
+ (test "return (false == false)")
;; exercise the operator precedence parser
(test "return 2" 2)
@@ -685,17 +1077,72 @@ of an identifier"
(test "return 1 + -6" -5)
;; conditionals
- (test "if true then return true end" #t)
- (test "if false then return false else return true end" #t)
- (test "if true then return true else return false end" #t)
- (test "if false then return false elseif true then return true elseif
false then return false else return false end" #t)
- (test "if false then return false elseif false then return false elseif
true then return true else return false end" #t)
- (test "if false then return false elseif false then return false elseif
false then return false else return true end" #t)
+ (test "if true then return true end")
+ (test "if false then return false else return true end")
+ (test "if true then return true else return false end")
+ (test "if false then return false elseif true then return true elseif
false then return false else return false end")
+ (test "if false then return false elseif false then return false elseif
true then return true else return false end")
+ (test "if false then return false elseif false then return false elseif
false then return false else return true end")
;; functions
(test "function identity(x) return x end return identity(21)" 21)
(test "function fib(n) if n < 2 then return n else return fib(n-1) +
fib(n-2) end end return fib(20)" 6765)
- ;; 20th fibonacci number
+ (test "\n-- fibonacci numbers\nfunction fib(n)\n if n < 2 then\n
return n\n else\n return fib(n-1) + fib(n-2)\n end\nend\nreturn fib(20)"
6765)
+ (test "assert(true)")
+ (test "print(T)" #nil)
+ (test "return false or true")
+ (test "return true or false")
+ (test "return false or false or true")
+ (test "return false or nil and true" #nil)
+ (test "return true and true")
+ (test "return true and nil" #nil)
+ (test "return true and false and nil" #f)
+ (test "print(false or true)" #nil)
+
+ ;; do
+ (test "do return true end")
+ (test "do if false then return false elseif false then return false elseif
false then return false else return true end end")
+
+ ;; undefined variables are implicitly defined to nil
+ (test "return undefined == nil")
+ (test "return undefined ~= nil" #f)
+
+ ;; assignments
+ (test "variable = true; return variable")
+ (test "a,b = 1,2; return a" 1)
+ (test "a,b=1,2;return b" 2)
+ (test "a,b=1;return b" #nil)
+
+ ;; parenthetical expressions
+ (test "return (true);")
+ (test "return (2 + (2))" 4)
+
+ ;; while
+ (test "while true do return true end")
+ (test "i=0; while i<5 do i=i+1 end return i" 5)
+
+ ;; tables
+ (test "a={}; return a[0]" #nil)
+ (test "a={true}; return a[1]" #t)
+ (test "a = { false , true } ; return a[2];" #t)
+ (test "a = { false ; true ; } ; return a[2];" #t)
+ (test "a = { b = true }; return a.b" #t)
+ (test "a = { a = false , false ; b = true , true ; }; return a.b" #t)
+ (test "a = { a = false , false ; b = true , true ; }; return a[2]" #t)
+
+ ;; method invocations
+ ;; for loops
+ ;; repeat loops
+ ;; local syntax
+ ;; metatables
+ ;; metatable events
+ ;; variable arguments
+ ;; multiple returns
))
-
+#;(begin
+ (define var
+ "a = { b = true }")
+ (display (compile ((make-parser (open-input-string var)))
+ #:from 'lua #:to 'tree-il))
+ (newline))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-37-gcee1530,
No Itisnt <=