20071025 16:27:34 04:00



;;; Ikarus Scheme  A compiler for R6RS Scheme.

20080129 00:34:34 05:00



;;; Copyright (C) 2006,2007,2008 Abdulaziz Ghuloum

20071025 16:27:34 04:00



;;;




;;; This program is free software: you can redistribute it and/or modify




;;; it under the terms of the GNU General Public License version 3 as




;;; published by the Free Software Foundation.




;;;




;;; This program is distributed in the hope that it will be useful, but




;;; WITHOUT ANY WARRANTY; without even the implied warranty of




;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU




;;; General Public License for more details.




;;;




;;; You should have received a copy of the GNU General Public License




;;; along with this program. If not, see <http://www.gnu.org/licenses/>.





20070505 04:25:15 04:00







(library (ikarus vectors)

20070505 06:06:26 04:00



(export makevector vector vectorlength vectorref vectorset!

20070902 02:22:23 04:00



vector>list list>vector vectormap vectorforeach




vectorfill!)

20070505 04:25:15 04:00



(import

20070505 05:19:31 04:00



(except (ikarus) makevector vector

20070505 06:06:26 04:00



vectorlength vectorref vectorset!

20070902 02:22:23 04:00



vector>list list>vector vectormap vectorforeach




vectorfill!)

20070506 18:52:19 04:00



(ikarus system $fx)




(ikarus system $pairs)




(ikarus system $vectors))

20070505 04:28:40 04:00











(define vectorlength




(lambda (x)




(unless (vector? x)

20071215 08:22:49 05:00



(die 'vectorlength "not a vector" x))

20070505 04:28:40 04:00



($vectorlength x)))

20070505 04:25:15 04:00







(module (makevector)




(define fill!




(lambda (v i n fill)




(cond




[($fx= i n) v]




[else




($vectorset! v i fill)




(fill! v ($fx+ i 1) n fill)])))




(define makevector




(caselambda




[(n) (makevector n (void))]




[(n fill)




(unless (and (fixnum? n) ($fx>= n 0))

20071215 08:22:49 05:00



(die 'makevector "not a valid length" n))

20070505 04:25:15 04:00



(fill! ($makevector n) 0 n fill)])))





20070505 05:19:31 04:00







(define vector




;;; FIXME: add caselambda




(letrec ([length




(lambda (ls n)




(cond




[(null? ls) n]




[else (length ($cdr ls) ($fx+ n 1))]))]




[loop




(lambda (v ls i n)




(cond




[($fx= i n) v]




[else




($vectorset! v i ($car ls))




(loop v ($cdr ls) ($fx+ i 1) n)]))])




(lambda ls




(let ([n (length ls 0)])




(let ([v (makevector n)])




(loop v ls 0 n))))))









20070505 05:17:43 04:00



(define vectorref




(lambda (v i)




(unless (vector? v)

20071215 08:22:49 05:00



(die 'vectorref "not a vector" v))

20070505 05:17:43 04:00



(unless (fixnum? i)

20071215 08:22:49 05:00



(die 'vectorref "not a valid index" i))

20070505 05:17:43 04:00



(unless (and ($fx< i ($vectorlength v))




($fx<= 0 i))

20071215 08:22:49 05:00



(die 'vectorref "index is out of range" i v))

20070505 05:17:43 04:00



($vectorref v i)))








(define vectorset!




(lambda (v i c)




(unless (vector? v)

20071215 08:22:49 05:00



(die 'vectorset! "not a vector" v))

20070505 05:17:43 04:00



(unless (fixnum? i)

20071215 08:22:49 05:00



(die 'vectorset! "not a valid index" i))

20070505 05:17:43 04:00



(unless (and ($fx< i ($vectorlength v))




($fx<= 0 i))

20071215 08:22:49 05:00



(die 'vectorset! "index is out of range" i v))

20070505 05:17:43 04:00



($vectorset! v i c)))

20070505 06:08:43 04:00







(define vector>list




(lambda (v)




(define f




(lambda (v i ls)




(cond




[($fx< i 0) ls]




[else




(f v ($fxsub1 i) (cons ($vectorref v i) ls))])))




(if (vector? v)




(let ([n ($vectorlength v)])




(if ($fxzero? n)




'()




(f v ($fxsub1 n) '())))

20071215 08:22:49 05:00



(die 'vector>list "not a vector" v))))

20070505 06:08:43 04:00




20070505 06:06:26 04:00



(define list>vector




(letrec ([race




(lambda (h t ls n)




(if (pair? h)




(let ([h ($cdr h)])




(if (pair? h)




(if (not (eq? h t))




(race ($cdr h) ($cdr t) ls ($fx+ n 2))

20071215 08:22:49 05:00



(die 'list>vector "circular list" ls))

20070505 06:06:26 04:00



(if (null? h)




($fx+ n 1)

20071215 08:22:49 05:00



(die 'list>vector "not a proper list" ls))))

20070505 06:06:26 04:00



(if (null? h)




n

20071215 08:22:49 05:00



(die 'list>vector "not a proper list" ls))))]

20070505 06:06:26 04:00



[fill




(lambda (v i ls)




(cond




[(null? ls) v]




[else




(let ([c ($car ls)])




($vectorset! v i c)




(fill v ($fxadd1 i) (cdr ls)))]))])




(lambda (ls)




(let ([n (race ls ls ls 0)])




(let ([v (makevector n)])




(fill v 0 ls))))))

20070505 05:17:43 04:00




20070828 15:37:51 04:00



(module (vectormap)




(define who 'vectormap)




(define (ls>vec ls n)

20071213 06:41:44 05:00



(let f ([v (makevector n)]

20070828 15:37:51 04:00



[n n]




[ls ls])




(cond




[(null? ls) v]




[else




(let ([n ($fxsub1 n)])




($vectorset! v n ($car ls))




(f v n ($cdr ls)))])))




(define vectormap




(caselambda




[(p v)




(unless (procedure? p)

20071215 08:22:49 05:00



(die who "not a procedure" p))

20070828 15:37:51 04:00



(unless (vector? v)

20071215 08:22:49 05:00



(die who "not a vector" v))

20070828 15:37:51 04:00



(let f ([p p] [v v] [i 0] [n (vectorlength v)] [ac '()])




(cond




[($fx= i n) (ls>vec ac n)]




[else




(f p v ($fxadd1 i) n (cons (p (vectorref v i)) ac))]))]




[(p v0 v1)




(unless (procedure? p)

20071215 08:22:49 05:00



(die who "not a procedure" p))

20070828 15:37:51 04:00



(unless (vector? v0)

20071215 08:22:49 05:00



(die who "not a vector" v0))

20070828 15:37:51 04:00



(unless (vector? v1)

20071215 08:22:49 05:00



(die who "not a vector" v1))

20070828 15:37:51 04:00



(let ([n (vectorlength v0)])




(unless ($fx= n ($vectorlength v1))

20071215 08:22:49 05:00



(die who "length mismatch" v0 v1))

20070828 15:37:51 04:00



(let f ([p p] [v0 v0] [v1 v1] [i 0] [n n] [ac '()])




(cond




[($fx= i n) (ls>vec ac n)]




[else




(f p v0 v1 ($fxadd1 i) n




(cons (p ($vectorref v0 i) ($vectorref v1 i)) ac))])))]




[(p v0 v1 . v*)




(unless (procedure? p)

20071215 08:22:49 05:00



(die who "not a procedure" p))

20070828 15:37:51 04:00



(unless (vector? v0)

20071215 08:22:49 05:00



(die who "not a vector" v0))

20070828 15:37:51 04:00



(unless (vector? v1)

20071215 08:22:49 05:00



(die who "not a vector" v1))

20070828 15:37:51 04:00



(let ([n (vectorlength v0)])




(unless ($fx= n ($vectorlength v1))

20071215 08:22:49 05:00



(die who "length mismatch" v0 v1))

20070828 15:37:51 04:00



(let f ([v* v*] [n n])




(unless (null? v*)




(let ([a ($car v*)])




(unless (vector? a)

20071215 08:22:49 05:00



(die who "not a vector" a))

20070828 15:37:51 04:00



(unless ($fx= ($vectorlength a) n)

20071215 08:22:49 05:00



(die who "length mismatch")))

20070828 15:37:51 04:00



(f ($cdr v*) n)))




(let f ([p p] [v0 v0] [v1 v1] [v* v*] [i 0] [n n] [ac '()])




(cond




[($fx= i n) (ls>vec ac n)]




[else




(f p v0 v1 v* ($fxadd1 i) n




(cons




(apply p ($vectorref v0 i) ($vectorref v1 i)




(let f ([i i] [v* v*])




(if (null? v*)




'()




(cons ($vectorref ($car v*) i)




(f i ($cdr v*))))))




ac))])))])))

20070505 05:17:43 04:00




20070828 17:24:53 04:00







(module (vectorforeach)




(define who 'vectorforeach)




(define vectorforeach




(caselambda




[(p v)




(unless (procedure? p)

20071215 08:22:49 05:00



(die who "not a procedure" p))

20070828 17:24:53 04:00



(unless (vector? v)

20071215 08:22:49 05:00



(die who "not a vector" v))

20070828 17:24:53 04:00



(let f ([p p] [v v] [i 0] [n (vectorlength v)])




(cond




[($fx= i n) (void)]




[else




(p (vectorref v i))




(f p v ($fxadd1 i) n)]))]




[(p v0 v1)




(unless (procedure? p)

20071215 08:22:49 05:00



(die who "not a procedure" p))

20070828 17:24:53 04:00



(unless (vector? v0)

20071215 08:22:49 05:00



(die who "not a vector" v0))

20070828 17:24:53 04:00



(unless (vector? v1)

20071215 08:22:49 05:00



(die who "not a vector" v1))

20070828 17:24:53 04:00



(let ([n (vectorlength v0)])




(unless ($fx= n ($vectorlength v1))

20071215 08:22:49 05:00



(die who "length mismatch" v0 v1))

20070828 17:24:53 04:00



(let f ([p p] [v0 v0] [v1 v1] [i 0] [n n])




(cond




[($fx= i n) (void)]




[else




(p ($vectorref v0 i) ($vectorref v1 i))




(f p v0 v1 ($fxadd1 i) n)])))]




[(p v0 v1 . v*)




(unless (procedure? p)

20071215 08:22:49 05:00



(die who "not a procedure" p))

20070828 17:24:53 04:00



(unless (vector? v0)

20071215 08:22:49 05:00



(die who "not a vector" v0))

20070828 17:24:53 04:00



(unless (vector? v1)

20071215 08:22:49 05:00



(die who "not a vector" v1))

20070828 17:24:53 04:00



(let ([n (vectorlength v0)])




(unless ($fx= n ($vectorlength v1))

20071215 08:22:49 05:00



(die who "length mismatch" v0 v1))

20070828 17:24:53 04:00



(let f ([v* v*] [n n])




(unless (null? v*)




(let ([a ($car v*)])




(unless (vector? a)

20071215 08:22:49 05:00



(die who "not a vector" a))

20070828 17:24:53 04:00



(unless ($fx= ($vectorlength a) n)

20071215 08:22:49 05:00



(die who "length mismatch")))

20070828 17:24:53 04:00



(f ($cdr v*) n)))




(let f ([p p] [v0 v0] [v1 v1] [v* v*] [i 0] [n n])




(cond




[($fx= i n) (void)]




[else




(apply p ($vectorref v0 i) ($vectorref v1 i)




(let f ([i i] [v* v*])




(if (null? v*)




'()




(cons ($vectorref ($car v*) i)




(f i ($cdr v*))))))




(f p v0 v1 v* ($fxadd1 i) n)])))])))

20070902 02:22:23 04:00







(define (vectorfill! v fill)




(unless (vector? v)

20071215 08:22:49 05:00



(die 'vectorfill! "not a vector" v))

20070902 02:22:23 04:00



(let f ([v v] [i 0] [n ($vectorlength v)] [fill fill])




(unless ($fx= i n)




($vectorset! v i fill)




(f v ($fxadd1 i) n fill))))





20070505 04:25:15 04:00



)
