Fix and/or double evaluation. Add math.modf, math.fmod.

* module/language/lua/compile-tree-il.scm: Fix and/or double evaluation.

* module/language/lua/notes.org: Add file describing known issues.

* module/language/lua/parser.scm: (token-type): Recognize and/or.

* module/language/lua/standard/math.scm: Add modf, fmod implementations.

* test-suite/tests/lua-eval-3.test: Add another test file for basic
  language features.

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

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

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)))

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,6 +91,24 @@
 (define (atan2 x y)
   (atan (/ x y)))
 
+(define (deg 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 log2
+  (let ((log2 (log 2)))
+    (lambda (x)
+      (/ (log x) log2))))
+
+(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*))
 
@@ -105,32 +123,3 @@
         ((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 log2
-  (let ((log2 (log 2)))
-    (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)))

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")
+  ))