~ chicken-core (chicken-5) c5279b81a24187c52b51088d0da2a7dd32c5d901
commit c5279b81a24187c52b51088d0da2a7dd32c5d901
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jan 25 22:17:21 2015 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jan 25 22:17:21 2015 +0100
And on, and on, and on.
diff --git a/batch-driver.scm b/batch-driver.scm
index fe96e5e8..a8de43a4 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -29,7 +29,7 @@
;; Same goes for "backend" and "platform".
(declare
(unit batch-driver)
- (uses extras data-structures files srfi-1
+ (uses extras data-structures files
support compiler-syntax compiler optimizer
;; TODO: Backend should be configurable
scrutinizer lfa2 c-platform c-backend) )
@@ -40,7 +40,7 @@
user-options-pass user-read-pass user-preprocessor-pass user-pass
user-post-analysis-pass)
-(import chicken scheme extras data-structures files srfi-1
+(import chicken scheme extras data-structures files
chicken.compiler.support
chicken.compiler.compiler-syntax
chicken.compiler.core
diff --git a/c-platform.scm b/c-platform.scm
index c93947cc..d55cb3c9 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -30,7 +30,7 @@
;; Same goes for "backend" and "driver".
(declare
(unit c-platform)
- (uses srfi-1 data-structures
+ (uses data-structures
optimizer support compiler))
(module chicken.compiler.c-platform
@@ -42,13 +42,13 @@
target-include-file words-per-flonum
parameter-limit small-parameter-limit)
-(import chicken scheme srfi-1 data-structures
+(import chicken scheme data-structures
chicken.compiler.optimizer
chicken.compiler.support
chicken.compiler.core)
(include "tweaks")
-
+(include "mini-srfi-1.scm")
;;; Parameters:
@@ -225,10 +225,10 @@
;; - Remove "1" from arguments.
;; - Replace multiplications with 2 by shift left. [fixnum-mode]
(let ([callargs
- (remove
+ (filter
(lambda (x)
- (and (eq? 'quote (node-class x))
- (eq? 1 (first (node-parameters x))) ) )
+ (not (and (eq? 'quote (node-class x))
+ (eq? 1 (first (node-parameters x))) ) ) )
callargs) ] )
(cond [(null? callargs) (make-node '##core#call (list #t) (list cont (qnode 0)))]
[(null? (cdr callargs))
@@ -266,10 +266,10 @@
[else
(let ([callargs
(cons (car callargs)
- (remove
+ (filter
(lambda (x)
- (and (eq? 'quote (node-class x))
- (zero? (first (node-parameters x))) ) )
+ (not (and (eq? 'quote (node-class x))
+ (zero? (first (node-parameters x))) ) ) )
(cdr callargs) ) ) ] )
(and (eq? number-type 'fixnum)
(>= (length callargs) 2)
@@ -293,10 +293,10 @@
(and (>= (length callargs) 2)
(let ([callargs
(cons (car callargs)
- (remove
+ (filter
(lambda (x)
- (and (eq? 'quote (node-class x))
- (eq? 1 (first (node-parameters x))) ) )
+ (not (and (eq? 'quote (node-class x))
+ (eq? 1 (first (node-parameters x))) ) ) )
(cdr callargs) ) ) ] )
(and (eq? number-type 'fixnum)
(>= (length callargs) 2)
@@ -493,7 +493,7 @@
(val (db-get db sym 'value)) )
(and (eq? '##core#lambda (node-class val))
(let ((llist (third (node-parameters val))))
- (and (proper-list? llist)
+ (and (list? llist)
(= 2 (length llist))
(let ((tmp (gensym))
(tmpk (gensym 'r)) )
diff --git a/chicken-status.scm b/chicken-status.scm
index 4b9a1e01..3e8ac163 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -24,15 +24,17 @@
; POSSIBILITY OF SUCH DAMAGE.
-(require-library setup-api srfi-1 posix data-structures utils ports irregex files)
+(require-library setup-api posix data-structures utils ports irregex files)
(module main ()
(import scheme chicken foreign)
- (import srfi-1 posix data-structures utils ports irregex
+ (import posix data-structures utils ports irregex
files setup-api extras)
+ (include "mini-srfi-1.scm")
+
(define-foreign-variable C_TARGET_LIB_HOME c-string)
(define-foreign-variable C_BINARY_VERSION int)
@@ -51,10 +53,7 @@
(define (gather-extensions patterns)
(let* ((extensions (gather-all-extensions))
(pats (concatenate (map (cut grep <> extensions) patterns))))
- (let loop ((pats pats))
- (cond ((null? pats) '())
- ((member (car pats) (cdr pats)) (loop (cdr pats)))
- (else (cons (car pats) (loop (cdr pats))))))))
+ (delete-duplicates pats)))
(define (gather-eggs patterns)
(define (egg-name extension)
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
index 1606785e..8709c0d5 100644
--- a/chicken-uninstall.scm
+++ b/chicken-uninstall.scm
@@ -26,14 +26,14 @@
(require-library
setup-api
- srfi-1 posix data-structures utils ports irregex files)
+ posix data-structures utils ports irregex files)
(module main ()
(import scheme chicken foreign)
(import setup-api)
- (import srfi-1 posix data-structures utils ports irregex files)
+ (import posix data-structures utils ports irregex files)
(include "mini-srfi-1.scm")
@@ -58,10 +58,7 @@
(let* ((eggs (map pathname-file
(glob (make-pathname (repo-path) "*" "setup-info"))))
(pats (concatenate (map (cut grep <> eggs) patterns))))
- (let loop ((pats pats))
- (cond ((null? pats) '())
- ((member (car pats) (cdr pats)) (loop (cdr pats)))
- (else (cons (car pats) (loop (cdr pats))))))))
+ (delete-duplicates pats)))
(define (fini code)
(print "aborted.")
diff --git a/chicken.scm b/chicken.scm
index d802438a..397b7186 100644
--- a/chicken.scm
+++ b/chicken.scm
@@ -27,7 +27,7 @@
(declare
(uses chicken-syntax chicken-ffi-syntax
- srfi-1 srfi-4 utils files extras data-structures support
+ srfi-4 utils files extras data-structures support
compiler optimizer lfa2 compiler-syntax scrutinizer
;; TODO: These three need to be made configurable somehow
batch-driver c-platform c-backend))
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index 19831406..fd362582 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -26,17 +26,18 @@
(declare
(unit compiler-syntax)
- (uses srfi-1 data-structures
+ (uses data-structures
support compiler) )
(module chicken.compiler.compiler-syntax
(compiler-syntax-statistics)
-(import chicken scheme srfi-1 data-structures
+(import chicken scheme data-structures
chicken.compiler.support
chicken.compiler.core)
(include "tweaks.scm")
+(include "mini-srfi-1.scm")
;;; Compiler macros (that operate in the expansion phase)
diff --git a/core.scm b/core.scm
index c5fd0040..48151fd4 100644
--- a/core.scm
+++ b/core.scm
@@ -264,7 +264,7 @@
(declare
(unit compiler)
- (uses srfi-1 extras data-structures
+ (uses extras data-structures
scrutinizer support) )
(module chicken.compiler.core
@@ -314,7 +314,7 @@
constant-table immutable-constants inline-table line-number-database-2
line-number-database-size)
-(import chicken scheme foreign srfi-1 extras data-structures
+(import chicken scheme foreign extras data-structures
chicken.compiler.scrutinizer
chicken.compiler.support)
@@ -327,7 +327,7 @@
(define-syntax d (syntax-rules () ((_ . _) (void))))
(include "tweaks")
-
+(include "mini-srfi-1.scm")
(define-inline (gensym-f-id) (gensym 'f_))
diff --git a/lfa2.scm b/lfa2.scm
index 6d16fbd2..04adf67f 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -34,13 +34,12 @@
(declare
(unit lfa2)
- (uses srfi-1
- support) )
+ (uses support) )
(module chicken.compiler.lfa2
(perform-secondary-flow-analysis)
-(import chicken scheme srfi-1
+(import chicken scheme
chicken.compiler.support)
(include "tweaks")
diff --git a/mini-srfi-1.scm b/mini-srfi-1.scm
index 16ffc33a..e50c2072 100644
--- a/mini-srfi-1.scm
+++ b/mini-srfi-1.scm
@@ -29,7 +29,8 @@
(hide take span drop partition split-at append-map every any cons* concatenate delete
first second third fourth alist-cons delete-duplicates fifth
filter filter-map unzip1 last list-index lset-adjoin lset-difference
- lset-union lset-intersection list-tabulate lset<= lset= length+))
+ lset-union lset-intersection list-tabulate lset<= lset= length+ find find-tail
+ iota make-list))
(define (partition pred lst)
@@ -113,7 +114,7 @@
(let* ((x (car lst))
(tail (cdr lst))
(new-tail (loop (delete/eq? x tail))))
- (if (eq? tail new-tail)
+ (if (equal? tail new-tail)
lst
(cons x new-tail))))))
@@ -199,3 +200,19 @@
len))
len)))
+(define (find pred lst)
+ (let loop ((lst lst))
+ (cond ((null? lst) #f)
+ ((pred (car lst)) (car lst))
+ (else (loop (cdr lst))))))
+
+(define (find-tail pred ls)
+ (let lp ((ls ls))
+ (cond ((null? ls) #f)
+ ((pred (car ls)) ls)
+ (else (lp (cdr ls))))))
+
+(define (iota n) (list-tabulate n (lambda (i) i)))
+
+(define (make-list n x)
+ (list-tabulate n (lambda _ x)))
diff --git a/optimizer.scm b/optimizer.scm
index 3eae76b3..5c480819 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -27,7 +27,7 @@
(declare
(unit optimizer)
- (uses srfi-1 data-structures
+ (uses data-structures
support) )
(module chicken.compiler.optimizer
@@ -36,10 +36,11 @@
eq-inline-operator membership-test-operators membership-unfold-limit
default-optimization-passes rewrite)
-(import chicken scheme srfi-1 data-structures
+(import chicken scheme data-structures
chicken.compiler.support)
(include "tweaks")
+(include "mini-srfi-1.scm")
(define-constant maximal-number-of-free-variables-for-liftable 16)
diff --git a/rules.make b/rules.make
index 66e4461a..c99f7ce6 100644
--- a/rules.make
+++ b/rules.make
@@ -36,7 +36,7 @@ VPATH=$(SRCDIR)
SETUP_API_OBJECTS_1 = setup-api setup-download
LIBCHICKEN_SCHEME_OBJECTS_1 = \
- library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 \
+ library eval data-structures ports files extras lolevel utils tcp srfi-4 \
$(POSIXFILE) irregex scheduler \
profiler stub expand modules chicken-syntax chicken-ffi-syntax build-version
LIBCHICKEN_OBJECTS_1 = $(LIBCHICKEN_SCHEME_OBJECTS_1) runtime
@@ -512,7 +512,7 @@ batch-driver.c: batch-driver.scm mini-srfi-1.scm \
chicken.compiler.lfa2.import.scm \
chicken.compiler.c-backend.import.scm \
chicken.compiler.support.import.scm
-c-platform.c: c-platform.scm \
+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
@@ -525,7 +525,7 @@ core.c: core.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm
optimizer.c: optimizer.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm
-scrutinizer.c: scrutinizer.scm \
+scrutinizer.c: scrutinizer.scm mini-srfi-1.scm \
chicken.compiler.support.import.scm
lfa2.c: lfa2.scm chicken.compiler.support.import.scm mini-srfi-1.scm
compiler-syntax.c: compiler-syntax.scm mini-srfi-1.scm \
@@ -571,8 +571,6 @@ lolevel.c: $(SRCDIR)lolevel.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
tcp.c: $(SRCDIR)tcp.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
-srfi-1.c: $(SRCDIR)srfi-1.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
srfi-4.c: $(SRCDIR)srfi-4.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
utils.c: $(SRCDIR)utils.scm $(SRCDIR)common-declarations.scm
diff --git a/scrutinizer.scm b/scrutinizer.scm
index c8fa309b..e19a24c4 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -26,17 +26,18 @@
(declare
(unit scrutinizer)
- (uses srfi-1 data-structures extras ports files
+ (uses data-structures extras ports files
support) )
(module chicken.compiler.scrutinizer
(scrutinize load-type-database emit-type-file
validate-type check-and-validate-type install-specializations)
-(import chicken scheme srfi-1 data-structures extras ports files
+(import chicken scheme data-structures extras ports files
chicken.compiler.support)
(include "tweaks")
+(include "mini-srfi-1.scm")
(define d-depth 0)
(define scrutiny-debug #t)
@@ -933,7 +934,7 @@
(else #f))))
(define (match-rest rtype args opt) ;XXX currently ignores `opt'
- (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
+ (let-values (((head tail) (span (lambda (x) (not (eq? '#!rest x))) args)))
(and (every
(lambda (t)
(or (eq? '#!optional t)
@@ -962,6 +963,12 @@
(all #f))
(match1 t1 t2)))
+ (define (every-match1 lst1 lst2)
+ (let loop ((lst1 lst1) (lst2 lst2))
+ (cond ((null? lst1))
+ ((match1 (car lst1) (car lst2)) (loop (cdr lst1) (cdr lst2)))
+ (else #f))))
+
(define (match1 t1 t2)
;; note: the order of determining the type is important
(dd " match1: ~s <-> ~s" t1 t2)
@@ -1082,11 +1089,11 @@
(and (match-args args1 args2)
(match-results results1 results2))))
((struct) (equal? t1 t2))
- ((pair) (every match1 (cdr t1) (cdr t2)))
+ ((pair) (every-match1 (cdr t1) (cdr t2)))
((list-of vector-of) (match1 (second t1) (second t2)))
((list vector)
(and (= (length t1) (length t2))
- (every match1 (cdr t1) (cdr t2))))
+ (every-match1 (cdr t1) (cdr t2))))
(else #f) ) )
((and (pair? t1) (eq? 'pair (car t1)))
(and (pair? t2)
@@ -1244,7 +1251,7 @@
((every procedure-type? ts)
(if (any (cut eq? 'procedure <>) ts)
'procedure
- (reduce
+ (foldl
(lambda (t pt)
(let* ((name1 (procedure-name t))
(atypes1 (procedure-arguments t))
@@ -1257,10 +1264,10 @@
(if (and name1 name2 (eq? name1 name2)) (list name1) '())
(list (merge-argument-types atypes1 atypes2))
(merge-result-types rtypes1 rtypes2))))
- #f
- ts)))
- ((lset= eq? '(true false) ts) 'boolean)
- ((lset= eq? '(fixnum float) ts) 'number)
+ (car ts)
+ (cdr ts))))
+ ((lset= '(true false) ts) 'boolean)
+ ((lset= '(fixnum float) ts) 'number)
(else
(let* ((ts (append-map
(lambda (t)
@@ -1320,7 +1327,7 @@
(else t)))
((assq t typeenv) =>
(lambda (e)
- (set! used (lset-adjoin eq? used t))
+ (set! used (lset-adjoin used t))
(cdr e)))
(else t)))))
(let ((t2 (simplify t)))
@@ -1472,10 +1479,15 @@
(else
(case (car t1)
((vector-of list-of) (test (second t1) (second t2)))
- ((pair) (every test (cdr t1) (cdr t2)))
+ ((pair)
+ (and (test (second t1) (second t2))
+ (test (third t1) (third t2))))
((list vector)
(and (= (length t1) (length t2))
- (every test (cdr t1) (cdr t2))))
+ (let loop ((lst1 (cdr t1)) (lst2 (cdr t2)))
+ (or (null? lst1)
+ (and (test (car lst1) (car lst2))
+ (loop (cdr lst1) (cdr lst2)))))))
((struct) (eq? (cadr t1) (cadr t2)))
((procedure)
(let ((args1 (if (named? t1) (caddr t1) (cadr t1)))
@@ -2064,7 +2076,7 @@
,(map (lambda (tv)
(cond ((assq tv constraints) => identity)
(else tv)))
- (delete-duplicates typevars eq?))
+ (delete-duplicates typevars))
,type)))
(let ((type2 (simplify-type type)))
(values
@@ -2334,7 +2346,7 @@
;; collect candidates for each typevar
(define (collect)
- (let* ((vars (delete-duplicates (concatenate (map unzip1 insts)) eq?))
+ (let* ((vars (delete-duplicates (concatenate (map unzip1 insts))))
(all (map (lambda (var)
(cons
var
@@ -2351,7 +2363,7 @@
(ddd " over-all-instantiations: ~s exact=~a" tlist exact)
;; process all tlist elements
- (let loop ((ts (delete-duplicates tlist equal?))
+ (let loop ((ts (delete-duplicates tlist))
(ok #f))
(cond ((null? ts)
(cond ((or ok (null? tlist))
Trap