i.e. bif, bsm, bci, and bcs.
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infstr.scm,v 1.4 1991/02/15 18:05:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infstr.scm,v 1.5 1992/05/26 16:06:14 mhwu Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
(expression false read-only true) ;dbg-expression
(procedures false read-only true) ;vector of dbg-procedure
(continuations false read-only true) ;vector of dbg-continuation
- (labels false read-only true) ;vector of dbg-label, sorted by offset
+ (labels/desc false read-only false) ;vector of dbg-label, sorted by offset
)
+(define (dbg-info/labels dbg-info)
+ (let ((labels/desc (dbg-info/labels/desc dbg-info)))
+ (if (vector? labels/desc)
+ labels/desc
+ (let ((labels (read-labels labels/desc)))
+ (and labels
+ (begin
+ (set-dbg-info/labels/desc! dbg-info labels)
+ labels))))))
+
+(define-structure (dbg-expression
+ (named
+ (string->symbol
+ "#[(runtime compiler-info)dbg-expression]"))
+ (conc-name dbg-expression/))
+ (block false read-only true) ;dbg-block
+ (label false) ;dbg-label
+ )
+
+(define-integrable (dbg-expression/label-offset expression)
+ (dbg-label/offset (dbg-expression/label expression)))
+
+(define-structure (dbg-procedure
+ (named
+ (string->symbol "#[(runtime compiler-info)dbg-procedure]"))
+ (constructor
+ make-dbg-procedure
+ (block label type name required optional rest auxiliary
+ source-code))
+ (conc-name dbg-procedure/))
+ (block false read-only true) ;dbg-block
+ (label false) ;dbg-label
+ (type false read-only true)
+ (name false read-only true) ;procedure's name
+ (required false read-only true) ;names of required arguments
+ (optional false read-only true) ;names of optional arguments
+ (rest false read-only true) ;name of rest argument, or #F
+ (auxiliary false read-only true) ;names of internal definitions
+ (external-label false) ;for closure, external entry
+ (source-code false read-only true) ;SCode
+ )
+
+(define (dbg-procedure/label-offset procedure)
+ (dbg-label/offset
+ (or (dbg-procedure/external-label procedure)
+ (dbg-procedure/label procedure))))
+
+(define-integrable (dbg-procedure<? x y)
+ (< (dbg-procedure/label-offset x) (dbg-procedure/label-offset y)))
+\f
+(define-structure (dbg-continuation
+ (named
+ (string->symbol
+ "#[(runtime compiler-info)dbg-continuation]"))
+ (conc-name dbg-continuation/))
+ (block false read-only true) ;dbg-block
+ (label false) ;dbg-label
+ (type false read-only true)
+ (offset false read-only true) ;difference between sp and block
+ (source-code false read-only true)
+ )
+
+(define-integrable (dbg-continuation/label-offset continuation)
+ (dbg-label/offset (dbg-continuation/label continuation)))
+
+(define-integrable (dbg-continuation<? x y)
+ (< (dbg-continuation/label-offset x) (dbg-continuation/label-offset y)))
+
+(define-structure (dbg-block
+ (named
+ (string->symbol "#[(runtime compiler-info)dbg-block]"))
+ (constructor
+ make-dbg-block
+ (type parent original-parent layout stack-link))
+ (conc-name dbg-block/))
+ (type false read-only true) ;continuation, stack, closure, ic
+ (parent false read-only true) ;parent block, or #F
+ (original-parent false read-only true) ;for closures, closing block
+ (layout false read-only true) ;vector of names, except #F for ic
+ (stack-link false read-only true) ;next block on stack, or #F
+ (procedure false) ;procedure which this is block of
+ )
+
+(define-structure (dbg-variable
+ (named
+ (string->symbol "#[(runtime compiler-info)dbg-variable]"))
+ (conc-name dbg-variable/))
+ (name false read-only true) ;symbol
+ (type false read-only true) ;normal, cell, integrated
+ value ;for integrated, the value
+ )
+
+(let-syntax
+ ((dbg-block-name
+ (macro (name)
+ (let ((symbol (symbol-append 'DBG-BLOCK-NAME/ name)))
+ `(DEFINE-INTEGRABLE ,symbol
+ ',(string->symbol
+ (string-append "#[(runtime compiler-info)"
+ (string-downcase (symbol->string symbol))
+ "]")))))))
+ ;; Various names used in `layout' to identify things that wouldn't
+ ;; otherwise have names.
+ (dbg-block-name dynamic-link)
+ (dbg-block-name ic-parent)
+ (dbg-block-name normal-closure)
+ (dbg-block-name return-address)
+ (dbg-block-name static-link))
+\f
+(define (dbg-label/name label)
+ (cond ((dbg-label-2? label) (dbg-label-2/name label))
+ ((dbg-label-1? label) (dbg-label-1/name label))
+ (else
+ (error:wrong-type-argument label "debugging label" 'DBG-LABEL/NAME))))
+
+(define (set-dbg-label/name! label name)
+ (cond ((dbg-label-1? label) (set-dbg-label-1/name! label name))
+ (else
+ (error:wrong-type-argument label "debugging label"
+ 'SET-DBG-LABEL/NAME!))))
+
+(define (dbg-label/offset label)
+ (cond ((dbg-label-2? label) (dbg-label-2/offset label))
+ ((dbg-label-1? label) (dbg-label-1/offset label))
+ (else
+ (error:wrong-type-argument label "debugging label"
+ 'DBG-LABEL/OFFSET))))
+
+(define (dbg-label/external? label)
+ (cond ((dbg-label-2? label) (dbg-label-2/external? label))
+ ((dbg-label-1? label) (dbg-label-1/external? label))
+ (else
+ (error:wrong-type-argument label "debugging label"
+ 'DBG-LABEL/EXTERNAL?))))
+
+(define (set-dbg-label/external?! label external?)
+ (cond ((dbg-label-2? label) (set-dbg-label-2/external?! label external?))
+ ((dbg-label-1? label) (set-dbg-label-1/external?! label external?))
+ (else
+ (error:wrong-type-argument label "debugging label"
+ 'SET-DBG-LABEL/EXTERNAL?!))))
+
+(define (dbg-label/names label)
+ (cond ((dbg-label-2? label) (dbg-label-2/names label))
+ ((dbg-label-1? label) (dbg-label-1/names label))
+ (else
+ (error:wrong-type-argument label "debugging label"
+ 'DBG-LABEL/NAMES))))
+
+(define (set-dbg-label/names! label names)
+ (cond ((dbg-label-1? label) (set-dbg-label-1/names! label names))
+ (else
+ (error:wrong-type-argument label "debugging label"
+ 'SET-DBG-LABEL/NAMES!))))
+
+(define-structure (dbg-label-1
+ (named
+ (string->symbol "#[(runtime compiler-info)dbg-label]"))
+ (constructor make-dbg-label (name offset))
+ (conc-name dbg-label-1/))
+ (name false) ;a string, primary name
+ (offset false read-only true) ;mach. dependent offset into code block
+ (external? false) ;if true, can have pointer to this
+ (names (list name)) ;names of all labels at this offset
+ )
+
+(define-integrable make-dbg-label-2 cons)
+(define-integrable dbg-label-2? pair?)
+(define-integrable dbg-label-2/name car)
+(define-integrable (dbg-label-2/offset label) (abs (cdr label)))
+(define-integrable (dbg-label-2/external? label) (negative? (cdr label)))
+(define-integrable (dbg-label-2/names label) (list (car label)))
+
+(define (set-dbg-label-2/external?! label external?)
+ (let ((offset (cdr label)))
+ (if (if external?
+ (not (negative? offset))
+ (negative? offset))
+ (set-cdr! label (- offset))))
+ unspecific)#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infstr.scm,v 1.5 1992/05/26 16:06:14 mhwu Exp $
+
+Copyright (c) 1988-91 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Compiled Code Information: Structures
+;;; package: (runtime compiler-info)
+
+(declare (usual-integrations))
+\f
+(define-integrable (make-dbg-info-vector info-vector)
+ (cons dbg-info-vector-tag info-vector))
+
+(define (dbg-info-vector? object)
+ (and (pair? object) (eq? (car object) dbg-info-vector-tag)))
+
+(define-integrable (dbg-info-vector/items info-vector)
+ (cdr info-vector))
+
+(define-integrable dbg-info-vector-tag
+ (string->symbol "#[(runtime compiler-info)dbg-info-vector-tag]"))
+
+(define-structure (dbg-info
+ (named
+ (string->symbol "#[(runtime compiler-info)dbg-info]"))
+ (conc-name dbg-info/))
+ (expression false read-only true) ;dbg-expression
+ (procedures false read-only true) ;vector of dbg-procedure
+ (continuations false read-only true) ;vector of dbg-continuation
+ (labels/desc false read-only false) ;vector of dbg-label, sorted by offset
+ )
+
+(define (dbg-info/labels dbg-info)
+ (let ((labels/desc (dbg-info/labels/desc dbg-info)))
+ (if (vector? labels/desc)
+ labels/desc
+ (let ((labels (read-labels labels/desc)))
+ (and labels
+ (begin
+ (set-dbg-info/labels/desc! dbg-info labels)
+ labels))))))
+
(define-structure (dbg-expression
(named
(string->symbol
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.22 1991/11/04 20:29:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.23 1992/05/26 16:05:25 mhwu Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
false)))
(define (read-binf-file filename)
- (and (file-exists? filename)
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler (list condition-type:fasload-band)
- (lambda (condition) condition (k false))
- (lambda () (fasload filename true)))))))
+ (let ((pathname (merge-pathnames filename)))
+ (if (file-exists? pathname)
+ (fasload-loader (->namestring pathname))
+ (find-alternate-file-type pathname
+ `(("binf" . ,fasload-loader)
+ ("inf" . ,fasload-loader)
+ ("bif" . ,fasload-loader)
+ ("bci" . ,compressed-loader))))))
(define (memoize-debugging-info! block dbg-info)
(without-interrupts
(let ((scode (dbg-procedure/source-code object)))
(and scode
(lambda-body scode))))
- entry)))
\ No newline at end of file
+ entry)))
+\f
+;;; Support of BSM files
+
+(define (read-labels descriptor)
+ (cond ((string? descriptor)
+ (let ((bsm (read-bsm-file descriptor)))
+ (and bsm ;; bsm are either vectors of pairs or vectors of vectors
+ (if (vector? bsm)
+ (let ((first (and (not (zero? (vector-length bsm)))
+ (vector-ref bsm 0))))
+ (cond ((pair? first) bsm)
+ ((vector? first) first)
+ (else false)))))))
+ ((and (pair? descriptor)
+ (string? (car descriptor))
+ (exact-nonnegative-integer? (cdr descriptor)))
+ (let ((bsm (read-bsm-file (car descriptor))))
+ (and bsm
+ (vector? bsm)
+ (< (cdr descriptor) (vector-length bsm))
+ (vector-ref bsm (cdr descriptor)))))
+ (else
+ false)))
+
+(define (read-bsm-file name)
+ (let ((filename (process-bsym-filename name)))
+ (if (file-exists? filename)
+ (fasload-loader filename)
+ (let ((pathname (merge-pathnames filename)))
+ (find-alternate-file-type pathname
+ `(("bsm" . ,fasload-loader)
+ ("bcs" . compressed-loader)))))))
+
+(define (process-bsym-filename name)
+ (->namestring
+ (rewrite-directory (merge-pathnames name))))
+
+;;; The conversion hack.
+
+(define (inf->bif/bsm inffile)
+ (let* ((infpath (merge-pathnames inffile))
+ (bifpath (pathname-new-type infpath "bif"))
+ (bsmpath (pathname-new-type infpath "bsm")))
+ (let ((binf (fasload infpath)))
+ (inf-structure->bif/bsm binf bifpath bsmpath))))
+
+(define (inf-structure->bif/bsm binf bifpath bsmpath)
+ (let* ((bifpath (merge-pathnames bifpath))
+ (bsmpath (merge-pathnames bsmpath))
+ (bsmname (->namestring bsmpath)))
+ (cond ((dbg-info? binf)
+ (let ((labels (dbg-info/labels/desc binf)))
+ (set-dbg-info/labels/desc! binf bsmname)
+ (fasdump binf bifpath)
+ (fasdump labels bsmpath)))
+ ((vector? binf)
+ (let ((bsm (make-vector (vector-length binf))))
+ (let loop ((pos 0))
+ (if (fix:= pos (vector-length bsm))
+ (begin
+ (fasdump bsm bsmpath)
+ (fasdump binf bifpath))
+ (let ((dbg-info (vector-ref binf pos)))
+ (let ((labels (dbg-info/labels/desc dbg-info)))
+ (vector-set! bsm pos labels)
+ (set-dbg-info/labels/desc! dbg-info (cons bsmname pos))
+ (loop (fix:1+ pos))))))))
+ (else
+ (error "Unknown inf file format" infpath))))))
+
+\f
+;;; UNCOMPRESS: A simple extractor for compressed binary info files.
+
+(define (uncompress ifile ofile)
+ (define-integrable window-size 4096)
+ (define (expand input-port output-channel buffer-size)
+ (let ((buffer (make-string buffer-size))
+ (cp-table (make-vector window-size))
+ (port/read-char
+ (or (input-port/operation/read-char input-port)
+ (error "Port doesn't support read-char" input-port)))
+ (port/read-substring
+ (or (input-port/operation input-port 'READ-SUBSTRING)
+ (error "Port doesn't support read-substring" input-port))))
+ (define (displacement->cp-index displacement cp)
+ (let ((index (fix:- cp displacement)))
+ (if (fix:< index 0) (fix:+ window-size index) index)))
+ (define-integrable (cp:+ cp n)
+ (fix:remainder (fix:+ cp n) window-size))
+ (define-integrable (read-substring! buffer start end)
+ (port/read-substring input-port buffer start end))
+ (define (read-ascii)
+ (let ((char (port/read-char input-port)))
+ (and (not (eof-object? char))
+ (char->ascii char))))
+ (define (guarantee-buffer nbp)
+ (if (fix:> nbp buffer-size)
+ (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4)))
+ (nbuffer (make-string new-size)))
+ (substring-move-right! buffer 0 buffer-size nbuffer 0)
+ (set! buffer-size new-size)
+ (set! buffer nbuffer))))
+
+ (let loop ((bp 0) (cp 0) (byte (read-ascii)))
+ (cond ((not byte)
+ (channel-write output-channel buffer 0 bp)
+ bp)
+ ((fix:< byte 16)
+ (let ((length (fix:+ byte 1)))
+ (let ((nbp (fix:+ bp length)) (ncp (cp:+ cp length)))
+ (guarantee-buffer nbp)
+ (read-substring! buffer bp nbp)
+ (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1)))
+ ((fix:= bp nbp))
+ (vector-set! cp-table cp bp))
+ (loop nbp ncp (read-ascii)))))
+ (else
+ (let ((cpi (displacement->cp-index
+ (fix:+ (fix:* (fix:remainder byte 16) 256)
+ (read-ascii))
+ cp))
+ (length (fix:+ (fix:quotient byte 16) 1)))
+ (let ((bp* (vector-ref cp-table cpi))
+ (nbp (fix:+ bp length))
+ (ncp (cp:+ cp 1)))
+ (guarantee-buffer nbp)
+ (substring-move-right! buffer bp* (fix:+ bp* length)
+ buffer bp)
+ (vector-set! cp-table cp bp)
+ (loop nbp ncp (read-ascii)))))))))
+\f
+ (let ((input (open-binary-input-file (merge-pathnames ifile))))
+ (if (not (input-port? input))
+ (error "UNCOMPRESS: error opening input" ifile))
+ (let ((output (file-open-output-channel
+ (->namestring (merge-pathnames ofile))))
+ (size (file-attributes/length (file-attributes ifile))))
+ (expand input output (fix:* size 2))
+ (channel-close output)
+ (close-input-port input))))
+
+
+(define (find-alternate-file-type base-pathname exts/receivers)
+ (or (null? exts/receivers)
+ (let ((file (pathname-new-type base-pathname (caar exts/receivers))))
+ (if (file-exists? file)
+ ((cdar exts/receivers) (->namestring file))
+ (find-alternate-file-type base-pathname (cdr exts/receivers))))))
+
+(define (fasload-loader filename)
+ (call-with-current-continuation
+ (lambda (if-fail)
+ (bind-condition-handler (list condition-type:fasload-band)
+ (lambda (condition) condition (if-fail false))
+ (lambda () (fasload filename true))))))
+
+(define (compressed-loader compressed-filename)
+ (call-with-temporary-filename
+ (lambda (uncompressed-filename)
+ (uncompress compressed-filename uncompressed-filename)
+ (fasload-loader uncompressed-filename))))
+
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.22 1991/11/04 20:29:04 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.23 1992/05/26 16:05:25 mhwu Exp $
Copyright (c) 1988-91 Massachusetts Institute of Technology
false)))
(define (read-binf-file filename)
- (and (file-exists? filename)
- (call-with-current-continuation
- (lambda (k)
- (bind-condition-handler (list condition-type:fasload-band)
- (lambda (condition) condition (k false))
- (lambda () (fasload filename true)))))))
+ (let ((pathname (merge-pathnames filename)))
+ (if (file-exists? pathname)
+ (fasload-loader (->namestring pathname))
+ (find-alternate-file-type pathname
+ `(("binf" . ,fasload-loader)
+ ("inf" . ,fasload-loader)
+ ("bif" . ,fasload-loader)
+ ("bci" . ,compressed-loader))))))
(define (memoize-debugging-info! block dbg-info)
(without-interrupts
(let ((scode (dbg-procedure/source-code object)))
(and scode
(lambda-body scode))))
- entry)))
\ No newline at end of file
+ entry)))
+\f
+;;; Support of BSM files
+
+(define (read-labels descriptor)
+ (cond ((string? descriptor)
+ (let ((bsm (read-bsm-file descriptor)))
+ (and bsm ;; bsm are either vectors of pairs or vectors of vectors
+ (if (vector? bsm)
+ (let ((first (and (not (zero? (vector-length bsm)))
+ (vector-ref bsm 0))))
+ (cond ((pair? first) bsm)
+ ((vector? first) first)
+ (else false)))))))
+ ((and (pair? descriptor)
+ (string? (car descriptor))
+ (exact-nonnegative-integer? (cdr descriptor)))
+ (let ((bsm (read-bsm-file (car descriptor))))
+ (and bsm
+ (vector? bsm)
+ (< (cdr descriptor) (vector-length bsm))
+ (vector-ref bsm (cdr descriptor)))))
+ (else
+ false)))
+
+(define (read-bsm-file name)
+ (let ((filename (process-bsym-filename name)))
+ (if (file-exists? filename)
+ (fasload-loader filename)
+ (let ((pathname (merge-pathnames filename)))
+ (find-alternate-file-type pathname
+ `(("bsm" . ,fasload-loader)
+ ("bcs" . compressed-loader)))))))
+
+(define (process-bsym-filename name)
+ (->namestring
+ (rewrite-directory (merge-pathnames name))))
+
+;;; The conversion hack.
+
+(define (inf->bif/bsm inffile)
+ (let* ((infpath (merge-pathnames inffile))
+ (bifpath (pathname-new-type infpath "bif"))
+ (bsmpath (pathname-new-type infpath "bsm")))
+ (let ((binf (fasload infpath)))
+ (inf-structure->bif/bsm binf bifpath bsmpath))))
+
+(define (inf-structure->bif/bsm binf bifpath bsmpath)
+ (let* ((bifpath (merge-pathnames bifpath))
+ (bsmpath (merge-pathnames bsmpath))
+ (bsmname (->namestring bsmpath)))
+ (cond ((dbg-info? binf)
+ (let ((labels (dbg-info/labels/desc binf)))
+ (set-dbg-info/labels/desc! binf bsmname)
+ (fasdump binf bifpath)
+ (fasdump labels bsmpath)))
+ ((vector? binf)
+ (let ((bsm (make-vector (vector-length binf))))
+ (let loop ((pos 0))
+ (if (fix:= pos (vector-length bsm))
+ (begin
+ (fasdump bsm bsmpath)
+ (fasdump binf bifpath))
+ (let ((dbg-info (vector-ref binf pos)))
+ (let ((labels (dbg-info/labels/desc dbg-info)))
+ (vector-set! bsm pos labels)
+ (set-dbg-info/labels/desc! dbg-info (cons bsmname pos))
+ (loop (fix:1+ pos))))))))
+ (else
+ (error "Unknown inf file format" infpath))))))
+
+\f
+;;; UNCOMPRESS: A simple extractor for compressed binary info files.
+
+(define (uncompress ifile ofile)
+ (define-integrable window-size 4096)
+ (define (expand input-port output-channel buffer-size)
+ (let ((buffer (make-string buffer-size))
+ (cp-table (make-vector window-size))
+ (port/read-char
+ (or (input-port/operation/read-char input-port)
+ (error "Port doesn't support read-char" input-port)))
+ (port/read-substring
+ (or (input-port/operation input-port 'READ-SUBSTRING)
+ (error "Port doesn't support read-substring" input-port))))
+ (define (displacement->cp-index displacement cp)
+ (let ((index (fix:- cp displacement)))
+ (if (fix:< index 0) (fix:+ window-size index) index)))
+ (define-integrable (cp:+ cp n)
+ (fix:remainder (fix:+ cp n) window-size))
+ (define-integrable (read-substring! buffer start end)
+ (port/read-substring input-port buffer start end))
+ (define (read-ascii)
+ (let ((char (port/read-char input-port)))
+ (and (not (eof-object? char))
+ (char->ascii char))))
+ (define (guarantee-buffer nbp)
+ (if (fix:> nbp buffer-size)
+ (let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4)))
+ (nbuffer (make-string new-size)))
+ (substring-move-right! buffer 0 buffer-size nbuffer 0)
+ (set! buffer-size new-size)
+ (set! buffer nbuffer))))
+
+ (let loop ((bp 0) (cp 0) (byte (read-ascii)))
+ (cond ((not byte)
+ (channel-write output-channel buffer 0 bp)
+ bp)
+ ((fix:< byte 16)
+ (let ((length (fix:+ byte 1)))
+ (let ((nbp (fix:+ bp length)) (ncp (cp:+ cp length)))
+ (guarantee-buffer nbp)
+ (read-substring! buffer bp nbp)
+ (do ((bp bp (fix:+ bp 1)) (cp cp (cp:+ cp 1)))
+ ((fix:= bp nbp))
+ (vector-set! cp-table cp bp))
+ (loop nbp ncp (read-ascii)))))
+ (else
+ (let ((cpi (displacement->cp-index
+ (fix:+ (fix:* (fix:remainder byte 16) 256)
+ (read-ascii))
+ cp))
+ (length (fix:+ (fix:quotient byte 16) 1)))
+ (let ((bp* (vector-ref cp-table cpi))
+ (nbp (fix:+ bp length))
+ (ncp (cp:+ cp 1)))
+ (guarantee-buffer nbp)
+ (substring-move-right! buffer bp* (fix:+ bp* length)
+ buffer bp)
+ (vector-set! cp-table cp bp)
+ (loop nbp ncp (read-ascii)))))))))
+\f
+ (let ((input (open-binary-input-file (merge-pathnames ifile))))
+ (if (not (input-port? input))
+ (error "UNCOMPRESS: error opening input" ifile))
+ (let ((output (file-open-output-channel
+ (->namestring (merge-pathnames ofile))))
+ (size (file-attributes/length (file-attributes ifile))))
+ (expand input output (fix:* size 2))
+ (channel-close output)
+ (close-input-port input))))
+
+
+(define (find-alternate-file-type base-pathname exts/receivers)
+ (or (null? exts/receivers)
+ (let ((file (pathname-new-type base-pathname (caar exts/receivers))))
+ (if (file-exists? file)
+ ((cdar exts/receivers) (->namestring file))
+ (find-alternate-file-type base-pathname (cdr exts/receivers))))))
+
+(define (fasload-loader filename)
+ (call-with-current-continuation
+ (lambda (if-fail)
+ (bind-condition-handler (list condition-type:fasload-band)
+ (lambda (condition) condition (if-fail false))
+ (lambda () (fasload filename true))))))
+
+(define (compressed-loader compressed-filename)
+ (call-with-temporary-filename
+ (lambda (uncompressed-filename)
+ (uncompress compressed-filename uncompressed-filename)
+ (fasload-loader uncompressed-filename))))
+
projects / mit-scheme.git / commitdiff