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

* list* is gone. All references renamed to cons*.

This commit is contained in:
Abdulaziz Ghuloum 2007-09-09 23:41:12 -04:00
parent 7b66d9af6b
commit 2692897900
9 changed files with 28 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

5
src/ikarus.compiler.ss
View File

@ -654,7 +654,6 @@
#|FIXME:missing-optimizations
128 list*
111 cadr
464 $record/rtd?
404 memq
@ -819,7 +818,7 @@
[(null? d) (make-seq a (make-constant #t))]
[else
(f (make-seq a (car d)) (cdr d))])))])]
[(list*)
[(cons*)
(case ctxt
[(e)
(cond
@ -847,7 +846,7 @@
(cond
[(null? rand*) (giveup)]
[(null? (cdr rand*)) (car rand*)]
[else (giveup)])])]
[else (giveup)])])]
[(cons)
(or (and (fx= (length rand*) 2)
(let ([a0 (car rand*)] [a1 (cadr rand*)])

10
src/ikarus.intel-assembler.ss
View File

@ -123,7 +123,7 @@
(define reloc-word+
(lambda (x d)
(list* 'reloc-word+ x d)))
(cons* 'reloc-word+ x d)))
(define byte?
(lambda (x)
@ -167,7 +167,7 @@
(cond
[(int? n)
(if (fixnum? n)
(list*
(cons*
(byte n)
(byte (fxsra n 8))
(byte (fxsra n 16))
@ -175,7 +175,7 @@
ac)
(let* ([lo (remainder n 256)]
[hi (quotient (if (< n 0) (- n 255) n) 256)])
(list*
(cons*
(byte lo)
(byte hi)
(byte (fxsra hi 8))
@ -200,7 +200,7 @@
(lambda (n ac)
(cond
[(int? n)
(list* (byte n) ac)]
(cons* (byte n) ac)]
[else (error 'IMM8 "invalid ~s" n)])))
@ -281,7 +281,7 @@
[(eq? r3 '%esp) (error 'assembler "BUG: invalid src %esp")]
[(eq? r1 '%ebp) (error 'assembler "BUG: invalid src %ebp")]
[else
(list*
(cons*
(byte (fxlogor 4 (fxsll (register-index r1) 3)))
(byte (fxlogor (register-index r2)
(fxsll (register-index r3) 3)))

12
src/ikarus.lists.ss
View File

@ -1,12 +1,12 @@
(library (ikarus lists)
(export $memq list? list list* cons* make-list append length list-ref reverse
(export $memq list? list cons* make-list append length list-ref reverse
last-pair memq memv member assq assv assoc
map for-each andmap ormap list-tail)
(import
(ikarus system $fx)
(ikarus system $pairs)
(except (ikarus) list? list list* cons* make-list append reverse
(except (ikarus) list? list cons* make-list append reverse
last-pair length list-ref memq memv member assq assv
assoc map for-each andmap ormap list-tail))
@ -28,14 +28,6 @@
[else
(cons fst (f ($car rest) ($cdr rest)))]))))
(define list*
(lambda (fst . rest)
(let f ([fst fst] [rest rest])
(cond
[(null? rest) fst]
[else
(cons fst (f ($car rest) ($cdr rest)))]))))
(define list?
(letrec ([race
(lambda (h t)

2
src/ikarus.numerics.ss
View File

@ -2102,7 +2102,7 @@
[(<= 1 expt 9)
(sign pos? (format-flonum-no-expt expt d0 d*))]
[(<= -3 expt 0)
(sign pos? (list* #\0 #\. (format-flonum-no-expt/neg expt digits)))]
(sign pos? (cons* #\0 #\. (format-flonum-no-expt/neg expt digits)))]
[else
(string-append
(if pos? "" "-")

14
src/ikarus.reader.ss
View File

@ -427,14 +427,14 @@
[(eof-object? c1)
(num-error "eof object" (cons c ls))]
[(memv c1 '(#\b #\B))
(tokenize-radix/exactness-marks p (list* c1 c ls) exact? 2)]
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 2)]
[(memv c1 '(#\x #\X))
(tokenize-radix/exactness-marks p (list* c1 c ls) exact? 16)]
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 16)]
[(memv c1 '(#\o #\O))
(tokenize-radix/exactness-marks p (list* c1 c ls) exact? 8)]
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 8)]
[(memv c1 '(#\d #\D))
(tokenize-radix/exactness-marks p (list* c1 c ls) exact? 10)]
[else (num-error "invalid sequence" (list* c1 c ls))]))]
(tokenize-radix/exactness-marks p (cons* c1 c ls) exact? 10)]
[else (num-error "invalid sequence" (cons* c1 c ls))]))]
[else (num-error "invalid sequence" (cons c ls))])))
(define (tokenize-radix-mark p ls radix)
(let ([c (read-char p)])
@ -462,7 +462,7 @@
[(memv c1 '(#\i #\I))
(tokenize-radix/exactness-marks p (cons c1 (cons c ls))
'i radix)]
[else (num-error "invalid sequence" (list* c1 c ls))]))]
[else (num-error "invalid sequence" (cons* c1 c ls))]))]
[else (num-error "invalid sequence" (cons c ls))])))
(define (tokenize-radix/exactness-marks p ls exact? radix)
(let ([c (read-char p)])
@ -757,7 +757,7 @@
[($char= c #\>)
(read-char p)
(let ([ls (tokenize-identifier '() p)])
(let ([str (list->string (list* #\- #\> (reverse ls)))])
(let ([str (list->string (cons* #\- #\> (reverse ls)))])
(cons 'datum (string->symbol str))))]
[else
(cons 'datum

22
src/ikarus.syntax.ss
View File

@ -19,7 +19,7 @@
(chez modules)
(ikarus symbols)
(ikarus parameters)
(only (ikarus) error printf ormap andmap list* format
(only (ikarus) error printf ormap andmap cons* format
make-record-type void set-rtd-printer! type-descriptor
pretty-print)
(only (r6rs syntax-case) syntax-case syntax with-syntax)
@ -447,9 +447,9 @@
(define sanitize-binding
(lambda (x src)
(cond
[(procedure? x) (list* 'local-macro x src)]
[(procedure? x) (cons* 'local-macro x src)]
[(and (pair? x) (eq? (car x) 'macro!) (procedure? (cdr x)))
(list* 'local-macro! (cdr x) src)]
(cons* 'local-macro! (cdr x) src)]
[(and (pair? x) (eq? (car x) '$rtd)) x]
[else (error 'expand "invalid transformer ~s" x)])))
(define make-variable-transformer
@ -600,7 +600,7 @@
;;; macros
(define add-lexical
(lambda (lab lex r)
(cons (list* lab 'lexical lex) r)))
(cons (cons* lab 'lexical lex) r)))
;;;
(define add-lexicals
(lambda (lab* lex* r)
@ -938,8 +938,8 @@
(define-syntax app*
(syntax-rules (quote)
[(_ 'x arg* ... last)
(list* (scheme-stx 'x) arg* ... last)]))
(define quasilist*
(cons* (scheme-stx 'x) arg* ... last)]))
(define quasicons*
(lambda (x y)
(let f ((x x))
(if (null? x) y (quasicons (car x) (f (cdr x)))))))
@ -991,7 +991,7 @@
(syntax-match p (unquote unquote-splicing)
[(unquote p ...)
(if (= lev 0)
(quasilist* p (vquasi q lev))
(quasicons* p (vquasi q lev))
(quasicons
(quasicons (app 'quote 'unquote)
(quasi p (- lev 1)))
@ -1015,7 +1015,7 @@
(quasicons (app 'quote 'unquote) (quasi (list p) (- lev 1))))]
[((unquote p ...) . q)
(if (= lev 0)
(quasilist* p (quasi q lev))
(quasicons* p (quasi q lev))
(quasicons
(quasicons (app 'quote 'unquote) (quasi p (- lev 1)))
(quasi q lev)))]
@ -1571,7 +1571,7 @@
(lambda (x) (cdr (assq (cadr x) r))))
(cdr e))])
`(map (primitive ,(car e)) . ,args))]
[else (list* 'map (list 'lambda formals e) actuals)]))))
[else (cons* 'map (list 'lambda formals e) actuals)]))))
(define gen-cons
(lambda (e x y xnew ynew)
(case (car ynew)
@ -2463,12 +2463,12 @@
(case (binding-type b)
[(lexical)
(f (cdr r)
(cons (list* label 'global (binding-value b)) env)
(cons (cons* label 'global (binding-value b)) env)
macro*)]
[(local-macro)
(let ([loc (gensym)])
(f (cdr r)
(cons (list* label 'global-macro loc) env)
(cons (cons* label 'global-macro loc) env)
(cons (cons loc (binding-value b)) macro*)))]
[($rtd $module) (f (cdr r) (cons x env) macro*)]
[else

1
src/makefile.ss
View File

@ -312,7 +312,6 @@
[list-ref i r]
[list-tail i r]
[make-list i r]
[list* i]
[cons* i r]
[list? i r]
[append i r]

21
src/pass-specify-rep-primops.ss
View File

@ -291,27 +291,6 @@
[(E . a*) (nop)])
(define-primop list* safe
[(V) (interrupt)]
[(V x) (T x)]
[(V a . a*)
(let ([t* (map T a*)] [n (length a*)])
(with-tmp ([v (prm 'alloc (K (* n pair-size)) (K pair-tag))])
(prm 'mset v (K (- disp-car pair-tag)) (T a))
(let f ([t* t*] [i pair-size])
(cond
[(null? (cdr t*))
(seq* (prm 'mset v (K (- i disp-cdr pair-tag)) (car t*)) v)]
[else
(with-tmp ([tmp (prm 'int+ v (K i))])
(prm 'mset tmp (K (- disp-car pair-tag)) (car t*))
(prm 'mset tmp (K (- (- disp-cdr pair-tag) pair-size)) tmp)
(f (cdr t*) (+ i pair-size)))]))))]
[(P) (interrupt)]
[(P x) (P x)]
[(P a . a*) (K #t)]
[(E) (interrupt)]
[(E . a*) (nop)])
/section)