ref: 7e65db3e745be35cd3622de1ef49f1ee7a278318
parent: bbcc68cfdf84fd2bd2f804f555c64d808a1c54d5
author: JeffBezanson <[email protected]>
date: Sat May 30 17:13:13 EDT 2009
faster append removing 'equal' alias removing some top level bindings
--- a/femtolisp/ast/match.lsp
+++ b/femtolisp/ast/match.lsp
@@ -44,7 +44,7 @@
(#t
(let ((capt (assq p state)))
(if capt
- (and (equal expr (cdr capt)) state)
+ (and (equal? expr (cdr capt)) state)
(cons (cons p expr) state))))))
((procedure? p)
@@ -51,8 +51,8 @@
(and (p expr) state))
((pair? p)
- (cond ((eq (car p) '-/) (and (equal (cadr p) expr) state))
- ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
+ (cond ((eq (car p) '-/) (and (equal? (cadr p) expr) state))
+ ((eq (car p) '-^) (and (not (match- (cadr p) expr state)) state))
((eq (car p) '--)
(and (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state)))
@@ -60,11 +60,11 @@
(match-alt (cdr p) () (list expr) state #f 1))
(#t
(and (pair? expr)
- (equal (car p) (car expr))
+ (equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
(#t
- (and (equal p expr) state))))
+ (and (equal? p expr) state))))
; match an alternation
(define (match-alt alt prest expr state var L)
--- a/femtolisp/cps.lsp
+++ b/femtolisp/cps.lsp
@@ -176,7 +176,7 @@
(let ((body (caddr form))
(args (cadr form)))
(and (pair? body)
- (equal (cdr body) args)
+ (equal? (cdr body) args)
(constant? (car (caddr form))))))
(car (caddr form)))
(#t (map η-reduce form))))
@@ -269,7 +269,7 @@
lo))
; example from Chung-chieh Shan's paper
-(assert (equal
+(assert (equal?
(with-delimited-continuations
(cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
'(a 1 b b c)))
--- a/femtolisp/flisp.boot
+++ b/femtolisp/flisp.boot
@@ -116,12 +116,10 @@
#function("n2c0e130q42;" [#function("r`e0e1g013131c2ms;" [1- length #function("n1e0g00g11f0[g10f0u43;" [put!])]) table])make-code-emitter
#function("n0_e030`Z3;" [table])-macroexpand-in
-#function("n2f0?6;0f0;c0e1f0Mf132q42;" [#function("rf06M0e0e1f031g00NQ2e2f03142;c3e4g0031q42;" [macroexpand-in cadr caddr #function("rf06F0e0f0g10NQ2g1142;g10Mc1<6T0g10;g10Mc2<6\x920c3e4g1031F6\x8d0e5g1031F6\x830c6e4g1031K5\x8a0e7g10315\x8e0^q42;g10Mc8<6\xc10c9e:g1031e;c2L1_L1e<e4g10313133L1q43;e=c>mg1042;" [macroexpand-in quote lambda #function("rc0e1f031e2f0g2132q43;" [#function("re0c1e2g3031f0A6G0f15Y0c1f0f1L3e3c4mf032Ke5g303144;" [nlist* lambda cadr map #function("n1^;" []) cdddr]) get-defined-vars macroexpand-in]) cddr cdddr begin caddr let-syntax #function("re0f1e1e2c3mf032g213242;" [macroexpand-in nconc map #function("n1f0Me0e1f031g3132g31L3;" [macroexpand-in cadr])]) cadr nconc copy-list map #function("n1e0f0g2142;" [macroexpand-in])]) macrocall?]) assq])macroexpand-1
#function("n1f0?6;0f0;c0e1f031q42;" [#function("rf06?0f0g00Nt2;g00;" []) macrocall?])macroexpand
-#function("n1e0f0_42;" [macroexpand-in])+#function("n1c0^^q43;" [#function("rc0mj02c1mj12f1g00_42;" [#function("n2c0e1f031F6]0e2f031F6T0c3e1f031K5Z0e4f0315^0^q42;" [#function("rc0e1f031g11f0g0132q43;" [#function("re0c1e2g1031f0A6G0f15Y0c1f0f1L3e3c4mf032Ke5g103144;" [nlist* lambda cadr map #function("n1^;" []) lastcdr]) get-defined-vars]) cddr cdddr begin caddr]) #function("n2f0?6;0f0;c0e1f0Mf132q42;" [#function("rf06N0g11e0f031g00NQ2e1f03142;c2e3g0031q42;" [cadr caddr #function("rf06G0g21f0g10NQ2g1142;g10Mc0<6U0g10;g10Mc1<6k0g20g10g1142;g10Mc2<6\x9a0c3e4g1031e5c1L1_L1e6e7g10313133L1q43;e8c9mg1042;" [quote lambda let-syntax #function("rg31f1e0e1c2mf032g213242;" [nconc map #function("n1f0Mg41e0f031g3132g31L3;" [cadr])]) cadr nconc copy-list cddr map #function("n1g31f0g2142;" [])]) macrocall?]) assq])])])macrocall?
#function("n1f0MC16E02e0e1f0M^43;" [get *syntax-environment*])lookup-sym
@@ -286,10 +284,8 @@
#function("n2e0e1c2f0c3f1f1aW6J0c45L0c53541;" [error string "compile error: " " expects " " argument." " arguments."])arg-counts
#table(:not 1 :set-cdr! 2 :cons 2 :number? 1 :equal? 2 :cdr 1 :vector? 1 :eqv? 2 := 2 :div0 2 :atom? 1 :aref 2 :compare 2 :< 2 :null? 1 :eq? 2 :car 1 :set-car! 2 :builtin? 1 :aset! 3 :bound? 1 :boolean? 1 :pair? 1 :symbol? 1 :fixnum? 1)
-append2
-#function("n2f0A6;0f1;f0Me0f0Nf132K;" [append2])append
-#function("o0f0A6:0_;f0NA6E0f0M;e0f0Me1f0NQ242;" [append2 append])+#function("o0f0A6:0_;f0NA6E0f0M;e0e1f0M31e2f0NQ242;" [nconc copy-list append])any
#function("n2f1F16O02f0f1M3117O02e0f0f1N42;" [any])abs
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -1566,7 +1566,6 @@
setc(symbol(builtin_names[i]), builtin(i));
}
setc(symbol("eq"), builtin(OP_EQ));- setc(symbol("equal"), builtin(OP_EQUAL)); setc(symbol("procedure?"), builtin(OP_FUNCTIONP));#ifdef LINUX
--- a/femtolisp/perf.lsp
+++ b/femtolisp/perf.lsp
@@ -4,9 +4,9 @@
(load "tcolor.lsp")
(princ "fib(34): ")
-(assert (equal (time (fib 34)) 5702887))
+(assert (equal? (time (fib 34)) 5702887))
(princ "yfib(32): ")
-(assert (equal (time (yfib 32)) 2178309))
+(assert (equal? (time (yfib 32)) 2178309))
(princ "sort: ")
(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
@@ -24,5 +24,5 @@
(load "rpasses.lsp")
(define *input* (load "datetimeR.lsp"))
(time (set! *output* (compile-ish *input*)))
-(assert (equal *output* (load "rpasses-out.lsp")))
+(assert (equal? *output* (load "rpasses-out.lsp")))
(path.cwd "..")
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -74,16 +74,11 @@
; standard procedures ---------------------------------------------------------
-(define (append2 l d)
- (if (null? l) d
- (cons (car l)
- (append2 (cdr l) d))))
-
(define (append . lsts)
(cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts))
- (#t (append2 (car lsts)
- (apply append (cdr lsts))))))
+ (#t (nconc (copy-list (car lsts))
+ (apply append (cdr lsts))))))
(define (member item lst)
(cond ((atom? lst) #f)
@@ -249,11 +244,6 @@
(define (reverse lst) (foldl cons () lst))
-(define (copy-tree l)
- (if (atom? l) l
- (cons (copy-tree (car l))
- (copy-tree (cdr l)))))
-
(define (nreverse l)
(let ((prev ()))
(while (pair? l)
@@ -262,6 +252,11 @@
(set! prev l))))))
prev))
+(define (copy-tree l)
+ (if (atom? l) l
+ (cons (copy-tree (car l))
+ (copy-tree (cdr l)))))
+
(define (delete-duplicates lst)
(if (atom? lst)
lst
@@ -609,46 +604,47 @@
(if f (apply f (cdr e))
e))))
-(define (macroexpand e) (macroexpand-in e ()))
-
-(define (macroexpand-in e env)
- (if (atom? e) e
- (let ((f (assq (car e) env)))
- (if f
- (macroexpand-in (apply (cadr f) (cdr e)) (caddr f))
- (let ((f (macrocall? e)))
- (if f
- (macroexpand-in (apply f (cdr e)) env)
- (cond ((eq (car e) 'quote) e)
- ((eq (car e) 'lambda)
- (let ((B (if (pair? (cddr e))
- (if (pair? (cdddr e))
- (cons 'begin (cddr e))
- (caddr e))
- #f)))
- (let ((V (get-defined-vars B))
- (Be (macroexpand-in B env)))
- (nlist* 'lambda
- (cadr e)
- (if (null? V)
- Be
- (cons (list 'lambda V Be)
- (map (lambda (x) #f) V)))
- (cdddr e)))))
- ((eq (car e) 'let-syntax)
- (let ((binds (cadr e))
- (body `((lambda () ,@(cddr e)))))
- (macroexpand-in
- body
- (nconc
- (map (lambda (bind)
- (list (car bind)
- (macroexpand-in (cadr bind) env)
- env))
- binds)
- env))))
- (else
- (map (lambda (x) (macroexpand-in x env)) e)))))))))
+(define (macroexpand e)
+ (define (expand-lambda e env)
+ (let ((B (if (pair? (cddr e))
+ (if (pair? (cdddr e))
+ (cons 'begin (cddr e))
+ (caddr e))
+ #f)))
+ (let ((V (get-defined-vars B))
+ (Be (macroexpand-in B env)))
+ (nlist* 'lambda
+ (cadr e)
+ (if (null? V)
+ Be
+ (cons (list 'lambda V Be)
+ (map (lambda (x) #f) V)))
+ (lastcdr e)))))
+ (define (macroexpand-in e env)
+ (if (atom? e) e
+ (let ((f (assq (car e) env)))
+ (if f
+ (macroexpand-in (apply (cadr f) (cdr e)) (caddr f))
+ (let ((f (macrocall? e)))
+ (if f
+ (macroexpand-in (apply f (cdr e)) env)
+ (cond ((eq (car e) 'quote) e)
+ ((eq (car e) 'lambda) (expand-lambda e env))
+ ((eq (car e) 'let-syntax)
+ (let ((binds (cadr e))
+ (body `((lambda () ,@(cddr e)))))
+ (macroexpand-in
+ body
+ (nconc
+ (map (lambda (bind)
+ (list (car bind)
+ (macroexpand-in (cadr bind) env)
+ env))
+ binds)
+ env))))
+ (else
+ (map (lambda (x) (macroexpand-in x env)) e)))))))))
+ (macroexpand-in e ()))
(define (expand x) (macroexpand x))
--- a/femtolisp/tcolor.lsp
+++ b/femtolisp/tcolor.lsp
@@ -9,7 +9,8 @@
(set! C (color-pairs Q '(a b c d e)))
(dotimes (n 99) (color-pairs Q '(a b c d e))))
(time (ct))
-(assert (equal C '((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))))
+(assert (equal? C
+ '((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/unittest.lsp
+++ b/femtolisp/unittest.lsp
@@ -58,15 +58,15 @@
(assert (< (- #uint64(0x8000000000000000)) 0))
(assert (> (- #int64(0x8000000000000000)) 0))
-(assert (not (equal #int64(0x8000000000000000) #uint64(0x8000000000000000))))
-(assert (equal (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
-(assert (equal (* 2 #int64(0x4000000000000000))
- #uint64(0x8000000000000000)))
+(assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
+(assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
+(assert (equal? (* 2 #int64(0x4000000000000000))
+ #uint64(0x8000000000000000)))
-(assert (equal (uint64 (double -123)) #uint64(0xffffffffffffff85)))
+(assert (equal? (uint64 (double -123)) #uint64(0xffffffffffffff85)))
-(assert (equal (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
+(assert (equal? (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
; NaNs
(assert (equal? +nan.0 +nan.0))
@@ -100,14 +100,14 @@
; ok, a couple end-to-end tests as well
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
-(assert (equal (fib 20) 6765))
+(assert (equal? (fib 20) 6765))
(load "color.lsp")
-(assert (equal (color-pairs (generate-5x5-pairs) '(a b c d e))
- '((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))))
+(assert (equal? (color-pairs (generate-5x5-pairs) '(a b c d e))
+ '((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))))
; hashing strange things
(assert (equal?