Permalink
Browse files

Improve _t-univ.scm tests and fix minor bugs (Python's bool type is a…

… subtype of int).
  • Loading branch information...
1 parent 0de1fcd commit 62bedea94c68a4a64fca3c2188e63c1a55878754 @feeley feeley committed Jun 2, 2012
Showing with 180 additions and 35 deletions.
  1. +100 −32 gsc/_t-univ.scm
  2. +2 −2 gsc/runtests.scm
  3. +26 −0 gsc/tests/eq.scm
  4. +11 −0 gsc/tests/fixnum.scm
  5. +11 −0 gsc/tests/flonum.scm
  6. +17 −0 gsc/tests/not.scm
  7. +12 −0 gsc/tests/println.scm
  8. +1 −1 include/stamp.h
View
@@ -651,23 +651,48 @@
(translate-lbl ctx gvm-opnd))
((obj? gvm-opnd)
- (let ((val (obj-val gvm-opnd)))
- (cond ((number? val)
- (gen val))
- ((void-object? val)
- (gen "undefined"))
- ((proc-obj? val)
- (lbl->id ctx 1 (proc-obj-name val)))
- (else
- (gen "UNIMPLEMENTED_OBJECT("
- (object->string val)
- ")")))))
+ (translate-obj ctx (obj-val gvm-opnd)))
(else
(compiler-internal-error
"translate-gvm-opnd, unknown 'gvm-opnd':"
gvm-opnd))))
+(define (translate-obj ctx obj)
+ (cond ((boolean? obj)
+ (univ-boolean ctx obj))
+ ((number? obj)
+ (if (exact? obj)
+ (cond ((integer? obj)
+ (gen obj))
+ (else
+ (compiler-internal-error
+ "translate-obj, unsupported exact number:" obj)))
+ (cond ((real? obj)
+ (let ((x
+ (if (integer? obj)
+ (gen obj 0)
+ (gen obj))))
+ (case (target-name (ctx-target ctx))
+ ((js)
+ (gen "new Flonum(" x ")"))
+ (else
+ x))))
+ (else
+ (compiler-internal-error
+ "translate-obj, unsupported inexact number:" obj)))))
+ ((string? obj)
+ ;; TODO: fix JS which has immutable strings
+ (gen (object->string obj)))
+ ((void-object? obj)
+ (gen "undefined"))
+ ((proc-obj? obj)
+ (lbl->id ctx 1 (proc-obj-name obj)))
+ (else
+ (gen "UNIMPLEMENTED_OBJECT("
+ (object->string obj)
+ ")"))))
+
(define (translate-lbl ctx lbl)
(lbl->id ctx (lbl-num lbl) (ctx-ns ctx)))
@@ -703,7 +728,14 @@ function Flonum(val) {
function lbl1_println() { // println
if (nargs !== 1)
throw "wrong number of arguments";
- print(reg[1]);
+ if (reg[1] === false)
+ print("#f");
+ else if (reg[1] === true)
+ print("#t");
+ else if (reg[1] instanceof Flonum)
+ print(reg[1].val);
+ else
+ print(reg[1]);
return reg[0];
}
@@ -738,7 +770,13 @@ def lbl1_println(): # println
global glo, reg, stack, sp, nargs, temp1, temp2
if nargs != 1:
raise "wrong number of arguments"
- print(reg[1])
+ if reg[1] is False:
+ print("#f")
+ else:
+ if reg[1] is True:
+ print("#t")
+ else:
+ print(reg[1])
return reg[0]
glo["println"] = lbl1_println
@@ -770,7 +808,15 @@ $lbl1_println = lambda { # println
if $nargs != 1
raise "wrong number of arguments"
end
- print($reg[1])
+ if $reg[1] == false
+ print("#f")
+ else
+ if $reg[1] == true
+ print("#t")
+ else
+ print($reg[1])
+ end
+ end
print("\n")
return $reg[0]
}
@@ -951,18 +997,18 @@ EOF
(compiler-internal-error
"univ-not=, unknown target"))))
-(define (univ-false ctx)
+(define (univ-boolean ctx val)
(case (target-name (ctx-target ctx))
((js ruby php)
- (gen "false"))
+ (gen (if val "true" "false")))
((python)
- (gen "False"))
+ (gen (if val "True" "False")))
(else
(compiler-internal-error
- "univ-false, unknown target"))))
+ "univ-boolean, unknown target"))))
(define (univ-assign ctx loc expr)
(case (target-name (ctx-target ctx))
@@ -1091,19 +1137,19 @@ EOF
(lambda (ctx opnds)
(ifjump-gen ctx opnds)))))))
-(define (univ-define-prim-bool name proc-safe? side-effects? gen)
- (univ-define-prim name proc-safe? side-effects? gen gen))
+(define (univ-define-prim-bool name proc-safe? side-effects? prim-gen)
+ (univ-define-prim name proc-safe? side-effects? prim-gen prim-gen))
;;; Primitive procedures
-(univ-define-prim-bool "##not" #f #f
+(univ-define-prim-bool "##not" #t #f
(lambda (ctx opnds)
(univ-eq ctx
(translate-gvm-opnd ctx (list-ref opnds 0))
- (univ-false ctx))))
+ (univ-boolean ctx #f))))
-(univ-define-prim-bool "##eq?" #f #f
+(univ-define-prim-bool "##eq?" #t #f
(lambda (ctx opnds)
(univ-eq ctx
@@ -1140,13 +1186,36 @@ EOF
(univ-define-prim-bool "##fx<" #f #f
(lambda (ctx opnds)
- (univ-< (translate-gvm-opnd ctx (list-ref opnds 0))
+ (univ-< ctx
+ (translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
+(univ-define-prim-bool "##fx<=" #f #f
+
+ (lambda (ctx opnds)
+ (univ-<= ctx
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ (translate-gvm-opnd ctx (list-ref opnds 1)))))
+
+(univ-define-prim-bool "##fx>" #f #f
+
+ (lambda (ctx opnds)
+ (univ-> ctx
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ (translate-gvm-opnd ctx (list-ref opnds 1)))))
+
+(univ-define-prim-bool "##fx>=" #f #f
+
+ (lambda (ctx opnds)
+ (univ->= ctx
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ (translate-gvm-opnd ctx (list-ref opnds 1)))))
+
(univ-define-prim-bool "##fx=" #f #f
(lambda (ctx opnds)
- (univ-= (translate-gvm-opnd ctx (list-ref opnds 0))
+ (univ-= ctx
+ (translate-gvm-opnd ctx (list-ref opnds 0))
(translate-gvm-opnd ctx (list-ref opnds 1)))))
(univ-define-prim "##fx+?" #f #f
@@ -1374,9 +1443,7 @@ EOF
#f)
-(univ-define-prim "##fixnum?" #f #f
-
- #f
+(univ-define-prim-bool "##fixnum?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
@@ -1389,7 +1456,10 @@ EOF
((python)
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
- ", int)"))
+ ", int) and not "
+ "isinstance("
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ", bool)"))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
@@ -1404,9 +1474,7 @@ EOF
(compiler-internal-error
"##fixnum?, unknown target")))))
-(univ-define-prim "##flonum?" #f #f
-
- #f
+(univ-define-prim-bool "##flonum?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
View
@@ -36,9 +36,9 @@
(if (not (equal? result (car results)))
(begin
(if (not diff?)
- (print "\n================ EXPECTED:\n" (cdr (car results))))
+ (print " (FAILED)\n======================= EXPECTED:\n" (cdr (car results))))
(set! diff? #t)
- (print "================ " (car target) ":\n" (cdr result)))))
+ (print "======================= " (car target) ":\n" (cdr result)))))
(cdr results)
(cdr targets))
View
@@ -0,0 +1,26 @@
+(declare (extended-bindings))
+
+(define str "")
+(define fl0 0.0)
+(define fl1 1.0)
+
+(define (test2 x y)
+ (println (##eq? x y))
+ (println (if (##eq? x y) "yes" "no")))
+
+(define (test x)
+ (test2 x #t)
+ (test2 x #f)
+ (test2 x 0)
+ (test2 x 1)
+ (test2 x str)
+ (test2 x fl0)
+ (test2 x fl1))
+
+(test #t)
+(test #f)
+(test 0)
+(test 1)
+(test str)
+(test fl0)
+(test fl1)
View
@@ -0,0 +1,11 @@
+(declare (extended-bindings))
+
+(define (test x)
+ (println (##fixnum? x))
+ (println (if (##fixnum? x) "yes" "no")))
+
+(test #t)
+(test #f)
+(test 0)
+(test 1)
+(test "")
View
@@ -0,0 +1,11 @@
+(declare (extended-bindings))
+
+(define (test x)
+ (println (##flonum? x))
+ (println (if (##flonum? x) "yes" "no")))
+
+(test #t)
+(test #f)
+(test 0)
+(test 1)
+(test "")
View
@@ -0,0 +1,17 @@
+(declare (extended-bindings))
+
+(define str "")
+(define fl0 0.0)
+(define fl1 1.0)
+
+(define (test x)
+ (println (##not x))
+ (println (if (##not x) "yes" "no")))
+
+(test #t)
+(test #f)
+(test 0)
+(test 1)
+(test str)
+(test fl0)
+(test fl1)
View
@@ -0,0 +1,12 @@
+(println 0)
+(println 1)
+(println -1)
+(println 123456789)
+(println -123456789)
+
+(println #t)
+(println #f)
+
+(println "hello")
+
+(println 1.5)
View
@@ -3,4 +3,4 @@
*/
#define ___STAMP_YMD 20120602
-#define ___STAMP_HMS 110636
+#define ___STAMP_HMS 184525

0 comments on commit 62bedea

Please sign in to comment.