[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-246-gb9fa
|
From: |
No Itisnt |
|
Subject: |
[Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-246-gb9fa70d |
|
Date: |
Sat, 24 Jul 2010 04:37:34 +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=b9fa70d4a187d6780b2b3c515cbf958329d6d2b7
The branch, lua has been updated
via b9fa70d4a187d6780b2b3c515cbf958329d6d2b7 (commit)
from c6f9ee62ea775754f1aed6b9543beac8cd601da3 (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 b9fa70d4a187d6780b2b3c515cbf958329d6d2b7
Author: No Itisnt <address@hidden>
Date: Fri Jul 23 23:36:03 2010 -0500
lua: Add most of math functionality and a test suite for it.
-----------------------------------------------------------------------
Summary of changes:
module/language/lua/compile-tree-il.scm | 36 +++++++----
module/language/lua/lexer.scm | 20 ++++--
module/language/lua/parser.scm | 8 +-
module/language/lua/runtime.scm | 16 +++--
module/language/lua/standard/math.scm | 76 ++++++++++++++++++++---
module/language/tree-il/compile-glil.scm | 98 +++++++++++++++---------------
test-suite/tests/lua-eval.test | 2 +-
test-suite/tests/lua-math.test | 47 ++++++++++++++
8 files changed, 212 insertions(+), 91 deletions(-)
create mode 100644 test-suite/tests/lua-math.test
diff --git a/module/language/lua/compile-tree-il.scm
b/module/language/lua/compile-tree-il.scm
index cd94220..e686740 100644
--- a/module/language/lua/compile-tree-il.scm
+++ b/module/language/lua/compile-tree-il.scm
@@ -183,20 +183,28 @@
(let ((left (compile #f left))
(right (compile #f right)))
(case operator
- ((#\+ #\- #\* #\/ #\^ #\< #:== #:~=)
- (make-runtime-application
- src
- (case operator
- ((#\+) 'add)
- ((#\-) 'sub)
- ((#\*) 'mul)
- ((#\/) 'div)
- ((#\^) 'pow)
- ((#\<) 'lt)
- ((#:==) 'eq)
- ((#:~=) 'neq)
- (else (error #:COMPILE "unhandled binary operator" operator)))
- (list left right)))
+ ((#\+ #\- #\* #\/ #\^ #\< #\> #:<= #:>= #:== #:~=)
+ (let* ((result
+ (make-runtime-application
+ src
+ (case operator
+ ((#\+) 'add)
+ ((#\-) 'sub)
+ ((#\*) 'mul)
+ ((#\/) 'div)
+ ((#\^) 'pow)
+ ((#\<) 'lt)
+ ((#\>) 'lt)
+ ((#:<=) 'le)
+ ((#:>=) 'le)
+ ((#:==) 'eq)
+ ((#:~=) 'neq)
+ (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 #:>=))
+ (list right left)
+ (list left right)))))
+ result))
((#:or)
(make-lua-conditional
src
diff --git a/module/language/lua/lexer.scm b/module/language/lua/lexer.scm
index 56b25ef..f5479dd 100644
--- a/module/language/lua/lexer.scm
+++ b/module/language/lua/lexer.scm
@@ -32,25 +32,25 @@
(define (drop-buffer)
(truncate-file buffer 0))
-
+
(define (clear-buffer)
"Reset the buffer and return a string of the contents"
(define string (get-output-string buffer))
(drop-buffer)
string)
-
+
(define saved-source-info #f)
-
+
(define (save-source-info)
"Save source code information for a particular location e.g. the beginning
of an identifier"
(set! saved-source-info (source-info port)))
-
+
(define (get-source-info)
(if saved-source-info
saved-source-info
(source-info port)))
-
+
(define (eat-comment)
(let consume ((c (read-char)))
(cond ((eof-object? c) #f)
@@ -100,7 +100,7 @@ of an identifier"
(loop (peek-char))))))
(else (write-char (read-char))
(loop (peek-char))))))
-
+
;; read a single or double quoted string, with escapes
(define (read-string delimiter)
(read-char) ;; consume delimiter
@@ -196,6 +196,12 @@ of an identifier"
(if (eq? (peek-char) #\=)
(begin (read-char) #:~=)
(syntax-error (get-source-info) "expected = after ~ but got ~c"
c)))
+ ((#\<)
+ (read-char)
+ (if (eq? (peek-char) #\=) (begin (read-char) #:<=) #\<))
+ ((#\>)
+ (read-char)
+ (if (eq? (peek-char) #\=) (begin (read-char) #:>=) #\>))
;; = and ==
((#\=)
(read-char)
@@ -231,7 +237,7 @@ of an identifier"
;; characters that are allowed directly through
((#\; #\( #\) #\,
#\+ #\/ #\*
- #\< #\^ #\{ #\} #\] #\: #\#) (read-char))
+ #\^ #\{ #\} #\] #\: #\#) (read-char))
;; numbers
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
(save-source-info)
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
index 78f54fc..81e7a37 100644
--- a/module/language/lua/parser.scm
+++ b/module/language/lua/parser.scm
@@ -108,9 +108,9 @@
((string? t) 'STRING)
(else
(case t
- ((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\# #:function
-#:end #:if #:return #:elseif #:then #:else #:true #:false #:nil #:== #:~= #:=
-#:local #:dots) t)
+ ((#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\#
+#:function #:end #:if #:return #:elseif #:then #:else #:true #:false
+#:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots) t)
(else (error #:TOKEN/TYPE t))))))
;;;;; OPERATOR PRECEDENCE PARSING
@@ -131,7 +131,7 @@
(case o
((#:or) 10)
((#:and) 20)
- ((#:== #:~= <= >= #\< #\>) 30)
+ ((#:== #:~= #:<= #:>= #\< #\>) 30)
((#\+ #\-) 60)
((#\* #\/ #\%) 70)
((#\^ #:concat) 99)))
diff --git a/module/language/lua/runtime.scm b/module/language/lua/runtime.scm
index d6dc4c9..2daeb08 100644
--- a/module/language/lua/runtime.scm
+++ b/module/language/lua/runtime.scm
@@ -35,8 +35,8 @@
;; modules
make-module-table
- set-global!
- get-global
+
+ ;; calling conventions
;; global environment
*global-env-table*
@@ -191,9 +191,16 @@
(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))
+;;;;; BUILT-INS
+
(define-syntax define-global
(syntax-rules ()
((_ name value)
@@ -229,7 +236,7 @@
(define message (if (null? opts) "assertion failed" (car opts)))
(if (false? v)
(runtime-error message)
- (apply values (cons assert (cons v opts)))))
+ (apply values (cons v opts))))
(define-global (print . arguments)
(for-each
@@ -290,8 +297,7 @@
;; require
(define (register-loaded-module name table)
- ;; TODO: needs to be fixed to use _G once globals are fixed
- (module-define! (resolve-module '(language lua global-environment))
(string->symbol name) table)
+ (rawset *global-env-table* name table)
(rawset loaded name table))
(define (module-exists? name)
diff --git a/module/language/lua/standard/math.scm
b/module/language/lua/standard/math.scm
index f93a3fd..dabda0d 100644
--- a/module/language/lua/standard/math.scm
+++ b/module/language/lua/standard/math.scm
@@ -1,21 +1,75 @@
(define-module (language lua standard math)
#:use-module (language lua runtime))
-;; abs, acos, asin, atan, atan2, ceil, cos, cosh, deg, exp, floor, fmod, frexp,
-;; huge (???), ldexp, log, log10, max, min, modf, pi, pow, rad, random,
randomseed,
-;; sin, sinh, sqrt, tan, tanh
+;; TODO: deg, rad, pi, frexp, ldexp
+;; TODO: random does not support lower limit
(letrec-syntax
- ((wrap-math-procedures
- (syntax-rules ()
- ((_ () (1 name))
+ ((wrap-builtins
+ (syntax-rules (rename 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))
+ (define (lua-name a . _)
+ ((@ (guile) guile-name) a)))
+
+ ;; simple wrap with 2 arguments
+ ((_ () (2 name))
+ (define (name a b . _)
+ ((@ (guile) name) a b)))
+
+ ;; simple wrap with variable arguments
+ ((_ () (variable-arity name))
+ (define (name . _)
+ (apply (@ (guile) name) _)))
+
+ ;; simple wrap with 1 argument
+ ((_ () name)
(define (name a . _)
((@ (guile) name) a)))
- ((_ () (name))
- (wrap-math-procedures () (1 name)))
+
+ ;; 1) take all input and pass it to subtransformers
((_ subform ...)
(begin
- (wrap-math-procedures () subform)
+ (wrap-builtins () subform)
...)))))
- (wrap-math-procedures
- (abs)))
+ (wrap-builtins
+ abs
+ acos
+ asin
+ atan
+ (rename ceil ceiling)
+ cos
+ cosh
+ exp
+ floor
+ log
+ log10
+ ;; DIFFERENCE: sqrt accepts negative arguments
+ sqrt
+ sin
+ sinh
+ (variable-arity max)
+ (variable-arity min)
+ (rename pow expt)
+ tan
+ tanh))
+
+(define (atan2 x y)
+ (atan (/ x y)))
+
+(define (randomseed seed . _)
+ (set! *random-state* (seed->random-state seed))
+ *unspecified*)
+
+(define (random . _)
+ (if (null? _)
+ ((@ (guile) random) 1)
+ (begin
+ (format #t "Guile-Lua runtime warning: 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
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 91ff8c7..8085648 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -6,12 +6,12 @@
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
-;;;;
+;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
@@ -137,7 +137,7 @@
((bytevector-s16-set! . 4) . bv-s16-set)
((bytevector-s16-native-ref . 2) . bv-s16-native-ref)
((bytevector-s16-native-set! . 3) . bv-s16-native-set)
-
+
((bytevector-u32-ref . 3) . bv-u32-ref)
((bytevector-u32-set! . 4) . bv-u32-set)
((bytevector-u32-native-ref . 2) . bv-u32-native-ref)
@@ -146,7 +146,7 @@
((bytevector-s32-set! . 4) . bv-s32-set)
((bytevector-s32-native-ref . 2) . bv-s32-native-ref)
((bytevector-s32-native-set! . 3) . bv-s32-native-set)
-
+
((bytevector-u64-ref . 3) . bv-u64-ref)
((bytevector-u64-set! . 4) . bv-u64-set)
((bytevector-u64-native-ref . 2) . bv-u64-native-ref)
@@ -155,7 +155,7 @@
((bytevector-s64-set! . 4) . bv-s64-set)
((bytevector-s64-native-ref . 2) . bv-s64-native-ref)
((bytevector-s64-native-set! . 3) . bv-s64-native-set)
-
+
((bytevector-ieee-single-ref . 3) . bv-f32-ref)
((bytevector-ieee-single-set! . 4) . bv-f32-set)
((bytevector-ieee-single-native-ref . 2) . bv-f32-native-ref)
@@ -175,7 +175,7 @@
(pmatch (hashq-ref (hashq-ref allocation v) proc)
((#t ,boxed? . ,n)
(list id boxed? n))
- (,x (error "badness" id v x))))
+ (,x (error "badness-1" id v x))))
ids
vars))
@@ -231,7 +231,7 @@
(emit-branch #f 'br RA)
(if (eq? context 'tail)
(emit-code #f (make-glil-call 'return 1)))))
-
+
(record-case x
((<void>)
(case context
@@ -301,7 +301,7 @@
(make-application src (make-primitive-ref #f 'apply)
(cons proc args)))
(maybe-emit-return)))))))
-
+
((and (primitive-ref? proc) (eq? (primitive-ref-name proc) 'values)
(not (eq? context 'push)))
;; tail: (lambda () (values '(1 2)))
@@ -317,7 +317,7 @@
((tail)
(for-each comp-push args)
(emit-code src (make-glil-call 'return/values (length args))))))
-
+
((and (primitive-ref? proc)
(eq? (primitive-ref-name proc) '@call-with-values)
(= (length args) 2))
@@ -395,7 +395,7 @@
(case context
((tail push vals) (emit-code #f (make-glil-void))))
(maybe-emit-return))
-
+
((and (primitive-ref? proc)
(or (hash-ref *primcall-ops*
(cons (primitive-ref-name proc) (length args)))
@@ -415,7 +415,7 @@
(else
(error "bad primitive op: too many pushes"
op (instruction-pushes op))))))
-
+
;; self-call in tail position
((and (lexical-ref? proc)
self-label (eq? (lexical-ref-gensym proc) self-label)
@@ -450,7 +450,7 @@
(emit-code #f (make-glil-lexical #t #f 'set i)))
(reverse (iota (length args))))
(emit-branch src 'br self-label)))))
-
+
;; lambda, the ultimate goto
((and (lexical-ref? proc)
(assq (lexical-ref-gensym proc) fix-labels))
@@ -488,7 +488,7 @@
;; object. but for now error, as this sort of case should
;; preclude label allocation.
(error "couldn't find matching case for label call" x)))))
-
+
(else
(if (not (eq? context 'tail))
(emit-code src (make-glil-call 'new-frame 0)))
@@ -549,7 +549,7 @@
(comp-push (car args))
(comp-push (cadr args))
(emit-branch src 'br-if-eq L1))
-
+
((and (eq? name 'null?) (= len 1))
(comp-push (car args))
(emit-branch src 'br-if-null L1))
@@ -563,7 +563,7 @@
(else
(comp-push app)
(emit-branch src 'br-if L1)))))
-
+
(else
(comp-push test)
(emit-branch src 'br-if-not L1)))))
@@ -583,7 +583,7 @@
(comp-tail alternate)
(if (and (not RA) (not (eq? context 'tail)))
(emit-label L2))))
-
+
((<primitive-ref> src name)
(cond
((eq? (module-variable (fluid-ref *comp-module*) name)
@@ -611,27 +611,27 @@
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'ref index)))
(,loc
- (error "badness" x loc)))))
+ (error "badness-2" x loc)))))
(maybe-emit-return))
-
+
((<lexical-set> src gensym exp)
(comp-push exp)
(pmatch (hashq-ref (hashq-ref allocation gensym) self)
((,local? ,boxed? . ,index)
(emit-code src (make-glil-lexical local? boxed? 'set index)))
(,loc
- (error "badness" x loc)))
+ (error "badness-3" x loc)))
(case context
((tail push vals)
(emit-code #f (make-glil-void))))
(maybe-emit-return))
-
+
((<module-ref> src mod name public?)
(emit-code src (make-glil-module 'ref mod name public?))
(case context
((drop) (emit-code #f (make-glil-call 'drop 1))))
(maybe-emit-return))
-
+
((<module-set> src mod name public? exp)
(comp-push exp)
(emit-code src (make-glil-module 'set mod name public?))
@@ -645,7 +645,7 @@
(case context
((drop) (emit-code #f (make-glil-call 'drop 1))))
(maybe-emit-return))
-
+
((<toplevel-set> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'set name))
@@ -653,7 +653,7 @@
((tail push vals)
(emit-code #f (make-glil-void))))
(maybe-emit-return))
-
+
((<toplevel-define> src name exp)
(comp-push exp)
(emit-code src (make-glil-toplevel 'define name))
@@ -679,7 +679,7 @@
(emit-code #f (make-glil-call 'make-closure
(length free-locs))))))))
(maybe-emit-return))
-
+
((<lambda-case> src req opt rest kw inits gensyms alternate body)
;; o/~ feature on top of feature o/~
;; req := (name ...)
@@ -774,7 +774,7 @@
(begin
(emit-label alternate-label)
(comp-tail alternate)))))
-
+
((<let> src names gensyms vals body)
(for-each comp-push vals)
(emit-bindings src names gensyms allocation self emit-code)
@@ -784,7 +784,7 @@
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "badness-3" x loc))))
(reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
@@ -795,7 +795,7 @@
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'empty-box n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "badness-4" x loc))))
gensyms)
;; Even though the slots are empty, the bindings are valid.
(emit-bindings src names gensyms allocation self emit-code)
@@ -807,7 +807,7 @@
((#t #t . ,n)
(comp-push val)
(emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "badness-5" x loc))))
names gensyms vals))
(else
;; But for letrec, eval all values, then bind.
@@ -816,7 +816,7 @@
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'set n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "badness-6" x loc))))
(reverse gensyms))))
(comp-tail body)
(emit-code #f (make-glil-unbind)))
@@ -852,7 +852,7 @@
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code src (make-glil-lexical #t #f 'set n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "badness-7" x loc))))
(else
;; labels allocation: emit label & body, but jump over it
(let ((POST (make-label)))
@@ -901,7 +901,7 @@
(pmatch (hashq-ref (hashq-ref allocation v) self)
((#t #f . ,n)
(emit-code #f (make-glil-lexical #t #f 'fix n)))
- (,loc (error "badness" x loc)))))))
+ (,loc (error "badness-8" x loc)))))))
vals
gensyms)
(comp-tail body)
@@ -929,7 +929,7 @@
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "badness-9" x loc))))
(reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind))))))
@@ -953,34 +953,34 @@
(comp-drop (make-application src unwinder '()))
;; ...and return the val
(emit-code #f (make-glil-call 'return 1))
-
+
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '()))
;; and return the values.
(emit-code #f (make-glil-call 'return/nvalues 1))))
-
+
((push)
;; we only want one value. so ask for one value
(comp-push body)
;; and unwind, leaving the val on the stack
(emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '())))
-
+
((vals)
(let ((MV (make-label)))
(comp-vals body MV)
;; one value: push 1 and fall through to MV case
(emit-code #f (make-glil-const 1))
-
+
(emit-label MV)
;; multiple values: unwind...
(emit-code #f (make-glil-call 'unwind 0))
(comp-drop (make-application src unwinder '()))
;; and goto the MVRA.
(emit-branch #f 'br MVRA)))
-
+
((drop)
;; compile body, discarding values. then unwind...
(comp-drop body)
@@ -1007,27 +1007,27 @@
;; one value: unwind and return
(emit-code #f (make-glil-call 'unwind-fluids 0))
(emit-code #f (make-glil-call 'return 1))
-
+
(emit-label MV)
;; multiple values: unwind and return values
(emit-code #f (make-glil-call 'unwind-fluids 0))
(emit-code #f (make-glil-call 'return/nvalues 1))))
-
+
((push)
(comp-push body)
(emit-code #f (make-glil-call 'unwind-fluids 0)))
-
+
((vals)
(let ((MV (make-label)))
(comp-vals body MV)
;; one value: push 1 and fall through to MV case
(emit-code #f (make-glil-const 1))
-
+
(emit-label MV)
;; multiple values: unwind and goto MVRA
(emit-code #f (make-glil-call 'unwind-fluids 0))
(emit-branch #f 'br MVRA)))
-
+
((drop)
;; compile body, discarding values. then unwind...
(comp-drop body)
@@ -1044,7 +1044,7 @@
(comp-push fluid)
(emit-code #f (make-glil-call 'fluid-ref 1))))
(maybe-emit-return))
-
+
((<dynset> src fluid exp)
(comp-push fluid)
(comp-push exp)
@@ -1053,7 +1053,7 @@
((push vals tail)
(emit-code #f (make-glil-void))))
(maybe-emit-return))
-
+
;; What's the deal here? The deal is that we are compiling the start of a
;; delimited continuation. We try to avoid heap allocation in the normal
;; case; so the body is an expression, not a thunk, and we try to render
@@ -1082,14 +1082,14 @@
(emit-label MV)
(emit-code #f (make-glil-call 'unwind 0))
(emit-code #f (make-glil-call 'return/nvalues 1))))
-
+
((push)
;; we only want one value. so ask for one value, unwind, and jump
to
;; post
(comp-push body)
(emit-code #f (make-glil-call 'unwind 0))
(emit-branch #f 'br POST))
-
+
((vals)
(let ((MV (make-label)))
(comp-vals body MV)
@@ -1099,13 +1099,13 @@
(emit-label MV)
(emit-code #f (make-glil-call 'unwind 0))
(emit-branch #f 'br MVRA)))
-
+
((drop)
;; compile body, discarding values, then unwind & fall through.
(comp-drop body)
(emit-code #f (make-glil-call 'unwind 0))
(emit-branch #f 'br (or RA POST))))
-
+
(emit-label H)
;; Now the handler. The stack is now made up of the continuation, and
;; then the args to the continuation (pushed separately), and then the
@@ -1125,7 +1125,7 @@
(emit-code src (make-glil-lexical #t #f 'set n)))
((#t #t . ,n)
(emit-code src (make-glil-lexical #t #t 'box n)))
- (,loc (error "badness" x loc))))
+ (,loc (error "badness-10" x loc))))
(reverse gensyms))
(comp-tail body)
(emit-code #f (make-glil-unbind))))
diff --git a/test-suite/tests/lua-eval.test b/test-suite/tests/lua-eval.test
index 0f8e965..4bebffa 100644
--- a/test-suite/tests/lua-eval.test
+++ b/test-suite/tests/lua-eval.test
@@ -139,7 +139,7 @@ return _G._G.a")
return _G._G._G.a")
;; built-in functions
- (test "assert(true)" #nil)
+ (test "assert(true)" #t)
(test "print(T)" #nil)
(test "print(false or true)" #nil)
(test "table = {}; rawset(table, 0, true); return table[0]")
diff --git a/test-suite/tests/lua-math.test b/test-suite/tests/lua-math.test
new file mode 100644
index 0000000..c24c2dd
--- /dev/null
+++ b/test-suite/tests/lua-math.test
@@ -0,0 +1,47 @@
+; -*- 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-math"
+ (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 "require 'math'; return true")
+ (test "return math.abs(-1)" 1)
+ (test "return math.asin(1)" (asin 1))
+ (test "return math.acos(5)" (acos 5))
+ (test "return math.atan(2/1)" (atan (/ 2 1)))
+ (test "return math.atan2(2,1)" (atan (/ 2 1)))
+ (test "return math.ceil(0.5)" (ceiling 0.5))
+ (test "return math.cos(1)" (cos 1))
+ (test "return math.cosh(1)" (cosh 1))
+ (test "return math.floor(0.5)" (floor 0.5))
+ (test "return math.log(10)" (log 10))
+ (test "return math.log10(5)" (log10 5))
+ (test "return math.sqrt(4)" (sqrt 4))
+ (test "return math.sin(5)" (sin 5))
+ (test "return math.sinh(5)" (sinh 5))
+ (test "return math.tan(5)" (tan 5))
+ (test "return math.tanh(5)" (tanh 5))
+
+
+))
+
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, lua, updated. release_1-9-11-246-gb9fa70d,
No Itisnt <=