faster append
removing 'equal' alias removing some top level bindings
This commit is contained in:
JeffBezanson
parent
bbcc68cfdf
commit
7e65db3e74
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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_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 @@ 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 "..")
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
Loading…
Reference in New Issue