~ chicken-core (chicken-5) 47e78e1ea6b0b32065a60ce441645d67a4b6e495
commit 47e78e1ea6b0b32065a60ce441645d67a4b6e495
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Jan 7 12:52:54 2010 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Jan 7 12:52:54 2010 +0100
added mini eggtest script; fixed silly bug in chicken-install that forgot to check for -no-install
diff --git a/chicken-install.scm b/chicken-install.scm
index 9d30369c..3f25c96a 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -322,10 +322,11 @@
(when (and (not depinstall-ok)
(= i 1)
(> num 1))
- (unless (yes-or-no?
- (string-append
- "You specified `-no-install', but this extension has dependencies"
- " that are required for building. Do you still want to install them?"))
+ (when (and *no-install*
+ (yes-or-no?
+ (string-append
+ "You specified `-no-install', but this extension has dependencies"
+ " that are required for building. Do you still want to install them?")))
(print "aborting installation.")
(cleanup)
(exit 1)))
diff --git a/patches/finalizer-closures.diff b/patches/finalizer-closures.diff
deleted file mode 100644
index 963d3bd1..00000000
--- a/patches/finalizer-closures.diff
+++ /dev/null
@@ -1,55 +0,0 @@
-Index: runtime.c
-===================================================================
---- runtime.c (Revision 12825)
-+++ runtime.c (Revision 12869)
-@@ -2701,10 +2701,15 @@
- /* Mark collectibles: */
- for(msp = collectibles; msp < collectibles_top; ++msp)
- if(*msp != NULL) mark(*msp);
--
-+
-+ /* mark GC roots: */
- for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next)
- mark(&gcrp->value);
-
-+ /* mark finalizer procedures: */
-+ for(flist = finalizer_list; flist != NULL; flist = flist->next)
-+ mark(&flist->finalizer);
-+
- mark_system_globals();
- }
- else {
-@@ -2769,7 +2774,6 @@
-
- for(flist = finalizer_list; flist != NULL; flist = flist->next) {
- mark(&flist->item);
-- mark(&flist->finalizer);
- ++fcount;
- }
-
-@@ -2786,7 +2790,6 @@
- }
-
- mark(&flist->item);
-- mark(&flist->finalizer);
- }
- }
-
-@@ -2794,7 +2797,7 @@
- finalizers_checked = 1;
-
- if(pending_finalizer_count > 0 && gc_report_flag)
-- C_printf(C_text("[GC] finalizers pending for rescan:\t %d (%d live)\n"),
-+ C_printf(C_text("[GC] finalizers pending: %d (%d live)\n"),
- pending_finalizer_count, live_finalizer_count);
-
- goto rescan;
-@@ -2803,7 +2806,7 @@
- /* Copy finalized items with remembered indices into `##sys#pending-finalizers'
- (and release finalizer node): */
- if(pending_finalizer_count > 0) {
-- if(gc_report_flag) C_printf(C_text("[GC] queueing %d finalizers\n"), pending_finalizer_count);
-+ if(gc_report_flag) C_printf(C_text("[GC] finalizers queued: %d\n"), pending_finalizer_count);
-
- last = C_block_item(pending_finalizers_symbol, 0);
- assert(C_u_i_car(last) == C_fix(0));
diff --git a/patches/finalizer-exceptions.diff b/patches/finalizer-exceptions.diff
deleted file mode 100644
index ef07c8b7..00000000
--- a/patches/finalizer-exceptions.diff
+++ /dev/null
@@ -1,26 +0,0 @@
-Index: library.scm
-===================================================================
-@@ -4250,6 +4257,7 @@
- (define ##sys#run-pending-finalizers
- (let ([vector-fill! vector-fill!]
- [print print]
-+ [with-exception-handler with-exception-handler]
- [working #f] )
- (lambda (state)
- (unless working
-@@ -4262,8 +4270,13 @@
- (do ([i 0 (fx+ i 1)])
- ((fx>= i c))
- (let ([i2 (fx+ 1 (fx* i 2))])
-- ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
-- (##sys#slot ##sys#pending-finalizers i2)) ) )
-+ (##sys#call-with-current-continuation
-+ (lambda (ret)
-+ (with-exception-handler
-+ ret
-+ (lambda ()
-+ ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
-+ (##sys#slot ##sys#pending-finalizers i2)))))) ) )
- (vector-fill! ##sys#pending-finalizers (##core#undefined))
- (##sys#setislot ##sys#pending-finalizers 0 0)
- (set! working #f) ) )
diff --git a/patches/record-rename.diff b/patches/record-rename.diff
deleted file mode 100644
index ce98e287..00000000
--- a/patches/record-rename.diff
+++ /dev/null
@@ -1,54 +0,0 @@
-Index: chicken-syntax.scm
-===================================================================
---- chicken-syntax.scm (revision 13204)
-+++ chicken-syntax.scm (working copy)
-@@ -46,8 +46,11 @@
- (lambda (x r c)
- (##sys#check-syntax 'define-record x '(_ symbol . #(symbol 0)))
- (let* ((name (cadr x))
-+ (prefix (symbol->string name))
-+ (name (if (##sys#current-module)
-+ (##sys#module-rename name (##sys#module-name (##sys#current-module)))
-+ name))
- (slots (cddr x))
-- (prefix (symbol->string name))
- (setters (memq #:record-setters ##sys#features))
- (%begin (r 'begin))
- (%define (r 'define))
-@@ -807,11 +810,21 @@
- 'define-record-printer (cons head body)
- '((symbol symbol symbol) . #(_ 1)))
- `(##sys#register-record-printer
-- ',(##sys#slot head 0)
-+ ',(if (##sys#current-module)
-+ (##sys#module-rename (##sys#slot head 0)
-+ (##sys#module-name
-+ (##sys#current-module)))
-+ (##sys#slot head 0))
- (,(r 'lambda) ,(##sys#slot head 1) ,@body)) ]
- [else
- (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
-- `(##sys#register-record-printer ',head ,@body) ] ) ))))
-+ `(##sys#register-record-printer
-+ ',(if (##sys#current-module)
-+ (##sys#module-rename head
-+ (##sys#module-name
-+ (##sys#current-module)))
-+ head)
-+ ,@body) ] ) ))))
-
-
- ;;; Exceptions:
-@@ -874,7 +887,11 @@
- (##sys#er-transformer
- (lambda (form r c)
- (##sys#check-syntax 'define-record-type form '(_ variable #(variable 1) variable . _))
-- (let* ((t (cadr form))
-+ (let* ((t (if (##sys#current-module)
-+ (##sys#module-rename (cadr form)
-+ (##sys#module-name
-+ (##sys#current-module)))
-+ (cadr form)))
- (conser (caddr form))
- (pred (cadddr form))
- (slots (cddddr form))
diff --git a/scripts/mini-salmonella.scm b/scripts/mini-salmonella.scm
new file mode 100644
index 00000000..ae21fe50
--- /dev/null
+++ b/scripts/mini-salmonella.scm
@@ -0,0 +1,89 @@
+;;;; mini-salmonella.scm - very simple tool to build all eggs
+;
+; usage: csi -s mini-salmonella.scm EGGDIR [PREFIX]
+
+
+(module mini-salmonella ()
+
+(import scheme chicken)
+(use posix files extras data-structures srfi-1 setup-api srfi-13 utils)
+
+(define (usage code)
+ (print "usage: mini-salmonella EGGDIR [PREFIX]")
+ (exit code) )
+
+(define-values (*eggdir* *prefix*)
+ (let-optionals (command-line-arguments)
+ ((eggdir (usage 1))
+ (prefix (pathname-directory (pathname-directory (repository-path)))))
+ (values eggdir prefix)))
+
+(define *binary-version* (##sys#fudge 42))
+(define *repository* (make-pathname *prefix* (conc "lib/chicken/" *binary-version*)))
+(define *snapshot* (directory *repository*))
+
+(define (cleanup-repository)
+ (for-each
+ (lambda (f)
+ (delete-file (make-pathname *repository* f)))
+ (lset-difference string=? (directory *repository*) *snapshot*)))
+
+(define *chicken-install*
+ (normalize-pathname (make-pathname *prefix* "bin/chicken-install")))
+
+(define *eggs* (directory *eggdir*))
+
+(define (find-newest egg)
+ (let* ((ed (make-pathname *eggdir* egg))
+ (tagsdir (directory-exists? (make-pathname ed "tags")))
+ (trunkdir (directory-exists? (make-pathname ed "trunk"))))
+ (if tagsdir
+ (let ((tags (sort (directory tagsdir) version>=?)))
+ (if (null? tags)
+ (or trunkdir ed)
+ (make-pathname ed (string-append "tags/" (first tags)))))
+ (or trunkdir ed))))
+
+(define (report egg msg . args)
+ (printf "~a..~?~%" (make-string (max 2 (- 32 (string-length egg))) #\.)
+ msg args) )
+
+(define *logfile* "mini-salmonella.log")
+(define *tmplogfile* "mini-salmonella.tmp.log")
+
+(on-exit (lambda () (delete-file* *tmplogfile*)))
+
+(define (copy-log file)
+ (let ((log (read-all file)))
+ (with-output-to-file *logfile*
+ (cut display log)
+ #:append)))
+
+(define (install-egg egg dir)
+ (let ((status
+ (system
+ (sprintf "~a -force -t local -l ~a ~a ;2>~a >nul:"
+ *chicken-install*
+ (normalize-pathname *eggdir*)
+ egg
+ *tmplogfile*))))
+ (cond ((zero? status) (report egg "OK"))
+ (else
+ (report egg "FAILED")
+ (copy-log *tmplogfile*)))))
+
+(for-each
+ (lambda (egg)
+ (and-let* ((dir (find-newest egg)))
+ (print* egg)
+ (cleanup-repository)
+ (let ((meta (file-exists? (make-pathname dir egg "meta"))))
+ (if meta
+ (let ((setup (file-exists? (make-pathname dir egg "setup"))))
+ (if setup
+ (install-egg egg dir)
+ (report egg "<no .setup script>")) )
+ (report egg "<no .meta file>")))))
+ (directory *eggdir*))
+
+)
Trap