From: Chris Hanson Date: Sun, 21 Nov 1993 22:56:50 +0000 (+0000) Subject: In LOAD-PACKED-BINARIES, delay purification of the packed files until X-Git-Tag: 20090517-FFI~7454 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=bfab619f41dc4af5cbd479d29380076a770f893e;p=mit-scheme.git In LOAD-PACKED-BINARIES, delay purification of the packed files until after the loading is complete. --- diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 17534ef0c..f8ab747ed 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.46 1993/11/11 20:29:35 cph Exp $ +$Id: load.scm,v 14.47 1993/11/21 22:56:50 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -510,65 +510,38 @@ MIT in each case. |# ;;;; Loader for packed binaries (define (load-packed-binaries pathname fname count environment) - (define (search-alist path alist predicate?) - (let loop ((alist alist)) - (and (not (null? alist)) - (if (predicate? path (cadar alist)) - (car alist) - (loop (cdr alist)))))) - - (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 (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))) - (write-string "...")))) - (define (process-bunch alist) (let ((real-load load) (real-fasload fasload) (real-file-exists? file-exists?) - (real-file-directory? file-directory?)) + (real-file-directory? file-directory?) + (to-purify '())) (fluid-let ((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 ((env (if (default-object? env) default-object env)) + (purify? + (if (default-object? purify?) default-object purify?))) (let ((place (find-filename fname alist))) (if (not place) - (real-load fname env st purify?) + (real-load fname + env + (if (default-object? syntax-table) + default-object + syntax-table) + purify?) (let ((scode (caddr place))) (loading-message fname load/suppress-loading-message? ";Pseudo-loading ") - (if (and purify? (not (eq? purify? default-object))) - (purify (load/purification-root scode))) - (extended-scode-eval scode env))))))) + (if (and (not (eq? purify? default-object)) purify?) + (set! to-purify + (cons (load/purification-root scode) + to-purify))) + (extended-scode-eval scode + (if (eq? env default-object) + environment + env)))))))) (fasload (lambda (filename #!optional suppress-message?) (let ((suppress-message? @@ -590,11 +563,44 @@ MIT in each case. |# (file-directory? (lambda (dname) (or (directory-represented? dname alist) - (real-file-directory? dname)))) - (flush-purification-queue! (lambda () 'done))) - (load (caar 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 (not (null? 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))) + (write-string "...")))) + (with-binary-input-file (->truename pathname) (lambda (channel) ((ucode-primitive binary-fasload) channel) ; Dismiss header. @@ -606,8 +612,6 @@ MIT in each case. |# (->pathname (car pair)) (cdr pair))) ((ucode-primitive binary-fasload) channel)))))) - - (do ((count count (-1+ count))) ((= count 1) (process-next-bunch)) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index 17534ef0c..f8ab747ed 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.46 1993/11/11 20:29:35 cph Exp $ +$Id: load.scm,v 14.47 1993/11/21 22:56:50 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -510,65 +510,38 @@ MIT in each case. |# ;;;; Loader for packed binaries (define (load-packed-binaries pathname fname count environment) - (define (search-alist path alist predicate?) - (let loop ((alist alist)) - (and (not (null? alist)) - (if (predicate? path (cadar alist)) - (car alist) - (loop (cdr alist)))))) - - (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 (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))) - (write-string "...")))) - (define (process-bunch alist) (let ((real-load load) (real-fasload fasload) (real-file-exists? file-exists?) - (real-file-directory? file-directory?)) + (real-file-directory? file-directory?) + (to-purify '())) (fluid-let ((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 ((env (if (default-object? env) default-object env)) + (purify? + (if (default-object? purify?) default-object purify?))) (let ((place (find-filename fname alist))) (if (not place) - (real-load fname env st purify?) + (real-load fname + env + (if (default-object? syntax-table) + default-object + syntax-table) + purify?) (let ((scode (caddr place))) (loading-message fname load/suppress-loading-message? ";Pseudo-loading ") - (if (and purify? (not (eq? purify? default-object))) - (purify (load/purification-root scode))) - (extended-scode-eval scode env))))))) + (if (and (not (eq? purify? default-object)) purify?) + (set! to-purify + (cons (load/purification-root scode) + to-purify))) + (extended-scode-eval scode + (if (eq? env default-object) + environment + env)))))))) (fasload (lambda (filename #!optional suppress-message?) (let ((suppress-message? @@ -590,11 +563,44 @@ MIT in each case. |# (file-directory? (lambda (dname) (or (directory-represented? dname alist) - (real-file-directory? dname)))) - (flush-purification-queue! (lambda () 'done))) - (load (caar 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 (not (null? 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))) + (write-string "...")))) + (with-binary-input-file (->truename pathname) (lambda (channel) ((ucode-primitive binary-fasload) channel) ; Dismiss header. @@ -606,8 +612,6 @@ MIT in each case. |# (->pathname (car pair)) (cdr pair))) ((ucode-primitive binary-fasload) channel)))))) - - (do ((count count (-1+ count))) ((= count 1) (process-next-bunch))