Remove unused LOAD-PACKED-BINARIES.

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index 9e928577e9a05edc4acaaf9181a9e5131dcdf684..edba02017262108e51ce061e76aaa48d1d98d6f7 100644 (file)
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.71 2005/04/01 04:46:49 cph Exp $
+$Id: load.scm,v 14.72 2005/07/19 03:48:44 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1999,2000,2001,2002,2003 Massachusetts Institute of Technology
@@ -556,135 +556,4 @@ USA.
           (repl-eval/write (read (open-input-string arg)
                                  environment)
                            environment
-                           repl)))))))
-\f
-;;;; Loader for packed binaries
-
-(define (load-packed-binaries pathname fname count environment)
-  fname
-
-  (define (process-bunch alist)
-    (let ((real-load load)
-         (real-fasload fasload)
-         (real-file-exists? file-exists?)
-         (real-file-directory? file-directory?)
-         (to-purify '()))
-      (fluid-let
-         ((load
-           (lambda (fname #!optional env syntax-table purify?)
-             syntax-table              ;ignored
-             (let ((place (find-filename fname alist)))
-               (if (not place)
-                   (real-load fname env 'DEFAULT purify?)
-                   (handle-load-hooks
-                    (lambda ()
-                      (let ((scode (caddr place)))
-                        (loading-message fname
-                                         load/suppress-loading-message?
-                                         ";Pseudo-loading ")
-                        (if (if (default-object? purify?) #f purify?)
-                            (set! to-purify
-                                  (cons (load/purification-root scode)
-                                        to-purify)))
-                        (fluid-let ((load/current-pathname (cadr place)))
-                          (extended-scode-eval scode
-                                               (if (default-object? env)
-                                                   environment
-                                                   env))))))))))
-          (fasload
-           (lambda (filename #!optional suppress-message?)
-             (let ((suppress-message?
-                    (if (default-object? suppress-message?)
-                        load/suppress-loading-message?
-                        suppress-message?))
-                   (place (find-filename filename alist)))
-               (if (not place)
-                   (real-fasload filename suppress-message?)
-                   (begin
-                     (loading-message filename
-                                      suppress-message?
-                                      ";Pseudo-fasloading ")
-                     (caddr place))))))
-          (file-exists?
-           (lambda (fname)
-             (or (find-filename fname alist)
-                 (real-file-exists? fname))))
-          (file-directory?
-           (lambda (dname)
-             (or (directory-represented? dname alist)
-                 (real-file-directory? dname)))))
-        (load (caar alist)))
-      (set! alist)
-      (for-each purify (reverse! to-purify)))
-    (flush-purification-queue!))
-
-  (define (find-filename fname alist)
-    (search-alist (->pathname fname) alist
-      (lambda (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"))))))))
-
-  (define (directory-represented? dname alist)
-    (search-alist (pathname-as-directory (->pathname dname)) alist
-      (lambda (path1 path2)
-       (equal? (pathname-directory path1)
-               (pathname-directory path2)))))
-
-  (define (search-alist path alist predicate?)
-    (let loop ((alist alist))
-      (and (pair? alist)
-          (if (predicate? path (cadar alist))
-              (car alist)
-              (loop (cdr alist))))))
-
-  (define (loading-message fname suppress? kind)
-    (if (not suppress?)
-       (let ((port (notification-output-port)))
-         (fresh-line port)
-         (write-string kind port)
-         (write-string (->namestring (->pathname fname)) port)
-         (write-string "..." port)
-         (newline port))))
-
-  (with-binary-input-file (->truename pathname)
-    (lambda (channel)
-      ((ucode-primitive binary-fasload) channel) ; Dismiss header.
-      (let ((process-next-bunch
-            (lambda ()
-              (process-bunch
-               (map (lambda (pair)
-                      (list (car pair)
-                            (->pathname (car pair))
-                            (cdr pair)))
-                    ((ucode-primitive binary-fasload) channel))))))
-       (do ((count count (-1+ count)))
-           ((= count 1)
-            (process-next-bunch))
-         (process-next-bunch))))))
-
-(define (with-binary-input-file file action)
-  (with-binary-file-channel file action
-    open-binary-input-file
-    port/input-channel
-    'with-binary-input-file))
-
-(define (with-binary-file-channel file action open extract-channel name)
-  (let ((port #f))
-    (dynamic-wind
-     (lambda ()
-       (if port
-           (error "cannot re-enter with-binary-file-channel" name)))
-     (lambda ()
-       (set! port (open file))
-       (action (channel-descriptor (extract-channel port))))
-     (lambda ()
-       (if (and port
-                (not (eq? port #t)))
-           (begin
-             (close-port port)
-             (set! port #t)))))))
\ No newline at end of file
+                           repl)))))))
\ No newline at end of file