source: project/release/5/coops-utils/trunk/closure-raw-introspection.scm @ 38866

Last change on this file since 38866 was 38866, checked in by Kon Lovett, 3 months ago

include-relative

File size: 2.6 KB
RevLine 
[38400]1;;;; closure-raw-introspection.scm
2;;;; Kon Lovett, Feb '18
3
4;; Issues
5;;
6
7(module closure-raw-introspection
8
9(;export
10  print-raw-closure)
11
12(import scheme)
13(import (chicken base))
14(import (chicken memory))
15(import format)
16(import (only check-types check-procedure))
17
18;;; Helpers
19
[38866]20(include-relative "object-uword-ref")
[38400]21
22;;;
23
24(define-constant ROW-COUNT 16)
25
26(define (print-raw-closure proc len #!optional (out (current-output-port)))
27  (let* (
28    (adr (object-uword-ref (check-procedure 'print-raw-closure proc)))
29    (ptr (address->pointer adr)) )
30    ;
31    (pointer-hexdump ptr len out) ) )
32
33;;
34
35(define (pointer-hexdump ptr len #!optional (out (current-output-port)))
36  (let ((stride ROW-COUNT))
37    (do ((off 0 (+ off stride)))
38      ((>= off len)
39        (let ((rem (mod len stride)))
40          (and
41            (< 0 rem)
42            (let* (
43              (rows (quotient len stride))
44              (off (* rows stride))
45              (rem-ptr (pointer+ ptr off)) )
46              ;
47              (pointer-hexdump-row rem-ptr rem out) ) ) ) )
48      (let ((row-ptr (pointer+ ptr off)))
49        (pointer-hexdump-row row-ptr stride out) ) ) ) )
50
51(define (pointer-hexdump-row ptr len out)
52  ;(integer->char 48) ;=> #\0
53  (format out "~16,48X" (pointer->address ptr))
54  (format out "  ")
55  (do (
56    (ptr ptr (pointer+ ptr 1))
57    (rem len (- rem 1)) )
58    ;
59    ((>= 0 rem))
60    ;
61    (format out "~2,48X " (pointer-u8-ref ptr)) )
62  (format out " ")
63  (do (
64    (ptr ptr (pointer+ ptr 1))
65    (rem len (- rem 1)) )
66    ;
67    ((>= 0 rem))
68    ;
69    (let* (
70      (byt (pointer-u8-ref ptr))
71      (chr (if (and (<= #x20 byt) (<= byt #x7e)) (integer->char byt) #\.)) )
72      (format out "~A" chr) ) )
73  (format out "~%") )
74
75;;
76
77#| csi "compiled rep"
78(define (checked-forward-closure? loc obj)
79  (and
80    (< 2 (##sys#size (check-procedure loc obj)))
81    obj ) )
82
83(: closure-docstring (procedure --> (or boolean string)))
84(define (closure-docstring proc)
85  "Return #f for procedures without a docstring, otherwise the documentation string."
86  (and-let* (
87    (real-proc (closure-lambda-procedure proc))
88    (1st-itm (##sys#slot real-proc 1)) )
89    (and (string? 1st-itm) 1st-itm) ) )
90
91(: closure-lambda-procedure (procedure --> (or boolean procedure)))
92(define (closure-lambda-procedure proc)
93  (and-let* ((proc (checked-forward-closure? 'closure-lambda-procedure proc)))
94    (##sys#slot (##sys#slot proc 2) 2) ) )
95
96(: closure-argvector-trampoline (procedure --> (or boolean procedure)))
97(define (closure-argvector-trampoline proc)
98  (and-let* ((proc (checked-forward-closure? 'closure-lambda-procedure proc)))
99    (##sys#slot proc 2) ) )
100|#
101
102) ;closure-introspection
Note: See TracBrowser for help on using the repository browser.