From bc7e4dba13555c0327ceb2a7dae3fdf3fb23ab70 Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Sat, 23 May 1992 00:10:32 +0000 Subject: [PATCH] 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. --- etc/pack.scm | 159 +++++---------------------------------------------- 1 file changed, 13 insertions(+), 146 deletions(-) diff --git a/etc/pack.scm b/etc/pack.scm index 3403cc114..dbf66ddcf 100644 --- 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)) -;; 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)) - (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))))) -(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!)) - - (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 -- 2.25.1