From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 21 Nov 1993 22:59:38 +0000 (+0000)
Subject: Tweak for 7.3 release.
X-Git-Tag: 20090517-FFI~7453
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2b986845f40b4bacd2196f63e5840b97b73f3106;p=mit-scheme.git

Tweak for 7.3 release.
---

diff --git a/etc/pack.scm b/etc/pack.scm
index dbf66ddcf..6d699f9b2 100644
--- a/etc/pack.scm
+++ b/etc/pack.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/etc/pack.scm,v 1.5 1992/05/23 00:10:32 jinx Exp $
+$Id: pack.scm,v 1.6 1993/11/21 22:59:38 cph Exp $
 
-Copyright (c) 1992 Massachusetts Institute of Technology
+Copyright (c) 1992-93 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -37,83 +37,48 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 (define (pack-binaries output files-lists)
-  (define (->string pathname-or-string)
-    (if (string? pathname-or-string)
-        pathname-or-string
-        (->namestring pathname-or-string)))
-
-  (define (make-load-wrapper output files-lists)
-    (syntax
-     `((in-package 
-         (->environment '(runtime load))
-         (lambda (environment-to-load)
-           (if (not load/loading?)
-               (error "packed-wrapper: Evaluated when not loaded!")
-               (let ((pathname load/current-pathname))
-                 (set! load/after-load-hooks
-                       (cons (lambda ()
-                               (load-packed-binaries
-                                 pathname
-                                 ,(->string output)
-				 ,(length files-lists)
-                                 environment-to-load))
-                             load/after-load-hooks))))))
-       (the-environment))
-     system-global-syntax-table))
-
-  (if (and (not (string? output))
-           (not (pathname? output)))
-      (error "pack-binaries: Bad output file" output))
   (if (null? files-lists)
-      (error "pack-binaries: No files"))
-
-  (let* ((pathnames-lists
-	  (map (lambda (files)
-		 (let ((dir (car files)))
-		   (cons dir
-			 (with-working-directory-pathname dir
-			   (lambda ()
-			     (map
-			      (lambda (file)
-				(let ((pathname (->pathname file)))
-				  (if (not (file-exists? pathname))
-				      (error "pack-binaries: Cannot find" file)
-				      pathname)))
-				  (cdr files)))))))
-	       files-lists))
-         (wrapper (make-load-wrapper output files-lists)))
-
-    (with-binary-output-file
-      output
-      (lambda (channel)
-        (channel-fasdump wrapper channel false)
-	(for-each (lambda (pathnames)
-		    (with-working-directory-pathname (car pathnames)
-		      (lambda ()
-			(channel-fasdump (map (lambda (pathname)
-						(cons (->string pathname)
-						      (fasload pathname)))
-					      (cdr pathnames))
-					 channel
-					 false))))
-		  pathnames-lists)))))
-
-;;;; Utilities and installation
+      (error:bad-range-argument files-lists 'PACK-BINARIES))
+  (with-binary-output-file (->pathname output)
+    (lambda (channel)
+      (channel-fasdump
+       (syntax
+	`((lambda (environment-to-load)
+	    (load/push-hook!
+	     (let ((pathname (current-load-pathname)))
+	       (lambda ()
+		 ((access load-packed-binaries
+			  (->environment '(runtime load)))
+		  pathname
+		  ,(->namestring output)
+		  ,(length files-lists)
+		  environment-to-load)))))
+	  (the-environment))
+	system-global-syntax-table)
+       channel
+       #f)
+      (for-each
+       (lambda (files)
+	 (with-working-directory-pathname (car files)
+	   (lambda ()
+	     (channel-fasdump (map (lambda (file)
+				     (cons (->namestring file)
+					   (fasload (->pathname file))))
+				   (cdr files))
+			      channel
+			      #f))))
+       files-lists))))
 
 (define (with-binary-output-file file action)
   (with-binary-file-channel file action
     open-binary-output-file
     output-port/channel
-    'with-binary-output-file))
+    'WITH-BINARY-OUTPUT-FILE))
 
 (define channel-fasdump
-  (make-primitive-procedure 'primitive-fasdump 3))
-
-;;; Link to global
+  (make-primitive-procedure 'PRIMITIVE-FASDUMP 3))
 
-(let ((system-global-environment '())
-      (this-environment (the-environment)))
-  (if (not (environment-bound? system-global-environment
-                               'pack-binaries))
-      (environment-link-name system-global-environment this-environment
-                             'pack-binaries)))
\ No newline at end of file
+(if (not (environment-bound? system-global-environment 'PACK-BINARIES))
+    (environment-link-name system-global-environment
+			   (the-environment)
+			   'PACK-BINARIES))
\ No newline at end of file