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

(module closure-raw-introspection

(;export
  print-raw-closure)

(import scheme)
(import (chicken base))
(import (chicken foreign))
(import (chicken memory))
(import format)
(import (only (check-errors sys) 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"

(: closure-docstring (procedure --> (or false string)))
(: closure-lambda-procedure (procedure --> (or false procedure)))
(: closure-argvector-trampoline (procedure --> (or false procedure)))

(define (checked-forward-closure? loc obj)
  (and (< 2 (##sys#size (check-procedure loc obj)))
       obj ) )

(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) ) )

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

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

) ;closure-introspection