source: project/release/4/dissector/chicken_dissect.scm @ 12396

Last change on this file since 12396 was 12286, checked in by felix winkelmann, 12 years ago

ported to chicken-4

File size: 4.0 KB
Line 
1;;;;;; Object -> stream of its components
2
3;;; Copyright (C) 2004, Taylor Campbell
4;;; All rights reserved.
5;;; See the LICENCE file for details.
6
7(define (dissect-components object)
8  (cond ((undissectable? object)
9         stream-nil)
10        ((procedure? object)
11         (dissect-procedure object))
12        ((symbol? object)
13         (dissect-symbol object))
14        ((##sys#pointer? object)
15         (stream (cons 'address
16                       (##sys#peek-unsigned-integer object 0))))
17        ((d-tagged-pointer? object)
18         (stream (cons 'address
19                       (##sys#peek-unsigned-integer object 0))
20                 (cons 'tag
21                       (##sys#peek-unsigned-integer object 1))))
22        ((port? object)
23         (dissect-port object))
24        ((pair? object)
25         (dissect-pair object))
26        ((srfi-9-record? object)
27         (dissect-srfi-9-record object))
28        ((srfi-9-record-type? object)
29         (dissect-srfi-9-record-type object))
30        (else
31         (dissect-unnamed-slots object 0))))
32
33(define (undissectable? object)
34  (or (##sys#immediate? object)
35      (byte-block? object)))
36
37(define (dissect-unnamed-slots object origin)
38  (let ((size (##sys#size object)))
39    (let recur ((i origin))
40      (lazy (if (>= i size)
41                stream-nil
42                (stream-cons (cons #f (##sys#slot object i))
43                             (recur (+ i 1))))))))
44
45(define (dissect-procedure proc)
46  (stream-cons (cons 'address (##sys#peek-unsigned-integer proc 0))
47               (dissect-unnamed-slots proc 1)))
48
49(define (dissect-symbol symbol)
50  (let ((tail (stream (cons 'string (##sys#slot symbol 1)))))
51    (if (##sys#symbol-has-toplevel-binding? symbol)
52        (stream-cons (cons 'toplevel-value (##sys#slot symbol 0))
53                     tail)
54        tail)))
55
56(define (dissect-port port)
57  (stream* (cons 'fp          (##sys#peek-unsigned-integer port 0))
58           (cons 'input-port? (##sys#slot port 1))
59           (cons 'class       (##sys#slot port 2))
60           (cons 'name        (##sys#slot port 3))
61           (cons 'row         (##sys#slot port 4))
62           (cons 'column      (##sys#slot port 5))
63           (cons 'at-end?     (##sys#slot port 6))
64           (cons 'type        (##sys#slot port 7))
65           (cons 'closed?     (##sys#slot port 8))
66           (cons 'data        (##sys#slot port 9))
67           (dissect-unnamed-slots port 10)))
68
69(define (dissect-pair pair)
70  (cond ((null? (cdr pair))
71         (stream (cons #f (car pair))))
72        ((pair? (cdr pair))
73         (dissect-list pair))
74        (else
75         (stream (cons 'car (car pair))
76                 (cons 'cdr (cdr pair))))))
77
78;++ At some point, this should support circular lists, but because the
79;++ Chicken printer doesn't (and therefore we never get past the main
80;++ object print-out), this isn't so much of an issue just yet.
81(define (dissect-list l)
82  (let recur ((l l))
83    (lazy (cond ((null? l)
84                 stream-nil)
85                ((pair? l)
86                 (stream-cons (cons #f (car l))
87                              (recur (cdr l))))
88                (else
89                 (stream (cons 'dotted-cdr l)))))))
90
91;++ Is the precision in these predicates really necessary?
92(define (srfi-9-record? x)
93  (and (##sys#structure? x 'record)
94       (> (##sys#size x) 1)
95       (srfi-9-record-type? (##sys#slot x 1))))
96
97(define (srfi-9-record-type? x)
98  (and (##sys#structure? x 'record-type)
99       (= (##sys#size x) 3)))
100
101(define (dissect-srfi-9-record record)
102  (stream-cons
103   (cons 'type (##sys#slot record 1))
104   (let recur ((fields (##sys#slot (##sys#slot record 1) 2))
105               (i 2))
106     (lazy (if (or (null? fields)
107                   (>= i                ; Just in case.
108                       (##sys#size record)))
109               stream-nil
110               (stream-cons (cons (car fields)
111                                  (##sys#slot record i))
112                            (recur (cdr fields) (+ i 1))))))))
113
114(define (dissect-srfi-9-record-type rtd)
115  (stream (cons 'name   (##sys#slot rtd 1))
116          (cons 'fields (##sys#slot rtd 2))))
Note: See TracBrowser for help on using the repository browser.