home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / unpars.scm < prev    next >
Text File  |  2001-06-15  |  23KB  |  688 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: unpars.scm,v 14.48 2001/06/15 20:38:51 cph Exp $
  4.  
  5. Copyright (c) 1988-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  20. 02111-1307, USA.
  21. |#
  22.  
  23. ;;;; Unparser
  24. ;;; package: (runtime unparser)
  25.  
  26. (declare (usual-integrations))
  27.  
  28. (define (initialize-package!)
  29.   (set! string-delimiters
  30.     (char-set-union char-set:not-graphic (char-set #\" #\\)))
  31.   (set! hook/interned-symbol unparse-symbol)
  32.   (set! hook/procedure-unparser false)
  33.   (set! *unparser-radix* 10)
  34.   (set! *unparser-list-breadth-limit* false)
  35.   (set! *unparser-list-depth-limit* false)
  36.   (set! *unparser-string-length-limit* false)
  37.   (set! *unparse-primitives-by-name?* false)
  38.   (set! *unparse-uninterned-symbols-by-name?* false)
  39.   (set! *unparse-with-maximum-readability?* false)
  40.   (set! *unparse-disambiguate-null-as-itself?* true)
  41.   (set! *unparse-disambiguate-null-lambda-list?* false)
  42.   (set! *unparse-compound-procedure-names?* true)
  43.   (set! *unparse-with-datum?* false)
  44.   (set! *unparse-abbreviate-quotations?* #f)
  45.   (set! system-global-unparser-table (make-system-global-unparser-table))
  46.   (set! *default-list-depth* 0)
  47.   (set-current-unparser-table! system-global-unparser-table))
  48.  
  49. (define *unparser-radix*)
  50. (define *unparser-list-breadth-limit*)
  51. (define *unparser-list-depth-limit*)
  52. (define *unparser-string-length-limit*)
  53. (define *unparse-primitives-by-name?*)
  54. (define *unparse-uninterned-symbols-by-name?*)
  55. (define *unparse-with-maximum-readability?*)
  56. (define *unparse-disambiguate-null-as-itself?*)
  57. (define *unparse-disambiguate-null-lambda-list?*)
  58. (define *unparse-compound-procedure-names?*)
  59. (define *unparse-with-datum?*)
  60. (define *unparse-abbreviate-quotations?*)
  61. (define system-global-unparser-table)
  62. (define *default-list-depth*)
  63. (define *current-unparser-table*)
  64.  
  65. (define (current-unparser-table)
  66.   *current-unparser-table*)
  67.  
  68. (define (set-current-unparser-table! table)
  69.   (guarantee-unparser-table table 'SET-CURRENT-UNPARSER-TABLE!)
  70.   (set! *current-unparser-table* table)
  71.   unspecific)
  72.  
  73. (define (make-system-global-unparser-table)
  74.   (let ((table (make-unparser-table unparse/default)))
  75.     (for-each (lambda (entry)
  76.         (unparser-table/set-entry! table (car entry) (cadr entry)))
  77.           `((BIGNUM ,unparse/number)
  78.         (CHARACTER ,unparse/character)
  79.         (COMPILED-ENTRY ,unparse/compiled-entry)
  80.         (COMPLEX ,unparse/number)
  81.         (CONSTANT ,unparse/constant)
  82.         (ENTITY ,unparse/entity)
  83.         (ENVIRONMENT ,unparse/environment)
  84.         (EXTENDED-PROCEDURE ,unparse/compound-procedure)
  85.         (FLONUM ,unparse/flonum)
  86.         (FUTURE ,unparse/future)
  87.         (INTERNED-SYMBOL ,unparse/interned-symbol)
  88.         (LIST ,unparse/pair)
  89.         (NEGATIVE-FIXNUM ,unparse/number)
  90.         (NULL ,unparse/null)
  91.         (POSITIVE-FIXNUM ,unparse/number)
  92.         (PRIMITIVE ,unparse/primitive-procedure)
  93.         (PROCEDURE ,unparse/compound-procedure)
  94.         (RATNUM ,unparse/number)
  95.         (RECORD ,unparse/record)
  96.         (RETURN-ADDRESS ,unparse/return-address)
  97.         (STRING ,unparse/string)
  98.         (UNINTERNED-SYMBOL ,unparse/uninterned-symbol)
  99.         (VARIABLE ,unparse/variable)
  100.         (VECTOR ,unparse/vector)
  101.         (VECTOR-1B ,unparse/bit-string)))
  102.     table))
  103.  
  104. ;;;; Unparser Table/State
  105.  
  106. (define-structure (unparser-table (constructor %make-unparser-table)
  107.                   (conc-name unparser-table/))
  108.   (dispatch-vector false read-only true))
  109.  
  110. (define (guarantee-unparser-table table procedure)
  111.   (if (not (unparser-table? table))
  112.       (error:wrong-type-argument table "unparser table" procedure))
  113.   table)
  114.  
  115. (define (make-unparser-table default-method)
  116.   (%make-unparser-table
  117.    (make-vector (microcode-type/code-limit) default-method)))
  118.  
  119. (define (unparser-table/copy table)
  120.   (%make-unparser-table (unparser-table/dispatch-vector table)))
  121.  
  122. (define (unparser-table/entry table type-name)
  123.   (vector-ref (unparser-table/dispatch-vector table)
  124.           (microcode-type type-name)))
  125.  
  126. (define (unparser-table/set-entry! table type-name method)
  127.   (vector-set! (unparser-table/dispatch-vector table)
  128.            (microcode-type type-name)
  129.            method))
  130.  
  131. (define-structure (unparser-state (conc-name unparser-state/))
  132.   (port false read-only true)
  133.   (list-depth false read-only true)
  134.   (slashify? false read-only true)
  135.   (unparser-table false read-only true))
  136.  
  137. (define (guarantee-unparser-state state procedure)
  138.   (if (not (unparser-state? state))
  139.       (error:wrong-type-argument state "unparser state" procedure))
  140.   state)
  141.  
  142. (define (with-current-unparser-state state procedure)
  143.   (guarantee-unparser-state state 'WITH-CURRENT-UNPARSER-STATE)
  144.   (fluid-let
  145.       ((*default-list-depth* (unparser-state/list-depth state))
  146.        (*current-unparser-table* (unparser-state/unparser-table state)))
  147.     (procedure (unparser-state/port state))))
  148.  
  149. ;;;; Top Level
  150.  
  151. (define (unparse-char state char)
  152.   (guarantee-unparser-state state 'UNPARSE-CHAR)
  153.   (write-char char (unparser-state/port state)))
  154.  
  155. (define (unparse-string state string)
  156.   (guarantee-unparser-state state 'UNPARSE-STRING)
  157.   (write-string string (unparser-state/port state)))
  158.  
  159. (define (unparse-object state object)
  160.   (guarantee-unparser-state state 'UNPARSE-OBJECT)
  161.   (unparse-object/internal object
  162.                (unparser-state/port state)
  163.                (unparser-state/list-depth state)
  164.                (unparser-state/slashify? state)
  165.                (unparser-state/unparser-table state)))
  166.  
  167. (define (unparse-object/top-level object port slashify? table)
  168.   (unparse-object/internal object port *default-list-depth* slashify? table))
  169.  
  170. (define (unparse-object/internal object port list-depth slashify? table)
  171.   (fluid-let ((*output-port* port)
  172.           (*list-depth* list-depth)
  173.           (*slashify?* slashify?)
  174.           (*unparser-table* table)
  175.           (*dispatch-vector* (unparser-table/dispatch-vector table)))
  176.     (*unparse-object object)))
  177.  
  178. (define-integrable (invoke-user-method method object)
  179.   (method (make-unparser-state *output-port*
  180.                    *list-depth*
  181.                    *slashify?*
  182.                    *unparser-table*)
  183.       object))
  184.  
  185. (define *list-depth*)
  186. (define *slashify?*)
  187. (define *unparser-table*)
  188. (define *dispatch-vector*)
  189.  
  190. (define (*unparse-object object)
  191.   ((vector-ref *dispatch-vector*
  192.            ((ucode-primitive primitive-object-type 1) object))
  193.    object))
  194.  
  195. ;;;; Low Level Operations
  196.  
  197. (define *output-port*)
  198.  
  199. (define-integrable (*unparse-char char)
  200.   (output-port/write-char *output-port* char))
  201.  
  202. (define-integrable (*unparse-string string)
  203.   (output-port/write-string *output-port* string))
  204.  
  205. (define-integrable (*unparse-substring string start end)
  206.   (output-port/write-substring *output-port* string start end))
  207.  
  208. (define-integrable (*unparse-datum object)
  209.   (*unparse-hex (object-datum object)))
  210.  
  211. (define (*unparse-hex number)
  212.   (*unparse-string "#x")
  213.   (*unparse-string (number->string number 16)))
  214.  
  215. (define-integrable (*unparse-hash object)
  216.   (*unparse-string (number->string (hash object))))
  217.  
  218. (define (*unparse-readable-hash object)
  219.   (*unparse-string "#@")
  220.   (*unparse-hash object))
  221.  
  222. (define (*unparse-with-brackets name object thunk)
  223.   (if (and *unparse-with-maximum-readability?* object)
  224.       (*unparse-readable-hash object)
  225.       (begin
  226.     (*unparse-string "#[")
  227.     (if (string? name)
  228.         (*unparse-string name)
  229.         (*unparse-object name))
  230.     (if object
  231.         (begin
  232.           (*unparse-char #\Space)
  233.           (*unparse-hash object)))
  234.     (if thunk
  235.         (begin
  236.           (*unparse-char #\Space)
  237.           (thunk))
  238.         (if *unparse-with-datum?*
  239.         (begin
  240.           (*unparse-char #\Space)
  241.           (*unparse-datum object))))
  242.     (*unparse-char #\]))))
  243.  
  244. ;;;; Unparser Methods
  245.  
  246. (define (unparse/default object)
  247.   (let ((type (user-object-type object)))
  248.     (case ((ucode-primitive primitive-object-gc-type 1) object)
  249.       ((1 2 3 4 -3 -4)        ; cell pair triple quad vector compiled
  250.        (*unparse-with-brackets type object false))
  251.       ((0)            ; non pointer
  252.        (*unparse-with-brackets type object
  253.      (lambda ()
  254.        (*unparse-datum object))))
  255.       (else            ; undefined, gc special
  256.        (*unparse-with-brackets type false
  257.      (lambda ()
  258.        (*unparse-datum object)))))))
  259.  
  260. (define (user-object-type object)
  261.   (let ((type-code (object-type object)))
  262.     (let ((type-name (microcode-type/code->name type-code)))
  263.       (if type-name
  264.       (rename-user-object-type type-name)
  265.       (intern
  266.        (string-append "undefined-type:" (number->string type-code)))))))
  267.  
  268. (define (rename-user-object-type type-name)
  269.   (let ((entry (assq type-name renamed-user-object-types)))
  270.     (if entry
  271.     (cdr entry)
  272.     type-name)))
  273.  
  274. (define renamed-user-object-types
  275.   '((NEGATIVE-FIXNUM . NUMBER)
  276.     (POSITIVE-FIXNUM . NUMBER)
  277.     (BIGNUM . NUMBER)
  278.     (FLONUM . NUMBER)
  279.     (COMPLEX . NUMBER)
  280.     (INTERNED-SYMBOL . SYMBOL)
  281.     (UNINTERNED-SYMBOL . SYMBOL)
  282.     (EXTENDED-PROCEDURE . PROCEDURE)
  283.     (PRIMITIVE . PRIMITIVE-PROCEDURE)
  284.     (LEXPR . LAMBDA)
  285.     (EXTENDED-LAMBDA . LAMBDA)
  286.     (COMBINATION-1 . COMBINATION)
  287.     (COMBINATION-2 . COMBINATION)
  288.     (PRIMITIVE-COMBINATION-0 . COMBINATION)
  289.     (PRIMITIVE-COMBINATION-1 . COMBINATION)
  290.     (PRIMITIVE-COMBINATION-2 . COMBINATION)
  291.     (PRIMITIVE-COMBINATION-3 . COMBINATION)
  292.     (SEQUENCE-2 . SEQUENCE)
  293.     (SEQUENCE-3 . SEQUENCE)))
  294.  
  295. (define (unparse/null object)
  296.   (if (eq? object '())
  297.       (if (and (eq? object #f)
  298.            (not *unparse-disambiguate-null-as-itself?*))
  299.       (*unparse-string "#f")
  300.       (*unparse-string "()"))
  301.       (if (eq? object #f)
  302.       (*unparse-string "#f")
  303.       (unparse/default object))))
  304.  
  305. (define (unparse/constant object)
  306.   (cond ((not object) (*unparse-string "#f"))
  307.     ((null? object) (*unparse-string "()"))
  308.     ((eq? object #t) (*unparse-string "#t"))
  309.     ((undefined-value? object)
  310.      (*unparse-string "#[unspecified-return-value]"))
  311.     ((eq? object lambda-auxiliary-tag) (*unparse-string "#!aux"))
  312.     ((eq? object lambda-optional-tag) (*unparse-string "#!optional"))
  313.     ((eq? object lambda-rest-tag) (*unparse-string "#!rest"))
  314.     (else (unparse/default object))))
  315.  
  316. (define (unparse/return-address return-address)
  317.   (*unparse-with-brackets 'RETURN-ADDRESS return-address
  318.     (lambda ()
  319.       (*unparse-object (return-address/name return-address)))))
  320.  
  321. (define (unparse/interned-symbol symbol)
  322.   (hook/interned-symbol symbol))
  323.  
  324. (define hook/interned-symbol)
  325.  
  326. (define (unparse/uninterned-symbol symbol)
  327.   (let ((unparse-symbol (lambda () (unparse-symbol symbol))))
  328.     (if *unparse-uninterned-symbols-by-name?*
  329.     (unparse-symbol)
  330.     (*unparse-with-brackets 'UNINTERNED-SYMBOL symbol unparse-symbol))))
  331.  
  332. (define (unparse-symbol symbol)
  333.   (*unparse-string (symbol-name symbol)))
  334.  
  335. (define (unparse/character character)
  336.   (if (or *slashify?*
  337.       (not (char-ascii? character)))
  338.       (begin (*unparse-string "#\\")
  339.          (*unparse-string (char->name character true)))
  340.       (*unparse-char character)))
  341.  
  342. (define (unparse/string string)
  343.   (if *slashify?*
  344.       (let ((end (string-length string)))
  345.     (let ((end*
  346.            (if *unparser-string-length-limit*
  347.            (min *unparser-string-length-limit* end)
  348.            end)))
  349.       (*unparse-char #\")
  350.       (if (substring-find-next-char-in-set string 0 end*
  351.                            string-delimiters)
  352.           (let loop ((start 0))
  353.         (let ((index
  354.                (substring-find-next-char-in-set string start end*
  355.                             string-delimiters)))
  356.           (if index
  357.               (begin
  358.             (*unparse-substring string start index)
  359.             (*unparse-char #\\)
  360.             (let ((char (string-ref string index)))
  361.               (cond ((char=? char char:newline)
  362.                  (*unparse-char #\n))
  363.                 ((char=? char #\Tab)
  364.                  (*unparse-char #\t))
  365.                 ((char=? char #\VT)
  366.                  (*unparse-char #\v))
  367.                 ((char=? char #\BS)
  368.                  (*unparse-char #\b))
  369.                 ((char=? char #\Return)
  370.                  (*unparse-char #\r))
  371.                 ((char=? char #\Page)
  372.                  (*unparse-char #\f))
  373.                 ((char=? char #\BEL)
  374.                  (*unparse-char #\a))
  375.                 ((or (char=? char #\\)
  376.                      (char=? char #\"))
  377.                  (*unparse-char char))
  378.                 (else
  379.                  (*unparse-string (char->octal char)))))
  380.             (loop (+ index 1)))
  381.               (*unparse-substring string start end*))))
  382.           (*unparse-substring string 0 end*))
  383.       (if (< end* end)
  384.           (*unparse-string "..."))
  385.       (*unparse-char #\")))
  386.       (*unparse-string string)))
  387.  
  388. (define (char->octal char)
  389.   (let ((qr1 (integer-divide (char->ascii char) 8)))
  390.     (let ((qr2 (integer-divide (integer-divide-quotient qr1) 8)))
  391.       (string (digit->char (integer-divide-quotient qr2) 8)
  392.           (digit->char (integer-divide-remainder qr2) 8)
  393.           (digit->char (integer-divide-remainder qr1) 8)))))
  394.  
  395. (define string-delimiters)
  396.  
  397. (define (unparse/bit-string bit-string)
  398.   (*unparse-string "#*")
  399.   (let loop ((index (-1+ (bit-string-length bit-string))))
  400.     (if (not (negative? index))
  401.     (begin (*unparse-char (if (bit-string-ref bit-string index) #\1 #\0))
  402.            (loop (-1+ index))))))
  403.  
  404. (define (unparse/vector vector)
  405.   (let ((method (unparse-vector/unparser vector)))
  406.     (if method
  407.     (invoke-user-method method vector)
  408.     (unparse-vector/normal vector))))
  409.  
  410. (define (unparse-vector/unparser vector)
  411.   (and (not (zero? (vector-length vector)))
  412.        (let ((tag (safe-vector-ref vector 0)))
  413.      (or (structure-tag/unparser-method tag 'VECTOR)
  414.          ;; Check the global tagging table too.
  415.          (unparser/tagged-vector-method tag)))))
  416.  
  417. (define (unparse-vector/normal vector)
  418.   (limit-unparse-depth
  419.    (lambda ()
  420.      (let ((length (vector-length vector)))
  421.        (if (zero? length)
  422.        (*unparse-string "#()")
  423.        (begin
  424.          (*unparse-string "#(")
  425.          (*unparse-object (safe-vector-ref vector 0))
  426.          (let loop ((index 1))
  427.            (cond ((= index length)
  428.               (*unparse-char #\)))
  429.              ((and *unparser-list-breadth-limit*
  430.                (>= index *unparser-list-breadth-limit*))
  431.               (*unparse-string " ...)"))
  432.              (else
  433.               (*unparse-char #\Space)
  434.               (*unparse-object (safe-vector-ref vector index))
  435.               (loop (1+ index)))))))))))
  436.  
  437. (define (safe-vector-ref vector index)
  438.   (if (with-absolutely-no-interrupts
  439.        (lambda ()
  440.      (or (object-type? (ucode-type manifest-nm-vector)
  441.                (vector-ref vector index))
  442.          (object-type? (ucode-type manifest-special-nm-vector)
  443.                (vector-ref vector index)))))
  444.       (error "Attempt to unparse partially marked vector"))
  445.   (vector-ref vector index))
  446.  
  447. (define (unparse/record record)
  448.   (if *unparse-with-maximum-readability?*
  449.       (*unparse-readable-hash record)
  450.       (invoke-user-method unparse-record record)))
  451.  
  452. (define (unparse/pair pair)
  453.   (let ((prefix (unparse-list/prefix-pair? pair)))
  454.     (if prefix
  455.     (unparse-list/prefix-pair prefix pair)
  456.     (let ((method (unparse-list/unparser pair)))
  457.       (cond (method
  458.          (invoke-user-method method pair))
  459.         ((and *unparse-disambiguate-null-lambda-list?*
  460.               (eq? (car pair) 'LAMBDA)
  461.               (pair? (cdr pair))
  462.               (null? (cadr pair))
  463.               (pair? (cddr pair)))
  464.          (limit-unparse-depth
  465.           (lambda ()
  466.             (*unparse-char #\()
  467.             (*unparse-object (car pair))
  468.             (*unparse-string " ()")
  469.             (unparse-tail (cddr pair) 3)
  470.             (*unparse-char #\)))))
  471.         (else
  472.          (unparse-list pair)))))))
  473.  
  474. (define (unparse-list list)
  475.   (limit-unparse-depth
  476.    (lambda ()
  477.      (*unparse-char #\()
  478.      (*unparse-object (car list))
  479.      (unparse-tail (cdr list) 2)
  480.      (*unparse-char #\)))))
  481.  
  482. (define (limit-unparse-depth kernel)
  483.   (if *unparser-list-depth-limit*
  484.       (fluid-let ((*list-depth* (1+ *list-depth*)))
  485.     (if (> *list-depth* *unparser-list-depth-limit*)
  486.         (*unparse-string "...")
  487.         (kernel)))
  488.       (kernel)))
  489.  
  490. (define (unparse-tail l n)
  491.   (cond ((pair? l)
  492.      (let ((method (unparse-list/unparser l)))
  493.        (if method
  494.            (begin
  495.          (*unparse-string " . ")
  496.          (invoke-user-method method l))
  497.            (begin
  498.          (*unparse-char #\space)
  499.          (*unparse-object (car l))
  500.          (if (and *unparser-list-breadth-limit*
  501.               (>= n *unparser-list-breadth-limit*)
  502.               (not (null? (cdr l))))
  503.              (*unparse-string " ...")
  504.              (unparse-tail (cdr l) (1+ n)))))))
  505.     ((not (null? l))
  506.      (*unparse-string " . ")
  507.      (*unparse-object l))))
  508.  
  509. (define (unparse-list/unparser pair)
  510.   (let ((tag (car pair)))
  511.     (or (structure-tag/unparser-method tag 'LIST)
  512.     ;; Check the global tagging table too.
  513.     (unparser/tagged-pair-method tag))))
  514.  
  515. (define (unparse-list/prefix-pair prefix pair)
  516.   (*unparse-string prefix)
  517.   (*unparse-object (cadr pair)))
  518.  
  519. (define (unparse-list/prefix-pair? object)
  520.   (and *unparse-abbreviate-quotations?*
  521.        (not (future? (car object)))
  522.        (pair? (cdr object))
  523.        (null? (cddr object))
  524.        (case (car object)
  525.      ((QUOTE) "'")
  526.      ((QUASIQUOTE) "`")
  527.      ((UNQUOTE) ",")
  528.      ((UNQUOTE-SPLICING) ",@")
  529.      (else false))))
  530.  
  531. ;;;; Procedures and Environments
  532.  
  533. (define hook/procedure-unparser)
  534.  
  535. (define (unparse-procedure procedure usual-method)
  536.   (let ((method
  537.      (and hook/procedure-unparser
  538.           (hook/procedure-unparser procedure))))
  539.     (cond (method (invoke-user-method method procedure))
  540.       ((generic-procedure? procedure)
  541.        (*unparse-with-brackets 'GENERIC-PROCEDURE procedure
  542.          (let ((name (generic-procedure-name procedure)))
  543.            (and name
  544.             (lambda () (*unparse-object name))))))
  545.       (else (usual-method)))))
  546.  
  547. (define (unparse/compound-procedure procedure)
  548.   (unparse-procedure procedure
  549.     (lambda ()
  550.       (*unparse-with-brackets 'COMPOUND-PROCEDURE procedure
  551.     (and *unparse-compound-procedure-names?*
  552.          (lambda-components* (procedure-lambda procedure)
  553.            (lambda (name required optional rest body)
  554.          required optional rest body
  555.          (and (not (eq? name lambda-tag:unnamed))
  556.               (lambda () (*unparse-object name))))))))))
  557.  
  558. (define (unparse/primitive-procedure procedure)
  559.   (unparse-procedure procedure
  560.     (lambda ()
  561.       (let ((unparse-name
  562.          (lambda ()
  563.            (*unparse-object (primitive-procedure-name procedure)))))
  564.     (cond (*unparse-primitives-by-name?*
  565.            (unparse-name))
  566.           (*unparse-with-maximum-readability?*
  567.            (*unparse-readable-hash procedure))
  568.           (else
  569.            (*unparse-with-brackets 'PRIMITIVE-PROCEDURE false
  570.          unparse-name)))))))
  571.  
  572. (define (unparse/compiled-entry entry)
  573.   (let* ((type (compiled-entry-type entry))
  574.      (procedure? (eq? type 'COMPILED-PROCEDURE))
  575.      (closure?
  576.       (and procedure?
  577.            (compiled-code-block/manifest-closure?
  578.         (compiled-code-address->block entry))))
  579.      (usual-method
  580.       (lambda ()
  581.         (*unparse-with-brackets (if closure? 'COMPILED-CLOSURE type)
  582.                     entry
  583.           (lambda ()
  584.         (let ((name (and procedure? (compiled-procedure/name entry))))
  585.           (with-values
  586.               (lambda () (compiled-entry/filename-and-index entry))
  587.             (lambda (filename block-number)
  588.               (*unparse-char #\()
  589.               (if name
  590.               (*unparse-string name))
  591.               (if filename
  592.               (begin
  593.                 (if name
  594.                 (*unparse-char #\Space))
  595.                 (*unparse-object (pathname-name filename))
  596.                 (if block-number
  597.                 (begin
  598.                   (*unparse-char #\Space)
  599.                   (*unparse-hex block-number)))))
  600.               (*unparse-char #\)))))
  601.         (*unparse-char #\Space)
  602.         (*unparse-hex (compiled-entry/offset entry))
  603.         (if closure?
  604.             (begin
  605.               (*unparse-char #\Space)
  606.               (*unparse-datum (compiled-closure->entry entry))))
  607.         (*unparse-char #\Space)
  608.         (*unparse-datum entry))))))
  609.     (if procedure?
  610.     (unparse-procedure entry usual-method)
  611.     (usual-method))))
  612.  
  613. ;;;; Miscellaneous
  614.  
  615. (define (unparse/environment environment)
  616.   (if (lexical-unreferenceable? environment ':PRINT-SELF)
  617.       (unparse/default environment)
  618.       ((lexical-reference environment ':PRINT-SELF))))
  619.  
  620. (define (unparse/variable variable)
  621.   (*unparse-with-brackets 'VARIABLE variable
  622.     (lambda () (*unparse-object (variable-name variable)))))
  623.  
  624. (define (unparse/number object)
  625.   (*unparse-string
  626.    (number->string
  627.     object
  628.     (let ((prefix
  629.        (lambda (prefix limit radix)
  630.          (if (exact-rational? object)
  631.          (begin
  632.            (if (not (and (exact-integer? object)
  633.                  (< (abs object) limit)))
  634.                (*unparse-string prefix))
  635.            radix)
  636.          10))))
  637.       (case *unparser-radix*
  638.     ((2) (prefix "#b" 2 2))
  639.     ((8) (prefix "#o" 8 8))
  640.     ((16) (prefix "#x" 10 16))
  641.     (else 10))))))
  642.  
  643. (define (unparse/flonum flonum)
  644.   (if (= (system-vector-length flonum) (system-vector-length 0.0))
  645.       (unparse/number flonum)
  646.       (unparse/floating-vector flonum)))
  647.  
  648. (define (unparse/floating-vector v)
  649.   (let ((length ((ucode-primitive floating-vector-length) v)))
  650.     (*unparse-with-brackets
  651.      "floating-vector"
  652.      v
  653.      (and (not (zero? length))
  654.       (lambda ()
  655.         (let ((limit (if (not *unparser-list-breadth-limit*)
  656.                  length
  657.                  (min length *unparser-list-breadth-limit*))))
  658.           (unparse/flonum ((ucode-primitive floating-vector-ref) v 0))
  659.           (do ((i 1 (1+ i)))
  660.           ((>= i limit))
  661.         (*unparse-char #\Space)
  662.         (unparse/flonum ((ucode-primitive floating-vector-ref) v i)))
  663.           (if (< limit length)
  664.           (*unparse-string " ..."))))))))
  665.  
  666. (define (unparse/future future)
  667.   (*unparse-with-brackets 'FUTURE false
  668.     (lambda ()
  669.       (*unparse-hex ((ucode-primitive primitive-object-datum 1) future)))))
  670.  
  671. (define (unparse/entity entity)
  672.   (define (plain name)
  673.     (*unparse-with-brackets name entity false))
  674.   (define (named-arity-dispatched-procedure name)
  675.     (*unparse-with-brackets 'ARITY-DISPATCHED-PROCEDURE
  676.                 entity
  677.                 (lambda () (*unparse-string name))))
  678.   (cond ((continuation? entity) (plain 'CONTINUATION))
  679.     ((apply-hook? entity)   (plain 'APPLY-HOOK))
  680.     ((arity-dispatched-procedure? entity)
  681.      (let ((proc  (entity-procedure entity)))
  682.        (cond ((and (compiled-code-address? proc)
  683.                (compiled-procedure? proc)
  684.                (compiled-procedure/name proc))
  685.           => named-arity-dispatched-procedure)
  686.          (else (plain 'ARITY-DISPATCHED-PROCEDURE)))))
  687.     (else (plain 'ENTITY))))
  688.