From 7e65db3e745be35cd3622de1ef49f1ee7a278318 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Sat, 30 May 2009 21:13:13 +0000 Subject: [PATCH] faster append removing 'equal' alias removing some top level bindings --- femtolisp/ast/match.lsp | 10 ++-- femtolisp/cps.lsp | 4 +- femtolisp/flisp.boot | 8 +--- femtolisp/flisp.c | 1 - femtolisp/perf.lsp | 6 +-- femtolisp/system.lsp | 100 +++++++++++++++++++--------------------- femtolisp/tcolor.lsp | 9 ++-- femtolisp/unittest.lsp | 26 +++++------ 8 files changed, 78 insertions(+), 86 deletions(-) diff --git a/femtolisp/ast/match.lsp b/femtolisp/ast/match.lsp index c242ccd..f251ea3 100644 --- a/femtolisp/ast/match.lsp +++ b/femtolisp/ast/match.lsp @@ -44,15 +44,15 @@ (#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) (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) diff --git a/femtolisp/cps.lsp b/femtolisp/cps.lsp index 6af5103..baa6bad 100644 --- 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))) diff --git a/femtolisp/flisp.boot b/femtolisp/flisp.boot index d6910b6..1025347 100644 --- a/femtolisp/flisp.boot +++ b/femtolisp/flisp.boot @@ -116,12 +116,10 @@ make-enum-table #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_L1emg1042;" [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 @@ argc-error #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 diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index 6813454..a95c2bf 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -1566,7 +1566,6 @@ static void lisp_init(void) 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 diff --git a/femtolisp/perf.lsp b/femtolisp/perf.lsp index 084024d..4aa97e9 100644 --- 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 "..") diff --git a/femtolisp/system.lsp b/femtolisp/system.lsp index ff59911..213a8f5 100644 --- 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)) diff --git a/femtolisp/tcolor.lsp b/femtolisp/tcolor.lsp index bd11d18..f61daa1 100644 --- 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)))) diff --git a/femtolisp/unittest.lsp b/femtolisp/unittest.lsp index 19064ac..62043a1 100644 --- 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?