conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Cadr is now open-coded.

This commit is contained in:
Abdulaziz Ghuloum 2006-12-07 02:48:31 -05:00
parent 1487c5ed54
commit bd71be0d64
4 changed files with 59 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
lib/ikarus.boot
View File

Binary file not shown.

38
lib/libcompile.ss
View File

@ -828,7 +828,7 @@
(for-each
(lambda (x)
(let ([n (getprop x '*compiler-giveup-tally*)])
(when (>= n 40)
(when (>= n 30)
(printf "~s ~s\n" n x))))
giveup-list))
(primitive-set! 'compiler-giveup-tally print-tally))
@ -1055,6 +1055,18 @@
[(car) (car v)]
[else (cdr v)]))))))))
(giveup))]
[(cadr)
(or (and (fx= (length rand*) 1)
(let ([a (car rand*)])
(or (constant-value a
(lambda (v)
(and (pair? v)
(pair? (cdr v))
(mk-seq a
(make-constant
(cadr v))))))
(make-primcall op rand*))))
(giveup))]
[(not null? pair? fixnum? vector? string? char? symbol?
eof-object?)
(or (and (fx= (length rand*) 1)
@ -2041,7 +2053,7 @@
[(seq e0 e1) (make-seq (Expr e0) (Expr e1))]
[(primcall op arg*)
(cond
[(memq op '(not car cdr fxadd1 fxsub1)) ;;; SIMPLIFY
[(memq op '(not car cdr cadr fxadd1 fxsub1)) ;;; SIMPLIFY
(make-primcall op (map Expr arg*))]
[else
(simplify* arg* '() '()
@ -3364,6 +3376,20 @@
(jne (label SL_cdr_error))
(movl (mem (fx- disp-cdr pair-tag) ebx) eax)
ac)))))]
[(cadr)
(NonTail (car arg*)
(list*
(movl eax ebx)
(andl (int pair-mask) eax)
(cmpl (int pair-tag) eax)
(jne (label SL_cadr_error))
(movl (mem (fx- disp-cdr pair-tag) ebx) eax)
(movl eax ecx)
(andl (int pair-mask) eax)
(cmpl (int pair-tag) eax)
(jne (label SL_cadr_error))
(movl (mem (fx- disp-car pair-tag) ecx) eax)
ac))]
[(top-level-value)
(let ([x (car arg*)])
(cond
@ -4365,6 +4391,7 @@
(define SL_top_level_value_error (gensym "SL_top_level_value_error"))
(define SL_car_error (gensym "SL_car_error"))
(define SL_cdr_error (gensym "SL_cdr_error"))
(define SL_cadr_error (gensym "SL_cadr_error"))
(define SL_invalid_args (gensym "SL_invalid_args"))
(define SL_foreign_call (gensym "SL_foreign_call"))
(define SL_continuation_code (gensym "SL_continuation_code"))
@ -4404,7 +4431,12 @@
(movl (primref-loc 'cdr-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_cadr_error)
(movl ebx (mem (fx- 0 wordsize) fpr))
(movl (primref-loc 'cadr-error) cpr)
(movl (int (argc-convention 1)) eax)
(tail-indirect-cpr-call))
(list 0
(label SL_top_level_value_error)
(movl ebx (mem (fx- 0 wordsize) fpr))

34
lib/libcxr.ss
View File

@ -1,13 +1,17 @@
(primitive-set! 'car (lambda (x) (car x)))
(primitive-set! 'cdr (lambda (x) (cdr x)))
(primitive-set! 'cadr (lambda (x) (cadr x)))
(let ([err (lambda (who x)
(error who "invalid list structure ~s" x))])
(primitive-set!
'car
(lambda (orig)
(if (pair? orig) ($car orig) (err 'car orig))))
(primitive-set!
'cdr
(lambda (orig)
(if (pair? orig) ($cdr orig) (err 'cdr orig))))
;(primitive-set!
; 'car
; (lambda (orig)
; (if (pair? orig) ($car orig) (err 'car orig))))
;(primitive-set!
; 'cdr
; (lambda (orig)
; (if (pair? orig) ($cdr orig) (err 'cdr orig))))
(primitive-set!
'caar
(lambda (orig)
@ -15,13 +19,13 @@
(let ([x ($car orig)])
(if (pair? x) ($car x) (err 'caar orig)))
(err 'caar orig))))
(primitive-set!
'cadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x) ($car x) (err 'cadr orig)))
(err 'cadr orig))))
;(primitive-set!
; 'cadr
; (lambda (orig)
; (if (pair? orig)
; (let ([x ($cdr orig)])
; (if (pair? x) ($car x) (err 'cadr orig)))
; (err 'cadr orig))))
(primitive-set!
'cdar
(lambda (orig)

5
lib/libhandlers.ss
View File

@ -55,3 +55,8 @@
(error 'fxsub1 "underflow")
(error 'fxsub1 "~s is not a fixnum" x))))
(primitive-set! 'cadr-error
(lambda (x)
(error 'cadr "invalid list structure in ~s" x)))