scm: Evaluate arguments of OR only once.

* module/mes/base.mes (or): Evaluate arguments only once.
* module/mes/read-0.mes (or): Likewise.
* tests/base.test ("or only once"): Test it.
* module/mes/read-0-32.mo: Regenerate.

diff --git a/module/mes/base.mes b/module/mes/base.mes
index 1c2f67986635a4a14b21405026668ab5f2751ec4..ad66a9876212e1d2c10fd6734a7c5a255b523073 100644 (file)
--- a/module/mes/base.mes
+++ b/module/mes/base.mes
@@ -73,18 +73,20 @@
 
 (define (command-line) %argv)
 
-(define-macro (or . x)
-  (if (null? x) #f
-      (if (null? (cdr x)) (car x)
-          (list 'if (car x) (car x)
-                (cons 'or (cdr x))))))
-
 (define-macro (and . x)
   (if (null? x) #t
       (if (null? (cdr x)) (car x)
           (list 'if (car x) (cons 'and (cdr x))
                 #f))))
 
+(define-macro (or . x)
+  (if (null? x) #f
+      (if (null? (cdr x)) (car x)
+          (list (list 'lambda (list 'r)
+                      (list 'if 'r 'r
+                            (cons 'or (cdr x))))
+                (car x)))))
+
 (define (and=> value procedure) (and value (procedure value)))
 (define eqv? eq?)
 

diff --git a/module/mes/read-0-32.mo b/module/mes/read-0-32.mo
index 915d5942a616a87d4ca7a160ff9fb512dcc7ea0e..4cd530f24e5bf4a0c4e8efefa4325a2ba581dd29 100644 (file)
Binary files a/module/mes/read-0-32.mo and b/module/mes/read-0-32.mo differ

diff --git a/module/mes/read-0.mes b/module/mes/read-0.mes
index 7dd4888ecff1446cd2431a07f579da37fa563456..7dab5d84cb1154831f2114b235d713b8701f5746 100644 (file)
--- a/module/mes/read-0.mes
+++ b/module/mes/read-0.mes
@@ -198,8 +198,11 @@
   (define-macro (or . x)
     (if (null? x) #f
         (if (null? (cdr x)) (car x)
-            (list (quote if) (car x) (car x)
-                  (cons (quote or) (cdr x))))))
+            (list (list (quote lambda) (list (quote r))
+                        (list (quote if) (quote r) (quote r)
+                              (cons (quote or) (cdr x))))
+                  (car x)))))
+
   (define (not x)
     (if x #f #t))
   

diff --git a/tests/base.test b/tests/base.test
index 3bdbceb65928cb358a37f24ac58ffd057dfb7908..fef26f56da2183fe1cd89fbcdcb6b5f0b14b46df 100755 (executable)
--- a/tests/base.test
+++ b/tests/base.test
@@ -76,6 +76,17 @@ exit $?
 (pass-if "or 3" (seq? (or #f (= 0 1) 3) 3))
 (pass-if "or 4" (seq? (or (= 0 0) (= 0 1)) #t))
 (pass-if "or 5" (seq? (or (= 0 1) (= 0 0)) #t))
+(pass-if-equal "or only once"
+               1
+               (let ()
+                 (define read
+                   (let ((lst '(1 0)))
+                     (lambda ()
+                       (let ((r (car lst)))
+                         (set! lst (cdr lst))
+                         r))))
+                 (or (read) #t)))
+
 (pass-if "let" (seq? (let () 0) 0))
 (pass-if "let 2" (seq? (let ((x 0)) x) 0))
 (pass-if "let 3" (seq? (let ((p 5) (q 6)) (+ p q)) 11))