From: Taylor R Campbell <campbell@mumble.net>
Date: Sun, 23 Feb 2014 01:17:57 +0000 (+0000)
Subject: Fix up fni->bci files in crsend.scm.
X-Git-Tag: release-9.2.0~41
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=fb22c8fa3bd3c9b8c2e4c77eeb4ef19e999c6370;p=mit-scheme.git

Fix up fni->bci files in crsend.scm.
---

diff --git a/src/compiler/base/crsend.scm b/src/compiler/base/crsend.scm
index 711f4f248..5944d8614 100644
--- a/src/compiler/base/crsend.scm
+++ b/src/compiler/base/crsend.scm
@@ -32,6 +32,8 @@ USA.
 ;;; compiler.
 
 (declare (usual-integrations))
+
+(load-option 'COMPRESS)			; XXX ugh
 
 (define (finish-cross-compilation:directory directory #!optional force?)
   (let ((force? (if (default-object? force?) #f force?)))
@@ -42,12 +44,38 @@ USA.
 				    (or (string=? ns ".")
 					(string=? ns ".."))))
 			     (loop pathname)))
+			((let ((t (pathname-type pathname)))
+			   (and (string? t)
+				(string=? t "fni")))
+			 (finish-cross-compilation:info-file pathname force?))
 			((let ((t (pathname-type pathname)))
 			   (and (string? t)
 				(string=? t "moc")))
 			 (finish-cross-compilation:file pathname force?))))
 		(directory-read (pathname-as-directory directory))))))
 
+(define (finish-cross-compilation:info-file pathname #!optional force?)
+  (let* ((input-file (pathname-default-type pathname "fni"))
+	 (output-file (pathname-new-type input-file "bci")))
+    (if (or (if (default-object? force?) #t force?)
+	    (file-modification-time<? output-file input-file))
+	(with-notification
+	    (lambda (port)
+	      (write-string "Compressing info: " port)
+	      (write (enough-namestring input-file) port)
+	      (write-string " => " port)
+	      (write (enough-namestring output-file) port))
+	    (lambda ()
+	      (let ((inf (fasload input-file #t)))
+		((access SPLIT-INF-STRUCTURE! ; XXX ugh
+			 (->environment '(RUNTIME COMPILER-INFO)))
+		 inf
+		 #f)
+		(call-with-temporary-filename
+		  (lambda (temp)
+		    (fasdump inf temp #t)
+		    (compress temp output-file)))))))))
+
 (define (finish-cross-compilation:file input-file #!optional force?)
   (let* ((input-file (pathname-default-type input-file "moc"))
 	 (output-file (pathname-new-type input-file "com")))