~ chicken-core (chicken-5) f7d4cb8c2a18ec71ef3ef7d8eed2907499899175
commit f7d4cb8c2a18ec71ef3ef7d8eed2907499899175
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Jan 25 22:39:20 2015 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Sun Jan 25 22:39:20 2015 +0100
Converted all core modules
diff --git a/c-backend.scm b/c-backend.scm
index ccfca618..16a3c315 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -30,7 +30,7 @@
;; Same goes for "platform" and "driver".
(declare
(unit c-backend)
- (uses srfi-1 data-structures
+ (uses data-structures
c-platform compiler support))
(module chicken.compiler.c-backend
@@ -38,11 +38,13 @@
;; For "foreign" (aka chicken-ffi-syntax):
foreign-type-declaration)
-(import chicken scheme foreign srfi-1 data-structures
+(import chicken scheme foreign data-structures
chicken.compiler.core
chicken.compiler.c-platform
chicken.compiler.support)
+(include "mini-srfi-1.scm")
+
;;; Write atoms to output-port:
(define output #f)
@@ -551,12 +553,12 @@
[direct (lambda-literal-direct ll)]
[allocated (lambda-literal-allocated ll)] )
(when (>= n small-parameter-limit)
- (set! large-signatures (lset-adjoin = large-signatures (add1 n))) )
+ (set! large-signatures (lset-adjoin large-signatures (add1 n))) )
(gen #t)
(for-each
(lambda (s)
(when (>= s small-parameter-limit)
- (set! large-signatures (lset-adjoin = large-signatures (add1 s))) ) )
+ (set! large-signatures (lset-adjoin large-signatures (add1 s))) ) )
(lambda-literal-callee-signatures ll) )
(cond [(not (eq? 'toplevel id))
(gen "C_noret_decl(" id ")" #t)
@@ -652,8 +654,8 @@
(gen ");}") ]
[(or rest (> (lambda-literal-allocated ll) 0) (lambda-literal-external ll))
(if (and rest (not (eq? rest-mode 'none)))
- (set! nsr (lset-adjoin = nsr argc))
- (set! ns (lset-adjoin = ns argc)) ) ] ) ) ) )
+ (set! nsr (lset-adjoin nsr argc))
+ (set! ns (lset-adjoin ns argc)) ) ] ) ) ) )
lambda-table)
(for-each
(lambda (n)
@@ -683,7 +685,7 @@
[(number? lit) words-per-flonum]
[(symbol? lit) 10] ; size of symbol, and possibly a bucket
[(pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit)))]
- [(vector? lit) (+ 1 (vector-length lit) (reduce + 0 (map literal-size (vector->list lit))))]
+ [(vector? lit) (+ 1 (vector-length lit) (foldl + 0 (map literal-size (vector->list lit))))]
[(block-variable-literal? lit) 0]
[(##sys#immediate? lit) (bad-literal lit)]
[(##core#inline "C_lambdainfop" lit) 0]
@@ -814,7 +816,7 @@
(gen #t (utype (cdr ubt)) #\space (car ubt) #\;))
ubtemps)))
(cond [(eq? 'toplevel id)
- (let ([ldemand (fold (lambda (lit n) (+ n (literal-size lit))) 0 literals)]
+ (let ([ldemand (foldl (lambda (n lit) (+ n (literal-size lit))) 0 literals)]
[llen (length literals)] )
(gen #t "C_word *a;"
#t "if(toplevel_initialized) C_kontinue(t1,C_SCHEME_UNDEFINED);"
@@ -1116,7 +1118,11 @@
(else ns) ) )
(else ns) ) ) ) )
- (let ((sizestr (fold compute-size "0" argtypes vlist)))
+ (let ((sizestr (let loop ((types argtypes) (vars vlist) (ns "0"))
+ (if (null? types)
+ ns
+ (loop (cdr types) (cdr vars)
+ (compute-size (car types) (car vars) ns))))))
(gen #t)
(when rname
(gen #t "/* from " (cleanup rname) " */") )
@@ -1145,11 +1151,10 @@
(n (length argtypes))
(vlist (make-argument-list n "t")) )
(gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\()
- (pair-for-each
- (lambda (vs ts)
- (gen (foreign-type-declaration (car ts) (car vs)))
- (when (pair? (cdr vs)) (gen #\,)) )
- vlist argtypes)
+ (let loop ((vs vlist) (ts argtypes))
+ (unless (null? vs)
+ (gen (foreign-type-declaration (car ts) (car vs)))
+ (when (pair? (cdr vs)) (gen #\,)) ))
(gen #\)) ) )
diff --git a/chicken-install.scm b/chicken-install.scm
index 5b5140d6..22a59e93 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -25,16 +25,18 @@
(require-library setup-download setup-api)
-(require-library srfi-1 posix data-structures utils irregex ports extras files)
+(require-library posix data-structures utils irregex ports extras files)
(module main ()
- (import scheme chicken srfi-1 posix data-structures utils irregex ports extras
+ (import scheme chicken posix data-structures utils irregex ports extras
files)
(import setup-download setup-api)
(import foreign)
+ (include "mini-srfi-1.scm")
+
(define +default-repository-files+
;;XXX keep this up-to-date!
'("setup-api.so" "setup-api.import.so"
@@ -566,8 +568,8 @@
(define (install eggs)
(when *keep-existing*
(set! eggs
- (remove
- (lambda (egg) (extension-information (if (pair? egg) (car egg) egg)))
+ (filter
+ (lambda (egg) (not (extension-information (if (pair? egg) (car egg) egg))))
eggs)))
(retrieve eggs)
(unless *retrieve-only*
@@ -650,7 +652,10 @@
(fluid-let ((*host-extension* #f))
(setup tmpcopy)))))))
eggs+dirs+vers
- (iota num num -1)))))
+ (let loop ((i num))
+ (if (fx= 1 i)
+ '()
+ (cons num (loop (fx- i 1)))))))))
(define (delete-stale-binaries)
(print* "deleting stale binaries ...")
@@ -722,7 +727,8 @@
(else (list egg))))
eggs)
same?)))
- (unless (lset= same? eggs eggs2)
+ (unless (and (= (length eggs) (length eggs2))
+ (every (lambda (egg) (find (cut same=? <> egg) eggs2)) eggs))
(print "mapped " eggs " to " eggs2))
eggs2))
diff --git a/chicken-profile.scm b/chicken-profile.scm
index e845e68b..fddfef7a 100644
--- a/chicken-profile.scm
+++ b/chicken-profile.scm
@@ -27,11 +27,12 @@
(declare
(block)
- (uses srfi-1
- data-structures
+ (uses data-structures
posix
utils))
+(include "mini-srfi-1.scm")
+
(define symbol-table-size 3001)
(define sort-by #f)
@@ -228,15 +229,15 @@ EOF
[alignments (list #f #t #t #t #t)]
[spacing 2]
[spacer (make-string spacing #\space)]
- [column-widths (fold
- (lambda (row max-widths)
+ [column-widths (foldl
+ (lambda (max-widths row)
(map max (map string-length row) max-widths))
(list 0 0 0 0 0)
(cons headers data))])
(define (print-row row)
(print (string-intersperse (map format-string row column-widths alignments) spacer)))
(print-row headers)
- (print (make-string (+ (reduce + 0 column-widths)
+ (print (make-string (+ (foldl + 0 column-widths)
(* spacing (- (length alignments) 1)))
#\-))
(for-each print-row data))))
diff --git a/mini-srfi-1.scm b/mini-srfi-1.scm
index e50c2072..4534ebf7 100644
--- a/mini-srfi-1.scm
+++ b/mini-srfi-1.scm
@@ -95,10 +95,10 @@
'()
(append (car lst) (loop (cdr lst))))))
-(define (delete x lst)
+(define (delete x lst #!optional (test eq?))
(let loop ((lst lst))
(cond ((null? lst) lst)
- ((eq? x (car lst)) (cdr lst))
+ ((test x (car lst)) (cdr lst))
(else (cons (car lst) (loop (cdr lst)))) ) ) )
(define (first x) (car x))
@@ -107,13 +107,13 @@
(define (fourth x) (cadddr x))
(define (fifth x) (car (cddddr x)))
-(define (delete-duplicates lst)
+(define (delete-duplicates lst #!optional (test equal?))
(let loop ((lst lst))
(if (null? lst)
lst
(let* ((x (car lst))
(tail (cdr lst))
- (new-tail (loop (delete/eq? x tail))))
+ (new-tail (loop (delete x tail test))))
(if (equal? tail new-tail)
lst
(cons x new-tail))))))
@@ -182,7 +182,7 @@
(define (lset<= s1 s2)
(every (lambda (s) (memq s s2)) s1))
-(define (lset= s1 s2)
+(define (lset= s1 s2)+
(and (eq? (length s1) (length s2))
(every (lambda (s) (memq s s2)) s1)))
diff --git a/rules.make b/rules.make
index c99f7ce6..cdc215c3 100644
--- a/rules.make
+++ b/rules.make
@@ -516,7 +516,7 @@ 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
-c-backend.c: c-backend.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
@@ -531,6 +531,7 @@ lfa2.c: lfa2.scm chicken.compiler.support.import.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
+support.c: support.scm mini-srfi-1.scm
define profile-flags
$(if $(filter $(basename $(1)),$(PROFILE_OBJECTS)),-profile)
@@ -606,9 +607,9 @@ $(foreach obj, $(COMPILER_OBJECTS_1),\
csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
-chicken-profile.c: $(SRCDIR)chicken-profile.scm
+chicken-profile.c: $(SRCDIR)chicken-profile.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
-chicken-install.c: $(SRCDIR)chicken-install.scm setup-download.c setup-api.c
+chicken-install.c: $(SRCDIR)chicken-install.scm setup-download.c setup-api.c $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-uninstall.c: $(SRCDIR)chicken-uninstall.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
diff --git a/support.scm b/support.scm
index ca0f3538..13b15e0a 100644
--- a/support.scm
+++ b/support.scm
@@ -27,7 +27,7 @@
(declare (unit support)
(not inline ##sys#user-read-hook) ; XXX: Is this needed?
- (uses data-structures srfi-1 files extras ports) )
+ (uses data-structures files extras ports) )
(module chicken.compiler.support
(compiler-cleanup-hook bomb collected-debugging-output debugging
@@ -75,9 +75,10 @@
;; in a lot of other places.
number-type unsafe)
-(import chicken scheme foreign data-structures srfi-1 files extras ports)
+(import chicken scheme foreign data-structures files extras ports)
(include "tweaks")
+(include "mini-srfi-1.scm")
(include "banner")
;; Evil globals
@@ -136,7 +137,7 @@
(define (test-mode mode set)
(if (symbol? mode)
(memq mode set)
- (pair? (lset-intersection eq? mode set))))
+ (pair? (lset-intersection mode set))))
(cond ((test-mode mode debugging-chicken)
(let ((txt (with-output-to-string thunk)))
(display txt)
@@ -359,9 +360,14 @@
(if (exn? ex)
(exn-msg ex)
(->string ex) ) )
- (let ([xs (with-input-from-string
+ (let ((xs (with-input-from-string
str
- (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))])
+ (lambda ()
+ (let loop ((lst '()))
+ (let ((x (read)))
+ (if (eof-object? x)
+ (apply values (reverse lst))
+ (loop (cons x lst)))))))))
(cond [(null? xs) '(##core#undefined)]
[(null? (cdr xs)) (car xs)]
[else `(begin ,@xs)] ) ) ) ) ) )
@@ -490,7 +496,7 @@
(define (walk x)
(cond ((symbol? x) (varnode x))
((node? x) x)
- ((not-pair? x) (bomb "bad expression" x))
+ ((not (pair? x)) (bomb "bad expression" x))
((symbol? (car x))
(case (car x)
((if ##core#undefined) (make-node (car x) '() (map walk (cdr x))))
@@ -559,7 +565,7 @@
(make-node
'##core#foreign-callback-wrapper
(list name (cadr (third x)) (cadr (fourth x)) (cadr (fifth x)))
- (list (walk (sixth x))) ) ) )
+ (list (walk (list-ref x 5))) ) ) )
((##core#inline_allocate ##core#inline_ref ##core#inline_update
##core#inline_loc_ref ##core#inline_loc_update)
(make-node (first x) (second x) (map walk (cddr x))) )
@@ -657,21 +663,23 @@
[body (if copy?
(copy-node-tree-and-rename body vars rlist db cfk)
body) ] )
- (fold-right
- (lambda (var val body) (make-node 'let (list var) (list val body)) )
- (if rest
- (make-node
- 'let (list (last rlist))
- (list (if (null? rargs)
- (qnode '())
- (make-node
- '##core#inline_allocate
- (list "C_a_i_list" (* 3 (length rargs)))
- rargs) )
- body) )
- body)
- (take rlist argc)
- largs) ) ) ) ) )
+ (let loop ((vars (take rlist argc))
+ (vals largs))
+ (if (null? vars)
+ (if rest
+ (make-node
+ 'let (list (last rlist))
+ (list (if (null? rargs)
+ (qnode '())
+ (make-node
+ '##core#inline_allocate
+ (list "C_a_i_list" (* 3 (length rargs)))
+ rargs) )
+ body) )
+ body)
+ (make-node 'let (list (car vars))
+ (list (car vals))
+ (loop (cdr vars) (cdr vals))))))))))
;; Copy along with the above
(define (copy-node-tree-and-rename node vars aliases db cfk)
@@ -1299,12 +1307,12 @@
((##core#variable)
(let ((var (first params)))
(unless (memq var e)
- (set! vars (lset-adjoin eq? vars var))
+ (set! vars (lset-adjoin vars var))
(unless (variable-visible? var block-compilation)
- (set! hvars (lset-adjoin eq? hvars var))))))
+ (set! hvars (lset-adjoin hvars var))))))
((set!)
(let ((var (first params)))
- (unless (memq var e) (set! vars (lset-adjoin eq? vars var)))
+ (unless (memq var e) (set! vars (lset-adjoin vars var)))
(walk (car subs) e) ) )
((let)
(walk (first subs) e)
Trap