summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/language/lua/compile-tree-il.scm28
-rw-r--r--module/language/lua/notes.org31
-rw-r--r--module/language/lua/parser.scm9
-rw-r--r--module/language/lua/standard/math.scm49
-rw-r--r--test-suite/tests/lua-eval-3.test49
5 files changed, 123 insertions, 43 deletions
diff --git a/module/language/lua/compile-tree-il.scm b/module/language/lua/compile-tree-il.scm
index 1cbd31882..dcd2956cc 100644
--- a/module/language/lua/compile-tree-il.scm
+++ b/module/language/lua/compile-tree-il.scm
@@ -104,7 +104,6 @@ dropped silently"
;; singly-valued continuation.
(make-application src (make-primitive-ref src 'values) (list exp)))
-
;; main compiler
(define context (make-parameter #f))
@@ -149,7 +148,7 @@ dropped silently"
src meta
(make-lambda-case src '() arguments '... #f
(map (lambda (x) (make-const src #nil)) arguments)
- (append! argument-gensyms (list '...))
+ (append argument-gensyms (list (gensym "...")))
(compile body)
#f))))
@@ -210,7 +209,7 @@ dropped silently"
;; FIXME: use abort instead of throw
(make-application src (make-module-ref src '(guile) 'throw #t)
(list (make-const src 'lua-break))))
-
+
;; FIXME: use prompt and abort instead of throw and catch
((ast-list-for-loop src names gs-names exps body)
(let* ((gs-iterator (gensym "iterator"))
@@ -260,7 +259,7 @@ dropped silently"
;; initialize variables and start loop
(begin
(apply (primitive call-with-values)
- (lambda ()
+ (lambda ()
(lambda-case
(,no-arguments
,(unparse-tree-il
@@ -305,7 +304,7 @@ dropped silently"
(gs-loop (gensym "loop"))
(while-condition
`(if (apply (primitive >) (lexical step ,gs-step) (const 0))
- (if (apply (primitive <=)
+ (if (apply (primitive <=)
(lexical variable ,gs-variable)
(lexical limit ,gs-limit))
(apply (lexical loop ,gs-loop))
@@ -401,6 +400,7 @@ dropped silently"
((not) (make-primitive-ref src 'not)))
(list (compile right)))))
+
((ast-binary-operation src operator left right)
(let ((left (compile left))
(right (compile right)))
@@ -417,10 +417,20 @@ dropped silently"
((#:==) (make-runtime-application src 'eq (list left right)))
((#:~=) (make-runtime-application src 'neq (list left right)))
((#:concat) (make-runtime-application src 'concat (list left right)))
- ;; FIXME: double-evaluation
- ((#:or) (make-conditional src left left right))
- ;; FIXME: double-evaluation
- ((#:and) (make-conditional src left right left))
+ ((#:or)
+ (let ((tmp (gensym "or-tmp")))
+ (make-let src '(or-tmp) (list tmp) (list left)
+ (make-conditional src
+ (make-lexical-ref src 'or-tmp tmp)
+ (make-lexical-ref src 'or-tmp tmp)
+ right))))
+ ((#:and)
+ (let ((tmp (gensym "and-tmp")))
+ (make-let src '(and-tmp) (list tmp) (list left)
+ (make-conditional src
+ (make-lexical-ref src 'and-tmp tmp)
+ right
+ (make-lexical-ref src 'and-tmp tmp)))))
(else (error #:COMPILE "unknown binary operator" operator)))))))
;; exported compiler function
diff --git a/module/language/lua/notes.org b/module/language/lua/notes.org
new file mode 100644
index 000000000..49f6b12fe
--- /dev/null
+++ b/module/language/lua/notes.org
@@ -0,0 +1,31 @@
+This is an org-mode todo list of stuff that needs to be done for Guile Lua.
+
+* Before inclusion
+** DONE And/or evaluate too much
+ CLOSED: [2011-04-19 Tue 19:36]
+** DONE Standard library functions: math.modf, math.fmod
+ CLOSED: [2011-04-21 Thu 15:43]
+** TODO Variable arguments and multiple returns
+** TODO Use prompt and abort instead of throw and catch
+** TODO Standard library function: module
+** TODO Standard library function: table.sort
+** TODO Get the official test suite running
+
+* Eh
+** TODO Better testing of standard library modules io, os
+** TODO Function environments (getfenv and setfenv)
+** TODO Parser should probably be rewritten
+
+
+* Differences
+ Here are some difference in Guile Lua's behavior that should not cause
+ problems in porting Lua code.
+
+** Guile Lua will accept the "break" statement anywhere
+ For instance:
+ for k,v in table do
+ function breaky() break end
+ end
+ Would be rejected by Lua but not by Guile Lua.
+
+** math.sqrt accepts negative arguments since Guile's numeric tower is capable of representing complex numbers
diff --git a/module/language/lua/parser.scm b/module/language/lua/parser.scm
index 1a04f89da..52cf5a381 100644
--- a/module/language/lua/parser.scm
+++ b/module/language/lua/parser.scm
@@ -125,7 +125,8 @@
(define *special-tokens*
'(#\. #\( #\) #\, #\- #\< #\; #\+ #\{ #\} #\[ #\] #\: #\#
#:function #:end #:if #:return #:elseif #:then #:else #:true #:false
- #:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in))
+ #:nil #:== #:~= #:= #\> #:>= #:<= #:local #:dots #:break #:do #:in
+ #:and #:or))
(define (token/type t)
(cond
@@ -252,11 +253,11 @@
"Given a variable's NAME, look up its binding."
(and e (or (assq-ref (environment-bindings e) name)
(environment-lookup-aux name (environment-parent e)))))
-
+
(define (environment-lookup-gensym name)
"Given a variable's NAME, look up its gensym"
(and=> (environment-lookup-aux name) binding-gensym))
-
+
(define (environment-lookup-type name)
"Given a variable's NAME, look up its global"
(and=> (environment-lookup-aux name) binding-type))
@@ -675,7 +676,7 @@
*void-literal*)))))))
(enforce-next! #:end)
x))))
-
+
;; repeat-statement -> REPEAT chunk UNTIL expression
(define (repeat-statement)
(let ((src (get-source-info)))
diff --git a/module/language/lua/standard/math.scm b/module/language/lua/standard/math.scm
index 91ccd174f..dd2bbbce2 100644
--- a/module/language/lua/standard/math.scm
+++ b/module/language/lua/standard/math.scm
@@ -21,14 +21,14 @@
(define-module (language lua standard math)
#:use-module (language lua runtime))
-;; TODO: math.modf
-;; TODO: math.deg,rad,frexp,random not tested
+;; TODO: math.frexp
;; 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))
+;; We define some constants here to more closely match Lua's behavior
(define pi 3.14159265358979323846)
(define radians_per_degree (/ pi 180.0))
@@ -91,27 +91,9 @@
(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 . _)
- (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*)
@@ -124,13 +106,20 @@
(lambda (x)
(/ (log x) log2))))
-(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)))
+(define (rad x)
+ (* x radians_per_degree))
+
+;; copy the global random state for this module so we don't mutate it
+(define randomstate (copy-random-state *random-state*))
+
+(define (randomseed seed . _)
+ (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"))))
diff --git a/test-suite/tests/lua-eval-3.test b/test-suite/tests/lua-eval-3.test
new file mode 100644
index 000000000..881389c32
--- /dev/null
+++ b/test-suite/tests/lua-eval-3.test
@@ -0,0 +1,49 @@
+;;;; lua-eval-2.test --- basic tests for builtin lua constructs, act III -*- mode: scheme -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; 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
+
+(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 #f "~S => ~S" string expect) (equal? (from-string string) expect)))
+ ((_ string)
+ (test string #t)))))
+
+ ;; make sure logical expressions don't evaluate expressions twice
+ ;;; y will equal 2 in case of extra eval
+ (test "y = 0 function tmp() y = y + 1 return true end assert(tmp() or tmp()) return y == 1")
+ ;;; y will equal 4 in case of extra eval
+ (test "y = 0 function tmp() y = y + 2 return false end; function tmp2() y = y + 1 return true end; print(tmp() and tmp2()) print(y) return y == 2")
+ ))