Tweak for 7.3 release.

diff --git a/etc/pack.scm b/etc/pack.scm
index dbf66ddcf1d578017752493b1ad2638253ef0195..6d699f9b25d2bacdee6f9c092e2b7d7d838a70b2 100644 (file)
--- 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))
 \f
 (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)))))
-\f
-;;;; 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