[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-303-g7130
|
From: |
No Itisnt |
|
Subject: |
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-303-g7130a69 |
|
Date: |
Mon, 16 Aug 2010 03:08:28 +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=7130a69bec4126e840ae41567fbf77e4a8ee1aa5
The branch, lua has been updated
via 7130a69bec4126e840ae41567fbf77e4a8ee1aa5 (commit)
via f46abb737c9fa366e6f6f00554784eddff0345e5 (commit)
via 3b2dcb1c92e28ccddc8593a76849b016e7babf82 (commit)
via 531a4dd2f1a10d398b983010712774926e024675 (commit)
from 57965d0bcfeeb9272cf9bd1e9fe4b633ebebdf77 (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 7130a69bec4126e840ae41567fbf77e4a8ee1aa5
Author: No Itisnt <address@hidden>
Date: Sun Aug 15 21:56:27 2010 -0500
lua: Pencil down.
What is missing:
+ Functions: module, getfenv, setfenv, math.modf, table.sort
+ Parser: needs to be more flexible
+ Compiler: needs more extensive work to properly handle all possible
cases of variable arguments, multiple returns, and loops
+ Language: Variable arguments and unpacking of multiple returns. (For
example we need to be able to handle something as complex as
print(unpack({...})), which is easy with Lua's explicit stack but will
require lots of tree-il gymnastics, or perhaps modifications to better
allow different calling conventions. (For instance -- how would we
support Python or Ruby, where keyword arguments are gathered into a
hashtable and passed as a single argument?)
What is there:
A fair shot at supporting Lua 5.1, not quite a drop-in replacement, but
not far from that goal either.
commit f46abb737c9fa366e6f6f00554784eddff0345e5
Author: No Itisnt <address@hidden>
Date: Sun Aug 15 21:56:19 2010 -0500
lua: next, ipairs
commit 3b2dcb1c92e28ccddc8593a76849b016e7babf82
Author: No Itisnt <address@hidden>
Date: Sun Aug 15 21:27:16 2010 -0500
lua: Prototypes are now in for 'for' loops. table.remove, ipairs, select,
and more.
commit 531a4dd2f1a10d398b983010712774926e024675
Author: No Itisnt <address@hidden>
Date: Sun Aug 15 15:00:40 2010 -0500
lua: Fix some inappropriate uses of append!
-----------------------------------------------------------------------
Summary of changes:
module/language/lua/compile-tree-il.scm | 20 +++--
module/language/lua/parser.scm | 46 ++++++-----
module/language/lua/runtime.scm | 127 ++++++++++++++++++++-------
module/language/lua/standard/table.scm | 21 +++++-
test-suite/tests/lua-eval-2.test | 2 +-
test-suite/tests/lua-standard-library.test | 1 +
6 files changed, 152 insertions(+), 65 deletions(-)
diff --git a/module/language/lua/compile-tree-il.scm
b/module/language/lua/compile-tree-il.scm
index 420b2e1..baf37ea 100644
--- a/module/language/lua/compile-tree-il.scm
+++ b/module/language/lua/compile-tree-il.scm
@@ -108,11 +108,13 @@
(tree '()))
(if (null? ls)
(reverse! tree)
- (lp (cdr ls) (append! (list (compile (car ls) (and care-about-last?
(null? (cdr ls))))) tree)))))
+ (lp (cdr ls) (cons (compile (car ls) (and care-about-last? (null?
(cdr ls)))) tree)))))
(record-case exp
((ast-sequence src exps)
- (make-sequence src (map-compile exps)))
+ (if (null? exps)
+ (make-void src)
+ (make-sequence src (map-compile exps))))
((ast-literal src exp)
(if (eq? exp *unspecified*)
@@ -185,15 +187,14 @@
(make-application src (make-module-ref src '(guile) 'throw #t) (list
(make-const src 'lua-break)))
)
- ((ast-list-for-loop src names exps body)
+ ((ast-list-for-loop src names gs-names exps body)
(let* ((gs-iterator (gensym "iterator"))
(gs-state (gensym "state"))
(gs-variable (gensym "variable"))
(gs-iterator2 (gensym "iterator"))
(gs-state2 (gensym "state"))
(gs-variable2 (gensym "variable"))
- (gs-loop (gensym "loop"))
- (gs-names (map gensym (map symbol->string names))))
+ (gs-loop (gensym "loop")))
(parse-tree-il
`(letrec*
;; names
@@ -214,13 +215,14 @@
(begin
(set! (lexical variable ,gs-variable) (lexical
,(car names) ,(car gs-names)))
(if (apply (primitive eq?) (lexical variable
,gs-variable) (const #nil))
- (apply (@ (guile) throw) (const 'lua-break))
+ (apply (@ (guile) throw) (const lua-break))
(void))
- ,(parameterize ((context 'list-for-loop))
(unparse-tree-il (compile body)))))))))))))
+ ,(parameterize ((context 'list-for-loop))
(unparse-tree-il (compile body)))
+ (apply (lexical loop ,gs-loop))))))))))))
;; initialize variables and start loop
(begin
(apply (primitive call-with-values)
- (lambda () (lambda-case (,no-arguments ,(unparse-tree-il
(make-sequence #f (map-compile exps))))))
+ (lambda () (lambda-case (,no-arguments ,(unparse-tree-il
(make-sequence src (map-compile exps))))))
(lambda () (lambda-case (((iterator state variable) #f #f
#f () (,gs-iterator2 ,gs-state2 ,gs-variable2))
(begin
(set! (lexical iterator
,gs-iterator) (lexical iterator ,gs-iterator2))
@@ -230,7 +232,7 @@
(const lua-break)
(lambda () (lambda-case (,no-arguments
(apply (lexical loop ,gs-loop)))))
- (lambda () (lambda-case (,no-arguments (void))))))))))
+ (lambda () (lambda-case (((key) #f #f #f () (,(gensym
"key"))) (void))))))))))
;; TODO: in order for this to have the same semantics as lua, all
;; potential subforms of while should introduce their own context,
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
index 7b96785..15255c2 100644
--- a/module/language/lua/parser.scm
+++ b/module/language/lua/parser.scm
@@ -85,7 +85,7 @@
(table-literal fields)
(while-loop condition body)
(numeric-for-loop named initial limit step body)
- (list-for-loop names exps body)
+ (list-for-loop names gs-names exps body)
(break)
(function name arguments argument-gensyms variable-arguments? body)
(function-call operator operands)
@@ -420,8 +420,8 @@
(loop
(if (not indice) (+ implicit-indice 1) implicit-indice)
- (append!
- (list (cons (or indice (make-ast-literal src
implicit-indice)) expr))
+ (cons
+ (cons (or indice (make-ast-literal src implicit-indice)) expr)
tree)))))))
;; table-literal -> '{' table-fields '}'
@@ -489,7 +489,7 @@
(let loop ((tree (list (expression))))
;; { ',' expression }
(if (maybe-skip-next! #\,)
- (loop (append! (list (expression)) tree))
+ (loop (cons (expression) tree))
;; finished
(reverse! tree))))
@@ -597,7 +597,7 @@
((and (not (null? left)) (not (null? right)))
(loop (cdr left)
(cdr right)
- (append! (list (make-lua-assignment (car left) (car right)))
tree)))
+ (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)))
@@ -608,8 +608,8 @@
(let* ((il (make-lua-assignment (car rest) *nil-literal*))
(rest (cdr rest)))
(if (null? rest)
- (reverse! (append! (list il) tree))
- (loop (append! (list il) tree) (cdr rest))))))
+ (reverse! (cons il tree))
+ (loop (cons il tree) (cdr rest))))))
(else (error 'PARSE-ASSIGNMENT "should not happen"))))))
;; assignment -> '=' expression-list | ',' primary-expression assignment
@@ -622,7 +622,7 @@
(let* ((src (get-source-info))
(left (let loop ((x first)
(tree '()))
- (set! tree (append! (list x) tree))
+ (set! tree (cons x tree))
(if (eq? token #\,)
(advance! (loop (primary-expression) tree))
(reverse! tree))))
@@ -718,7 +718,7 @@
(let lp ((names '()))
;; NAME
(assert-token-type 'NAME)
- (set! names (append! (list token) names))
+ (set! names (cons token names))
(advance!)
(if (maybe-skip-next! #\,)
;; { ',' NAME }
@@ -750,6 +750,7 @@
;; 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)
@@ -765,8 +766,6 @@
;; list-for -> FOR NAME { ',' NAME } IN expression-list DO chunk END
(define (list-for src name)
- (when (eq? token #\,)
- (advance!))
(let* ((names
(let lp ((names (list name)))
(advance!)
@@ -779,9 +778,13 @@
(enforce-next! #:in)
(let* ((exps (expression-list)))
(enforce-next! #:do)
+ (for-each
+ (lambda (name)
+ (environment-define! name 'hidden))
+ names)
(let* ((body (chunk)))
(enforce-next! #:end)
- (make-ast-list-for-loop src 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)
@@ -791,10 +794,10 @@
(let* ((name token)
(result
(begin
- (advance!)
- (if (eq? token #:=)
+ (lookahead!)
+ (if (eq? token2 #:=)
(numeric-for src name)
- (if (or-eqv? token #:in #\,)
+ (if (or-eqv? token2 #:in #\,)
(list-for src name)
(syntax-error src "expected = or in after for
variable"))))))
result))
@@ -844,15 +847,16 @@
(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))))
+ (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) (append! (list node)
tree))))))
+ (loop (or (end-of-chunk? token) is-last) (cons node tree))))))
(initialize-lua-lexer! port get-source-info lexer)
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
index 921ecd0..60e7ed2 100644
--- a/module/language/lua/runtime.scm
+++ b/module/language/lua/runtime.scm
@@ -300,9 +300,11 @@
;;;;; BUILT-INS
(define-syntax define-global
- (syntax-rules (*)
- ((_ (* name . rest) body ...)
- (define-global name (lambda* rest body ...)))
+ (syntax-rules (do-not-export)
+ ((_ (do-not-export name) value)
+ (begin
+ (define name value)
+ (new-index! *global-env-table* (symbol->string 'name) name)))
((_ (name . rest) body ...)
(define-global name (lambda rest body ...)))
((_ name value)
@@ -322,17 +324,18 @@
;; can be incremental but i don't think we can turn that on from guile
;; currently, and even if we could i'm not sure that libgc exposes what
;; lua wants
-(define-global (* collectgarbage opt #:optional (arg #nil))
- (define (ignore) (runtime-warning "collectgarbage cannot respect command ~a"
opt))
- (assert-type 1 "collectgarbage" "string" opt string?)
- (cond ((string=? opt "stop") (ignore))
- ((string=? opt "restart") (ignore))
- ((string=? opt "collect") (gc))
- ((string=? opt "count") (ignore))
- ((string=? opt "step") (ignore))
- ((string=? opt "setpause") (ignore))
- ((string=? opt "setstepmul") (ignore))
- (else (runtime-error "bad argument #1 to 'collectgarbage' (invalid
option ~a)" opt))))
+(define-global collectgarbage
+ (lambda* (opt #:optional (arg #nil))
+ (define (ignore) (runtime-warning "collectgarbage cannot respect command
~a" opt))
+ (assert-type 1 "collectgarbage" "string" opt string?)
+ (cond ((string=? opt "stop") (ignore))
+ ((string=? opt "restart") (ignore))
+ ((string=? opt "collect") (gc))
+ ((string=? opt "count") (ignore))
+ ((string=? opt "step") (ignore))
+ ((string=? opt "setpause") (ignore))
+ ((string=? opt "setstepmul") (ignore))
+ (else (runtime-error "bad argument #1 to 'collectgarbage' (invalid
option ~a)" opt)))))
(define-global (dofile filename)
(assert-string 1 "dofile" filename)
@@ -342,7 +345,10 @@
(compile ((@ (language lua parser) read-lua) file) #:from 'lua #:to
'value)))
#nil)
-;; TODO: error(message, [level])
+(define-global (do-not-export error)
+ (lambda* (message #:optional level)
+ (runtime-warning "level argument to error is not respected")
+ (throw 'lua-error message)))
;; global variable table
(define-global _G *global-env-table*)
@@ -357,9 +363,12 @@
(define-global (ipairs table)
(assert-table 1 "ipairs" table)
(values
- (lambda (t i)
- (set! i (+ i 1))
-
+ (lambda (table indice)
+ (set! indice (+ indice 1))
+ (let* ((value (index table indice)))
+ (if (eq? value #nil)
+ (values #nil #nil)
+ (values indice value)))
)
table
0))
@@ -396,12 +405,40 @@
(compile ((@ (language lua parser) read-lua) file) #:from 'lua
#:to 'value)))
(read-and-compile (current-input-port) #:from 'lua)))))
-;; TODO: loadstring
+(define-global loadstring
+ (lambda* (string #:optional chunkname)
+ (load-warning)
+ (load-chunkname-warning chunkname)
+ (lambda ()
+ (compile ((@ (language lua parser) read-lua) (open-input-string string))
#:from 'lua #:to 'value))))
;; TODO: module
-;; TODO: next(table [, index])
-;; TODO: pairs
-;; TODO: pcall
+
+(define-global next
+ (lambda* (table #:optional (index #nil))
+ (assert-table 1 "next" table)
+ (let* ((keys (hash-table-keys (table-slots table))))
+ ;; empty table = nil
+ (if (null? keys)
+ #nil
+ (begin
+ (if (eq? index #nil)
+ (let* ((next-index (list-ref keys 0)))
+ (values next-index (rawget table next-index)))
+ (let* ((key-ref (+ ((@ (srfi srfi-1) list-index) (lambda (x)
(equal? x index)) keys) 1)))
+ (if (>= key-ref (length keys))
+ (values #nil #nil)
+ (let* ((next-index (list-ref keys key-ref)))
+ (values next-index (rawget table next-index)))))))))))
+
+(define-global pairs
+ (lambda* (table)
+ (values next table #nil)))
+
+(define-global (pcall function . arguments)
+ (catch #t
+ (lambda () (apply function arguments))
+ (lambda args (apply values (cons #f args)))))
(define-global (print . arguments)
(for-each
@@ -423,7 +460,15 @@
(assert-table 1 "rawset" table)
(hash-table-set! (table-slots table) key value))
-;; TODO: select
+(define-global (select index . rest)
+ (define rest-length (length rest))
+ (cond ((number? index)
+ (let lp ((vals '())
+ (i index))
+ (if (> i rest-length)
+ (apply values (reverse! vals))
+ (lp (cons (list-ref rest (- i 1)) vals) (+ i 1)))))
+ (else rest-length)))
(define-global (setmetatable table metatable)
(assert-table 1 "setmetatable" table)
@@ -432,14 +477,15 @@
table)
;; NOTE: built-in 'tonumber' is implemented on string->number and may
-;; not have the same semantics as lua's tonumber
-(define-global (* tonumber e #:optional (base #nil))
- (cond ((number? e) e)
- ((string? e)
- (unless (or-eqv? base 2 8 10 16)
- (runtime-warning "tonumber cannot respect bases other than 2, 8,
10, and 16"))
- (string->number e base))
- (else #nil)))
+;; not have the same semantics as lua's tonumber; it should be based on the
lexer
+(define-global tonumber
+ (lambda* (e #:optional (base 10))
+ (cond ((number? e) e)
+ ((string? e)
+ (unless (or-eqv? base 2 8 10 16)
+ (runtime-warning "tonumber cannot respect bases other than 2, 8,
10, and 16"))
+ (string->number e base))
+ (else #nil))))
(define-global (tostring e)
(cond ((string? e) e)
@@ -458,13 +504,27 @@
(define-global (type v)
(value-type->string v))
-;; TODO: unpack(list [, i [, j]])
+(define-global unpack
+ (lambda* (array #:optional (i 1) j)
+ (assert-table 1 "unpack" array)
+ (unless j (set! j (table-length array)))
+ (apply values (reverse!
+ (let lp ((ls '())
+ (i i))
+ (if (> i j)
+ ls
+ (if (eq? #nil (index array i))
+ ls
+ (lp (cons (index array i) ls) (+ i 1)))))))))
;; _VERSION
;; contains a string describing the lua version
(define-global _VERSION "Guile/Lua 5.1")
-;; TODO: xpcall
+(define-global (xpcall f err)
+ (catch #t
+ (lambda () (values #t (f)))
+ (lambda args (values #f (err args)))))
;;; MODULE SYSTEM
@@ -525,3 +585,4 @@
(if (not (hash-table-exists? (table-slots loaded) module-name))
(runtime-error "require failed"))
(rawget loaded module-name))
+
diff --git a/module/language/lua/standard/table.scm
b/module/language/lua/standard/table.scm
index a3f064c..9786cbd 100644
--- a/module/language/lua/standard/table.scm
+++ b/module/language/lua/standard/table.scm
@@ -61,4 +61,23 @@
(let* ((result (sort! (filter! number? (hash-table-keys (table-slots
table))) >)))
(if (null? result)
0
- (car result))))
\ No newline at end of file
+ (car result))))
+
+(define* (remove table #:optional pos)
+ (assert-table 1 "remove" table)
+ (let* ((e (table-length table)))
+ (unless pos (set! pos (table-length table)))
+ (assert-number 2 "remove" pos)
+ (if (eq? (table-length table) 0)
+ 0
+ (let* ((result (rawget table pos)))
+ (let lp ((pos pos))
+ (if (< pos e)
+ (begin
+ (rawset table pos (rawget table (+ pos 1)))
+ (lp (+ pos 1)))
+ (rawset table pos #nil)))
+ result))))
+
+(define (sort . rest)
+ (runtime-error "table.sort UNIMPLEMENTED"))
\ No newline at end of file
diff --git a/test-suite/tests/lua-eval-2.test b/test-suite/tests/lua-eval-2.test
index ae15377..17072fd 100644
--- a/test-suite/tests/lua-eval-2.test
+++ b/test-suite/tests/lua-eval-2.test
@@ -91,5 +91,5 @@
(test "for x = 1,2,1 do print(true) end return true")
;; list for loop, and ipairs
- (test "table = {1,2,3} for i,v in ipairs(table) do print(i,v) end")
+ (test "table = {1,2,3} for i,v in ipairs(table) do print(i,v) end return
true")
))
diff --git a/test-suite/tests/lua-standard-library.test
b/test-suite/tests/lua-standard-library.test
index 0341b16..95e5bc3 100644
--- a/test-suite/tests/lua-standard-library.test
+++ b/test-suite/tests/lua-standard-library.test
@@ -27,6 +27,7 @@
(with-test-prefix "lua-builtin"
(test "assert(true)")
(test "rawequal(true,true)")
+ (test "return tonumber('2')" 2)
)
(with-test-prefix "lua-math"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-303-g7130a69,
No Itisnt <=