~ chicken-core (chicken-5) c5599d13eb1aa919991adf6ccb4b3cfca0db0074
commit c5599d13eb1aa919991adf6ccb4b3cfca0db0074
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jan 28 23:29:35 2015 +0100
Commit: Evan Hanson <evhan@foldling.org>
CommitDate: Wed Jan 28 23:29:35 2015 +0100
Many changes to make build run trough
diff --git a/c-backend.scm b/c-backend.scm
index 16a3c315..d012a09d 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -177,7 +177,7 @@
(gen "a[" j "]=")
(expr x i)
(gen #\,) )
- subs (iota n 1 1) )
+ subs (list-tabulate n add1))
(gen "tmp=(C_word)a,a+=" (add1 n) ",tmp)") ) )
((##core#box)
@@ -256,8 +256,8 @@
(call-id
(cond ((and (eq? call-id (lambda-literal-id ll))
(lambda-literal-looping ll) )
- (let* ([temps (lambda-literal-temporaries ll)]
- [ts (iota n (+ temps nf) 1)] )
+ (let* ((temps (lambda-literal-temporaries ll))
+ (ts (list-tabulate n (lambda (i) (+ temps nf i)))))
(for-each
(lambda (arg tr)
(gen #t #\t tr #\=)
@@ -266,7 +266,7 @@
args ts)
(for-each
(lambda (from to) (gen #t #\t to "=t" from #\;))
- ts (iota n 1 1) )
+ ts (list-tabulate n add1))
(unless customizable (gen #t "c=" nf #\;))
(gen #t "goto loop;") ) )
(else
@@ -332,8 +332,8 @@
[call-id (second params)]
[empty-closure (zero? (lambda-literal-closure-size ll))] )
(cond (tailcall
- (let* ([temps (lambda-literal-temporaries ll)]
- [ts (iota n (+ temps nf) 1)] )
+ (let* ((temps (lambda-literal-temporaries ll))
+ (ts (list-tabulate n (cut + temps nf <>))))
(for-each
(lambda (arg tr)
(gen #t #\t tr #\=)
@@ -342,7 +342,7 @@
subs ts)
(for-each
(lambda (from to) (gen #t #\t to "=t" from #\;))
- ts (iota n 1 1) )
+ ts (list-tabulate n add1))
(gen #t "goto loop;") ) )
(else
(gen call-id #\()
@@ -460,11 +460,10 @@
(else (bomb "bad form" (node-class n))) ) ) )
(define (expr-args args i)
- (pair-for-each
- (lambda (xs)
- (if (not (eq? xs args)) (gen #\,))
- (expr (car xs) i) )
- args) )
+ (let loop ((xs args))
+ (unless (null? xs)
+ (unless (eq? xs args) (gen #\,))
+ (expr (car xs) i) )))
(expr node temps) )
diff --git a/chicken-install.scm b/chicken-install.scm
index 22a59e93..c377837c 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -728,7 +728,7 @@
eggs)
same?)))
(unless (and (= (length eggs) (length eggs2))
- (every (lambda (egg) (find (cut same=? <> egg) eggs2)) eggs))
+ (every (lambda (egg) (find (cut same? <> egg) eggs2)) eggs))
(print "mapped " eggs " to " eggs2))
eggs2))
diff --git a/core.scm b/core.scm
index 48151fd4..4cd4d9e0 100644
--- a/core.scm
+++ b/core.scm
@@ -573,7 +573,7 @@
(warning
(sprintf "reference to variable `~s' possibly unintended" x) )))
(resolve-variable x e se dest ldest h))
- ((not-pair? x)
+ ((not (pair? x))
(if (constant? x)
`(quote ,x)
(##sys#syntax-error/context "illegal atomic form" x)))
diff --git a/library.scm b/library.scm
index fb85c860..fae96a8f 100644
--- a/library.scm
+++ b/library.scm
@@ -429,12 +429,6 @@ EOF
(define (list-tail lst i) (##core#inline "C_i_list_tail" lst i))
(define (list-ref lst i) (##core#inline "C_i_list_ref" lst i))
-(define (##sys#delq x lst)
- (let loop ([lst lst])
- (cond ((null? lst) lst)
- ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
- (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
-
(define (##sys#error-not-a-proper-list arg #!optional loc)
(##sys#error-hook
(foreign-value "C_NOT_A_PROPER_LIST_ERROR" int)
diff --git a/modules.scm b/modules.scm
index a5055d99..0322c6d3 100644
--- a/modules.scm
+++ b/modules.scm
@@ -32,6 +32,7 @@
(not inline ##sys#alias-global-hook))
(include "common-declarations.scm")
+(include "mini-srfi-1.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
@@ -189,7 +190,7 @@
(##sys#module-rename sym (module-name mod))
mod exp #f)
(and-let* ((a (assq sym ulist)))
- (set-module-undefined-list! mod (##sys#delq a ulist)))
+ (set-module-undefined-list! mod (delete a ulist)))
(check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
(set-module-exist-list! mod (cons sym (module-exist-list mod)))
(when exp
@@ -643,14 +644,14 @@
(loop impv (cdr imps)
v
(cons (cons (cadr a) (cdar imps)) s)
- (##sys#delq a ids))))
+ (delete a ids))))
(else (loop impv (cdr imps) v (cons (car imps) s) ids))))
((assq (caar impv) ids) =>
(lambda (a)
(loop (cdr impv) imps
(cons (cons (cadr a) (cdar impv)) v)
s
- (##sys#delq a ids))))
+ (delete a ids))))
(else (loop (cdr impv) imps
(cons (car impv) v)
s ids)))))
diff --git a/rules.make b/rules.make
index cdc215c3..5a61887d 100644
--- a/rules.make
+++ b/rules.make
@@ -545,7 +545,7 @@ eval.c: $(SRCDIR)eval.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
-modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm
+modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm $(SRCDIR)mini-srfi-1.scm
$(bootstrap-lib)
extras.c: $(SRCDIR)extras.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib)
@@ -620,10 +620,10 @@ csc.c: $(SRCDIR)csc.scm mini-srfi-1.scm
chicken-bug.c: $(SRCDIR)chicken-bug.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
-setup-api.c: $(SRCDIR)setup-api.scm
+setup-api.c: $(SRCDIR)setup-api.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_DYNAMIC_OPTIONS) -emit-import-library setup-api \
-output-file $@
-setup-download.c: $(SRCDIR)setup-download.scm setup-api.c
+setup-download.c: $(SRCDIR)setup-download.scm setup-api.c $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_DYNAMIC_OPTIONS) -emit-import-library setup-download \
-output-file $@
diff --git a/scheduler.scm b/scheduler.scm
index ff5d80d2..d20a08eb 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -31,7 +31,7 @@
(hide ready-queue-head ready-queue-tail ##sys#timeout-list
##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer
remove-from-ready-queue ##sys#unblock-threads-for-i/o ##sys#force-primordial
- fdset-set fdset-test create-fdset stderr
+ fdset-set fdset-test create-fdset stderr delq
##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes)
(not inline ##sys#interrupt-hook)
(unsafe)
@@ -148,6 +148,13 @@ EOF
(syntax-rules ()
((_ msg) (##core#inline "C_halt" msg))))
+(define (delq x lst)
+ (let loop ([lst lst])
+ (cond ((null? lst) lst)
+ ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
+ (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
+
+
(define (##sys#schedule)
(define (switch thread)
(dbg "switching to " thread)
@@ -334,9 +341,9 @@ EOF
(let ((blocked (##sys#slot t 11)))
(cond
((##sys#structure? blocked 'condition-variable)
- (##sys#setslot blocked 2 (##sys#delq t (##sys#slot blocked 2))))
+ (##sys#setslot blocked 2 (delq t (##sys#slot blocked 2))))
((##sys#structure? blocked 'thread)
- (##sys#setslot blocked 12 (##sys#delq t (##sys#slot blocked 12))))) )
+ (##sys#setslot blocked 12 (delq t (##sys#slot blocked 12))))) )
(##sys#remove-from-timeout-list t)
(##sys#clear-i/o-state-for-thread! t)
(##sys#setslot t 3 s)
@@ -503,7 +510,7 @@ EOF
(let* ((a (car lst))
(fd2 (car a)) )
(if (eq? fd fd2)
- (let ((ts (##sys#delq t (cdr a)))) ; remove from fd-list entry
+ (let ((ts (delq t (cdr a)))) ; remove from fd-list entry
(cond ((null? ts) (cdr lst))
(else
(##sys#setslot a 1 ts) ; fd-list entry is list with t removed
diff --git a/setup-api.scm b/setup-api.scm
index 566c1350..b9b5a63d 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -69,6 +69,8 @@
irregex utils posix ports extras data-structures
files)
+(include "mini-srfi-1.scm")
+
;;; Constants, variables and parameters
(define-constant setup-file-extension "setup-info")
diff --git a/setup-download.scm b/setup-download.scm
index 956d163d..163a22bd 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -40,6 +40,8 @@
(import extras irregex posix utils data-structures tcp files
setup-api)
+ (include "mini-srfi-1.scm")
+
(define-constant +default-tcp-connect-timeout+ 30000) ; 30 seconds
(define-constant +default-tcp-read/write-timeout+ 30000) ; 30 seconds
diff --git a/support.scm b/support.scm
index 13b15e0a..678575b5 100644
--- a/support.scm
+++ b/support.scm
@@ -678,8 +678,8 @@
body) )
body)
(make-node 'let (list (car vars))
- (list (car vals))
- (loop (cdr vars) (cdr vals))))))))))
+ (list (car vals)
+ (loop (cdr vars) (cdr vals)))))))))))
;; Copy along with the above
(define (copy-node-tree-and-rename node vars aliases db cfk)
@@ -820,20 +820,20 @@
(else (eq? v x)) ) )
(define (match1 x p)
- (cond ((not-pair? p) (resolve p x))
- ((not-pair? x) #f)
+ (cond ((not (pair? p)) (resolve p x))
+ ((not (pair? x)) #f)
((match1 (car x) (car p)) (match1 (cdr x) (cdr p)))
(else #f) ) )
(define (matchn n p)
- (if (not-pair? p)
+ (if (not (pair? p))
(resolve p n)
(and (eq? (node-class n) (first p))
(match1 (node-parameters n) (second p))
(let loop ((ns (node-subexpressions n))
(ps (cddr p)) )
(cond ((null? ps) (null? ns))
- ((not-pair? ps) (resolve ps ns))
+ ((not (pair? ps)) (resolve ps ns))
((null? ns) #f)
(else (and (matchn (car ns) (car ps))
(loop (cdr ns) (cdr ps)) ) ) ) ) ) ) )
Trap