;;;; closure-raw-introspection.scm
;;;; Kon Lovett, Feb '18

;; Issues
;;

(module closure-raw-introspection

(;export
  print-raw-closure)

(import scheme)
(import (chicken base))
(import (chicken memory))
(import format)
(import (only check-types check-procedure))

;;; Helpers

(include-relative "object-uword-ref")

;;;

(define-constant ROW-COUNT 16)

(define (print-raw-closure proc len #!optional (out (current-output-port)))
  (let* (
    (adr (object-uword-ref (check-procedure 'print-raw-closure proc)))
    (ptr (address->pointer adr)) )
    ;
    (pointer-hexdump ptr len out) ) )

;;

(define (pointer-hexdump ptr len #!optional (out (current-output-port)))
  (let ((stride ROW-COUNT))
    (do ((off 0 (+ off stride)))
      ((>= off len)
        (let ((rem (mod len stride)))
          (and
            (< 0 rem)
            (let* (
              (rows (quotient len stride))
              (off (* rows stride))
              (rem-ptr (pointer+ ptr off)) )
              ;
              (pointer-hexdump-row rem-ptr rem out) ) ) ) )
      (let ((row-ptr (pointer+ ptr off)))
        (pointer-hexdump-row row-ptr stride out) ) ) ) )

(define (pointer-hexdump-row ptr len out)
  ;(integer->char 48) ;=> #\0
  (format out "~16,48X" (pointer->address ptr))
  (format out "  ")
  (do (
    (ptr ptr (pointer+ ptr 1))
    (rem len (- rem 1)) )
    ;
    ((>= 0 rem))
    ;
    (format out "~2,48X " (pointer-u8-ref ptr)) )
  (format out " ")
  (do (
    (ptr ptr (pointer+ ptr 1))
    (rem len (- rem 1)) )
    ;
    ((>= 0 rem))
    ;
    (let* (
      (byt (pointer-u8-ref ptr))
      (chr (if (and (<= #x20 byt) (<= byt #x7e)) (integer->char byt) #\.)) )
      (format out "~A" chr) ) )
  (format out "~%") )

;;

#| csi "compiled rep"
(define (checked-forward-closure? loc obj)
  (and
    (< 2 (##sys#size (check-procedure loc obj)))
    obj ) )

(: closure-docstring (procedure --> (or boolean string)))
(define (closure-docstring proc)
  "Return #f for procedures without a docstring, otherwise the documentation string."
  (and-let* (
    (real-proc (closure-lambda-procedure proc))
    (1st-itm (##sys#slot real-proc 1)) )
    (and (string? 1st-itm) 1st-itm) ) )

(: closure-lambda-procedure (procedure --> (or boolean procedure)))
(define (closure-lambda-procedure proc)
  (and-let* ((proc (checked-forward-closure? 'closure-lambda-procedure proc)))
    (##sys#slot (##sys#slot proc 2) 2) ) )

(: closure-argvector-trampoline (procedure --> (or boolean procedure)))
(define (closure-argvector-trampoline proc)
  (and-let* ((proc (checked-forward-closure? 'closure-lambda-procedure proc)))
    (##sys#slot proc 2) ) )
|#

) ;closure-introspection