blob: 442dddd46e7f49e681f432af56ca17c8e7fc93c9 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
;;;; Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc.
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2, or (at your option)
;;;; any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;; Boston, MA 02111-1307 USA
;;;;
;;; {Print}
;;;
;;; This code was removed from boot-9.scm by MDJ 970301
;;; <djurfeldt@nada.kth.se>. It is placed here for archival
;;; purposes.
(define (print obj . args)
(let ((default-args (list (current-output-port) 0 0 default-print-style #f)))
(apply-to-args (append args (list-cdr-ref default-args (length args)))
(lambda (port depth length style table)
(cond
((and table (print-table-ref table obj))
((print-style-tag-hook style 'eq-val)
obj port depth length style table))
(else
(and table (print-table-add! table obj))
(cond
((print-style-max-depth? style depth)
((print-style-excess-depth-hook style)))
((print-style-max-length? style length)
((print-style-excess-length-hook style)))
(else
((print-style-hook style obj)
obj port depth length style table)))))))))
(define (make-print-style) (make-vector 59 '()))
(define (extend-print-style! style utag printer)
(hashq-set! style utag printer))
(define (print-style-hook style obj)
(let ((type-tag (tag obj)))
(or (hashq-ref style type-tag)
(hashq-ref style (logand type-tag 255))
print-obj)))
(define (print-style-tag-hook style type-tag)
(or (hashq-ref style type-tag)
print-obj))
(define (print-style-max-depth? style d) #f)
(define (print-style-max-length? style l) #f)
(define (print-style-excess-length-hook style)
(hashq-ref style 'excess-length-hook))
(define (print-style-excess-depth-hook style)
(hashq-ref style 'excess-depth-hook))
(define (make-print-table) (make-vector 59 '()))
(define (print-table-ref table obj) (hashq-ref table obj))
(define (print-table-add! table obj) (hashq-set! table obj (gensym 'ref)))
(define (print-obj obj port depth length style table) (write obj port))
(define (print-pair pair port depth length style table)
(if (= 0 length)
(display #\( port))
(print (car pair) port (+ 1 depth) 0 style table)
(cond
((and (pair? (cdr pair))
(or (not table)
(not (print-table-ref table (cdr pair)))))
(display #\space port)
(print (cdr pair) port depth (+ 1 length) style table))
((null? (cdr pair)) (display #\) port))
(else (display " . " port)
(print (cdr pair) port (+ 1 depth) 0
style table)
(display #\) port))))
(define (print-vector obj port depth length style table)
(if (= 0 length)
(cond
((weak-key-hash-table? obj) (display "#wh(" port))
((weak-value-hash-table? obj) (display "#whv(" port))
((doubly-weak-hash-table? obj) (display "#whd(" port))
(else (display "#(" port))))
(if (< length (vector-length obj))
(print (vector-ref obj length) port (+ 1 depth) 0 style table))
(cond
((>= (+ 1 length) (vector-length obj)) (display #\) port))
(else (display #\space port)
(print obj port depth
(+ 1 length)
style table))))
(define default-print-style (make-print-style))
(extend-print-style! default-print-style utag_vector print-vector)
(extend-print-style! default-print-style utag_wvect print-vector)
(extend-print-style! default-print-style utag_pair print-pair)
(extend-print-style! default-print-style 'eq-val
(lambda (obj port depth length style table)
(if (symbol? obj)
(display obj)
(begin
(display "##" port)
(display (print-table-ref table obj))))))
|
