[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-252-g21a2
|
From: |
No Itisnt |
|
Subject: |
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-252-g21a2bac |
|
Date: |
Mon, 09 Aug 2010 03:00:51 +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=21a2bac977305f14557214454676ab06c97c8968
The branch, lua has been updated
via 21a2bac977305f14557214454676ab06c97c8968 (commit)
via bbd706e177fa00c04de86c58f3422c7ea3a901c2 (commit)
via c91d3f33740eff4417c76fa542bf375715a97785 (commit)
via c5212c2cd7a9bb1b680b031f2d9ce7de9c5f648f (commit)
via d747106c48491183d31107f1e53baa1474cbf28d (commit)
from a4292669aa26760ed267bca222b7f749be418f46 (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 21a2bac977305f14557214454676ab06c97c8968
Author: No Itisnt <address@hidden>
Date: Sun Aug 8 21:50:48 2010 -0500
lua: Finish io, os modules. Start on variable argument handling.
commit bbd706e177fa00c04de86c58f3422c7ea3a901c2
Author: No Itisnt <address@hidden>
Date: Fri Aug 6 21:27:11 2010 -0500
lua: Functions can now be called with standalone table literals.
commit c91d3f33740eff4417c76fa542bf375715a97785
Author: No Itisnt <address@hidden>
Date: Fri Aug 6 16:15:12 2010 -0500
lua:
+ Change '/' to '-' in all record accessors.
+ All Lua arguments are now optional and default to nil (this is the
standard
behavior of Lua).
+ table.insert has been fixed.
+ Function names are inserted in tree-il when possible.
commit c5212c2cd7a9bb1b680b031f2d9ce7de9c5f648f
Author: No Itisnt <address@hidden>
Date: Fri Aug 6 00:52:23 2010 -0500
lua: Add table.maxn test; fix table methods.
commit d747106c48491183d31107f1e53baa1474cbf28d
Author: No Itisnt <address@hidden>
Date: Thu Aug 5 17:29:59 2010 -0500
lua: Work on concatenation, length operators
-----------------------------------------------------------------------
Summary of changes:
module/language/lua/common.scm | 23 ++-
module/language/lua/compile-tree-il.scm | 60 ++++--
module/language/lua/lexer.scm | 12 +-
module/language/lua/parser.scm | 133 +++++++------
module/language/lua/runtime.scm | 285 ++++++++++++++++++++--------
module/language/lua/standard/io.scm | 160 +++++++++++++++-
module/language/lua/standard/math.scm | 80 ++++++---
module/language/lua/standard/os.scm | 72 ++++++-
module/language/lua/standard/table.scm | 46 ++++--
test-suite/tests/lua-eval-2.test | 89 +++++++++
test-suite/tests/lua-eval.test | 69 +-------
test-suite/tests/lua-lexer.test | 1 -
test-suite/tests/lua-scratch.test | 118 +-----------
test-suite/tests/lua-standard-library.test | 9 +
14 files changed, 754 insertions(+), 403 deletions(-)
create mode 100644 test-suite/tests/lua-eval-2.test
diff --git a/module/language/lua/common.scm b/module/language/lua/common.scm
index 5b83a7e..045a945 100644
--- a/module/language/lua/common.scm
+++ b/module/language/lua/common.scm
@@ -8,17 +8,18 @@
(define (syntax-error src string . arguments)
"Throw an error tagged with 'lua-syntax, and print detailed source
code information when available. STRING and ARGUMENTS are given to FORMAT."
- (string-append
- (if src
- (format "address@hidden"
- (cdr (assq 'filename src))
- (cdr (assq 'line src))
- (if (assq 'column src)
- (cdr (assq 'column src))
- "[no column available]"))
- "[no source code information given]")
- ": "
- (apply format (cons string arguments))))
+ (throw 'lua-syntax
+ (string-append
+ (if src
+ (format "address@hidden"
+ (cdr (assq 'filename src))
+ (cdr (assq 'line src))
+ (if (assq 'column src)
+ (cdr (assq 'column src))
+ "[no column available]"))
+ "[no source code information given]")
+ ": "
+ (apply format (cons string arguments)))))
;; I was using CASE, but this is more succinct
;; (or-eqv? 1 #f 1) => (or (eqv? 1 #f) (eqv? 1 1))
diff --git a/module/language/lua/compile-tree-il.scm
b/module/language/lua/compile-tree-il.scm
index e686740..e92b585 100644
--- a/module/language/lua/compile-tree-il.scm
+++ b/module/language/lua/compile-tree-il.scm
@@ -65,20 +65,22 @@
(define (adjust-to-single-value src exp)
"adjust an expression so that it only returns one result; the rest are
dropped silently"
+ (define value-gensym (gensym "%value"))
+ (define adjust-gensym (gensym "%adjust"))
(make-letrec src
#t
'(%adjust)
- '(%adjust)
+ (list adjust-gensym)
(list
(make-plain-lambda
src
'(%value)
- #f
- (make-lexical-ref src '%value '%value)))
+ (list value-gensym)
+ (make-lexical-ref src '%value value-gensym)))
(make-application
src
(make-primitive-ref src 'call-with-values)
- (list (make-argless-lambda src exp) (make-lexical-ref src '%adjust
'%adjust)))))
+ (list (make-argless-lambda src exp) (make-lexical-ref src '%adjust
adjust-gensym)))))
;; main compiler
@@ -91,7 +93,7 @@
(lp (cdr ls) (append! (list (compile ctx (car ls) (and
care-about-last? (null? (cdr ls))))) tree)))))
(record-case exp
- ((ast-body src exps)
+ ((ast-sequence src exps)
(make-sequence src (map-compile #f exps)))
((ast-literal src exp)
@@ -104,16 +106,34 @@
(list (make-application src
(make-primitive-ref src 'values)
(if (list? exp) (map-compile #f exp #t) (list (compile #f
exp)))))))
-
- ((ast-function src arguments argument-gensyms variable-arguments? body)
- ;; %rest is always attached because lua functions must ignore variable
arguments
- (make-lambda src '() (make-lambda-case src arguments #f '%rest #f '()
(append! argument-gensyms (list '%rest)) (compile #f body) #f)))
-
- ((ast-function-call src operator operands)
- (let* ((app (make-application src (compile #f operator) (map-compile #f
operands #t))))
+ ((ast-function src name arguments argument-gensyms variable-arguments?
body)
+ ;; ... is always attached because lua functions must ignore
+ ;; variable arguments; the parser will catch when ... is improperly
+ ;; used
+ (make-lambda src (if name `((name . ,name)) '()) (make-lambda-case src
'() arguments '... #f (map (lambda (x) (make-const src #nil)) arguments)
(append! argument-gensyms (list '...)) (compile #f body) #f)))
+
+#| ((ast-function-call src operator operands)
+ (let* ((proc (compile #f operator))
+ (args (make-application src (make-primitive-ref src 'list)
(map-compile #f operands)))
+ (app-args (make-application src (make-primitive-ref src 'cons)
(list proc args)))
+ (app (make-application src (make-primitive-ref src 'apply) (list
app-args))))
+; (if last-in-list? app (adjust-to-single-value src app))))
+ app))
+#| (let* ((proc (compile #f operator))
+ (args (map-compile #f operands))
+ (app (make-application src (make-primitive-ref src 'apply)
(make-application (make-primitive-ref proc args))))
(if last-in-list?
- app
- (adjust-to-single-value src app))))
+ app
+ (adjust-to-single-value src app)))
+ )
+|#
+ |#
+ ((ast-function-call src operator operands)
+ (let* ((proc (compile #f operator))
+ (args (make-application src (make-primitive-ref src 'list)
(map-compile #f operands)))
+ (app-args (make-application src (make-primitive-ref src 'list)
(list proc args)))
+ (app (make-application src (make-primitive-ref src 'apply) (list
(make-primitive-ref src 'apply) app-args))))
+ app))
((ast-local-block src names gensyms initial-values exp)
(make-let src names gensyms (map-compile #f initial-values) (compile #f
exp)))
@@ -130,11 +150,11 @@
((ast-global-set src name exp)
(make-table-set! src (ref-runtime src '*global-env-table*) name (compile
#f exp)))
- ((ast-table-ref src table name)
- (make-table-ref src (compile #f table) (compile #f name)))
+ ((ast-table-ref src table key)
+ (make-table-ref src (compile #f table) (compile #f key)))
- ((ast-table-set src table name exp)
- (make-runtime-application src 'new-index! (list (compile #f table)
(compile #f name) (compile #f exp))))
+ ((ast-table-set src table key exp)
+ (make-table-set! src (compile #f table) (compile #f key) (compile #f
exp)))
((ast-condition src test then else)
(make-conditional src (compile #f test) (compile #f then) (compile #f
else)))
@@ -183,7 +203,7 @@
(let ((left (compile #f left))
(right (compile #f right)))
(case operator
- ((#\+ #\- #\* #\/ #\^ #\< #\> #:<= #:>= #:== #:~=)
+ ((#\+ #\- #\* #\/ #\^ #\< #\> #:<= #:>= #:== #:~= #:concat)
(let* ((result
(make-runtime-application
src
@@ -199,6 +219,7 @@
((#:>=) 'le)
((#:==) 'eq)
((#:~=) 'neq)
+ ((#:concat) 'concat)
(else (error #:COMPILE "unhandled binary operator"
operator)))
;; reverse order of arguments for >, >= so they can be
implemented on top of <, <=
(if (or (eq? operator #\>) (eq? operator #:>=))
@@ -221,6 +242,5 @@
))
;; exported compiler function
-
(define (compile-tree-il exp env opts)
(values (compile #f exp) env env))
diff --git a/module/language/lua/lexer.scm b/module/language/lua/lexer.scm
index 4109d31..75fb7e0 100644
--- a/module/language/lua/lexer.scm
+++ b/module/language/lua/lexer.scm
@@ -1,10 +1,10 @@
;; lexer.scm --- lua tokenizer
-;; This is a simple lexer with two tokens of lookahead. It generally
-;; matches up Lua data types with Scheme. Reserved words in Lua, like
-;; 'not', are returned as keywords, like '#:not'. Operators are returned
-;; as keywords like #:==, or characters like #\+ when they're only a
-;; character long. Identifiers are returned as symbols
+;; This is a simple lexer. It generally matches up Lua data types with
+;; Scheme. Reserved words in Lua, like 'not', are returned as keywords,
+;; like '#:not'. Operators are returned as keywords like #:==, or
+;; characters like #\+ when they're only a character long. Identifiers
+;; are returned as symbols
(define-module (language lua lexer)
#:use-module (srfi srfi-8)
@@ -16,6 +16,8 @@
#:export (make-lexer)
#:export-syntax (define-lua-lexer initialize-lua-lexer!))
+(define stdout (current-output-port))
+
(define (source-info port)
`((backtrace . #f)
(filename . ,(port-filename port))
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
index 13ecfa7..53cf270 100644
--- a/module/language/lua/parser.scm
+++ b/module/language/lua/parser.scm
@@ -1,10 +1,5 @@
;; parser.scm --- lua parser
-;; rewrite
-;; - use WHEN, UNLESS where appropriate
-;; - try to put less in MAKE-PARSER, maybe even make a state record
-;; - move lexer stuff to lexer (token buffer, advance!, token assertions etc)
& export
-
;; This parser is based heavily on Lua's parser. It does not use
;; lalr-scm, because Lua's grammar is a little too plucky. Unlike Lua's
;; parser, it returns an abstract syntax tree instead of incrementally
@@ -15,7 +10,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-8)
#:use-module (srfi srfi-9)
- #:use-module ((rnrs control) #:version (6))
+ #:use-module (rnrs control)
#:use-module (language lua common)
#:use-module (language lua lexer)
@@ -76,7 +71,7 @@
(define-ast
(unary-not exp)
(literal exp)
- (body exps)
+ (sequence exps)
(return exp)
(condition test then else)
(local-block names gensyms initial-values exp)
@@ -85,13 +80,14 @@
(local-set name gensym exp)
(global-ref name)
(global-set name exp)
- (table-ref table name)
- (table-set table name exp)
+ (table-ref table key)
+ (table-set table key exp)
(table-literal fields)
(while-loop condition body)
- (function arguments argument-gensyms variable-arguments? body)
+ (function name arguments argument-gensyms variable-arguments? body)
(function-call operator operands)
- (binary-operation operator left right))
+ (binary-operation operator left right)
+ (variable-arguments))
) ; letrec-syntax
@@ -118,7 +114,7 @@
;; infix operator parsing
(define (binary-operator? t)
"Return #t if the token may be a binary operator"
- (or-eqv? t #\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or))
+ (or-eqv? t #\+ #\* #\/ #\- #\^ #\< #\> #:== #:~= #:and #:or #:concat))
(define (unary-operator? t)
"Return #t if the token may be a unary operator"
@@ -145,6 +141,8 @@
(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"))))
@@ -174,6 +172,9 @@
;; Lexical environment
(define environment #f)
+ ;; True if inside a function and the function accepts variable arguments
+ (define *vararg-function* #f)
+
;;;;; ENVIRONMENTS
(define (enter-environment!)
"Create a new environment, and set ENVIRONMENT to it"
@@ -260,8 +261,8 @@
(define (enforce-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)))
+ (unless (maybe-skip-next! expect)
+ (syntax-error (get-source-info) "expected '~A' but got '~A'" expect
token)))
;;;;; GRAMMAR
@@ -281,27 +282,27 @@
(single-name #:return-src #t)
(resolve-ref src save)))
- ;; application-arguments -> '(' [ expression-list ] ')' | STRING
+ ;; application-arguments -> '(' [ expression-list ] ')' | STRING | TABLE
(define (application-arguments)
- (case (token/type token)
- ;; STRING
- ((STRING)
- (let* ((string token))
- (advance!)
- (list (make-ast-literal #f string))))
- ;; TODO: table constructor
- ;; '('
- ((#\()
- (advance!)
- (if (eq? token #\))
- ;; ')'
- (advance! '())
- ;; [ expression-list ]
- (let* ((arguments (expression-list)))
- ;; ')'
- (enforce-next! #\))
- arguments)))
- (else (error #:APPLICATION-ARGUMENTS "should not happen"))))
+ (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"))))
;; prefix-expression -> NAME | '(' expression ')'
(define (prefix-expression)
@@ -354,7 +355,7 @@
(make-ast-table-ref src expr (make-ast-literal src
(symbol->string name)))
(cons expr (application-arguments))))))
;; application-arguments
- ((#\( STRING)
+ ((#\( STRING #\{)
(lp (make-ast-function-call src expr (application-arguments))))
(else expr))))
@@ -432,14 +433,14 @@
;; 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)
- parameters
+ (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!)
@@ -450,32 +451,33 @@
(values parameters (eq? last-token #:dots)))))))
;; 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?)
- (if (eq? token #\))
- (values '() #f)
- (parameter-list name))
- (enforce-next! #\))
- ;; create function
- (enter-environment!)
- (when implicit-self?
+ (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 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)
- result)))
+ (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)
@@ -504,6 +506,11 @@
(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
@@ -572,7 +579,7 @@
(define (parse-assignment src left right)
;; and then parses it, branching to handle overflows on either side if
necessary
- (make-ast-body
+ (make-ast-sequence
src
(let loop ((left left)
(right right)
@@ -688,12 +695,12 @@
;; [ ':' NAME ]
(if (eq? token #\:)
(let* ((name (advance! (single-name))))
- (advance!)
(values (cons name last-expr) 'table-method))
(values last-expr 'function))))
- (define body (function-body src (eq? type 'table-method)
(symbol->string name)))
+ (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))
+ ((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")))))
@@ -766,7 +773,7 @@
(wrap-expression-in-environment
src
environment
- (make-ast-body src (reverse! tree))))
+ (make-ast-sequence src (reverse! tree))))
(receive
(is-last node)
(statement)
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
index f5dc01d..7842db8 100644
--- a/module/language/lua/runtime.scm
+++ b/module/language/lua/runtime.scm
@@ -1,8 +1,10 @@
-; runtime.scm --- lua runtime functionality
+;; runtime.scm --- lua runtime functionality
(define-module (language lua runtime)
#:use-module (language lua common)
+ #:use-module (rnrs control)
+ #:use-module ((srfi srfi-1) #:select (filter!))
#:use-module (srfi srfi-9)
#:use-module ((srfi srfi-69) #:renamer (lambda (s) (if (eq? s
'make-hash-table) 'srfi-69-make-hash-table s)))
#:use-module ((srfi srfi-98) #:select (get-environment-variable))
@@ -18,34 +20,43 @@
assert-type
assert-table
assert-string
+ assert-number
;; tables
make-table
table?
- table/slots
- table/metatable
- table/metatable!
-
+ table-slots
+ table-metatable
+ table-metatable!
+ table-length
+
+ ;; userdata
+ userdata
+ userdata-metatable
+ register-userdata!
+
+ ;; metatable
+ might-have-metatable?
+ get-metatable
dispatch-metatable-event
- ;; metatable events
+ ;; table interaction
index
new-index!
+ get-field
;; operators
len unm eq lt le gt ge add sub mul div pow
- neq
+ neq concat
;; modules
make-module-table
- ;; calling conventions
-
;; global environment
*global-env-table*
)
- #:export-syntax (table/slots table? table/metatable table/metatable!)
+ #:export-syntax (table-slots table? table-metatable table-metatable!)
) ; define-module
@@ -79,6 +90,7 @@
((boolean? x) "boolean")
((eq? x #nil) "nil")
((procedure? x) "function")
+ ;; TODO: value-type->string must recognize threads
(else "userdata")))
(define (assert-type argument caller expected value predicate)
@@ -92,47 +104,128 @@
(define-assert assert-table "table" table?)
(define-assert assert-string "string" string?)
+(define-assert assert-number "number" number?)
;;;;; TABLES
(define-record-type table
(%make-table metatable slots)
table?
- (metatable table/metatable table/metatable!)
- (slots table/slots))
+ (metatable table-metatable table-metatable!)
+ (slots table-slots))
(define (make-table)
- (%make-table #nil (srfi-69-make-hash-table)))
+ (%make-table #f (srfi-69-make-hash-table)))
(define (table? x) (table? x))
-(define (table/metatable x) (table/metatable x))
-(define (table/metatable! x y) (table/metatable! x y))
-
-(define (dispatch-metatable-event key default table . arguments)
- (apply
- ;; if the table has a metatable
- (if (true? (table/metatable table))
- ;; if the metatable has the appropriate slot, use its value, otherwise
use the default function
- (hash-table-ref/default (table/slots (table/metatable table)) key
default)
- ;; otherwise, use the provided default function
- default)
- arguments))
+(define (table-metatable x) (table-metatable x))
+(define (table-metatable! x y) (table-metatable! x y))
+
+;;;;; USERDATA
+
+;; Userdata is tracked by this property. It can be #f, indicating the
+;; object is not userdata, #t, indicating the object is userdata but has
+;; no metatable, or an actual table, which counts as the metatable.
+(define userdata-property (make-object-property))
+
+(define userdata? userdata-property)
+(define (userdata-metatable x)
+ (and (table? (userdata-property x)) (userdata-property x)))
+
+(define* (register-userdata! x #:optional metatable)
+ (set! (userdata? x) (or metatable #t)))
+
+;;;;; METATABLES
+
+(define (might-have-metatable? x)
+ (or (table? x) (userdata? x)))
+
+(define (get-metatable x)
+ (cond ((table? x) (table-metatable x))
+ ((userdata? x) (userdata-metatable x))
+ (else #f)))
+
+;;;;; TABLE INTERACTION
+
+(define (dispatch-metatable-event key default x . arguments)
+ (let* ((metatable (get-metatable x)))
+ (apply
+ (if metatable
+ (hash-table-ref/default (table-slots metatable) key default)
+ default)
+ arguments)))
+
+;; see manual section 2.5.5
+(define (table-length table)
+ (let* ((numeric-keys (sort! (filter! number? (hash-table-keys
(table-slots table))) <)))
+ (if (eq? (car numeric-keys) 1)
+ (let lp ((cell (car numeric-keys))
+ (rest (cdr numeric-keys))
+ (length 0))
+ ;; length does not count "holes"
+ ;; so if a table has the keys 1,2,3 and 5, the length of the
table is 3
+ (if (or (> cell (+ length 1)) (null? rest))
+ (+ length 1) ;; add one to length as though we had
started from one
+ (lp (car rest) (cdr rest) cell)))
+ 0)))
(define (index table key)
(dispatch-metatable-event
"__index"
- (lambda (table key) (hash-table-ref/default (table/slots table) key #nil))
+ (lambda (table key) (hash-table-ref/default (table-slots table) key #nil))
table
table key))
(define (new-index! table key value)
(dispatch-metatable-event
"__newindex"
- (lambda (table key value) (hash-table-set! (table/slots table) key value))
+ (lambda (table key value) (hash-table-set! (table-slots table) key value))
table
table key value))
+(define* (get-field table key #:optional (default #nil))
+ (define result (index table key))
+ (if (eq? result #nil)
+ default
+ result))
+
;;;;; OPERATORS
+(define (len a)
+ "A function backing the unary # (length) operator"
+ (cond ((string? a) (string-length a))
+ ((table? a) (table-length a))
+ (else (runtime-error "attempt to get length of a ~A value"
(value-type->string a)))))
+
+(define (unm a)
+ "A function backing the unary - (negation) operator"
+ (if (might-have-metatable? a)
+ (dispatch-metatable-event "__unm" - a a)
+ (- a)))
+
+(define (builtin-eq a b)
+ "A function backing the == operator"
+ (equal? a b))
+
+(define (builtin-concat a b)
+ (when (or (table? a) (table? b))
+ (runtime-error "attempt to concatenate a table value"))
+ (when (or (eq? a #nil) (eq? b #nil))
+ (runtime-error "attempt to concatenate a nil value"))
+ (when (or (boolean? a) (boolean? b))
+ (runtime-error "attempt to concatenate a boolean value"))
+ (format "~a~a" a b))
+
+(define (neq a b)
+ "An inversion of eq"
+ (not (eq a b)))
+
+(define (ge a b)
+ "A function backing the >= (greater-than-or-equal-to) operator"
+ (not (lt a b)))
+
+(define (gt a b)
+ "A function backing the > (greater-than) operator"
+ (not (le a b)))
;; This macro could be even cooler and generate the slot names as well as the
;; parsers name/function mappings at expand-time
@@ -146,9 +239,9 @@
((_ () name slot-name default)
(begin
(define (name a b)
- (cond ((table? a)
+ (cond ((might-have-metatable? a)
(dispatch-metatable-event slot-name default a a b))
- ((table? b)
+ ((might-have-metatable? b)
(dispatch-metatable-event slot-name default b a b))
(else (default a b)))))))))
(define-binary-operators
@@ -158,32 +251,9 @@
(div "__div" /)
(pow "__pow" expt)
(le "__le" <=)
- (lt "__lt" <)))
-
-(define (len a)
- "A function backing the unary # (length) operator"
- (cond ((string? a) (string-length a))
- (else (runtime-error "attempt to get length of a ~A value"
(value-type->string a)))))
-
-(define (unm a)
- "A function backing the unary - (negation) operator"
- (- a))
-
-(define (eq a b)
- "A function backing the == operator"
- (equal? a b))
-
-(define (neq a b)
- "An inversion of eq"
- (not (eq a b)))
-
-(define (ge a b)
- "A function backing the >= (greater-than-or-equal-to) operator"
- (not (lt a b)))
-
-(define (gt a b)
- "A function backing the > (greater-than) operator"
- (not (le a b)))
+ (lt "__lt" <)
+ (eq "__eq" builtin-eq)
+ (concat "__concat" builtin-concat)))
;;;;; MODULES
@@ -191,9 +261,9 @@
(define module-metatable (make-table))
(hash-table-set!
- (table/slots module-metatable) "__index"
+ (table-slots module-metatable) "__index"
(lambda (table key)
- (define slots (table/slots table))
+ (define slots (table-slots table))
(if (hash-table-exists? slots key)
(hash-table-ref slots key)
(let ((key (string->symbol key))
@@ -204,14 +274,10 @@
(define (make-module-table name)
(define table (make-table))
- (table/metatable! table module-metatable)
- (hash-table-set! (table/slots table) 'module (resolve-module name))
+ (table-metatable! table module-metatable)
+ (hash-table-set! (table-slots table) 'module (resolve-module name))
table)
-;;;;; CALLING CONVENTIONS
-
-(define (adjust x) x)
-
;;;;; GLOBAL ENVIRONMENT
(define *global-env-table* (make-table))
@@ -230,22 +296,23 @@
(export name)
(new-index! *global-env-table* (symbol->string 'name) name)))))
-;; _G
-;; global variable table
-(define-global _G *global-env-table*)
-
(define-global (assert v . opts)
(define message (if (null? opts) "assertion failed" (car opts)))
(if (false? v)
(runtime-error message)
(apply values (cons v opts))))
+;; NOTE: collectgarbage cannot be fully implemented because it expects
+;; an incremental garbage collector that matches lua's interface; libgc
+;; 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") (ignore))
+ ((string=? opt "collect") (gc))
((string=? opt "count") (ignore))
((string=? opt "step") (ignore))
((string=? opt "setpause") (ignore))
@@ -258,40 +325,102 @@
(runtime-warning "UNIMPLEMENTED")
#nil)
+;; TODO: error(message, [level])
+
+;; global variable table
+(define-global _G *global-env-table*)
+
+;; TODO: getfenv
+
(define-global (getmetatable table)
(assert-table 1 "getmetatable" table)
- (table/metatable table))
+ (let* ((mt (table-metatable table)))
+ (if (eq? mt #f)
+ #nil
+ mt)))
+
+#;(define-global (ipairs table)
+ (assert-table 1 "ipairs" table)
+ (values
+ (lambda ()
+ )
+ table
+ 0))
+
+;; TODO: ipairs
+;; TODO: load
+;; TODO: loadfile
+;; TODO: loadstring
+;; TODO: module
+;; TODO: next(table [, index])
+;; TODO: pairs
+;; TODO: pcall
(define-global (print . arguments)
(for-each
(lambda (x)
- (cond ((eq? x #t) (display "true"))
- ((eq? x #f) (display "false"))
- ((eq? x #nil) (display "nil"))
- (else (write x)))
+ (display (tostring x))
(write-char #\tab))
arguments)
(newline)
#nil)
+(define-global (rawequal v1 v2)
+ (equal? v1 v2))
+
(define-global (rawget table key)
(assert-table 1 "rawget" table)
- (hash-table-ref (table/slots table) key))
+ (hash-table-ref (table-slots table) key))
(define-global (rawset table key value)
(assert-table 1 "rawset" table)
- (hash-table-set! (table/slots table) key value))
+ (hash-table-set! (table-slots table) key value))
+
+;; TODO: setfenv
(define-global (setmetatable table metatable)
(assert-table 1 "setmetatable" table)
(assert-type 2 "setmetatable" "nil or table" metatable (lambda (x) (or
(table? x) (eq? x #nil))))
- (table/metatable! table metatable)
+ (table-metatable! table (if (eq? metatable #nil) #f metatable))
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)))
+
+
+;; NOTE: tostring does not check for __tostring
+(define-global (tostring e)
+ (cond ((string? e) e)
+ ((eqv? e #t) "true")
+ ((eqv? e #f) "false")
+ ((eqv? e #nil) "nil")
+ ((number? e) (number->string e))
+ ((table? e)
+ (dispatch-metatable-event
+ "__tostring"
+ (lambda (table) (format "~A" e))
+ e
+ e))
+ (else (runtime-error "tostring cannot convert value ~A" e))))
+
+(define-global (type v)
+ (value-type->string v))
+
+;; TODO: unpack(list [, i [, j]])
+
;; _VERSION
;; contains a string describing the lua version
(define-global _VERSION "Guile-Lua 5.1")
+;; TODO: xpcall
+
;;; MODULE SYSTEM
;; package
@@ -343,11 +472,11 @@
(define-global (require module-name . _)
(assert-type 1 "require" "string" module-name string?)
;; try to load module, if it's not already loaded
- (if (not (hash-table-exists? (table/slots loaded) module-name))
+ (if (not (hash-table-exists? (table-slots loaded) module-name))
(let* ((std-module-name `(language lua standard ,(string->symbol
module-name))))
(if (module-exists? std-module-name)
(register-loaded-module module-name (make-module-table
std-module-name)))))
- (if (not (hash-table-exists? (table/slots loaded) module-name))
+ (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/io.scm
b/module/language/lua/standard/io.scm
index 44b5f19..eb6b014 100644
--- a/module/language/lua/standard/io.scm
+++ b/module/language/lua/standard/io.scm
@@ -1,13 +1,165 @@
(define-module (language lua standard io)
- #:use-module (language lua runtime))
+ #:use-module (language lua runtime)
-;; close, flush, input, lines, open, output, popen, read, tmpfile, type,
write, file:close, file:flush, file:lines, file:read, file:seek, file:setvbuf,
file:write
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (rnrs control))
+
+;; io.file:read
+
+;; metatable for file objects
+(define file (make-table))
+
+(rawset file '__index
+ (lambda (self key)
+ (rawget file key)))
(define stdin (current-input-port))
(define stdout (current-output-port))
(define stderr (current-error-port))
-(define (close file)
- #f)
+(define* (close #:optional (file stdout))
+ (close-port file))
+
+(rawset file 'close
+ (lambda (self)
+ (close self)))
+
+;; lua doesn't actually have an optional flush argument, but this is more in
line with everything else
+(define* (flush #:optional (file stdout))
+ (force-output file))
+
+(rawset file 'flush
+ (lambda (self)
+ (flush self)))
+
+(define* (input #:optional filename)
+ (if filename
+ (let* ((file (open filename)))
+ (set! stdin file)
+ file)
+ stdin))
+
+(define (line-iterator file auto-close?)
+ (lambda ()
+ (let* ((line (read-line file)))
+ (if (eof-object? line)
+ (begin
+ (if auto-close?
+ (close-port file))
+ #nil)
+ line))))
+
+(define* (lines #:optional filename)
+ (let* ((file (if filename (open filename) stdin)))
+ (line-iterator file (and filename))))
+
+(rawset file 'lines
+ (lambda (self)
+ (line-iterator self #f)))
+
+(define* (open filename #:optional (mode "r"))
+ (assert-string 1 "io.open" filename)
+ (assert-string 2 "io.open" mode)
+ (let* ((handle (open-file filename mode)))
+ (register-userdata! handle file)
+ handle))
+
+(define* (output #:optional filename)
+ (if filename
+ (let* ((file (open filename "w")))
+ (set! stdout file)
+ file)
+ stdout))
+
+(define* (popen prog #:optional (mode "r"))
+ (open-process
+ (assert-string 2 "io.popen" mode)
+ (if (string=? mode "w") OPEN_WRITE OPEN_READ)
+ prog))
+
+(define (default-read port)
+ (if (eof-object? (peek-char port))
+ #nil
+ (read-line port)))
+
+(rawset file 'read
+ (lambda formats
+ (if (null? formats)
+ (default-read self)
+ (apply
+ values
+ (map
+ (lambda (self . formats)
+ (unless (or (number? format) (string? format))
+ (runtime-error "'file:read' expects a string or number as
format argument, but got ~a" format))
+ (if (number? format)
+ (if (eof-object? (peek-char self))
+ #nil
+ (let lp ((out (open-output-string))
+ (i format))
+ (if (= i 0)
+ (get-output-string out)
+ (let ((c (read-char self)))
+ (if (eof-object? self)
+ (get-output-string out)
+ (begin
+ (write-char c out)
+ (lp out (- i 1))))))))
+
+ (let* ((format-length (string-length format))
+ (c1 (if (> format-length 0) (string-ref format 0) #f))
+ (c2 (if (> format-length 1) (string-ref format 1) #f)))
+ (cond ((eq? c2 #\n) (runtime-error "'file:read' number
reading is not yet supported"))
+ ((eq? c2 #\a)
+ (if (eof-object? (peek-char self))
+ #nil
+ (let lp ((out (open-output-string)))
+ (let ((c (read-char self)))
+ (if (eof-object? c)
+ (get-output-string out)
+ (begin
+ (write-char c out)
+ (lp out)))))))
+ ((eq? c2 #\l)
+ (default-read port))
+ (else
+ (runtime-error "file:read does not understand format
~a" format))))))
+ formats)))))
+
+(rawset file 'seek
+ (lambda* (self #:optional (whence "cur") (offset 0))
+ (assert-string 1 "file:seek" whence)
+ (assert-number 2 "file:seek" offset)
+ (seek self offset
+ (cond ((string=? whence "cur") SEEK_CUR)
+ ((string=? whence "set") SEEK_SET)
+ ((string=? whence "end") SEEK_END)
+ (else (runtime-error "invalid 'whence' argument to
'file:seek'; expected \"cur\", \"set\", or \"end\""))))))
+
+(rawset file 'setvbuf
+ (lambda* (self mode #:optional size)
+ (assert-string 1 "file:setvbuf" mode)
+ (let* ((translated-mode
+ (cond ((string=? mode "no") _IONBF)
+ ((string=? mode "line") _IOLBF)
+ ((string=? mode "full") _IOFBF))))
+ (if size
+ (setvbuf self mode)
+ (setvbuf self mode size)))))
+(rawset file 'write
+ (lambda* (self . args)
+ (for-each
+ (lambda (arg)
+ (unless (or (string? arg) (number? arg))
+ (runtime-error "'file:write' expects string or number as argument
but got '~a'" arg))
+ (display arg self))
+ args)))
+(define (type obj)
+ (if (port? obj)
+ (if (port-closed? obj)
+ "closed"
+ "file")
+ #nil))
diff --git a/module/language/lua/standard/math.scm
b/module/language/lua/standard/math.scm
index abb8339..469ac2d 100644
--- a/module/language/lua/standard/math.scm
+++ b/module/language/lua/standard/math.scm
@@ -1,19 +1,31 @@
(define-module (language lua standard math)
#:use-module (language lua runtime))
-;; TODO: deg, rad, pi, frexp, ldexp
-;; TODO: random does not support lower limit
+;; TODO: math.modf
+;; TODO: math.deg,rad,frexp,random not tested
+
+;; NOTE: as opposed to lua, math.sqrt accepts negative arguments, as
+;; guile's numeric tower is capable of representing complex numbers
+
+(define huge +inf.0)
+(define *nan* (nan))
+(define pi 3.14159265358979323846)
+(define radians_per_degree (/ pi 180.0))
(letrec-syntax
((wrap-builtins
- (syntax-rules (rename variable-arity)
+ (syntax-rules (rename rename2 variable-arity)
;; we must know the arity of the wrapped procedure because lua ignores
superfluous arguments whereas it is an error in scheme
;; simple wrap with new name and 1 argument
- ((_ () (rename lua-name guile-name))
+ ((_ () (rename guile-name lua-name))
(define (lua-name a . _)
((@ (guile) guile-name) a)))
+ ((_ () (rename2 guile-name lua-name))
+ (define (lua-name a b . _)
+ ((@ (guile) guile-name) a b)))
+
;; simple wrap with 2 arguments
((_ () (2 name))
(define (name a b . _)
@@ -39,39 +51,61 @@
acos
asin
atan
- (rename ceil ceiling)
+ (rename ceiling ceil)
cos
cosh
exp
+ (rename2 remainder modf)
floor
log
log10
- ;; DIFFERENCE: sqrt accepts negative arguments
- sqrt
sin
sinh
+ sqrt
(variable-arity max)
(variable-arity min)
- (rename pow expt)
+ (rename expt pow)
tan
tanh))
(define (atan2 x y)
(atan (/ x y)))
+;; copy the global random state for this module so we don't mutate it
+(define randomstate (copy-random-state *random-state*))
+
(define (randomseed seed . _)
- ;; should have our own state in here
- (warining "math.randomseed: (@ (guile) *random-state*) will be mutated as a
result of this call")
- (set! *random-state* (seed->random-state seed))
- *unspecified*)
-
-(define (random . _)
- (if (null? _)
- ((@ (guile) random) 1)
- (begin
- (warning "math.random: lower bound of random will not be respected")
- (if (null? (cdr _))
- ((@ (guile) random) 1)
- ((@ (guile) random) (cadr _))))))
-
-(define huge +inf.0)
\ No newline at end of file
+ (set! randomstate (seed->random-state seed)))
+
+(define* (random #:optional m n #:rest _)
+ ;; this can be a little confusing because guile's random number
+ ;; generator only allows [0, N) but we need [0,1), [1,m] and [m,n]
+ (cond ((and (not m) (not n)) ((@ (guile) random) 1.0))
+ ;; this is really [1,M)
+ ((and m) (+ 1 ((@ (guile) random) m)))
+ ((and m n) (+ m ((@ (guile) random) n)))
+ (else (error #:RANDOM "should not happen"))))
+
+(define (deg x)
+ (/ x radians_per_degree))
+
+(define (rad x)
+ (* x radians_per_degree))
+
+(define (ldexp x exp)
+ (cond ((= exp 0) x)
+ ((= exp *nan*) *nan*)
+ ((= exp +inf.0) +inf.0)
+ ((= exp -inf.0) -inf.0)
+ (else (* x (expt 2 exp)))))
+
+(define (frexp x)
+ (if (zero? x)
+ 0.0
+ (let* ((l2 (log2 x))
+ (e (floor (log2 x)))
+ (e (if (= l2 e)
+ (inexact->exact e)
+ (+ (inexact->exact e) 1)))
+ (f (/ x (expt 2 e))))
+ f)))
diff --git a/module/language/lua/standard/os.scm
b/module/language/lua/standard/os.scm
index ca27cff..f2301a1 100644
--- a/module/language/lua/standard/os.scm
+++ b/module/language/lua/standard/os.scm
@@ -3,16 +3,35 @@
#:use-module (srfi srfi-98))
-;; clock, date, difftime, setlocale, time
-
(define (clock)
- ;; ??? does this work
- (vector-ref (times) 0))
+ (tms:clock (times)))
+
+(define* (date #:optional (format "%c") time)
+ (let* ((utc? (eq? (string-ref format 0) #\!))
+ ;; skip !
+ (format (if utc? (string-copy format 1) format))
+ (stm ((if utc? gmtime localtime) (or time (current-time)))))
+ (if time
+ (begin
+ (assert-number 2 "date" time)
+ (if (string=? format "*t")
+ (let* ((table (make-table)))
+ (rawset table "sec" (tm:sec stm))
+ (rawset table "min" (tm:min stm))
+ (rawset table "hour" (tm:hour stm))
+ (rawset table "month" (+ 1 (tm:month stm)))
+ (rawset table "year" (+ 1900 (tm:year stm)))
+ (rawset table "wday" (+ 1 (tm:wday stm)))
+ (rawset table "yday" (+ 1 (tm:yday stm)))
+ (rawset table "isdst" (> (tm:isdst stm) 0))
+ table)
+ (strftime format stm)))
+ (strftime format stm))))
(define (difftime t2 t1)
(- t2 t1))
-(define* (execute #:optional (command #f))
+(define* (execute #:optional command)
(if (not command)
1
(system command)))
@@ -23,16 +42,47 @@
(define (getenv varname)
(or (get-environment-variable varname) #nil))
-(define (rename oldname newname)
- (rename-file oldname newname))
+(define rename rename-file)
(define (remove filename)
(if (file-is-directory? filename)
(rmdir filename)
(delete-file filename)))
-(define* (time #:optional (table #f))
- #f)
+(define* (setlocale locale #:optional (category "all"))
+ (assert-string 2 "setlocale" category)
+ ((@ (guile) setlocale)
+ locale
+ (cond ((string=? category "all") LC_ALL)
+ ((string=? category "collate") LC_COLLATE)
+ ((string=? category "ctype") LC_CTYPE)
+ ((string=? category "messages") LC_MESSAGES)
+ ((string=? category "monetary") LC_MONETARY)
+ ((string=? category "numeric") LC_NUMERIC)
+ ((string=? category "time") LC_TIME))))
+
+(define* (time #:optional table)
+ (if table
+ (begin
+ (assert-table 1 "time" table)
+ (let* ((sec (get-field table "sec" 0))
+ (min (get-field table "min" 0))
+ (hour (get-field table "hour" 12))
+ (day (get-field table "day" -1))
+ (month (- (get-field table "month" -1) 1))
+ (year (- (get-field table "year" -1) 1900))
+ (isdst (get-field table "isdst" 0))
+ (result (make-vector 11 0)))
+ (set-tm:sec result sec)
+ (set-tm:min result min)
+ (set-tm:hour result hour)
+ (set-tm:mday result day)
+ (set-tm:mon result month)
+ (set-tm:year result year)
+ (set-tm:isdst result isdst)
+ (set-tm:zone result "")
+ (car (mktime result)))
+ )
+ (current-time)))
-(define (tmpname)
- (mkstemp!))
+(define tmpname mkstemp!)
diff --git a/module/language/lua/standard/table.scm
b/module/language/lua/standard/table.scm
index 2d15368..a3f064c 100644
--- a/module/language/lua/standard/table.scm
+++ b/module/language/lua/standard/table.scm
@@ -3,10 +3,13 @@
#:use-module (language lua runtime)
#:use-module (rnrs control)
- #:use-module ((srfi srfi-69) #:select (hash-table-size))
+ #:use-module ((srfi srfi-1) #:select (filter!))
+ #:use-module (srfi srfi-8)
+ #:use-module (srfi srfi-16)
+ #:use-module ((srfi srfi-69) #:select (hash-table-size hash-table-keys))
)
-;; TODO - concat, insert, remove, sort
+;; TODO - insert, remove, sort
(define (add-field! table buffer i)
(define string (rawget table i))
@@ -17,8 +20,8 @@
(define* (concat table #:optional (sep "") (i 1) (%last #f) #:rest _)
(define buffer (open-output-string))
(assert-table 1 "concat" table)
- (let* ((ht (table/slots table))
- (last (if (not %last) (hash-table-size ht) %last)))
+ (let* ((ht (table-slots table))
+ (last (if (not %last) (table-length table) %last)))
(let lp ((i i))
(if (< i last)
(begin
@@ -29,14 +32,33 @@
(add-field! table buffer i)))))
(get-output-string buffer))
+;; Arguments are named a1 and a2 because confusingly, the middle argument is
optional
+;; table.insert(table, [pos,] value)
+(define (insert table . arguments)
+ (assert-table 1 "insert" table)
+ (receive
+ (pos value)
+ (apply
+ (case-lambda
+ ((value)
+ (values (table-length table) value))
+ ((pos value)
+ (assert-number 1 "insert" pos)
+ (let* ((length (table-length table))
+ (e (if (> pos length) pos length)))
+ (let lp ((i e))
+ (when (> i pos)
+ (rawset table i (rawget table (- i 1)))
+ (lp (- i 1))))
+ (values pos value)))
+ (else
+ (runtime-error "wrong number of arguments to 'insert'")))
+ arguments)
+ (rawset table pos value)))
(define (maxn table . _)
(assert-table 1 "maxn" table)
- (let loop ((rest (hash-table-keys (table/slots table)))
- (n 0))
- (if (null? rest)
- (values n)
- (let* ((item (car rest)))
- (if (and (number? item) (> item n))
- (loop (cdr rest) item)
- (loop (cdr rest) n))))))
+ (let* ((result (sort! (filter! number? (hash-table-keys (table-slots
table))) >)))
+ (if (null? result)
+ 0
+ (car result))))
\ No newline at end of file
diff --git a/test-suite/tests/lua-eval-2.test b/test-suite/tests/lua-eval-2.test
new file mode 100644
index 0000000..272fea4
--- /dev/null
+++ b/test-suite/tests/lua-eval-2.test
@@ -0,0 +1,89 @@
+;; lua-eval.test --- basic tests for builtin lua constructs -*- mode: scheme
-*-
+(define-module (test-lua)
+ #:use-module (ice-9 format)
+ #:use-module (language tree-il)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:use-module (system base compile)
+ #:use-module (test-suite lib)
+
+ #:use-module (language lua parser)
+
+ )
+
+(with-test-prefix "lua-eval"
+ (define (from-string string)
+ (compile ((make-parser (open-input-string string)))
+ #:from 'lua
+ #:to 'value))
+ (letrec-syntax
+ ((test
+ (syntax-rules ()
+ ((_ string expect)
+ (pass-if (format "~S => ~S" string expect) (equal? (from-string
string) expect)))
+ ((_ string)
+ (test string #t)))))
+
+ ;; 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)
+
+ ;; locals
+ (test "local a; a = true; return a")
+ (test "local a = true; return a")
+ (test "local a,b=false,true; return b")
+ (test "local a,b,c=false,true,false; return b")
+ (test "local a,b,c=false,false,true; return c")
+
+ ;; local function statements
+ (test "local function identity(x) return x end; return identity(true)")
+
+ ;; metatable events
+ (test "table = {} setmetatable(table, { __add = function(a,b) return b end
}) return table + 5" 5)
+ (test "table = {} setmetatable(table, { __add = function(a,b) return a end
}) return 5 + table" 5)
+
+ ;; field functions
+ (test "table = {} function table.identity(x) return x end return
table.identity(true)")
+
+ ;; repeat
+ (test "i=0; repeat i = i+1 until i == 5; return i" 5)
+ (test "i=5; repeat i = i-1 until i == 0; return i" 0)
+
+ ;; length operator
+ (test "return #\"asdf\"" 4)
+ (test "table = {1,2,3,4}; return #table" 4)
+
+ ;; _G
+ (test "a = true return _G.a")
+ (test "a = true return _G._G.a")
+ (test "a = true return _G._G._G.a")
+
+ ;; concat
+ (test "return \"hello\"..\" world\"" "hello world")
+
+ ;; built-in functions
+ (test "assert(true)" #t)
+ (test "print(T)" #nil)
+ (test "print(false or true)" #nil)
+ (test "table = {}; rawset(table, 0, true); return table[0]")
+ (test "table = {}; rawset(table, 0, true); return rawget(table, 0)")
+
+ ;; methods
+ (test "table = {} function table:identity() return self end return
table.identity(true)")
+ (test "table = {} function table.identity(self,x) return x end return
table:identity(true)")
+
+ ;; arguments default to nil
+ (test "function test(x) return x end return test()" #nil)
+
+ ;; application with freestanding string or table as argument
+ (test "print {x=5}; return true")
+ (test "print \"hello world\"; return true")
+
+ ;; variable arguments
+ (test "function test(...) print(...) end test(1,2)")
+ ))
diff --git a/test-suite/tests/lua-eval.test b/test-suite/tests/lua-eval.test
index 20d3d73..e65b734 100644
--- a/test-suite/tests/lua-eval.test
+++ b/test-suite/tests/lua-eval.test
@@ -1,4 +1,4 @@
-;; lua-eval.test --- lua language test suite -*- mode: scheme -*-
+;; lua-eval.test --- basic tests for builtin lua constructs -*- mode: scheme
-*-
(define-module (test-lua)
#:use-module (ice-9 format)
#:use-module (language tree-il)
@@ -33,6 +33,8 @@
(test "return (true)")
(test "return (false == false)")
(test "return;" *unspecified*)
+ (test "return [[string]]" "string")
+ (test "return [=[string]=]" "string")
;; exercise the operator precedence parser
(test "return 2" 2)
@@ -78,7 +80,7 @@
(test "function noargs() return true end noargs()")
(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)
- (test "-- 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 "function fib(n) if n < 2 then return n else return fib(n-1) +
fib(n-2) end end return fib(20)" 6765)
;; do
(test "do return true end")
@@ -92,67 +94,4 @@
(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)
-
- ;; locals
- (test "local a; a = true; return a")
- (test "local a = true; return a")
- (test "local a,b=false,true; return b")
- (test "local a,b,c=false,true,false; return b")
- (test "local a,b,c=false,false,true; return c")
-
- ;; local function statements
- (test "local function identity(x) return x end; return identity(true)")
-
- ;; metatable events
- (test "table = {}
-setmetatable(table, { __add = function(a,b) return b end })
-return table + 5" 5)
- (test "table = {}
-setmetatable(table, { __add = function(a,b) return a end })
-return 5 + table" 5)
-
- ;; field functions
- (test "table = {}
-function table.identity(x) return x end
-return table.identity(true)")
-
- ;; repeat
- (test "i=0; repeat i = i+1 until i == 5; return i" 5)
- (test "i=5; repeat i = i-1 until i == 0; return i" 0)
-
- ;; length operator
- (test "return #\"asdf\"" 4)
-
- ;; _G
- (test "a = true
-return _G.a")
- (test "a = true
-return _G._G.a")
- (test "a = true
-return _G._G._G.a")
-
- ;; built-in functions
- (test "assert(true)" #t)
- (test "print(T)" #nil)
- (test "print(false or true)" #nil)
- (test "table = {}; rawset(table, 0, true); return table[0]")
- (test "table = {}; rawset(table, 0, true); return rawget(table, 0)")
-
- ;; methods
- (test "
-table = {}
-function table:identity() return self end return table.identity(true)")
- (test "
-table = {}
-function table.identity(self,x) return x end return table:identity(true)")
-
))
-
diff --git a/test-suite/tests/lua-lexer.test b/test-suite/tests/lua-lexer.test
index aff6ec6..91644be 100644
--- a/test-suite/tests/lua-lexer.test
+++ b/test-suite/tests/lua-lexer.test
@@ -13,7 +13,6 @@
string
(lambda (port)
-; (format #t "SHIT ASS ~A\n" get-source-info lex)
(initialize-lua-lexer! port get-source-info lex)
(lex))))
diff --git a/test-suite/tests/lua-scratch.test
b/test-suite/tests/lua-scratch.test
index b380968..b8e5da4 100644
--- a/test-suite/tests/lua-scratch.test
+++ b/test-suite/tests/lua-scratch.test
@@ -1,82 +1,3 @@
-; -*- mode: scheme -*-
-
- ;;;;; TODO LIST
- ;; - Multiple values
- ;; - Variable arguments
- ;; - Applications of a table literal with no parentheses
- ;; - Concatenation
- ;; - Method invocations
- ;; - For loops
- ;; - Modules: os, table, io, math
- ;; - Metatable events: __index, __newindex, __mode, __call, __metatable,
__tostring, __gc, __concat, __eq, __unm
- ;; require 'math' FAILS
- ;;;;; NOT PART OF PROJECT
- ;; - bitlib, coroutine, debug, string
-
- ;;;;; tenative multiple values idea:
- ;; The context of expressions is recorded by the parser when relevant When
- ;; multiple values can occur, evaluating the expression will result in a
- ;; <multiple-values> record. This record shall be inspected by functions in
- ;; (language lua runtime), and used as necessary
-
- ;; Situations where we need to consider multiple values:
-
- ;; table literals
- ;; return statements
- ;; assignments
- ;; function calls
-
-#|
- Manual excerpt on multiple values:
-
- ;; Before the assignment, the list of values is adjusted to the length of
- ;; the list of variables. If there are more values than needed, the excess
- ;; values are thrown away. If there are fewer values than needed, the list
- ;; is extended with as many nil's as needed. If the list of expressions
ends
- ;; with a function call, then all values returned by that call enter the
- ;; list of values, before the adjustment (except when the call is enclosed
- ;; in parentheses; see §2.5).
-
- ;; 2.5 - Expressions
-
- ;; Both function calls and vararg expressions can result in multiple
- ;; values. If an expression is used as a statement (only possible for
- ;; function calls (see §2.4.6)), then its return list is adjusted to zero
- ;; elements, thus discarding all returned values. If an expression is used
- ;; as the last (or the only) element of a list of expressions, then no
- ;; adjustment is made (unless the call is enclosed in parentheses). In all
- ;; other contexts, Lua adjusts the result list to one element, discarding
- ;; all values except the first one.
-
- End manual excerpt
-
- Multiple values
-
- we must know the context of all expressions -- whether they occur alone,
- before the end of a list, or at the end of a list
-
- f() -- adjusted to 0 results
- g(f(), x) -- f() is adjusted to 1 result
- g(x, f()) -- g gets x plus all results from f()
- a,b,c = f(), x -- f() is adjusted to 1 result (c gets nil)
- a,b = ... -- a gets the first vararg parameter, b gets
- -- the second (both a and b can get nil if there
- -- is no corresponding vararg parameter)
-
- a,b,c = x, f() -- f() is adjusted to 2 results
- a,b,c = f() -- f() is adjusted to 3 results
- return f() -- returns all results from f()
- return ... -- returns all received vararg parameters
- return x,y,f() -- returns x, y, and all results from f()
- {f()} -- creates a list with all results from f()
- {...} -- creates a list with all vararg parameters
- {f(), nil} -- f() is adjusted to 1 result
-
-
-
-
- |#
-
(define-module (test-lua)
#:use-module (ice-9 format)
#:use-module (language tree-il)
@@ -89,37 +10,14 @@
)
-;; so now we need to deal with multiple values when:
-;; function call is last in application (pass all results to function
application, append?)
-;; function call is last in assignment (assign all results to variables, nil
to overflows)
-;; function is last in table constructor (assign to indices)
-;; table constructor
-;; also variable arguments (later)
-
-(with-test-prefix "lua-eval"
- (define (from-string string)
- (compile ((make-parser (open-input-string string)))
- #:from 'lua
- #:to 'value))
- (letrec-syntax
- ((test
- (syntax-rules ()
- ((_ string expect)
- (pass-if (format "~S => ~S" string expect) (equal? (from-string
string) expect)))
- ((_ string)
- (test string #t)))))
-
- ;(test "function identity(x) return x end return identity(21)" 21)
- ;(test "assert(true)" #t)
- ;(test "function fib(n) if n < 2 then return n else return fib(n-1) +
fib(n-2) end end return fib(20)" 6765)
- ;(test "function identity(x) return x end return identity(2) +
identity(2)" 4)
- #t
-))
-
(begin
(define var
-"table = {}
-function table:identity() return self end return table:identity(true)"
- ) (display (compile ((make-parser (open-input-string var)))
+ "require 'io';"
+ )
+
+ (display (compile ((make-parser (open-input-string var)))
#:from 'lua #:to 'value))
- (newline))
+ (newline)
+)
+
+
diff --git a/test-suite/tests/lua-standard-library.test
b/test-suite/tests/lua-standard-library.test
index 8fa6665..0341b16 100644
--- a/test-suite/tests/lua-standard-library.test
+++ b/test-suite/tests/lua-standard-library.test
@@ -24,6 +24,11 @@
((_ string)
(test string #t))))
+(with-test-prefix "lua-builtin"
+ (test "assert(true)")
+ (test "rawequal(true,true)")
+)
+
(with-test-prefix "lua-math"
(test "require 'math'; return true")
(test "return math.abs(-1)" 1)
@@ -42,9 +47,13 @@
(test "return math.sinh(5)" (sinh 5))
(test "return math.tan(5)" (tan 5))
(test "return math.tanh(5)" (tanh 5))
+ (test "return math.ldexp(4,3)" 32)
+ (test "return math.modf(6,4)" 2)
)
(with-test-prefix "lua-table"
(test "require 'table'; return true")
+ (test "t = {}; t[1] = true; t[555] = true; t[1234] = true; return
table.maxn(t)" 1234)
(test "return table.concat({\"1\", \"2\", \"3\"}, \" \")" "1 2 3")
+ (test "t = {}; t[1] = true; t[2] = false; table.insert(t, 2, true); return
t[2]")
)
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-252-g21a2bac,
No Itisnt <=