Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Added some tests. Implementing lists/pairs but not completed.

  • Loading branch information...
commit 085fb697a72ae87566c2981bd8d069300b859a3d 1 parent 61e7f96
@Gabriano Gabriano authored
View
431 gsc/_t-univ.scm
@@ -690,6 +690,12 @@
((string? obj)
(univ-string ctx obj))
+
+ ((null? obj)
+ (univ-null ctx obj))
+
+ ((list? obj)
+ (univ-list ctx obj))
((void-object? obj)
(gen "undefined"))
@@ -793,98 +799,174 @@ function Gambit_Char(i) {
this.i = i;
}
-Gambit_Char.integerToChar = function (i) {
- var ch = Gambit_chars[i];
+Gambit_Char.fxToChar = function ( i ) {
+ var ch = Gambit_chars[i];
- if (!ch) {
- Gambit_chars[i] = new Gambit_Char(i);
- ch = Gambit_chars[i];
- }
+ if (!ch) {
+ Gambit_chars[i] = new Gambit_Char(i);
+ ch = Gambit_chars[i];
+ }
- return ch;
+ return ch;
+}
+
+Gambit_Char.charToFx = function ( c ) {
+ return c.i;
}
Gambit_Char.prototype.toString = function ( ) {
- return String.fromCharCode(this.i);
+ return String.fromCharCode(this.i);
+}
+
+// pair obj
+function Gambit_Pair ( car, cdr ) {
+ this.car = car;
+ this.cdr = cdr;
+}
+
+function Gambit_pairp ( p ) {
+ return (p instanceof Gambit_Pair);
+}
+
+Gambit_Pair.prototype.toString = function ( ) {
+ var res = "(" + this.car.toString();
+ if (this.cdr !== null)
+ res += " . " + this.cdr.toString();
+ res += ")";
+
+ return res;
+}
+
+function prettyPrintList ( o ) {
+ if (!Gambit_nullp(o)) {
+ lbl1_println(Gambit_car(o));
+ if (!Gambit_nullp(Gambit_cdr(o))) {
+ print(" ");
+ prettyPrintList(Gambit_cdr(o));
+ }
+ }
+}
+
+function Gambit_nullp ( o ) {
+ return o === null;
+}
+
+// cons
+function Gambit_cons ( a, b ) {
+ return new Gambit_Pair(a, b);
+}
+
+// car
+function Gambit_car ( p ) {
+ return p.car;
+}
+
+// cdr
+function Gambit_cdr ( p ) {
+ return p.cdr;
+}
+
+// set-car!
+function Gambit_setcar ( p, a ) {
+ p.car = a;
+}
+
+// set-cdr!
+function Gambit_setcdr ( p, b ) {
+ p.cdr = b;
+}
+
+// list
+function Gambit_list ( ) {
+ var listaux = function (a, n, lst) {
+ if (n === 0) {
+ return Gambit_cons(a[0], lst);
+ } else {
+ return listaux(a, n-1, Gambit_cons(a[n], lst));
+ }
+ }
+
+ var res = listaux(arguments, arguments.length - 1, null);
+ return res;
}
-function Gambit_Pair(car, cdr) {
- this.car = car;
- this.cdr = cdr;
+// list?
+function Gambit_listp ( lst ) {
+ return (Gambit_nullp(lst) || (Gambit_pairp(lst) && Gambit_listp(Gambit_cdr(lst))));
}
function Gambit_String(charray) {
- this.charray = charray;
+ this.charray = charray;
}
Gambit_String.makestring = function ( n, c ) {
- var a = new Array(n);
- c = c || "";
- for (i = 0; i < n; i++) {
- a[i] = c.i;
- }
+ var a = new Array(n);
+ c = c || "";
+ for (i = 0; i < n; i++) {
+ a[i] = c.i;
+ }
- return new Gambit_String(a);
+ return new Gambit_String(a);
}
Gambit_String.prototype.stringlength = function ( ) {
- return this.charray.length;
+ return this.charray.length;
}
// string-ref
Gambit_String.prototype.stringref = function ( n ) {
- return this.charray[n];
+ return this.charray[n];
}
// string-set!
Gambit_String.prototype.stringset = function ( n, c ) {
- this.charray[n] = c.i;
+ this.charray[n] = c.i;
}
Gambit_String.prototype.toString = function ( ) {
- var s = "";
- for (i = 0; i < this.stringlength(); i++) {
- s = s.concat(String.fromCharCode(this.stringref(i)));
- }
+ var s = "";
+ for (i = 0; i < this.stringlength(); i++) {
+ s = s.concat(String.fromCharCode(this.stringref(i)));
+ }
- return s;
+ return s;
}
var Gambit_syms = {};
function Gambit_Symbol(s) {
- this.symbolToString = function ( ) { return s; }
- this.toString = function ( ) { return s; }
+ this.symbolToString = function ( ) { return s; }
+ this.toString = function ( ) { return s; }
}
Gambit_Symbol.stringToSymbol = function ( s ) {
- var sym = Gambit_syms[s];
+ var sym = Gambit_syms[s];
- if (!sym) {
- Gambit_syms[s] = new Gambit_Symbol(s);
- sym = Gambit_syms[s];
- }
+ if (!sym) {
+ Gambit_syms[s] = new Gambit_Symbol(s);
+ sym = Gambit_syms[s];
+ }
- return sym;
+ return sym;
}
var Gambit_kwds = {};
function Gambit_Keyword(s) {
- s = s + ":";
+ s = s + ":";
- this.keywordToString = function( ) { return s.substring(0, s.length-1); }
- this.toString = function( ) { return s; }
+ this.keywordToString = function( ) { return s.substring(0, s.length-1); }
+ this.toString = function( ) { return s; }
}
Gambit_Keyword.stringToKeyword = function(s) {
- var kwd = Gambit_kwds[s];
+ var kwd = Gambit_kwds[s];
- if (!kwd) {
- Gambit_kwds[s] = new Gambit_Keyword(s);
- kwd = Gambit_kwds[s];
- }
+ if (!kwd) {
+ Gambit_kwds[s] = new Gambit_Keyword(s);
+ kwd = Gambit_kwds[s];
+ }
- return kwd;
+ return kwd;
}
function lbl1_println() { // println
@@ -894,12 +976,18 @@ function lbl1_println() { // println
print("#f");
else if (Gambit_reg[1] === true)
print("#t");
+ else if (Gambit_reg[1] === null)
+ print("");
else if (Gambit_reg[1] instanceof Gambit_Flonum)
print(Gambit_reg[1].toString());
else if (Gambit_reg[1] instanceof Gambit_String)
print(Gambit_reg[1].toString());
else if (Gambit_reg[1] instanceof Gambit_Char)
print(Gambit_reg[1].toString());
+ else if (Gambit_listp(Gambit_reg[1]))
+ print("(" + prettyPrintList(Gambit_reg[1]) + ")");
+ else if (Gambit_reg[1] instanceof Gambit_Pair)
+ print(Gambit_reg[1].toString());
else
print(Gambit_reg[1]);
return Gambit_reg[0];
@@ -993,16 +1081,16 @@ class Gambit_Char:
def __str__ ( self ):
return self.c
-# integer->char
-def Gambit_integerToChar ( i ):
+# ##fx->char
+def Gambit_fxToChar ( i ):
if Gambit_Char.chars.has_key(i):
return Gambit_Char.chars[i]
else:
Gambit_Char.chars[i] = Gambit_Char(unichr(i))
return Gambit_Char.chars[i]
-# char->integer
-def Gambit_charToInteger ( c ):
+# ##fx<-char
+def Gambit_charToFx ( c ):
return ord(c.c)
# char?
@@ -1010,6 +1098,45 @@ def Gambit_charp ( c ):
return (isinstance(c, Char))
#
+# Pair
+#
+class Gambit_Pair:
+ def __init__ ( self, car, cdr ):
+ self.car = car
+ self.cdr = cdr
+
+ def __str__ ( self ):
+ return "(" + self.car + " . " + self.cdr + ")"
+
+ def __eq__ ( self, p ):
+ return self is p
+
+ def car ( self ):
+ return self.car
+
+ def cdr ( self ):
+ return self.cdr
+
+ def setcar ( self, newcar ):
+ self.car = newcar
+
+ def setcdr ( self, newcdr ):
+ self.cdr = newcdr
+
+def Gambit_cons ( a, b ):
+ return Gambit_Pair(a, b)
+
+def Gambit_list ( *args ):
+ n = len(args)
+ lst = None
+
+ while n > 0:
+ lst = Gambit_cons(args[n-1], lst)
+ n -= 1
+
+ return lst
+
+#
# String
#
class Gambit_String:
@@ -1092,7 +1219,7 @@ class Gambit_Char
end
end
-def Gambit_integerToChar ( i )
+def Gambit_fxToChar ( i )
if $Gambit_chars.has_key?(i)
return $Gambit_chars[i]
else
@@ -1102,6 +1229,10 @@ def Gambit_integerToChar ( i )
end
end
+def Gambit_charToFx ( c )
+ return c.code
+end
+
$lbl1_println = lambda { # println
if $Gambit_nargs != 1
raise "wrong number of arguments"
@@ -1406,7 +1537,6 @@ EOF
(define (univ-define-prim name proc-safe? side-effects? apply-gen ifjump-gen)
(let ((prim (univ-prim-info* (string->canonical-symbol name))))
-
(if apply-gen
(begin
@@ -1473,13 +1603,13 @@ EOF
(case (target-name (ctx-target ctx))
((js)
- (gen (univ-prefix ctx "Char.integerToChar")
+ (gen (univ-prefix ctx "Char.fxToChar")
"("
code
")"))
((python ruby)
- (gen (univ-prefix ctx "integerToChar")
+ (gen (univ-prefix ctx "fxToChar")
"("
code
")"))
@@ -1536,6 +1666,67 @@ EOF
(compiler-internal-error
"univ-string, unknown target"))))
+(define (univ-null ctx obj)
+ (case (target-name (ctx-target ctx))
+
+ ((js)
+ (gen "null"))
+
+ ((python)
+ (gen "None"))
+
+ ((ruby)
+ (gen "nil"))
+
+ ((php) ;TODO: complete
+ (gen ""))
+
+ (else
+ (compiler-internal-error
+ "univ-null, unknown target"))))
+
+(define (univ-list ctx obj) ;obj is a non-null list
+
+ (define (make-list n elt)
+ (if (<= n 0)
+ '()
+ (cons elt (make-list (- n 1) elt))))
+
+ (define (zip lst1 lst2)
+ (define (zip-aux lst1 lst2 lst)
+ (cond ((null? lst1)
+ (append lst lst2))
+ ((null? lst2)
+ (append lst lst1))
+ (else
+ (cons (car lst1)
+ (cons (car lst2)
+ (zip-aux (cdr lst1) (cdr lst2) lst))))))
+
+ (zip-aux lst1 lst2 '()))
+
+ (define (univ-list-aux ctx obj objs) ;translate each obj in list
+ (if (null? obj)
+ objs
+ (cons (translate-obj ctx (car obj))
+ (univ-list-aux ctx (cdr obj) objs))))
+
+ (case (target-name (ctx-target ctx))
+
+ ((js python)
+ (let ((tobj (univ-list-aux ctx obj '()))
+ (sep (make-list (- (length obj) 1) ", ")))
+ (gen (univ-prefix ctx "list(")
+ (apply gen (zip tobj sep))
+ ")")))
+
+ ((python ruby php) ;TODO: complete
+ (gen (object->string obj)))
+
+ (else
+ (compiler-internal-error
+ "univ-list, unknown target"))))
+
;;; Primitive procedures
(univ-define-prim-bool "##not" #t #f
@@ -1839,7 +2030,7 @@ EOF
#f)
-(univ-define-prim "##null?" #f #f
+(univ-define-prim-bool "##null?" #t #f
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
@@ -1863,9 +2054,7 @@ EOF
(else
(compiler-internal-error
- "##null?, unknown target"))))
-
- #f)
+ "##null?, unknown target")))))
(univ-define-prim "##cons" #f #f
@@ -1902,8 +2091,9 @@ EOF
(case (target-name (ctx-target ctx))
((js)
- (gen (translate-gvm-opnd ctx (list-ref opnds 0))
- ".car"))
+ (gen (univ-prefix ctx "car(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ")"))
;; ((python)
;; (gen ""))
@@ -1926,8 +2116,9 @@ EOF
(case (target-name (ctx-target ctx))
((js)
- (gen (translate-gvm-opnd ctx (list-ref opnds 0))
- ".cdr"))
+ (gen (univ-prefix ctx "cdr(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ")"))
;; ((python)
;; (gen ""))
@@ -1944,15 +2135,17 @@ EOF
#f)
-(univ-define-prim "##set-car!" #f #f
+(univ-define-prim "##set-car!" #f #t
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
- (gen (translate-gvm-opnd ctx (list-ref opnds 0))
- ".car = "
- (translate-gvm-opnd ctx (list-ref opnds 1))))
+ (gen (univ-prefix ctx "setcar(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ", "
+ (translate-gvm-opnd ctx (list-ref opnds 1))
+ ")"))
;; ((python)
;; (gen ""))
@@ -1969,15 +2162,17 @@ EOF
#f)
-(univ-define-prim "##set-cdr!" #f #f
+(univ-define-prim "##set-cdr!" #f #t
(lambda (ctx opnds)
(case (target-name (ctx-target ctx))
((js)
- (gen (translate-gvm-opnd ctx (list-ref opnds 0))
- ".cdr = "
- (translate-gvm-opnd ctx (list-ref opnds 1))))
+ (gen (univ-prefix ctx "setcdr(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ", "
+ (translate-gvm-opnd ctx (list-ref opnds 1))
+ ")"))
;; ((python)
;; (gen ""))
@@ -1994,6 +2189,35 @@ EOF
#f)
+(univ-define-prim "##list" #f #f
+
+ (lambda (ctx opnds)
+ (case (target-name (ctx-target ctx))
+
+ ((js)
+ (let ((nbopnd (length opnds)))
+ (if (= nbopnd 0)
+ (gen "null")
+ (let ((args (list (univ-prefix ctx "list(")
+ (translate-gvm-opnd ctx (list-ref opnds 0)))))
+ (let loop ((opnd 1)
+ (args args))
+ (if (= opnd nbopnd)
+ (apply gen (append args '(")")))
+ (loop (+ opnd 1)
+ (append args
+ (list ", "
+ (translate-gvm-opnd ctx (list-ref opnds opnd)))))))))))
+
+ ((python ruby php) ;TODO: complete
+ (gen ""))
+
+ (else
+ (compiler-internal-error
+ "##list, unknown target"))))
+
+ #f)
+
(univ-define-prim "##make-string" #f #f
(lambda (ctx opnds)
@@ -2070,7 +2294,6 @@ EOF
(univ-define-prim "##string-ref" #f #f
(lambda (ctx opnds)
- (display "##string-ref")(newline)
(case (target-name (ctx-target ctx))
((js)
@@ -2103,6 +2326,55 @@ EOF
#f)
+(univ-define-prim "##fx->char" #f #f
+
+ (lambda (ctx opnds)
+ (pp "##fx->char")
+ (case (target-name (ctx-target ctx))
+
+ ((js)
+ (gen (univ-prefix ctx "Char.fxToChar(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ")"))
+
+ ((python ruby)
+ (gen (univ-prefix ctx "fxToChar(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ")"))
+
+ ((php) ;TODO: complete
+ (gen ""))
+
+ (else
+ (compiler-internal-error
+ "##fx->char, unknown target"))))
+
+ #f)
+
+(univ-define-prim "##fx<-char" #f #f
+
+ (lambda (ctx opnds)
+ (case (target-name (ctx-target ctx))
+
+ ((js)
+ (gen (univ-prefix ctx "Char.charToFx(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ")"))
+
+ ((python ruby)
+ (gen (univ-prefix ctx "charToFx(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ")"))
+
+ ((php) ;TODO: complete
+ (gen ""))
+
+ (else
+ (compiler-internal-error
+ "##fx<-char, unknown target"))))
+
+ #f)
+
(univ-define-prim-bool "##fixnum?" #t #f
(lambda (ctx opnds)
@@ -2176,7 +2448,7 @@ EOF
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
- (univ-prefix ctx "Char")))
+ (univ-prefix ctx "Char)")))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
@@ -2201,7 +2473,7 @@ EOF
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
- (univ-prefix ctx "Pair")))
+ (univ-prefix ctx "Pair)")))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
@@ -2212,6 +2484,23 @@ EOF
(compiler-internal-error
"##pair?, unknown target")))))
+(univ-define-prim-bool "list?" #t #f
+
+ (lambda (ctx opnds)
+ (case (target-name (ctx-target ctx))
+
+ ((js)
+ (gen (univ-prefix ctx "listp(")
+ (translate-gvm-opnd ctx (list-ref opnds 0))
+ ")"))
+
+ ((python ruby php)
+ (gen ""))
+
+ (else
+ (compiler-internal-error
+ "list?, unknown target")))))
+
(univ-define-prim-bool "##string?" #t #f
(lambda (ctx opnds)
@@ -2226,7 +2515,7 @@ EOF
(gen "isinstance("
(translate-gvm-opnd ctx (list-ref opnds 0))
", "
- (univ-prefix ctx "String")))
+ (univ-prefix ctx "String)")))
((ruby)
(gen (translate-gvm-opnd ctx (list-ref opnds 0))
View
29 gsc/tests/7-char/and.scm
@@ -0,0 +1,29 @@
+(declare (extended-bindings))
+
+(define c1 #\A)
+(define c2 #\B)
+
+(define (test2 x y)
+ (println (and x y))
+ (println (if (and x y) 11 22))
+ (println (and (##not x) y))
+ (println (if (and (##not x) y) 11 22))
+ (println (and x (##not y)))
+ (println (if (and x (##not y)) 11 22))
+ (println (and (##not x) (##not y)))
+ (println (if (and (##not x) (##not y)) 11 22))
+ (println (##not (and x y)))
+ (println (if (##not (and x y)) 11 22))
+ (println (##not (and (##not x) y)))
+ (println (if (##not (and (##not x) y)) 11 22))
+ (println (##not (and x (##not y))))
+ (println (if (##not (and x (##not y))) 11 22))
+ (println (##not (and (##not x) (##not y))))
+ (println (if (##not (and (##not x) (##not y))) 11 22)))
+
+(define (test x)
+ (test2 x c1)
+ (test2 x c2))
+
+(test c1)
+(test c2)
View
10 gsc/tests/7-char/charp.scm
@@ -0,0 +1,10 @@
+(declare (extended-bindings) (not safe))
+
+(define c1 #\A)
+(define notchar 42)
+
+(define (test x)
+ (println (##char? x)))
+
+(test c1)
+(test notchar)
View
15 gsc/tests/7-char/eq.scm
@@ -0,0 +1,15 @@
+(declare (extended-bindings))
+
+(define c1 #\A)
+(define c2 #\B)
+
+(define (test2 x y)
+ (println (##eq? x y))
+ (println (if (##eq? x y) 11 22)))
+
+(define (test x)
+ (test2 x c1)
+ (test2 x c2))
+
+(test c1)
+(test c2)
View
10 gsc/tests/7-char/if.scm
@@ -0,0 +1,10 @@
+(declare (extended-bindings))
+
+(define c1 #\A)
+(define c2 #\B)
+
+(define (test x)
+ (println (if x 11 22)))
+
+(test c1)
+(test c2)
View
10 gsc/tests/7-char/not.scm
@@ -0,0 +1,10 @@
+(declare (extended-bindings))
+
+(define c1 #\A)
+(define c2 #\B)
+
+(define (test x)
+ (println (if (##not x) 11 22)))
+
+(test c1)
+(test c2)
View
29 gsc/tests/7-char/or.scm
@@ -0,0 +1,29 @@
+(declare (extended-bindings))
+
+(define c1 #\A)
+(define c2 #\B)
+
+(define (test2 x y)
+ (println (or x y))
+ (println (if (or x y) 11 22))
+ (println (or (##not x) y))
+ (println (if (or (##not x) y) 11 22))
+ (println (or x (##not y)))
+ (println (if (or x (##not y)) 11 22))
+ (println (or (##not x) (##not y)))
+ (println (if (or (##not x) (##not y)) 11 22))
+ (println (##not (or x y)))
+ (println (if (##not (or x y)) 11 22))
+ (println (##not (or (##not x) y)))
+ (println (if (##not (or (##not x) y)) 11 22))
+ (println (##not (or x (##not y))))
+ (println (if (##not (or x (##not y))) 11 22))
+ (println (##not (or (##not x) (##not y))))
+ (println (if (##not (or (##not x) (##not y))) 11 22)))
+
+(define (test x)
+ (test2 x c1)
+ (test2 x c2))
+
+(test c1)
+(test c2)
View
2  gsc/tests/7-char/println.scm
@@ -0,0 +1,2 @@
+(println #\A)
+(println #\B)
View
15 gsc/tests/8-charprim/char.scm
@@ -0,0 +1,15 @@
+(declare (extended-bindings))
+
+(define f (##not 123))
+(define t (##not f))
+(define c #\A)
+
+(define (test x)
+ (println (##char? x))
+ (println (if (##char? x) 11 22)))
+
+(test 0)
+(test 1)
+(test f)
+(test t)
+(test c)
View
4 include/stamp.h
@@ -2,5 +2,5 @@
* Time stamp of last source code repository commit.
*/
-#define ___STAMP_YMD 20120612
-#define ___STAMP_HMS 162147
+#define ___STAMP_YMD 20120704
+#define ___STAMP_HMS 202448
Please sign in to comment.
Something went wrong with that request. Please try again.