ref: 97c05e8eb4b7b2266faa062bd5ec48cab7cf5d05
parent: b59dcdc877ab723f066d2910d2984d264ac492f9
author: JeffBezanson <[email protected]>
date: Sun Aug 9 16:34:07 EDT 2009
a couple bug fixes some small performance tweaks moving some test files around
--- a/femtolisp/equal.scm
+++ /dev/null
@@ -1,68 +1,0 @@
-; Terminating equal predicate
-; by Jeff Bezanson
-;
-; This version only considers pairs and simple atoms.
-
-; equal?, with bounded recursion. returns 0 if we suspect
-; nontermination, otherwise #t or #f for the correct answer.
-(define (bounded-equal a b N)
- (cond ((<= N 0) 0)
- ((and (pair? a) (pair? b))
- (let ((as
- (bounded-equal (car a) (car b) (- N 1))))
- (if (number? as)
- 0
- (and as
- (bounded-equal (cdr a) (cdr b) (- N 1))))))
- (else (eq? a b))))
-
-; union-find algorithm
-
-; find equivalence class of a cons cell, or #f if not yet known
-; the root of a class is a cons that is its own class
-(define (class table key)
- (let ((c (hashtable-ref table key #f)))
- (if (or (not c) (eq? c key))
- c
- (class table c))))
-
-; move a and b to the same equivalence class, given c and cb
-; as the current values of (class table a) and (class table b)
-; Note: this is not quite optimal. We blindly pick 'a' as the
-; root of the new class, but we should pick whichever class is
-; larger.
-(define (union! table a b c cb)
- (let ((ca (if c c a)))
- (if cb
- (hashtable-set! table cb ca))
- (hashtable-set! table a ca)
- (hashtable-set! table b ca)))
-
-; cyclic equal. first, attempt to compare a and b as best
-; we can without recurring. if we can't prove them different,
-; set them equal and move on.
-(define (cyc-equal a b table)
- (cond ((eq? a b) #t)
- ((not (and (pair? a) (pair? b))) (eq? a b))
- (else
- (let ((aa (car a)) (da (cdr a))
- (ab (car b)) (db (cdr b)))
- (cond ((or (not (eq? (atom? aa) (atom? ab)))
- (not (eq? (atom? da) (atom? db)))) #f)
- ((and (atom? aa)
- (not (eq? aa ab))) #f)
- ((and (atom? da)
- (not (eq? da db))) #f)
- (else
- (let ((ca (class table a))
- (cb (class table b)))
- (if (and ca cb (eq? ca cb))
- #t
- (begin (union! table a b ca cb)
- (and (cyc-equal aa ab table)
- (cyc-equal da db table)))))))))))
-
-(define (equal a b)
- (let ((guess (bounded-equal a b 2048)))
- (if (boolean? guess) guess
- (cyc-equal a b (make-eq-hashtable)))))
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -422,7 +422,8 @@
*pcdr = cdr_(v);
return first;
}
- *pcdr = nc = mk_cons();
+ *pcdr = nc = tagptr((cons_t*)curheap, TAG_CONS);
+ curheap += sizeof(cons_t);
d = cdr_(v);
car_(v) = TAG_FWD; cdr_(v) = nc;
car_(nc) = relocate(a);
--- a/femtolisp/iostream.c
+++ b/femtolisp/iostream.c
@@ -114,9 +114,11 @@
else {arg = args[0];
}
- ios_t *s = toiostream(arg, "read");
+ (void)toiostream(arg, "read");
+ fl_gc_handle(&arg);
value_t v = read_sexpr(arg);
- if (ios_eof(s))
+ fl_free_gc_handles(1);
+ if (ios_eof(value2c(ios_t*,arg)))
return FL_EOF;
return v;
}
--- a/femtolisp/pisum.lsp
+++ /dev/null
@@ -1,8 +1,0 @@
-(define (pisum)
- (dotimes (j 500)
- ((label sumloop
- (lambda (i sum)
- (if (> i 10000)
- sum
- (sumloop (+ i 1) (+ sum (/ (* i i)))))))
- 1.0 0.0)))
--- a/femtolisp/printcases.lsp
+++ /dev/null
@@ -1,26 +1,0 @@
-macroexpand
-append
-bq-process
-
-(define (syntax-environment)
- (map (lambda (s) (cons s (symbol-syntax s)))
- (filter symbol-syntax (environment))))
-
-(syntax-environment)
-
-(symbol-syntax 'try)
-
-(map-int (lambda (x) `(a b c d e)) 90)
-
-(list->vector (map-int (lambda (x) `(a b c d e)) 90))
-
-'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
-
-'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
-
-'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
-
-'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
- (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
- (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
- (3 . d) (2 . c) (0 . b) (1 . a))
--- a/femtolisp/read.c
+++ b/femtolisp/read.c
@@ -13,8 +13,8 @@
// an ordinary symbol character unless it's the first character.
static int symchar(char c)
{- static char *special = "()[]'\";`,\\|";
- return (!isspace(c) && !strchr(special, c));
+ static char *special = "()[]'\";`,\\| \f\n\r\t\v";
+ return !strchr(special, c);
}
int isnumtok_base(char *tok, value_t *pval, int base)
@@ -91,22 +91,28 @@
{int ch;
char c;
+ ios_t *f = F;
do {- ch = ios_getc(F);
- if (ch == IOS_EOF)
- return 0;
+ if (f->bpos < f->size) {+ ch = f->buf[f->bpos++];
+ }
+ else {+ ch = ios_getc(f);
+ if (ch == IOS_EOF)
+ return 0;
+ }
c = (char)ch;
if (c == ';') {// single-line comment
do {- ch = ios_getc(F);
+ ch = ios_getc(f);
if (ch == IOS_EOF)
return 0;
} while ((char)ch != '\n');
c = (char)ch;
}
- } while (isspace(c));
+ } while (c==' ' || isspace(c));
return c;
}
@@ -658,6 +664,7 @@
htable_new(&state.gensyms, 8);
state.source = f;
readstate = &state;
+ assert(toktype == TOK_NONE);
v = do_read_sexpr(UNBOUND);
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -489,8 +489,9 @@
(newline)
(apply #.apply args)))))
(lambda (f)
- (equal? (function:code f)
- (function:code sample-traced-lambda)))))
+ (and (closure? f)
+ (equal? (function:code f)
+ (function:code sample-traced-lambda))))))
(define (trace sym)
(let* ((func (top-level-value sym))
--- /dev/null
+++ b/femtolisp/tests/argv.lsp
@@ -1,0 +1,1 @@
+(print *argv*) (princ "\n")
--- /dev/null
+++ b/femtolisp/tests/equal.scm
@@ -1,0 +1,68 @@
+; Terminating equal predicate
+; by Jeff Bezanson
+;
+; This version only considers pairs and simple atoms.
+
+; equal?, with bounded recursion. returns 0 if we suspect
+; nontermination, otherwise #t or #f for the correct answer.
+(define (bounded-equal a b N)
+ (cond ((<= N 0) 0)
+ ((and (pair? a) (pair? b))
+ (let ((as
+ (bounded-equal (car a) (car b) (- N 1))))
+ (if (number? as)
+ 0
+ (and as
+ (bounded-equal (cdr a) (cdr b) (- N 1))))))
+ (else (eq? a b))))
+
+; union-find algorithm
+
+; find equivalence class of a cons cell, or #f if not yet known
+; the root of a class is a cons that is its own class
+(define (class table key)
+ (let ((c (hashtable-ref table key #f)))
+ (if (or (not c) (eq? c key))
+ c
+ (class table c))))
+
+; move a and b to the same equivalence class, given c and cb
+; as the current values of (class table a) and (class table b)
+; Note: this is not quite optimal. We blindly pick 'a' as the
+; root of the new class, but we should pick whichever class is
+; larger.
+(define (union! table a b c cb)
+ (let ((ca (if c c a)))
+ (if cb
+ (hashtable-set! table cb ca))
+ (hashtable-set! table a ca)
+ (hashtable-set! table b ca)))
+
+; cyclic equal. first, attempt to compare a and b as best
+; we can without recurring. if we can't prove them different,
+; set them equal and move on.
+(define (cyc-equal a b table)
+ (cond ((eq? a b) #t)
+ ((not (and (pair? a) (pair? b))) (eq? a b))
+ (else
+ (let ((aa (car a)) (da (cdr a))
+ (ab (car b)) (db (cdr b)))
+ (cond ((or (not (eq? (atom? aa) (atom? ab)))
+ (not (eq? (atom? da) (atom? db)))) #f)
+ ((and (atom? aa)
+ (not (eq? aa ab))) #f)
+ ((and (atom? da)
+ (not (eq? da db))) #f)
+ (else
+ (let ((ca (class table a))
+ (cb (class table b)))
+ (if (and ca cb (eq? ca cb))
+ #t
+ (begin (union! table a b ca cb)
+ (and (cyc-equal aa ab table)
+ (cyc-equal da db table)))))))))))
+
+(define (equal a b)
+ (let ((guess (bounded-equal a b 2048)))
+ (if (boolean? guess) guess
+ (cyc-equal a b (make-eq-hashtable)))))
--- /dev/null
+++ b/femtolisp/tests/err.lsp
@@ -1,0 +1,4 @@
+(define (f x) (begin (list-tail '(1) 3) 3))
+(f 2)
+a
+(trycatch a (lambda (e) (print (stacktrace))))
--- /dev/null
+++ b/femtolisp/tests/hashtest.lsp
@@ -1,0 +1,40 @@
+; -*- scheme -*-
+
+(define (hins1)
+ (let ((h (table)))
+ (dotimes (n 200000)
+ (put! h (mod (rand) 1000) 'apple))
+ h))
+
+(define (hread h)
+ (dotimes (n 200000)
+ (get h (mod (rand) 10000) nil)))
+
+(time (dotimes (i 100000)
+ (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8 :bar 9)))
+(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4 :e 5 :f 6 :g 7 :foo 8)))
+(time (dotimes (i 100000) (table :a 1 :b 2 :c 3 :d 4)))
+(time (dotimes (i 100000) (table :a 1 :b 2)))
+(time (dotimes (i 100000) (table)))
+
+#t
+
+#|
+
+with HT_N_INLINE==16
+Elapsed time: 0.0796329975128174 seconds
+Elapsed time: 0.0455679893493652 seconds
+Elapsed time: 0.0272290706634521 seconds
+Elapsed time: 0.0177979469299316 seconds
+Elapsed time: 0.0102229118347168 seconds
+
+
+with HT_N_INLINE==8
+
+Elapsed time: 0.1010119915008545 seconds
+Elapsed time: 0.174872875213623 seconds
+Elapsed time: 0.0322129726409912 seconds
+Elapsed time: 0.0195930004119873 seconds
+Elapsed time: 0.008836030960083 seconds
+
+|#
--- /dev/null
+++ b/femtolisp/tests/pisum.lsp
@@ -1,0 +1,8 @@
+(define (pisum)
+ (dotimes (j 500)
+ ((label sumloop
+ (lambda (i sum)
+ (if (> i 10000)
+ sum
+ (sumloop (+ i 1) (+ sum (/ (* i i)))))))
+ 1.0 0.0)))
--- /dev/null
+++ b/femtolisp/tests/printcases.lsp
@@ -1,0 +1,26 @@
+macroexpand
+append
+bq-process
+
+(define (syntax-environment)
+ (map (lambda (s) (cons s (symbol-syntax s)))
+ (filter symbol-syntax (environment))))
+
+(syntax-environment)
+
+(symbol-syntax 'try)
+
+(map-int (lambda (x) `(a b c d e)) 90)
+
+(list->vector (map-int (lambda (x) `(a b c d e)) 90))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x yffffffffffffffffffff)) (a b c) (d e f) 2 3 (r t y))
+
+'((lambda (x y) (if (< x y) x y)) (a b c) (d (e zz zzz) f) 2 3 (r t y))
+
+'((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
+ (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
+ (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
+ (3 . d) (2 . c) (0 . b) (1 . a))
--- /dev/null
+++ b/femtolisp/tests/tme.lsp
@@ -1,0 +1,4 @@
+(let ((t (table)))
+ (time (dotimes (i 2000000)
+ (put! t (rand) (rand)))))
+#t
--- /dev/null
+++ b/femtolisp/tests/wt.lsp
@@ -1,0 +1,28 @@
+(define-macro (while- test . forms)
+ `((label -loop- (lambda ()
+ (if ,test
+ (begin ,@forms
+ (-loop-))
+ ())))))
+
+(define (tw)
+ (set! i 0)
+ (while (< i 10000000) (set! i (+ i 1))))
+
+(define (tw2)
+ (letrec ((loop (lambda ()
+ (if (< i 10000000)
+ (begin (set! i (+ i 1))
+ (loop))
+ ()))))
+ (loop)))
+
+#|
+interpreter:
+while: 1.82sec
+macro: 2.98sec
+
+compiler:
+while: 0.72sec
+macro: 1.24sec
+|#
--- a/femtolisp/wt.lsp
+++ /dev/null
@@ -1,28 +1,0 @@
-(define-macro (while- test . forms)
- `((label -loop- (lambda ()
- (if ,test
- (begin ,@forms
- (-loop-))
- ())))))
-
-(define (tw)
- (set! i 0)
- (while (< i 10000000) (set! i (+ i 1))))
-
-(define (tw2)
- (letrec ((loop (lambda ()
- (if (< i 10000000)
- (begin (set! i (+ i 1))
- (loop))
- ()))))
- (loop)))
-
-#|
-interpreter:
-while: 1.82sec
-macro: 2.98sec
-
-compiler:
-while: 0.72sec
-macro: 1.24sec
-|#