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

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

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

12
src/ikarus.lists.ss
View File

@ -1,12 +1,12 @@
(library (ikarus lists) (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 last-pair memq memv member assq assv assoc
map for-each andmap ormap list-tail) map for-each andmap ormap list-tail)
(import (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $pairs) (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 last-pair length list-ref memq memv member assq assv
assoc map for-each andmap ormap list-tail)) assoc map for-each andmap ormap list-tail))
@ -28,14 +28,6 @@
[else [else
(cons fst (f ($car rest) ($cdr rest)))])))) (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? (define list?
(letrec ([race (letrec ([race
(lambda (h t) (lambda (h t)

2
src/ikarus.numerics.ss
View File

@ -2102,7 +2102,7 @@
[(<= 1 expt 9) [(<= 1 expt 9)
(sign pos? (format-flonum-no-expt expt d0 d*))] (sign pos? (format-flonum-no-expt expt d0 d*))]
[(<= -3 expt 0) [(<= -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 [else
(string-append (string-append
(if pos? "" "-") (if pos? "" "-")

14
src/ikarus.reader.ss
View File

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

22
src/ikarus.syntax.ss
View File

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

1
src/makefile.ss
View File

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

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

@ -291,27 +291,6 @@
[(E . a*) (nop)]) [(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) /section)