(last-reference *dbg-continuations*)
*label-bindings*
(last-reference *external-labels*))))
- (cond ((eq? pathname 'KEEP) ; for dynamic execution
- (values (vector 'DEBUGGING-INFO-WRAPPER
- 2
+ (cond ((eq? pathname 'keep) ; for dynamic execution
+ (values (vector 'debugging-info-wrapper
+ 3
#f
#f
#f
- info)
+ info
+ #f)
#f))
- ((eq? pathname 'RECURSIVE) ; recursive compilation
+ ((eq? pathname 'recursive) ; recursive compilation
(set! *recursive-compilation-results*
(cons (vector *recursive-compilation-number*
info
*tl-free*
*tl-metadata*)
*recursive-compilation-results*))
- (values (vector 'DEBUGGING-INFO-WRAPPER
- 2
+ (values (vector 'debugging-info-wrapper
+ 3
*debugging-key*
(if (pathname? *info-output-filename*)
(->namestring *info-output-filename*)
*info-output-filename*)
*recursive-compilation-number*
- #f)
+ #f
+ *library-name*)
#f))
(else
- (values (vector 'DEBUGGING-INFO-WRAPPER
- 2
+ (values (vector 'debugging-info-wrapper
+ 3
*debugging-key*
(if (pathname? *info-output-filename*)
(->namestring *info-output-filename*)
*info-output-filename*)
0
- #f)
- (vector 'DEBUGGING-FILE-WRAPPER
- 2
+ #f
+ *library-name*)
+ (vector 'debugging-file-wrapper
+ 3
*debugging-key*
(list->vector
- (cons info
- (map (lambda (other)
- (vector-ref other 1))
- (recursive-compilation-results))
- )))))))
+ (cons
+ info
+ (map (lambda (other)
+ (vector-ref other 1))
+ (recursive-compilation-results))))
+ *library-name*)))))
(set-debugging-info! *code-vector* debug-info)
file-wrapper))))
(define (compiler:dump-inf-file binf pathname)
(compiler-file-output binf pathname))
-(define (compiler:dump-bif/bsm-files binf pathname)
- (let ((bif-path (pathname-new-type pathname "bif"))
- (bsm-path (pathname-new-type pathname "bsm")))
- (let ((bsm (split-inf-structure! binf bsm-path)))
- (compiler-file-output binf bif-path)
- (compiler-file-output bsm bsm-path))))
-
-(define (compiler:dump-bci/bcs-files binf pathname)
- (let ((bci-path (pathname-new-type pathname "bci"))
- (bcs-path (pathname-new-type pathname "bcs")))
- (let ((bsm (split-inf-structure! binf bcs-path)))
- (dump-compressed binf bci-path)
- (dump-compressed bsm bcs-path))))
-
(define (compiler:dump-bci-file binf pathname)
- (let ((bci-path (pathname-new-type pathname "bci")))
- (split-inf-structure! binf #f)
- (dump-compressed binf bci-path)))
+ (dump-compressed binf (pathname-new-type pathname "bci")))
(define (dump-compressed object path)
(call-with-temporary-filename
(write (enough-namestring output-file) port))
(lambda ()
(let ((inf (fasload input-file #t)))
- ((access SPLIT-INF-STRUCTURE! ; XXX ugh
- (->environment '(RUNTIME COMPILER-INFO)))
- inf
- #f)
(call-with-temporary-filename
(lambda (temp)
(fasdump inf temp #t)
(define (compile-bin-file-1 scode info-output-pathname rtl-output-port
lap-output-port)
- (receive (result file-wrapper)
- (compile-scode/internal scode info-output-pathname rtl-output-port
- lap-output-port)
- (if file-wrapper
- (compiler:dump-info-file file-wrapper
+ (receive (result wrapper)
+ (let ((do-one-expr
+ (lambda (scode library-name)
+ (fluid-let ((*library-name* library-name))
+ (compile-scode/internal scode
+ info-output-pathname
+ rtl-output-port
+ lap-output-port)))))
+ (if (r7rs-scode-file? scode)
+ (let ((file-wrappers '()))
+ (let ((result
+ (map-r7rs-scode-file
+ (lambda (library)
+ (let ((name
+ (or (scode-library-name library)
+ 'program)))
+ (map-scode-library
+ (lambda (contents)
+ (receive (result file-wrapper)
+ (do-one-expr contents name)
+ (if file-wrapper
+ (set! file-wrappers
+ (cons file-wrapper
+ file-wrappers)))
+ result))
+ library)))
+ scode)))
+ (values result
+ (vector 'debugging-library-wrapper
+ 3
+ *debugging-key*
+ (list->vector (reverse file-wrappers))))))
+ (do-one-expr scode #f)))
+ (if wrapper
+ (compiler:dump-info-file wrapper
info-output-pathname))
result))
(define *debugging-key*)
(define *compiler-input-pathname*)
(define *compiler-output-pathname*)
+(define *library-name*)
(define (maybe-open-file open? pathname receiver)
(if open?
(define (phase/rtl-file-output scode port)
(compiler-phase "RTL File Output"
(lambda ()
- (write-string "RTL for object " port)
- (write *recursive-compilation-number* port)
- (newline port)
- (pp scode port #t 4)
- (newline port)
- (newline port)
+ (rtl/lap-file-header "RTL" scode port)
(write-rtl-instructions (linearize-rtl *rtl-root*
*rtl-procedures*
*rtl-continuations*)
port)
- (if (not (zero? *recursive-compilation-number*))
- (begin
- (write-char #\page port)
- (newline port)))
- (output-port/flush-output port))))
+ (rtl/lap-file-footer port))))
\f
(define (phase/lap-generation)
(compiler-phase "LAP Generation"
(lambda ()
(parameterize ((param:printer-radix 16)
(param:print-uninterned-symbols-by-name? #t))
- (parameterize ((current-output-port port))
- (write-string "LAP for object ")
- (write *recursive-compilation-number*)
- (newline)
- (pp scode (current-output-port) #t 4)
- (newline)
- (newline)
- (newline)
- (for-each
- (lambda (instruction)
- (cond ((and (pair? instruction)
- (eq? (car instruction) 'LABEL))
- (write (cadr instruction))
- (write-char #\:))
- ((and (pair? instruction)
- (eq? (car instruction) 'COMMENT))
- (write-char #\tab)
- (write-string ";;")
- (for-each (lambda (frob)
- (write-string " ")
- (write (if (and (pair? frob)
- (eq? (car frob) 'RTL))
- (cadr frob)
- frob)))
- (cdr instruction)))
- (else
- (write-char #\tab)
- (write instruction)))
- (newline))
- *lap*)
- (if (not (zero? *recursive-compilation-number*))
- (begin
- (write-char #\page)
- (newline)))
- (output-port/flush-output port))))))
\ No newline at end of file
+ (rtl/lap-file-header "LAP" scode port)
+ (for-each (lambda (instruction)
+ (write-lap-instruction instruction port))
+ *lap*)
+ (rtl/lap-file-footer port)))))
+
+(define (write-lap-instruction instruction port)
+ (cond ((and (pair? instruction)
+ (eq? (car instruction) 'label))
+ (write (cadr instruction) port)
+ (write-char #\: port))
+ ((and (pair? instruction)
+ (eq? (car instruction) 'comment))
+ (write-char #\tab port)
+ (write-string ";;" port)
+ (for-each (lambda (frob)
+ (write-string " " port)
+ (write (if (and (pair? frob)
+ (eq? (car frob) 'rtl))
+ (cadr frob)
+ frob)
+ port))
+ (cdr instruction)))
+ (else
+ (write-char #\tab port)
+ (write instruction port)))
+ (newline port))
+
+(define (rtl/lap-file-header tag scode port)
+ (write-char #\page port)
+ (newline port)
+ (write-string tag port)
+ (write-string " for object " port)
+ (write *recursive-compilation-number* port)
+ (cond ((eq? *library-name* 'program)
+ (write-string " in R7RS top level" port))
+ (*library-name*
+ (write-string " in R7RS library " port)
+ (write *library-name* port)))
+ (newline port)
+ (pp scode port #t 4)
+ (newline port)
+ (newline port))
+
+(define (rtl/lap-file-footer port)
+ (output-port/flush-output port))
\ No newline at end of file
*root-expression*
*rtl-procedures*
*rtl-graphs*)
- (import (runtime compiler-info)
- split-inf-structure!)
(import (runtime load)
fasload-object-file)
(import (scode-optimizer build-utilities)
others)))))))))))
(define (compiler:dump-bci-file binf pathname)
- (let ((bci-path (pathname-new-type pathname "bci")))
- (split-inf-structure! binf #f)
- (dump-compressed binf bci-path)))
+ (dump-compressed binf (pathname-new-type pathname "bci")))
(define (dump-compressed object path)
(call-with-temporary-filename
*root-expression*
*rtl-procedures*
*rtl-graphs*)
- (import (runtime compiler-info)
- split-inf-structure!)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(let ((symbol-table (and info (dbg-info/labels info))))
(write-string "Disassembly of ")
(write block)
- (call-with-values
- (lambda () (compiled-code-block/filename-and-index block))
- (lambda (filename index)
- (if filename
- (begin
- (write-string " (Block ")
- (write index)
- (write-string " in ")
- (write-string filename)
- (write-string ")")))))
+ (receive (filename index library)
+ (compiled-code-block/filename-and-index block)
+ (if filename
+ (begin
+ (write-string " (Block ")
+ (write index)
+ (if library
+ (begin
+ (write-string " of library ")
+ (write library)))
+ (write-string " in ")
+ (write-string filename)
+ (write-string ")"))))
(write-string ":\n")
(write-string "Code:\n\n")
(disassembler/write-instruction-stream
*root-expression*
*rtl-procedures*
*rtl-graphs*)
- (import (runtime compiler-info)
- split-inf-structure!)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(let ((cursor (block-cursor block symbol-table?)))
(write-string "Disassembly of ")
(write block)
- (call-with-values
- (lambda () (compiled-code-block/filename-and-index block))
- (lambda (filename index)
- (if filename
- (begin
- (write-string " (Block ")
- (write index)
- (write-string " in ")
- (write-string filename)
- (write-string "):\n")))))
+ (receive (filename index library)
+ (compiled-code-block/filename-and-index block)
+ (if filename
+ (begin
+ (write-string " (Block ")
+ (write index)
+ (if library
+ (begin
+ (write-string " of library ")
+ (write library)))
+ (write-string " in ")
+ (write-string filename)
+ (write-string "):\n"))))
(write-string "\nCode:\n")
(write-instructions cursor)
(write-string "\nConstants:\n")
*root-expression*
*rtl-procedures*
*rtl-graphs*)
- (import (runtime compiler-info)
- split-inf-structure!)
+ (import (runtime)
+ map-r7rs-scode-file
+ map-scode-library
+ r7rs-scode-file?
+ scode-library-name)
(import (scode-optimizer build-utilities)
directory-processor))
\f
(let ((symbol-table (and info (dbg-info/labels info))))
(write-string "Disassembly of ")
(write block)
- (call-with-values
- (lambda () (compiled-code-block/filename-and-index block))
- (lambda (filename index)
- (if filename
- (begin
- (write-string " (Block ")
- (write index)
- (write-string " in ")
- (write-string filename)
- (write-string ")")))))
+ (receive (filename index library)
+ (compiled-code-block/filename-and-index block)
+ (if filename
+ (begin
+ (write-string " (Block ")
+ (write index)
+ (if library
+ (begin
+ (write-string " of library ")
+ (write library)))
+ (write-string " in ")
+ (write-string filename)
+ (write-string ")"))))
(write-string ":\n")
(write-string "Code:\n\n")
(disassembler/write-instruction-stream
(write-string "within ")
(let ((block (stack-frame/ref frame hardware-trap/pc-info1-index)))
(write block)
- (call-with-values
- (lambda () (compiled-code-block/filename-and-index block))
- (lambda (filename index)
- index
- (if filename
- (begin
- (write-string " (")
- (write-string filename)
- (write-string ")")))))))
+ (receive (filename index library)
+ (compiled-code-block/filename-and-index block)
+ (declare (ignore index library))
+ (if filename
+ (begin
+ (write-string " (")
+ (write-string filename)
+ (write-string ")"))))))
((3) ; probably compiled-code
(write-string " at an unknown compiled-code location."))
((4) ; builtin (i.e. hook)
(expression #f read-only #t) ;dbg-expression
(procedures #f read-only #t) ;vector of dbg-procedure
(continuations #f read-only #t) ;vector of dbg-continuation
- (labels/desc #f read-only #f) ;vector of dbg-label, sorted by offset
+ (labels #f read-only #f) ;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
(type vector)
(named '|#[(runtime compiler-info)dbg-expression]|)
(define (compiled-code-block/debugging-wrapper block)
(let ((wrapper (compiled-code-block/debugging-info block)))
- (if (debugging-wrapper? wrapper)
- wrapper
- #f)))
-
-(define (debugging-wrapper? wrapper)
+ (cond ((debugging-wrapper-v2? wrapper)
+ (let ((v (vector-grow wrapper 7)))
+ (vector-set! v 1 3)
+ (vector-set! v 6 #f)
+ (set-compiled-code-block/debugging-info! block v)
+ v))
+ ((debugging-wrapper-v3? wrapper) wrapper)
+ (else #f))))
+
+(define (debugging-wrapper-v2? wrapper)
(and (vector? wrapper)
(fix:= (vector-length wrapper) 6)
- (eq? (vector-ref wrapper 0) 'debugging-info-wrapper)
- (fix:= (vector-ref wrapper 1) 2)
+ (eqv? (vector-ref wrapper 1) 2)
+ (debugging-wrapper-common? wrapper)))
+
+(define (debugging-wrapper-v3? wrapper)
+ (and (vector? wrapper)
+ (fix:= (vector-length wrapper) 7)
+ (eqv? (vector-ref wrapper 1) 3)
+ (debugging-wrapper-common? wrapper)
+ (debugging-library-name? (vector-ref wrapper 6))))
+
+(define (debugging-library-name? object)
+ (or (not object)
+ (eq? object 'program)
+ (library-name? object)))
+
+(define (debugging-library-name=? n1 n2)
+ (or (eq? n1 n2)
+ (and (library-name? n1)
+ (library-name? n2)
+ (library-name=? n1 n2))))
+
+(define (debugging-wrapper-common? wrapper)
+ (and (eq? (vector-ref wrapper 0) 'debugging-info-wrapper)
(or (and (not (vector-ref wrapper 2))
(not (vector-ref wrapper 3))
(not (vector-ref wrapper 4))
(define (set-debugging-wrapper/info! wrapper info)
(vector-set! wrapper 5 info))
+
+(define (debugging-wrapper/library-name wrapper)
+ (vector-ref wrapper 6))
\f
-(define (debugging-file-wrapper? wrapper)
+(define (canonicalize-file-wrapper wrapper)
+ (cond ((debugging-file-wrapper-v2? wrapper)
+ (let ((v (vector-grow wrapper 5)))
+ (vector-set! v 1 3)
+ (vector-set! v 4 #f)
+ v))
+ ((or (debugging-file-wrapper-v3? wrapper)
+ (debugging-library-wrapper? wrapper))
+ wrapper)
+ (else #f)))
+
+(define (debugging-file-wrapper-v2? wrapper)
(and (vector? wrapper)
(fix:= (vector-length wrapper) 4)
- (eq? (vector-ref wrapper 0) 'debugging-file-wrapper)
- (fix:= (vector-ref wrapper 1) 2)
+ (eqv? (vector-ref wrapper 1) 2)
+ (debugging-file-wrapper-common? wrapper)))
+
+(define (debugging-file-wrapper-v3? wrapper)
+ (and (vector? wrapper)
+ (fix:= (vector-length wrapper) 5)
+ (eqv? (vector-ref wrapper 1) 3)
+ (debugging-file-wrapper-common? wrapper)
+ (debugging-library-name? (vector-ref wrapper 4))))
+
+(define (debugging-file-wrapper-common? wrapper)
+ (and (eq? (vector-ref wrapper 0) 'debugging-file-wrapper)
(dbg-info-key? (vector-ref wrapper 2))
(let ((info (vector-ref wrapper 3)))
(and (vector? info)
(define (debugging-file-wrapper/info wrapper)
(vector-ref wrapper 3))
-(define (canonicalize-file-wrapper wrapper)
- (cond ((debugging-file-wrapper? wrapper)
- wrapper)
- (else #f)))
-
-(define (get-wrapped-dbg-info file-wrapper wrapper)
- (and (let ((k1 (debugging-wrapper/key wrapper))
- (k2 (debugging-file-wrapper/key file-wrapper)))
- (or (and k1 k2 (dbg-info-key=? k1 k2))
- (and (not k1) (not k2))))
- (let ((v (debugging-file-wrapper/info file-wrapper))
- (index (debugging-wrapper/index wrapper)))
- (and (fix:< index (vector-length v))
- (vector-ref v index)))))
+(define (debugging-file-wrapper/library-name wrapper)
+ (vector-ref wrapper 4))
(define (dbg-info-key? object)
(or (and (bytevector? object)
(and ((ucode-primitive string? 1) object)
(fix:= ((ucode-primitive string-length 1) object) 32))))
-(define (dbg-info-key=? a b)
- (equal? a b))
+(define (dbg-info-key=? k1 k2)
+ (or (and k1 k2 (equal? k1 k2))
+ (and (not k1) (not k2))))
+\f
+(define (debugging-library-wrapper? wrapper)
+ (and (vector? wrapper)
+ (fix:= (vector-length wrapper) 4)
+ (eq? (vector-ref wrapper 0) 'debugging-library-wrapper)
+ (eqv? (vector-ref wrapper 1) 3)
+ (dbg-info-key? (vector-ref wrapper 2))
+ (let ((info (vector-ref wrapper 3)))
+ (and (vector? info)
+ (fix:>= (vector-length info) 1)
+ (vector-every debugging-file-wrapper-v3? info)))))
+
+(define (debugging-library-wrapper/version wrapper)
+ (vector-ref wrapper 1))
+
+(define (debugging-library-wrapper/key wrapper)
+ (vector-ref wrapper 2))
+
+(define (debugging-library-wrapper/file-wrappers wrapper)
+ (vector-ref wrapper 3))
+
+(define (get-wrapped-dbg-info from-file from-block)
+ (let ((lookup-by-index
+ (lambda (from-file)
+ (let ((v (debugging-file-wrapper/info from-file))
+ (index (debugging-wrapper/index from-block)))
+ (and (fix:< index (vector-length v))
+ (vector-ref v index))))))
+ (cond ((debugging-file-wrapper-v3? from-file)
+ (and (dbg-info-key=? (debugging-wrapper/key from-block)
+ (debugging-file-wrapper/key from-file))
+ (lookup-by-index from-file)))
+ ((debugging-library-wrapper? from-file)
+ (and (dbg-info-key=? (debugging-wrapper/key from-block)
+ (debugging-library-wrapper/key from-file))
+ (let ((name (debugging-wrapper/library-name from-block))
+ (v (debugging-library-wrapper/file-wrappers from-file)))
+ (let ((n (vector-length v)))
+ (let loop ((i 0))
+ (and (fix:< i n)
+ (if (debugging-library-name=?
+ name
+ (debugging-file-wrapper/library-name
+ (vector-ref v i)))
+ (lookup-by-index (vector-ref v i))
+ (loop (fix:+ i 1)))))))))
+ (else #f))))
\f
(define (debug-info-pathname? object)
(or (string? object)
(and file-wrapper
(let ((file-wrapper (canonicalize-file-wrapper file-wrapper)))
(and file-wrapper
- (let ((info
- (get-wrapped-dbg-info file-wrapper wrapper)))
+ (let ((info (get-wrapped-dbg-info file-wrapper wrapper)))
(if info
(memoize-debugging-info! wrapper info))
info))))))))
(let ((pathname (debugging-wrapper/pathname wrapper)))
(if pathname
(values (canonicalize-debug-info-filename pathname)
- (debugging-wrapper/index wrapper))
- (values #f #f)))
- (values #f #f))))
+ (debugging-wrapper/index wrapper)
+ (debugging-wrapper/library-name wrapper))
+ (values #f #f #f)))
+ (values #f #f #f))))
(define (dbg-labels/find-offset labels offset)
(vector-binary-search labels < dbg-label/offset offset))
(scode-lambda-body scode))))
entry)))
\f
-;;; Support of BSM files
-
-(define (read-labels descriptor)
- (cond ((debug-info-pathname? 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 #f)))))))
- ((and (pair? descriptor)
- (debug-info-pathname? (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 #f)))
-
-(define (read-bsm-file name)
- (let ((pathname
- (let ((pathname
- (canonicalize-debug-info-pathname
- (rewrite-directory (merge-pathnames name)))))
- (if (file-exists? pathname)
- pathname
- (let loop ((types '("bsm" "bcs")))
- (and (not (null? types))
- (let ((pathname
- (pathname-new-type pathname (car types))))
- (if (file-exists? pathname)
- pathname
- (loop (cdr types))))))))))
- (and pathname
- (if (equal? "bcs" (pathname-type pathname))
- (compressed-loader pathname)
- (fasload-loader pathname)))))
-
-;;;; Splitting of info structures
-
-(define (inf->bif/bsm inffile)
- (let* ((infpath (merge-pathnames inffile))
- (bifpath (pathname-new-type infpath "bif"))
- (bsmpath (pathname-new-type infpath "bsm")))
- (let ((file-info (fasload infpath)))
- (inf-structure->bif/bsm file-info bifpath bsmpath))))
-
-(define (inf-structure->bif/bsm file-info bifpath bsmpath)
- (let ((bifpath (merge-pathnames bifpath))
- (bsmpath (and bsmpath (merge-pathnames bsmpath))))
- (call-with-values (lambda () (split-inf-structure! file-info bsmpath))
- (lambda (file-wrapper bsm)
- (fasdump file-wrapper bifpath #t)
- (if bsmpath (fasdump bsm bsmpath #t))))))
-
-(define (split-inf-structure! file-info bsmpath)
- (let ((file-wrapper (canonicalize-file-wrapper file-info))
- (bsmname (and bsmpath (->namestring bsmpath))))
- (if (not file-wrapper)
- (error "Unknown debugging-file format:" file-info))
- (let ((info (debugging-file-wrapper/info file-wrapper)))
- (let ((n (vector-length info)))
- (let ((bsm (make-vector n)))
- (do ((i 0 (fix:+ i 1)))
- ((fix:= i n))
- (let ((dbg-info (vector-ref info i)))
- (let ((labels (dbg-info/labels/desc dbg-info)))
- (vector-set! bsm i labels)
- (set-dbg-info/labels/desc! dbg-info
- (and bsmname (cons bsmname i))))))
- (values file-wrapper bsm))))))
-\f
;;;; UNCOMPRESS
;;; A simple extractor for compressed binary info files.
(strip-comments (scode-comment-expression object))
object))
+;; Unlike map, guarantees that procedure is called on the libraries in order.
(define (map-r7rs-scode-file procedure scode)
(guarantee r7rs-scode-file? scode 'map-r7rs-scode-file)
- (make-scode-sequence (map procedure (r7rs-scode-file-libraries scode))))
\ No newline at end of file
+ (let loop ((libraries (r7rs-scode-file-libraries scode)) (results '()))
+ (if (pair? libraries)
+ (loop (cdr libraries)
+ (cons (procedure (car libraries)) results))
+ (make-scode-sequence (reverse results)))))
\ No newline at end of file
(bignum ,print-number)
(bytevector ,print-bytevector)
(character ,print-character)
+ (compiled-code-block ,print-compiled-code-block)
(compiled-entry ,print-compiled-entry)
(complex ,print-number)
(constant ,print-constant)
(lambda (context*)
(*print-char #\space context*)
(print-name context*)))))))
-
+\f
(define (print-compiled-entry entry context)
(let* ((type (compiled-entry-type entry))
(procedure? (eq? type 'compiled-procedure))
context
(lambda (context*)
(let ((name (and procedure? (compiled-procedure/name entry))))
- (receive (filename block-number)
+ (receive (filename block-number library)
(compiled-entry/filename-and-index entry)
(*print-char #\space context*)
(*print-char #\( context*)
(begin
(if name
(*print-char #\space context*))
- (print-object (pathname-name filename) context*)
- (if block-number
- (begin
- (*print-char #\space context*)
- (*print-hex block-number context*)))))
+ (print-block-info filename block-number library context*)))
(*print-char #\) context*)))
(*print-char #\space context*)
(*print-hex (compiled-entry/offset entry) context*)
(begin
(*print-char #\space context*)
(*print-datum (compiled-closure->entry entry)
- context*)))
+ context*)))
(*print-char #\space context*)
(*print-datum entry context*)))))
+
+(define (print-compiled-code-block block context)
+ (*print-with-brackets 'compiled-code-block block context
+ (lambda (context*)
+ (receive (filename block-number library)
+ (compiled-code-block/filename-and-index block)
+ (*print-char #\space context*)
+ (if filename
+ (begin
+ (*print-char #\( context*)
+ (print-block-info filename block-number library context*)
+ (*print-char #\) context*))))
+ (*print-char #\space context*)
+ (*print-datum block context*))))
+
+(define (print-block-info filename block-number library context*)
+ (print-object (pathname-name filename) context*)
+ (if block-number
+ (begin
+ (*print-char #\space context*)
+ (*print-hex block-number context*)))
+ (if library
+ (begin
+ (*print-char #\space context*)
+ (print-object library context*))))
\f
;;;; Miscellaneous
(files "library-parser")
(parent (runtime library))
(export (runtime)
+ library-name=?
+ library-name?
r7rs-source-program
r7rs-source-libraries
r7rs-source?
read-r7rs-source
register-r7rs-source!)
(export (runtime library)
- library-name=?
- library-name?
parsed-import-library
parse-define-library-form
parse-import-form
projects / mit-scheme.git / commitdiff