lassik
/
upscheme
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

faster append 

removing 'equal' alias
removing some top level bindings
This commit is contained in:
JeffBezanson 2009-05-30 21:13:13 +00:00
parent bbcc68cfdf
commit 7e65db3e74
8 changed files with 78 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
femtolisp/ast/match.lsp
View File

@ -44,15 +44,15 @@
(#t (#t
(let ((capt (assq p state))) (let ((capt (assq p state)))
(if capt (if capt
(and (equal expr (cdr capt)) state) (and (equal? expr (cdr capt)) state)
(cons (cons p expr) state)))))) (cons (cons p expr) state))))))
((procedure? p) ((procedure? p)
(and (p expr) state)) (and (p expr) state))
((pair? p) ((pair? p)
(cond ((eq (car p) '-/) (and (equal (cadr p) expr) 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 (not (match- (cadr p) expr state)) state))
((eq (car p) '--) ((eq (car p) '--)
(and (match- (caddr p) expr state) (and (match- (caddr p) expr state)
(cons (cons (cadr p) expr) state))) (cons (cons (cadr p) expr) state)))
@ -60,11 +60,11 @@
(match-alt (cdr p) () (list expr) state #f 1)) (match-alt (cdr p) () (list expr) state #f 1))
(#t (#t
(and (pair? expr) (and (pair? expr)
(equal (car p) (car expr)) (equal? (car p) (car expr))
(match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) (match-seq (cdr p) (cdr expr) state (length (cdr expr)))))))
(#t (#t
(and (equal p expr) state)))) (and (equal? p expr) state))))
; match an alternation ; match an alternation
(define (match-alt alt prest expr state var L) (define (match-alt alt prest expr state var L)

4
femtolisp/cps.lsp
View File

@ -176,7 +176,7 @@
(let ((body (caddr form)) (let ((body (caddr form))
(args (cadr form))) (args (cadr form)))
(and (pair? body) (and (pair? body)
(equal (cdr body) args) (equal? (cdr body) args)
(constant? (car (caddr form)))))) (constant? (car (caddr form))))))
(car (caddr form))) (car (caddr form)))
(#t (map η-reduce form)))) (#t (map η-reduce form))))
@ -269,7 +269,7 @@
lo)) lo))
; example from Chung-chieh Shan's paper ; example from Chung-chieh Shan's paper
(assert (equal (assert (equal?
(with-delimited-continuations (with-delimited-continuations
(cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ()))))))))) (cons 'a (reset (cons 'b (shift f (cons 1 (f (f (cons 'c ())))))))))
'(a 1 b b c))) '(a 1 b b c)))

8
femtolisp/flisp.boot
View File

@ -116,12 +116,10 @@ make-enum-table
#function("n2c0e130q42;" [#function("r`e0e1g013131c2ms;" [1- length #function("n1e0g00g11f0[g10f0u43;" [put!])]) table]) #function("n2c0e130q42;" [#function("r`e0e1g013131c2ms;" [1- length #function("n1e0g00g11f0[g10f0u43;" [put!])]) table])
make-code-emitter make-code-emitter
#function("n0_e030`Z3;" [table]) #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 macroexpand-1
#function("n1f0?6;0f0;c0e1f031q42;" [#function("rf06?0f0g00Nt2;g00;" []) macrocall?]) #function("n1f0?6;0f0;c0e1f031q42;" [#function("rf06?0f0g00Nt2;g00;" []) macrocall?])
macroexpand 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? macrocall?
#function("n1f0MC16E02e0e1f0M^43;" [get *syntax-environment*]) #function("n1f0MC16E02e0e1f0M^43;" [get *syntax-environment*])
lookup-sym lookup-sym
@ -286,10 +284,8 @@ argc-error
#function("n2e0e1c2f0c3f1f1aW6J0c45L0c53541;" [error string "compile error: " " expects " " argument." " arguments."]) #function("n2e0e1c2f0c3f1f1aW6J0c45L0c53541;" [error string "compile error: " " expects " " argument." " arguments."])
arg-counts 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) #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 append
#function("o0f0A6:0_;f0NA6E0f0M;e0f0Me1f0NQ242;" [append2 append]) #function("o0f0A6:0_;f0NA6E0f0M;e0e1f0M31e2f0NQ242;" [nconc copy-list append])
any any
#function("n2f1F16O02f0f1M3117O02e0f0f1N42;" [any]) #function("n2f1F16O02f0f1M3117O02e0f0f1N42;" [any])
abs abs

1
femtolisp/flisp.c
View File

@ -1566,7 +1566,6 @@ static void lisp_init(void)
setc(symbol(builtin_names[i]), builtin(i)); setc(symbol(builtin_names[i]), builtin(i));
} }
setc(symbol("eq"), builtin(OP_EQ)); setc(symbol("eq"), builtin(OP_EQ));
setc(symbol("equal"), builtin(OP_EQUAL));
setc(symbol("procedure?"), builtin(OP_FUNCTIONP)); setc(symbol("procedure?"), builtin(OP_FUNCTIONP));
#ifdef LINUX #ifdef LINUX

6
femtolisp/perf.lsp
View File

@ -4,9 +4,9 @@
(load "tcolor.lsp") (load "tcolor.lsp")
(princ "fib(34): ") (princ "fib(34): ")
(assert (equal (time (fib 34)) 5702887)) (assert (equal? (time (fib 34)) 5702887))
(princ "yfib(32): ") (princ "yfib(32): ")
(assert (equal (time (yfib 32)) 2178309)) (assert (equal? (time (yfib 32)) 2178309))
(princ "sort: ") (princ "sort: ")
(set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000)) (set! r (map-int (lambda (x) (mod (+ (* x 9421) 12345) 1024)) 1000))
@ -24,5 +24,5 @@
(load "rpasses.lsp") (load "rpasses.lsp")
(define *input* (load "datetimeR.lsp")) (define *input* (load "datetimeR.lsp"))
(time (set! *output* (compile-ish *input*))) (time (set! *output* (compile-ish *input*)))
(assert (equal *output* (load "rpasses-out.lsp"))) (assert (equal? *output* (load "rpasses-out.lsp")))
(path.cwd "..") (path.cwd "..")

100
femtolisp/system.lsp
View File

@ -74,16 +74,11 @@
; standard procedures --------------------------------------------------------- ; standard procedures ---------------------------------------------------------
(define (append2 l d)
(if (null? l) d
(cons (car l)
(append2 (cdr l) d))))
(define (append . lsts) (define (append . lsts)
(cond ((null? lsts) ()) (cond ((null? lsts) ())
((null? (cdr lsts)) (car lsts)) ((null? (cdr lsts)) (car lsts))
(#t (append2 (car lsts) (#t (nconc (copy-list (car lsts))
(apply append (cdr lsts)))))) (apply append (cdr lsts))))))
(define (member item lst) (define (member item lst)
(cond ((atom? lst) #f) (cond ((atom? lst) #f)
@ -249,11 +244,6 @@
(define (reverse lst) (foldl cons () lst)) (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) (define (nreverse l)
(let ((prev ())) (let ((prev ()))
(while (pair? l) (while (pair? l)
@ -262,6 +252,11 @@
(set! prev l)))))) (set! prev l))))))
prev)) prev))
(define (copy-tree l)
(if (atom? l) l
(cons (copy-tree (car l))
(copy-tree (cdr l)))))
(define (delete-duplicates lst) (define (delete-duplicates lst)
(if (atom? lst) (if (atom? lst)
lst lst
@ -609,46 +604,47 @@
(if f (apply f (cdr e)) (if f (apply f (cdr e))
e)))) e))))
(define (macroexpand e) (macroexpand-in e ())) (define (macroexpand e)
(define (expand-lambda e env)
(define (macroexpand-in e env) (let ((B (if (pair? (cddr e))
(if (atom? e) e (if (pair? (cdddr e))
(let ((f (assq (car e) env))) (cons 'begin (cddr e))
(if f (caddr e))
(macroexpand-in (apply (cadr f) (cdr e)) (caddr f)) #f)))
(let ((f (macrocall? e))) (let ((V (get-defined-vars B))
(if f (Be (macroexpand-in B env)))
(macroexpand-in (apply f (cdr e)) env) (nlist* 'lambda
(cond ((eq (car e) 'quote) e) (cadr e)
((eq (car e) 'lambda) (if (null? V)
(let ((B (if (pair? (cddr e)) Be
(if (pair? (cdddr e)) (cons (list 'lambda V Be)
(cons 'begin (cddr e)) (map (lambda (x) #f) V)))
(caddr e)) (lastcdr e)))))
#f))) (define (macroexpand-in e env)
(let ((V (get-defined-vars B)) (if (atom? e) e
(Be (macroexpand-in B env))) (let ((f (assq (car e) env)))
(nlist* 'lambda (if f
(cadr e) (macroexpand-in (apply (cadr f) (cdr e)) (caddr f))
(if (null? V) (let ((f (macrocall? e)))
Be (if f
(cons (list 'lambda V Be) (macroexpand-in (apply f (cdr e)) env)
(map (lambda (x) #f) V))) (cond ((eq (car e) 'quote) e)
(cdddr e))))) ((eq (car e) 'lambda) (expand-lambda e env))
((eq (car e) 'let-syntax) ((eq (car e) 'let-syntax)
(let ((binds (cadr e)) (let ((binds (cadr e))
(body `((lambda () ,@(cddr e))))) (body `((lambda () ,@(cddr e)))))
(macroexpand-in (macroexpand-in
body body
(nconc (nconc
(map (lambda (bind) (map (lambda (bind)
(list (car bind) (list (car bind)
(macroexpand-in (cadr bind) env) (macroexpand-in (cadr bind) env)
env)) env))
binds) binds)
env)))) env))))
(else (else
(map (lambda (x) (macroexpand-in x env)) e))))))))) (map (lambda (x) (macroexpand-in x env)) e)))))))))
(macroexpand-in e ()))
(define (expand x) (macroexpand x)) (define (expand x) (macroexpand x))

9
femtolisp/tcolor.lsp
View File

@ -9,7 +9,8 @@
(set! C (color-pairs Q '(a b c d e))) (set! C (color-pairs Q '(a b c d e)))
(dotimes (n 99) (color-pairs Q '(a b c d e)))) (dotimes (n 99) (color-pairs Q '(a b c d e))))
(time (ct)) (time (ct))
(assert (equal C '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e) (assert (equal? C
(19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d) '((23 . a) (9 . a) (22 . b) (17 . d) (14 . d) (8 . b) (21 . e)
(18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e) (19 . b) (16 . c) (13 . c) (11 . b) (7 . e) (24 . c) (20 . d)
(3 . d) (2 . c) (0 . b) (1 . a)))) (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
(3 . d) (2 . c) (0 . b) (1 . a))))

26
femtolisp/unittest.lsp
View File

@ -58,15 +58,15 @@
(assert (< (- #uint64(0x8000000000000000)) 0)) (assert (< (- #uint64(0x8000000000000000)) 0))
(assert (> (- #int64(0x8000000000000000)) 0)) (assert (> (- #int64(0x8000000000000000)) 0))
(assert (not (equal #int64(0x8000000000000000) #uint64(0x8000000000000000)))) (assert (not (equal? #int64(0x8000000000000000) #uint64(0x8000000000000000))))
(assert (equal (+ #int64(0x4000000000000000) #int64(0x4000000000000000)) (assert (equal? (+ #int64(0x4000000000000000) #int64(0x4000000000000000))
#uint64(0x8000000000000000))) #uint64(0x8000000000000000)))
(assert (equal (* 2 #int64(0x4000000000000000)) (assert (equal? (* 2 #int64(0x4000000000000000))
#uint64(0x8000000000000000))) #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 ; NaNs
(assert (equal? +nan.0 +nan.0)) (assert (equal? +nan.0 +nan.0))
@ -100,14 +100,14 @@
; ok, a couple end-to-end tests as well ; ok, a couple end-to-end tests as well
(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))) (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") (load "color.lsp")
(assert (equal (color-pairs (generate-5x5-pairs) '(a b c d e)) (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) '((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) (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) (18 . e) (15 . a) (12 . a) (10 . e) (6 . d) (5 . c) (4 . e)
(3 . d) (2 . c) (0 . b) (1 . a)))) (3 . d) (2 . c) (0 . b) (1 . a))))
; hashing strange things ; hashing strange things
(assert (equal? (assert (equal?