~ chicken-core (chicken-5) 9eb48ff1e8aba8599a7f449f290a07f178004b37
commit 9eb48ff1e8aba8599a7f449f290a07f178004b37
Author: Peter Bex <peter@more-magic.net>
AuthorDate: Thu Dec 21 21:11:46 2017 +0100
Commit: Kooda <kooda@upyum.com>
CommitDate: Fri Dec 29 17:32:09 2017 +0100
Move (chicken data-structures) procedures into (chicken base)
Signed-off-by: Kooda <kooda@upyum.com>
diff --git a/c-backend.scm b/c-backend.scm
index 81a98c35..4272a041 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -34,13 +34,16 @@
;; For "foreign" (aka chicken-ffi-syntax):
foreign-type-declaration)
-(import chicken scheme
+(import scheme
+ (only chicken get-output-string)
+ chicken.base
chicken.bitwise
- (only chicken.data-structures intersperse)
+ chicken.fixnum
chicken.flonum
chicken.foreign
chicken.format
chicken.internal
+ chicken.platform
chicken.sort
chicken.string
chicken.time
diff --git a/c-platform.scm b/c-platform.scm
index 6803db64..87ed4440 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -27,7 +27,7 @@
(declare
(unit c-platform)
- (uses data-structures internal optimizer support compiler))
+ (uses internal optimizer support compiler))
(module chicken.compiler.c-platform
(;; Batch compilation defaults
@@ -39,11 +39,12 @@
;; For consumption by c-backend *only*
target-include-file words-per-flonum)
-(import chicken scheme
- chicken.data-structures
+(import scheme
+ chicken.base
chicken.compiler.optimizer
chicken.compiler.support
chicken.compiler.core
+ chicken.fixnum
chicken.internal)
(include "tweaks")
@@ -166,6 +167,9 @@
chicken.base#setter chicken.base#getter-with-setter
chicken.base#equal=? chicken.base#exact-integer? flush-output
+ chicken.base#identity chicken.base#o chicken.base#atom?
+ chicken.base#alist-ref chicken.base#rassoc
+
chicken.bitwise#integer-length
chicken.bitwise#bitwise-and chicken.bitwise#bitwise-not
chicken.bitwise#bitwise-ior chicken.bitwise#bitwise-xor
@@ -225,10 +229,6 @@
chicken.string#substring-index chicken.string#substring-index-ci
chicken.string#substring=? chicken.string#substring-ci=?
- chicken.data-structures#identity chicken.data-structures#o
- chicken.data-structures#atom?
- chicken.data-structures#alist-ref chicken.data-structures#rassoc
-
chicken.io#read-string
chicken.format#format
@@ -685,7 +685,7 @@
(rewrite 'scheme#gcd 12 '##sys#gcd #t 2)
(rewrite 'scheme#lcm 12 '##sys#lcm #t 2)
-(rewrite 'chicken.data-structures#identity 12 #f #t 1)
+(rewrite 'chicken.base#identity 12 #f #t 1)
(rewrite 'scheme#gcd 19)
(rewrite 'scheme#lcm 19)
@@ -915,7 +915,7 @@
(rewrite 'srfi-4#f32vector-length 2 1 "C_u_i_32vector_length" #f)
(rewrite 'srfi-4#f64vector-length 2 1 "C_u_i_64vector_length" #f)
-(rewrite 'chicken.data-structures#atom? 17 1 "C_i_not_pair_p")
+(rewrite 'chicken.base#atom? 17 1 "C_i_not_pair_p")
(rewrite 'srfi-4#u8vector->blob/shared 7 1 "C_slot" 1 #f)
(rewrite 'srfi-4#s8vector->blob/shared 7 1 "C_slot" 1 #f)
diff --git a/chicken-install.scm b/chicken-install.scm
index e73e9100..7e4e86cd 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -27,22 +27,25 @@
(module main ()
(import (scheme))
-(import (chicken))
+(import (only chicken open-input-string flush-output))
+(import (chicken base))
(import (chicken condition))
-(import (only (chicken data-structures) o constantly))
(import (chicken foreign))
(import (chicken keyword))
(import (chicken file))
+(import (chicken fixnum))
(import (chicken format))
(import (chicken irregex))
(import (chicken tcp))
(import (chicken posix))
(import (chicken port))
+(import (chicken platform))
(import (chicken io))
(import (chicken sort))
(import (chicken time))
(import (chicken pathname))
(import (chicken process))
+(import (chicken process-context))
(import (chicken pretty-print))
(import (chicken string))
diff --git a/chicken.base.import.scm b/chicken.base.import.scm
index 5bf90d2e..de53c9e8 100644
--- a/chicken.base.import.scm
+++ b/chicken.base.import.scm
@@ -27,42 +27,63 @@
'chicken.base
'library
'((add1 . chicken.base#add1)
+ (alist-ref . chicken.base#alist-ref)
+ (alist-update . chicken.base#alist-update)
+ (alist-update! . chicken.base#alist-update!)
+ (atom? . chicken.base#atom?)
(bignum? . chicken.base#bignum?)
+ (butlast . chicken.base#butlast)
(call/cc . chicken.base#call/cc)
(char-name . chicken.base#char-name)
+ (chop . chicken.base#chop)
+ (complement . chicken.base#complement)
+ (compose . chicken.base#compose)
+ (compress . chicken.base#compress)
+ (conjoin . chicken.base#conjoin)
+ (constantly . chicken.base#constantly)
(cplxnum? . chicken.base#cplxnum?)
(current-error-port . chicken.base#current-error-port)
+ (disjoin . chicken.base#disjoin)
+ (each . chicken.base#each)
(emergency-exit . chicken.base#emergency-exit)
(enable-warnings . chicken.base#enable-warnings)
(equal=? . chicken.base#equal=?)
- (exit . chicken.base#exit)
(error . chicken.base#error)
(exact-integer? . chicken.base#exact-integer?)
- (exact-integer-sqrt . chicken.base#exact-integer-sqrt)
(exact-integer-nth-root . chicken.base#exact-integer-nth-root)
+ (exact-integer-sqrt . chicken.base#exact-integer-sqrt)
+ (exit . chicken.base#exit)
(exit-handler . chicken.base#exit-handler)
(finite? . chicken.base#finite?)
(fixnum? . chicken.base#fixnum?)
+ (flatten . chicken.base#flatten)
+ (flip . chicken.base#flip)
(flonum? . chicken.base#flonum?)
(foldl . chicken.base#foldl)
(foldr . chicken.base#foldr)
(gensym . chicken.base#gensym)
(get-call-chain . chicken.base#get-call-chain)
(getter-with-setter . chicken.base#getter-with-setter)
+ (identity . chicken.base#identity)
(implicit-exit-handler . chicken.base#implicit-exit-handler)
(infinite? . chicken.base#infinite?)
+ (intersperse . chicken.base#intersperse)
+ (join . chicken.base#join)
+ (list-of? . chicken.base#list-of?)
(make-parameter . chicken.base#make-parameter)
(make-promise . chicken.base#make-promise)
(nan? . chicken.base#nan?)
(notice . chicken.base#notice)
+ (o . chicken.base#o)
(on-exit . chicken.base#on-exit)
- (print . chicken.base#print)
(print-call-chain . chicken.base#print-call-chain)
+ (print . chicken.base#print)
(print* . chicken.base#print*)
(procedure-information . chicken.base#procedure-information)
(promise? . chicken.base#promise?)
(quotient&modulo . chicken.base#quotient&modulo)
(quotient&remainder . chicken.base#quotient&remainder)
+ (rassoc . chicken.base#rassoc)
(ratnum? . chicken.base#ratnum?)
(setter . chicken.base#setter)
(signum . chicken.base#signum)
@@ -70,6 +91,7 @@
(sub1 . chicken.base#sub1)
(subvector . chicken.base#subvector)
(symbol-append . chicken.base#symbol-append)
+ (tail? . chicken.base#tail?)
(vector-copy! . chicken.base#vector-copy!)
(vector-resize . chicken.base#vector-resize)
(void . chicken.base#void)
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 7a15de57..dadc8456 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -26,15 +26,16 @@
(declare
(unit compiler-syntax)
- (uses data-structures extras support compiler))
+ (uses extras support compiler))
(module chicken.compiler.compiler-syntax
(compiler-syntax-statistics)
-(import chicken scheme
+(import scheme
+ chicken.base
chicken.compiler.support
chicken.compiler.core
- chicken.data-structures
+ chicken.fixnum
chicken.format)
(include "tweaks.scm")
@@ -138,9 +139,9 @@
(##sys#slot ,%result 1))))))
x)))
-(define-internal-compiler-syntax ((chicken.data-structures#o) x r c) '()
+(define-internal-compiler-syntax ((chicken.base#o) x r c) '()
(if (and (fx> (length x) 1)
- (memq 'chicken.data-structures#o extended-bindings)) ; s.a.
+ (memq 'chicken.base#o extended-bindings)) ; s.a.
(let ((%tmp (r 'tmp)))
`(,(r 'lambda) (,%tmp) ,(foldr list %tmp (cdr x))))
x))
diff --git a/core.scm b/core.scm
index 67bf2eb4..b22ff9f3 100644
--- a/core.scm
+++ b/core.scm
@@ -321,22 +321,26 @@
constant-table immutable-constants inline-table line-number-database-2
line-number-database-size)
-(import chicken scheme
+(import scheme
+ (only chicken open-output-string get-output-string file-exists?)
+ chicken.base
chicken.condition
chicken.compiler.scrutinizer
chicken.compiler.support
- (only chicken.data-structures butlast rassoc o)
chicken.eval
+ chicken.fixnum
chicken.foreign
chicken.format
chicken.internal
chicken.io
chicken.keyword
chicken.load
+ chicken.platform
chicken.pretty-print
chicken.pathname
chicken.string
- chicken.syntax)
+ chicken.syntax
+ chicken.type)
(define (d arg1 . more)
(when (##sys#debug-mode?)
diff --git a/csi.scm b/csi.scm
index 15a9cdf1..ad4b170d 100644
--- a/csi.scm
+++ b/csi.scm
@@ -44,9 +44,14 @@ EOF
(module chicken.csi
(editor-command toplevel-command set-describer!)
-(import chicken scheme
+(import scheme
+ (only chicken open-input-string open-output-string
+ get-output-string file-exists? parentheses-synonyms
+ case-sensitive symbol-escape flush-output port?
+ keyword-style)
+ chicken.base
chicken.condition
- (only chicken.data-structures atom?)
+ chicken.fixnum
chicken.foreign
chicken.format
chicken.gc
@@ -57,10 +62,13 @@ EOF
chicken.platform
chicken.port
chicken.pretty-print
+ chicken.process
+ chicken.process-context
chicken.repl
chicken.sort
chicken.string
- chicken.syntax)
+ chicken.syntax
+ chicken.time)
(include "banner.scm")
(include "mini-srfi-1.scm")
diff --git a/data-structures.scm b/data-structures.scm
index 4f8a758d..3e5d1d68 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -28,251 +28,6 @@
(declare
(unit data-structures))
-(module chicken.data-structures
- (alist-ref alist-update alist-update! atom? butlast
- chop compress flatten intersperse join rassoc tail?
- constantly complement compose
- conjoin disjoin each flip identity list-of? o)
-
-(import scheme chicken)
-(import chicken.foreign)
-(import chicken.condition)
-
-(include "common-declarations.scm")
-
-
-;;; Combinators:
-
-(define (identity x) x)
-
-(define (conjoin . preds)
- (lambda (x)
- (let loop ([preds preds])
- (or (null? preds)
- (and ((##sys#slot preds 0) x)
- (loop (##sys#slot preds 1)) ) ) ) ) )
-
-(define (disjoin . preds)
- (lambda (x)
- (let loop ([preds preds])
- (and (not (null? preds))
- (or ((##sys#slot preds 0) x)
- (loop (##sys#slot preds 1)) ) ) ) ) )
-
-(define (constantly . xs)
- (if (eq? 1 (length xs))
- (let ([x (car xs)])
- (lambda _ x) )
- (lambda _ (apply values xs)) ) )
-
-(define (flip proc) (lambda (x y) (proc y x)))
-
-(define complement
- (lambda (p)
- (lambda args (not (apply p args))) ) )
-
-(define (compose . fns)
- (define (rec f0 . fns)
- (if (null? fns)
- f0
- (lambda args
- (call-with-values
- (lambda () (apply (apply rec fns) args))
- f0) ) ) )
- (if (null? fns)
- values
- (apply rec fns) ) )
-
-(define (o . fns)
- (if (null? fns)
- identity
- (let loop ((fns fns))
- (let ((h (##sys#slot fns 0))
- (t (##sys#slot fns 1)) )
- (if (null? t)
- h
- (lambda (x) (h ((loop t) x))))))))
-
-(define (list-of? pred)
- (lambda (lst)
- (let loop ([lst lst])
- (cond [(null? lst) #t]
- [(not (pair? lst)) #f]
- [(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
- [else #f] ) ) ) )
-
-(define (each . procs)
- (cond ((null? procs) (lambda _ (void)))
- ((null? (##sys#slot procs 1)) (##sys#slot procs 0))
- (else
- (lambda args
- (let loop ((procs procs))
- (let ((h (##sys#slot procs 0))
- (t (##sys#slot procs 1)) )
- (if (null? t)
- (apply h args)
- (begin
- (apply h args)
- (loop t) ) ) ) ) ) ) ) )
-
-
-;;; List operators:
-
-(define (atom? x) (##core#inline "C_i_not_pair_p" x))
-
-(define (tail? x y)
- (##sys#check-list y 'tail?)
- (or (##core#inline "C_eqp" x '())
- (let loop ((y y))
- (cond ((##core#inline "C_eqp" y '()) #f)
- ((##core#inline "C_eqp" x y) #t)
- (else (loop (##sys#slot y 1))) ) ) ) )
-
-(define intersperse
- (lambda (lst x)
- (let loop ((ns lst))
- (if (##core#inline "C_eqp" ns '())
- ns
- (let ((tail (cdr ns)))
- (if (##core#inline "C_eqp" tail '())
- ns
- (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )
-
-(define (butlast lst)
- (##sys#check-pair lst 'butlast)
- (let loop ((lst lst))
- (let ((next (##sys#slot lst 1)))
- (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
- (cons (##sys#slot lst 0) (loop next))
- '() ) ) ) )
-
-(define (flatten . lists0)
- (let loop ([lists lists0] [rest '()])
- (cond [(null? lists) rest]
- [else
- (let ([head (##sys#slot lists 0)]
- [tail (##sys#slot lists 1)] )
- (if (list? head)
- (loop head (loop tail rest))
- (cons head (loop tail rest)) ) ) ] ) ) )
-
-(define chop
- (lambda (lst n)
- (##sys#check-fixnum n 'chop)
- (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))
- (let ([len (length lst)])
- (let loop ([lst lst] [i len])
- (cond [(null? lst) '()]
- [(fx< i n) (list lst)]
- [else
- (do ([hd '() (cons (##sys#slot tl 0) hd)]
- [tl lst (##sys#slot tl 1)]
- [c n (fx- c 1)] )
- ((fx= c 0)
- (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) )
-
-(define (join lsts . lst)
- (let ([lst (if (pair? lst) (car lst) '())])
- (##sys#check-list lst 'join)
- (let loop ([lsts lsts])
- (cond [(null? lsts) '()]
- [(not (pair? lsts))
- (##sys#error-not-a-proper-list lsts) ]
- [else
- (let ([l (##sys#slot lsts 0)]
- [r (##sys#slot lsts 1)] )
- (if (null? r)
- l
- (##sys#append l lst (loop r)) ) ) ] ) ) ) )
-
-(define compress
- (lambda (blst lst)
- (let ([msg "bad argument type - not a proper list"])
- (##sys#check-list lst 'compress)
- (let loop ([blst blst] [lst lst])
- (cond [(null? blst) '()]
- [(not (pair? blst))
- (##sys#signal-hook #:type-error 'compress msg blst) ]
- [(not (pair? lst))
- (##sys#signal-hook #:type-error 'compress msg lst) ]
- [(##sys#slot blst 0)
- (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
- [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
-
-
-;;; Alists:
-
-(define (alist-update! x y lst #!optional (cmp eqv?))
- (let* ([aq (cond [(eq? eq? cmp) assq]
- [(eq? eqv? cmp) assv]
- [(eq? equal? cmp) assoc]
- [else
- (lambda (x lst)
- (let loop ([lst lst])
- (and (pair? lst)
- (let ([a (##sys#slot lst 0)])
- (if (and (pair? a) (cmp x (##sys#slot a 0)))
- a
- (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ]
- [item (aq x lst)] )
- (if item
- (begin
- (##sys#setslot item 1 y)
- lst)
- (cons (cons x y) lst) ) ) )
-
-(define (alist-update k v lst #!optional (cmp eqv?))
- (let loop ((lst lst))
- (cond ((null? lst)
- (list (cons k v)))
- ((not (pair? lst))
- (error 'alist-update "bad argument type" lst))
- (else
- (let ((a (##sys#slot lst 0)))
- (cond ((not (pair? a))
- (error 'alist-update "bad argument type" a))
- ((cmp k (##sys#slot a 0))
- (cons (cons k v) (##sys#slot lst 1)))
- (else
- (cons (cons (##sys#slot a 0) (##sys#slot a 1))
- (loop (##sys#slot lst 1))))))))))
-
-(define (alist-ref x lst #!optional (cmp eqv?) (default #f))
- (let* ((aq (cond ((eq? eq? cmp) assq)
- ((eq? eqv? cmp) assv)
- ((eq? equal? cmp) assoc)
- (else
- (lambda (x lst)
- (let loop ((lst lst))
- (cond
- ((null? lst) #f)
- ((pair? lst)
- (let ((a (##sys#slot lst 0)))
- (##sys#check-pair a 'alist-ref)
- (if (cmp x (##sys#slot a 0))
- a
- (loop (##sys#slot lst 1)) ) ))
- (else (error 'alist-ref "bad argument type" lst)) ) ) ) ) ) )
- (item (aq x lst)) )
- (if item
- (##sys#slot item 1)
- default) ) )
-
-;; TODO: Make inlineable in C without "tst", to be more like assoc?
-(define (rassoc x lst . tst)
- (##sys#check-list lst 'rassoc)
- (let ([tst (if (pair? tst) (car tst) eqv?)])
- (let loop ([l lst])
- (and (pair? l)
- (let ([a (##sys#slot l 0)])
- (##sys#check-pair a 'rassoc)
- (if (tst x (##sys#slot a 1))
- a
- (loop (##sys#slot l 1)) ) ) ) ) ) )
-
-) ; chicken.data-structures
-
-
(module chicken.string
(conc ->string string-chop string-chomp
string-compare3 string-compare3-ci
@@ -600,10 +355,7 @@
(module chicken.sort
(merge merge! sort sort! sorted? topological-sort)
-(import chicken scheme)
-(import (only (chicken data-structures)
- alist-ref alist-update!))
-
+(import scheme chicken.base chicken.condition chicken.fixnum)
;;; Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
diff --git a/defaults.make b/defaults.make
index 7e40ec45..851fb1dc 100644
--- a/defaults.make
+++ b/defaults.make
@@ -271,8 +271,8 @@ DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise blob errno file.posix \
process process.signal process-context random sort string \
time time.posix
DYNAMIC_CHICKEN_COMPILER_IMPORT_LIBRARIES = user-pass
-DYNAMIC_CHICKEN_UNIT_IMPORT_LIBRARIES = continuation data-structures \
- eval file internal irregex pathname port read-syntax repl tcp
+DYNAMIC_CHICKEN_UNIT_IMPORT_LIBRARIES = continuation eval file \
+ internal irregex pathname port read-syntax repl tcp
# targets
diff --git a/distribution/manifest b/distribution/manifest
index eafac8c6..1450e019 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -279,8 +279,6 @@ chicken.continuation.import.scm
chicken.continuation.import.c
chicken.csi.import.scm
chicken.csi.import.c
-chicken.data-structures.import.scm
-chicken.data-structures.import.c
chicken.errno.import.scm
chicken.errno.import.c
chicken.eval.import.scm
diff --git a/library.scm b/library.scm
index bb0bce73..221a43b8 100644
--- a/library.scm
+++ b/library.scm
@@ -596,10 +596,9 @@ EOF
notice procedure-information setter signum string->uninterned-symbol
subvector symbol-append vector-copy! vector-resize
warning quotient&remainder quotient&modulo
- ;; TODO: Move from data-structures.scm:
- ;; alist-ref alist-update alist-update! rassoc atom? butlast chop
- ;; compress flatten intersperse join list-of? tail? constantly
- ;; complement compose conjoin disjoin each flip identity o
+ alist-ref alist-update alist-update! rassoc atom? butlast chop
+ compress flatten intersperse join list-of? tail? constantly
+ complement compose conjoin disjoin each flip identity o
on-exit exit exit-handler implicit-exit-handler emergency-exit
)
@@ -717,6 +716,223 @@ EOF
(##sys#check-fixnum code 'emergency-exit)
(##core#inline "C_exit_runtime" code))
+
+;;; Combinators:
+
+(define (identity x) x)
+
+(define (conjoin . preds)
+ (lambda (x)
+ (let loop ((preds preds))
+ (or (null? preds)
+ (and ((##sys#slot preds 0) x)
+ (loop (##sys#slot preds 1)) ) ) ) ) )
+
+(define (disjoin . preds)
+ (lambda (x)
+ (let loop ((preds preds))
+ (and (not (null? preds))
+ (or ((##sys#slot preds 0) x)
+ (loop (##sys#slot preds 1)) ) ) ) ) )
+
+(define (constantly . xs)
+ (if (eq? 1 (length xs))
+ (let ((x (car xs)))
+ (lambda _ x) )
+ (lambda _ (apply values xs)) ) )
+
+(define (flip proc) (lambda (x y) (proc y x)))
+
+(define complement
+ (lambda (p)
+ (lambda args (not (apply p args))) ) )
+
+(define (compose . fns)
+ (define (rec f0 . fns)
+ (if (null? fns)
+ f0
+ (lambda args
+ (call-with-values
+ (lambda () (apply (apply rec fns) args))
+ f0) ) ) )
+ (if (null? fns)
+ values
+ (apply rec fns) ) )
+
+(define (o . fns)
+ (if (null? fns)
+ identity
+ (let loop ((fns fns))
+ (let ((h (##sys#slot fns 0))
+ (t (##sys#slot fns 1)) )
+ (if (null? t)
+ h
+ (lambda (x) (h ((loop t) x))))))))
+
+(define (list-of? pred)
+ (lambda (lst)
+ (let loop ((lst lst))
+ (cond ((null? lst) #t)
+ ((not (pair? lst)) #f)
+ ((pred (##sys#slot lst 0)) (loop (##sys#slot lst 1)))
+ (else #f) ) ) ) )
+
+(define (each . procs)
+ (cond ((null? procs) (lambda _ (void)))
+ ((null? (##sys#slot procs 1)) (##sys#slot procs 0))
+ (else
+ (lambda args
+ (let loop ((procs procs))
+ (let ((h (##sys#slot procs 0))
+ (t (##sys#slot procs 1)) )
+ (if (null? t)
+ (apply h args)
+ (begin
+ (apply h args)
+ (loop t) ) ) ) ) ) ) ) )
+
+
+;;; List operators:
+
+(define (atom? x) (##core#inline "C_i_not_pair_p" x))
+
+(define (tail? x y)
+ (##sys#check-list y 'tail?)
+ (or (##core#inline "C_eqp" x '())
+ (let loop ((y y))
+ (cond ((##core#inline "C_eqp" y '()) #f)
+ ((##core#inline "C_eqp" x y) #t)
+ (else (loop (##sys#slot y 1))) ) ) ) )
+
+(define intersperse
+ (lambda (lst x)
+ (let loop ((ns lst))
+ (if (##core#inline "C_eqp" ns '())
+ ns
+ (let ((tail (cdr ns)))
+ (if (##core#inline "C_eqp" tail '())
+ ns
+ (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )
+
+(define (butlast lst)
+ (##sys#check-pair lst 'butlast)
+ (let loop ((lst lst))
+ (let ((next (##sys#slot lst 1)))
+ (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
+ (cons (##sys#slot lst 0) (loop next))
+ '() ) ) ) )
+
+(define (flatten . lists0)
+ (let loop ((lists lists0) (rest '()))
+ (cond ((null? lists) rest)
+ (else
+ (let ((head (##sys#slot lists 0))
+ (tail (##sys#slot lists 1)) )
+ (if (list? head)
+ (loop head (loop tail rest))
+ (cons head (loop tail rest)) ) ) ) ) ) )
+
+(define chop)
+
+(define (join lsts . lst)
+ (let ((lst (if (pair? lst) (car lst) '())))
+ (##sys#check-list lst 'join)
+ (let loop ((lsts lsts))
+ (cond ((null? lsts) '())
+ ((not (pair? lsts))
+ (##sys#error-not-a-proper-list lsts) )
+ (else
+ (let ((l (##sys#slot lsts 0))
+ (r (##sys#slot lsts 1)) )
+ (if (null? r)
+ l
+ (##sys#append l lst (loop r)) ) ) ) ) ) ) )
+
+(define compress
+ (lambda (blst lst)
+ (let ((msg "bad argument type - not a proper list"))
+ (##sys#check-list lst 'compress)
+ (let loop ((blst blst) (lst lst))
+ (cond ((null? blst) '())
+ ((not (pair? blst))
+ (##sys#signal-hook #:type-error 'compress msg blst) )
+ ((not (pair? lst))
+ (##sys#signal-hook #:type-error 'compress msg lst) )
+ ((##sys#slot blst 0)
+ (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1))))
+ (else (loop (##sys#slot blst 1) (##sys#slot lst 1))) ) ) ) ) )
+
+
+;;; Alists:
+
+(define (alist-update! x y lst #!optional (cmp eqv?))
+ (let* ((aq (cond ((eq? eq? cmp) assq)
+ ((eq? eqv? cmp) assv)
+ ((eq? equal? cmp) assoc)
+ (else
+ (lambda (x lst)
+ (let loop ((lst lst))
+ (and (pair? lst)
+ (let ((a (##sys#slot lst 0)))
+ (if (and (pair? a) (cmp x (##sys#slot a 0)))
+ a
+ (loop (##sys#slot lst 1)) ) ) ) ) ) ) ) )
+ (item (aq x lst)) )
+ (if item
+ (begin
+ (##sys#setslot item 1 y)
+ lst)
+ (cons (cons x y) lst) ) ) )
+
+(define (alist-update k v lst #!optional (cmp eqv?))
+ (let loop ((lst lst))
+ (cond ((null? lst)
+ (list (cons k v)))
+ ((not (pair? lst))
+ (error 'alist-update "bad argument type" lst))
+ (else
+ (let ((a (##sys#slot lst 0)))
+ (cond ((not (pair? a))
+ (error 'alist-update "bad argument type" a))
+ ((cmp k (##sys#slot a 0))
+ (cons (cons k v) (##sys#slot lst 1)))
+ (else
+ (cons (cons (##sys#slot a 0) (##sys#slot a 1))
+ (loop (##sys#slot lst 1))))))))))
+
+(define (alist-ref x lst #!optional (cmp eqv?) (default #f))
+ (let* ((aq (cond ((eq? eq? cmp) assq)
+ ((eq? eqv? cmp) assv)
+ ((eq? equal? cmp) assoc)
+ (else
+ (lambda (x lst)
+ (let loop ((lst lst))
+ (cond
+ ((null? lst) #f)
+ ((pair? lst)
+ (let ((a (##sys#slot lst 0)))
+ (##sys#check-pair a 'alist-ref)
+ (if (cmp x (##sys#slot a 0))
+ a
+ (loop (##sys#slot lst 1)) ) ))
+ (else (error 'alist-ref "bad argument type" lst)) ) ) ) ) ) )
+ (item (aq x lst)) )
+ (if item
+ (##sys#slot item 1)
+ default) ) )
+
+;; TODO: Make inlineable in C without "tst", to be more like assoc?
+(define (rassoc x lst . tst)
+ (##sys#check-list lst 'rassoc)
+ (let ((tst (if (pair? tst) (car tst) eqv?)))
+ (let loop ((l lst))
+ (and (pair? l)
+ (let ((a (##sys#slot l 0)))
+ (##sys#check-pair a 'rassoc)
+ (if (tst x (##sys#slot a 1))
+ a
+ (loop (##sys#slot l 1)) ) ) ) ) ) )
+
) ; chicken.base
(import chicken.base)
@@ -1295,6 +1511,20 @@ EOF
(##core#inline "C_substring_copy" f dest 0 flen pos)
(loop (##sys#slot fs 1) (fx+ pos flen)) ) ) ) ) )
+(set! chicken.base#chop
+ (lambda (lst n)
+ (##sys#check-fixnum n 'chop)
+ (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))
+ (let ((len (length lst)))
+ (let loop ((lst lst) (i len))
+ (cond ((null? lst) '())
+ ((fx< i n) (list lst))
+ (else
+ (do ((hd '() (cons (##sys#slot tl 0) hd))
+ (tl lst (##sys#slot tl 1))
+ (c n (fx- c 1)) )
+ ((fx= c 0)
+ (cons (reverse hd) (loop tl (fx- i n))) ) ) ) ) ) ) ) )
;;; Numeric routines:
;; Abbreviations of paper and book titles used in comments are:
diff --git a/modules.scm b/modules.scm
index a5521cbd..4e29e718 100644
--- a/modules.scm
+++ b/modules.scm
@@ -1042,9 +1042,6 @@
(##sys#register-module-alias 'r5rs 'scheme)
(##sys#register-module-alias 'srfi-88 'chicken.keyword)
-;; TODO drop when data-structures goes away
-(##sys#register-module-alias 'data-structures 'chicken.data-structures)
-
(define-inline (se-subset names env) (map (cut assq <> env) names))
;; Hack for library.scm to use macros from modules it defines itself.
diff --git a/optimizer.scm b/optimizer.scm
index 6286265a..f36433dc 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -35,9 +35,10 @@
eq-inline-operator membership-test-operators membership-unfold-limit
default-optimization-passes rewrite)
-(import chicken scheme
+(import scheme
+ chicken.base
chicken.compiler.support
- (only chicken.data-structures o alist-ref alist-update! butlast)
+ chicken.fixnum
chicken.internal
chicken.sort
chicken.string)
diff --git a/rules.make b/rules.make
index 7025bb86..202262c1 100644
--- a/rules.make
+++ b/rules.make
@@ -526,14 +526,13 @@ c-platform.c: c-platform.scm mini-srfi-1.scm \
chicken.compiler.optimizer.import.scm \
chicken.compiler.support.import.scm \
chicken.compiler.core.import.scm \
- chicken.data-structures.import.scm \
chicken.internal.import.scm
c-backend.c: c-backend.scm mini-srfi-1.scm \
chicken.compiler.c-platform.import.scm \
chicken.compiler.support.import.scm \
chicken.compiler.core.import.scm \
+ chicken.base.import.scm \
chicken.bitwise.import.scm \
- chicken.data-structures.import.scm \
chicken.flonum.import.scm \
chicken.foreign.import.scm \
chicken.format.import.scm \
@@ -544,7 +543,7 @@ c-backend.c: c-backend.scm mini-srfi-1.scm \
core.c: core.scm mini-srfi-1.scm \
chicken.compiler.scrutinizer.import.scm \
chicken.compiler.support.import.scm \
- chicken.data-structures.import.scm \
+ chicken.base.import.scm \
chicken.eval.import.scm \
chicken.format.import.scm \
chicken.io.import.scm \
@@ -555,15 +554,15 @@ core.c: core.scm mini-srfi-1.scm \
chicken.syntax.import.scm
optimizer.c: optimizer.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm \
- chicken.data-structures.import.scm \
+ chicken.base.import.scm \
chicken.internal.import.scm \
chicken.sort.import.scm \
chicken.string.import.scm
scheduler.c: scheduler.scm \
chicken.format.import.scm
scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \
+ chicken.base.import.scm \
chicken.compiler.support.import.scm \
- chicken.data-structures.import.scm \
chicken.format.import.scm \
chicken.internal.import.scm \
chicken.io.import.scm \
@@ -579,17 +578,16 @@ lfa2.c: lfa2.scm mini-srfi-1.scm \
compiler-syntax.c: compiler-syntax.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm \
chicken.compiler.core.import.scm \
- chicken.data-structures.import.scm \
chicken.format.import.scm
chicken-ffi-syntax.c: chicken-ffi-syntax.scm \
chicken.format.import.scm \
chicken.internal.import.scm \
chicken.string.import.scm
support.c: support.scm mini-srfi-1.scm \
+ chicken.base.import.scm \
chicken.bitwise.import.scm \
chicken.blob.import.scm \
chicken.condition.import.scm \
- chicken.data-structures.import.scm \
chicken.file.import.scm \
chicken.foreign.import.scm \
chicken.format.import.scm \
@@ -622,8 +620,8 @@ csc.c: csc.scm \
chicken.process.import.scm \
chicken.string.import.scm
csi.c: csi.scm \
+ chicken.base.import.scm \
chicken.condition.import.scm \
- chicken.data-structures.import.scm \
chicken.foreign.import.scm \
chicken.format.import.scm \
chicken.gc.import.scm \
@@ -656,7 +654,6 @@ chicken-status.c: chicken-status.scm \
chicken.string.import.scm
chicken-install.c: chicken-install.scm \
chicken.condition.import.scm \
- chicken.data-structures.import.scm \
chicken.file.import.scm \
chicken.foreign.import.scm \
chicken.format.import.scm \
@@ -819,7 +816,6 @@ continuation.c: $(SRCDIR)continuation.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) -emit-import-library chicken.continuation
data-structures.c: $(SRCDIR)data-structures.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) \
- -emit-import-library chicken.data-structures \
-emit-import-library chicken.sort \
-emit-import-library chicken.string
pathname.c: $(SRCDIR)pathname.scm $(SRCDIR)common-declarations.scm
diff --git a/scripts/makedist.scm b/scripts/makedist.scm
index f66747eb..5c804690 100644
--- a/scripts/makedist.scm
+++ b/scripts/makedist.scm
@@ -1,8 +1,7 @@
;;;; makedist.scm - Make distribution tarballs
-(import (chicken data-structures)
- (chicken file)
+(import (chicken file)
(chicken fixnum)
(chicken format)
(chicken io)
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 84e96b29..a6b9ce68 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -34,10 +34,11 @@
;; Exported for use in the tests:
match-types refine-types type<=?)
-(import chicken scheme
+(import scheme
+ (only chicken file-exists?) ; Should this depend on "file"?
+ chicken.base
chicken.compiler.support
- (only chicken.data-structures
- identity constantly alist-ref alist-update! butlast atom?)
+ chicken.fixnum
chicken.format
chicken.internal
chicken.io
diff --git a/support.scm b/support.scm
index 7b425df3..44f91fe9 100644
--- a/support.scm
+++ b/support.scm
@@ -76,12 +76,14 @@
;; in a lot of other places.
number-type unsafe)
-(import chicken scheme
+(import scheme
+ (only chicken open-output-string get-output-string flush-output)
+ chicken.base
chicken.bitwise
chicken.blob
chicken.condition
- (only chicken.data-structures butlast alist-ref atom?)
chicken.file
+ chicken.fixnum
chicken.foreign
chicken.format
chicken.internal
diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm
index 7edbc48e..b1851857 100644
--- a/tests/data-structures-tests.scm
+++ b/tests/data-structures-tests.scm
@@ -1,8 +1,6 @@
;;;; data-structures-tests.scm
-(import (only (chicken data-structures)
- alist-ref alist-update! alist-update)
- (chicken sort)
+(import (chicken sort)
(chicken string))
(define-syntax assert-error
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 7a9f71b1..8dad2368 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -1,7 +1,7 @@
;;;; functor-tests.scm
-(import data-structures chicken.fixnum chicken.port chicken.pretty-print)
+(import chicken.fixnum chicken.port chicken.pretty-print)
(include "test.scm")
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 812073e3..4fde81c0 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -1,6 +1,5 @@
-(import chicken.condition (only data-structures constantly)
- chicken.file chicken.flonum chicken.format chicken.io
- chicken.port chicken.posix chicken.tcp srfi-4)
+(import chicken.condition chicken.file chicken.flonum chicken.format
+ chicken.io chicken.port chicken.posix chicken.tcp srfi-4)
(include "test.scm")
(test-begin "ports")
diff --git a/tests/runtests.bat b/tests/runtests.bat
index de2f0510..794faf24 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -340,7 +340,7 @@ if errorlevel 1 exit /b 1
echo ======================================== r4rstest ...
echo (expect mult-float-print-test to fail)
-%interpret% -R data-structures -e "(set! ##sys#procedure->string (constantly \"#<procedure>\"))" -i -s r4rstest.scm >r4rstest.out
+%interpret% -e "(set! ##sys#procedure->string (constantly \"#<procedure>\"))" -i -s r4rstest.scm >r4rstest.out
if errorlevel 1 exit /b 1
type r4rstest.out
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 763267f0..8975370c 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -279,7 +279,7 @@ $interpret -s loopy-test.scm
echo "======================================== r4rstest ..."
echo "(expect mult-float-print-test to fail)"
-$interpret -R data-structures -e '(set! ##sys#procedure->string (constantly "#<procedure>"))' \
+$interpret -e '(set! ##sys#procedure->string (constantly "#<procedure>"))' \
-i -s r4rstest.scm >r4rstest.out
diff $DIFF_OPTS r4rstest.expected r4rstest.out
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 6b09b7e3..44c6c32c 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -1,8 +1,7 @@
;;;; typematch-tests.scm
-(import (only chicken.data-structures identity)
- chicken.blob chicken.condition chicken.memory chicken.locative)
+(import chicken.blob chicken.condition chicken.memory chicken.locative)
(define (make-list n x)
diff --git a/types.db b/types.db
index 4064f8fd..b0772da5 100644
--- a/types.db
+++ b/types.db
@@ -1004,6 +1004,51 @@
;; TODO: Add nonspecializing type specific entries, to help flow analysis?
(chicken.base#quotient&modulo (#(procedure #:clean #:enforce #:foldable) chicken.base#quotient&modulo ((or integer float) (or integer float)) (or integer float) (or integer float)))
+(chicken.base#alist-ref
+ (forall (a b c d)
+ (#(procedure #:clean #:foldable) chicken.base#alist-ref
+ (a (list-of (pair b c)) #!optional (procedure (a b) *) d)
+ (or false c d))))
+(chicken.base#alist-update!
+ (forall (a b c d)
+ (#(procedure) chicken.base#alist-update!
+ (a b (list-of (pair c d)) #!optional (procedure (a c) *))
+ (list-of (pair c (or b d))))))
+(chicken.base#alist-update
+ (forall (a b c d)
+ (#(procedure #:clean) chicken.base#alist-update
+ (a b (list-of (pair c d)) #!optional (procedure (a c) *))
+ (list-of (pair c (or b d))))))
+
+(chicken.base#atom? (#(procedure #:pure #:foldable) chicken.base#atom? (*) boolean)
+ ((pair) (let ((#(tmp) #(1))) '#f))
+ (((not (or pair list))) (let ((#(tmp) #(1))) '#t)))
+
+(chicken.base#butlast (forall (a) (#(procedure #:clean #:enforce) chicken.base#butlast ((pair a *)) (list-of a))))
+(chicken.base#chop (forall (a) (#(procedure #:clean #:enforce) chicken.base#chop ((list-of a) fixnum) (list-of a))))
+(chicken.base#complement (#(procedure #:clean #:enforce) chicken.base#complement ((procedure (#!rest) *)) (procedure (#!rest) boolean)))
+(chicken.base#compose (#(procedure #:clean #:enforce) chicken.base#compose (#!rest procedure) procedure))
+(chicken.base#compress (forall (a) (#(procedure #:clean #:enforce) chicken.base#compress (list (list-of a)) (list-of a))))
+(chicken.base#conjoin (#(procedure #:clean #:enforce) chicken.base#conjoin (#!rest (procedure (*) *)) (procedure (*) *)))
+(chicken.base#constantly (forall (a) (#(procedure #:pure) chicken.base#constantly (a) (procedure (#!rest) a))))
+(chicken.base#disjoin (#(procedure #:clean #:enforce) chicken.base#disjoin (#!rest (procedure (*) *)) (procedure (*) *)))
+(chicken.base#each (#(procedure #:clean #:enforce) chicken.base#each (#!rest procedure) procedure))
+(chicken.base#flatten (#(procedure #:clean #:enforce) chicken.base#flatten (#!rest *) list))
+(chicken.base#flip (#(procedure #:clean #:enforce) chicken.base#flip ((procedure (* *) . *)) (procedure (* *) . *)))
+(chicken.base#identity (forall (a) (#(procedure #:pure #:foldable) chicken.base#identity (a) a)))
+(chicken.base#intersperse (#(procedure #:clean #:enforce) chicken.base#intersperse (list *) list))
+(chicken.base#join (#(procedure #:clean #:enforce) chicken.base#join ((list-of list) #!optional list) list))
+(chicken.base#list-of? (#(procedure #:clean #:enforce) chicken.base#list-of? ((procedure (*) *)) (procedure (list) boolean)))
+
+(chicken.base#o (#(procedure #:clean #:enforce) chicken.base#o (#!rest (procedure (*) *)) (procedure (*) *)))
+
+(chicken.base#rassoc
+ (forall (a b c) (#(procedure #:clean #:foldable) chicken.base#rassoc
+ (a (list-of (pair b c)) #!optional (procedure (a b) *))
+ (or false (pair b c)))))
+(chicken.base#tail? (#(procedure #:clean) chicken.base#tail? (* *) boolean))
+
+
;; bitwise
(chicken.bitwise#integer-length
@@ -1490,51 +1535,6 @@
(chicken.string#reverse-list->string (#(procedure #:clean #:enforce) chicken.string#reverse-list->string ((list-of char)) string))
(chicken.string#reverse-string-append (#(procedure #:clean #:enforce) chicken.string#reverse-string-append ((list-of string)) string))
-;; data-structures
-
-(chicken.data-structures#alist-ref
- (forall (a b c d)
- (#(procedure #:clean #:foldable) chicken.data-structures#alist-ref
- (a (list-of (pair b c)) #!optional (procedure (a b) *) d)
- (or false c d))))
-(chicken.data-structures#alist-update!
- (forall (a b c d)
- (#(procedure) chicken.data-structures#alist-update!
- (a b (list-of (pair c d)) #!optional (procedure (a c) *))
- (list-of (pair c (or b d))))))
-(chicken.data-structures#alist-update
- (forall (a b c d)
- (#(procedure #:clean) chicken.data-structures#alist-update
- (a b (list-of (pair c d)) #!optional (procedure (a c) *))
- (list-of (pair c (or b d))))))
-
-(chicken.data-structures#atom? (#(procedure #:pure #:foldable) chicken.data-structures#atom? (*) boolean)
- ((pair) (let ((#(tmp) #(1))) '#f))
- (((not (or pair list))) (let ((#(tmp) #(1))) '#t)))
-
-(chicken.data-structures#butlast (forall (a) (#(procedure #:clean #:enforce) chicken.data-structures#butlast ((pair a *)) (list-of a))))
-(chicken.data-structures#chop (forall (a) (#(procedure #:clean #:enforce) chicken.data-structures#chop ((list-of a) fixnum) (list-of a))))
-(chicken.data-structures#complement (#(procedure #:clean #:enforce) chicken.data-structures#complement ((procedure (#!rest) *)) (procedure (#!rest) boolean)))
-(chicken.data-structures#compose (#(procedure #:clean #:enforce) chicken.data-structures#compose (#!rest procedure) procedure))
-(chicken.data-structures#compress (forall (a) (#(procedure #:clean #:enforce) chicken.data-structures#compress (list (list-of a)) (list-of a))))
-(chicken.data-structures#conjoin (#(procedure #:clean #:enforce) chicken.data-structures#conjoin (#!rest (procedure (*) *)) (procedure (*) *)))
-(chicken.data-structures#constantly (forall (a) (#(procedure #:pure) chicken.data-structures#constantly (a) (procedure (#!rest) a))))
-(chicken.data-structures#disjoin (#(procedure #:clean #:enforce) chicken.data-structures#disjoin (#!rest (procedure (*) *)) (procedure (*) *)))
-(chicken.data-structures#each (#(procedure #:clean #:enforce) chicken.data-structures#each (#!rest procedure) procedure))
-(chicken.data-structures#flatten (#(procedure #:clean #:enforce) chicken.data-structures#flatten (#!rest *) list))
-(chicken.data-structures#flip (#(procedure #:clean #:enforce) chicken.data-structures#flip ((procedure (* *) . *)) (procedure (* *) . *)))
-(chicken.data-structures#identity (forall (a) (#(procedure #:pure #:foldable) chicken.data-structures#identity (a) a)))
-(chicken.data-structures#intersperse (#(procedure #:clean #:enforce) chicken.data-structures#intersperse (list *) list))
-(chicken.data-structures#join (#(procedure #:clean #:enforce) chicken.data-structures#join ((list-of list) #!optional list) list))
-(chicken.data-structures#list-of? (#(procedure #:clean #:enforce) chicken.data-structures#list-of? ((procedure (*) *)) (procedure (list) boolean)))
-
-(chicken.data-structures#o (#(procedure #:clean #:enforce) chicken.data-structures#o (#!rest (procedure (*) *)) (procedure (*) *)))
-
-(chicken.data-structures#rassoc
- (forall (a b c) (#(procedure #:clean #:foldable) chicken.data-structures#rassoc
- (a (list-of (pair b c)) #!optional (procedure (a b) *))
- (or false (pair b c)))))
-
(##sys#substring-index
(#(procedure #:clean #:enforce #:foldable) ##sys#substring-index
(string string fixnum)
@@ -1545,8 +1545,6 @@
(string string fixnum)
(or false fixnum)))
-(chicken.data-structures#tail? (#(procedure #:clean) chicken.data-structures#tail? (* *) boolean))
-
;; io
(chicken.io#read-list (#(procedure #:enforce) chicken.io#read-list (#!optional input-port (procedure (input-port) *) fixnum) list))
Trap