The packed binary loader has moved to the runtime system. The packer

and the loader now use ports to eliminate interrupt windows and
guarantee closing.

diff --git a/etc/pack.scm b/etc/pack.scm
index 3403cc11421864cf2a8faa3c71770a8c071c26f8..dbf66ddcf1d578017752493b1ad2638253ef0195 100644 (file)
--- a/etc/pack.scm
+++ b/etc/pack.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/etc/pack.scm,v 1.4 1992/05/22 23:22:41 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/etc/pack.scm,v 1.5 1992/05/23 00:10:32 jinx Exp $
 
 Copyright (c) 1992 Massachusetts Institute of Technology
 
@@ -36,66 +36,6 @@ MIT in each case. |#
 
 (declare (usual-integrations))
 \f
-;; This code has interrupt windows because it does not use the
-;; channel stuff from the runtime system.
-;; In addition, the channel will not be closed if it is lost and gc'd.
-
-(define open-binary-input-file
-  (let ((open-file
-         (make-primitive-procedure 'file-open-input-channel 1)))
-    (lambda (file-name)
-      (open-file (->namestring (->truename (->pathname file-name)))))))
-
-(define close-binary-input-channel
-  (let ((channel-close (make-primitive-procedure 'channel-close 1)))
-    (lambda (channel)
-      (channel-close channel))))
-
-(define open-binary-output-file
-  (let ((open-file
-         (make-primitive-procedure 'file-open-output-channel 1)))
-    (lambda (file-name)
-      (open-file (->namestring (->pathname file-name))))))
-
-(define close-binary-output-channel
-  (let ((channel-close (make-primitive-procedure 'channel-close 1)))
-    (lambda (channel)
-      (channel-close channel))))
-
-(define (with-binary-file file action open close name)
-  (let ((channel false))
-    (dynamic-wind
-     (lambda ()
-       (if channel
-           (error "cannot re-enter with-binary-file" name)))
-     (lambda ()
-       (set! channel (open file))
-       (action channel))
-     (lambda ()
-       (if (and channel
-                (not (eq? channel true)))
-           (begin
-             (close channel)
-             (set! channel true)))))))
-
-(define (with-binary-input-file file action)
-  (with-binary-file file action
-    open-binary-input-file
-    close-binary-input-channel
-    action))
-
-(define (with-binary-output-file file action)
-  (with-binary-file file action
-    open-binary-output-file
-    close-binary-output-channel
-    action))
-
-(define channel-fasdump
-  (make-primitive-procedure 'primitive-fasdump 3))
-
-(define channel-fasload
-  (make-primitive-procedure 'binary-fasload 1))
-\f
 (define (pack-binaries output files-lists)
   (define (->string pathname-or-string)
     (if (string? pathname-or-string)
@@ -112,7 +52,7 @@ MIT in each case. |#
                (let ((pathname load/current-pathname))
                  (set! load/after-load-hooks
                        (cons (lambda ()
-                               (unpack-binaries-and-load 
+                               (load-packed-binaries
                                  pathname
                                  ,(->string output)
                                 ,(length files-lists)
@@ -158,85 +98,16 @@ MIT in each case. |#
                                         false))))
                  pathnames-lists)))))
 \f
-(define (unpack-binaries-and-load pathname fname strings environment)
-  (define (find-filename fname alist)
-    (define (compatible? path1 path2)
-      (and (equal? (pathname-directory path1)
-                   (pathname-directory path2))
-           (equal? (pathname-name path1)
-                   (pathname-name path2))
-           (or (equal? (pathname-type path1) (pathname-type path2))
-               (and (member (pathname-type path1) '(#f "bin" "com"))
-                    (member (pathname-type path2) '(#f "bin" "com"))))))
-
-    (let ((path (->pathname fname)))
-      (let loop ((alist alist))
-        (and (not (null? alist))
-             (if (compatible? path (cadar alist))
-                 (car alist)
-                 (loop (cdr alist)))))))
-
-  (define (process-bunch alist)
-    (let* ((real-load load)
-          (new-load
-           (lambda (fname #!optional env syntax-table purify?)
-             (let ((env (if (default-object? env)
-                            environment
-                            env))
-                   (st (if (default-object? syntax-table)
-                           default-object
-                           syntax-table))
-                   (purify? (if (default-object? purify?)
-                                default-object
-                                purify?)))
-               (let ((place (find-filename fname alist)))
-                 (if (not place)
-                     (real-load fname env st purify?)
-                     (let ((scode (caddr place)))
-                       (if (not load/suppress-loading-message?)
-                           (begin
-                             (newline)
-                             (display ";Pseudo-loading ")
-                             (display (->namestring (->pathname fname)))
-                             (display "...")))
-                       (if (and purify? (not (eq? purify? default-object)))
-                           (purify (load/purification-root scode)))
-                       (extended-scode-eval scode env))))))))
-      (fluid-let ((load new-load)
-                 (flush-purification-queue! (lambda () 'done)))
-        (new-load (caar alist))))
-    (flush-purification-queue!))
-\f
-  (with-binary-input-file (->truename pathname)
-    (lambda (channel)
-      ;; Dismiss header.
-      (channel-fasload channel)
-      (let ((process-next-bunch
-            (lambda ()
-              (process-bunch
-               (map (lambda (pair)
-                      (list (car pair)
-                            (->pathname (car pair))
-                            (cdr pair)))
-                    (channel-fasload channel))))))
-
-       (cond ((number? strings)
-              (do ((count strings (-1+ count)))
-                  ((= count 1)
-                   (process-next-bunch))
-                (process-next-bunch)))
-             ((eq? strings true)
-              (process-next-bunch))
-             (else
-              (do ((i (length strings) (-1+ i))
-                   (strings strings (cdr strings))
-                   (alist '()
-                          (cons (list (car strings)
-                                      (->pathname (car strings))
-                                      (channel-fasload channel))
-                                alist)))
-                  ((zero? i)
-                   (process-bunch (reverse! alist))))))))))
+;;;; Utilities and installation
+
+(define (with-binary-output-file file action)
+  (with-binary-file-channel file action
+    open-binary-output-file
+    output-port/channel
+    'with-binary-output-file))
+
+(define channel-fasdump
+  (make-primitive-procedure 'primitive-fasdump 3))
 
 ;;; Link to global
 
@@ -245,8 +116,4 @@ MIT in each case. |#
   (if (not (environment-bound? system-global-environment
                                'pack-binaries))
       (environment-link-name system-global-environment this-environment
-                             'pack-binaries))
-  (if (not (environment-bound? system-global-environment
-                               'unpack-binaries-and-load))
-      (environment-link-name system-global-environment this-environment
-                             'unpack-binaries-and-load)))
\ No newline at end of file
+                             'pack-binaries)))
\ No newline at end of file