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

(module closure-raw-introspection

(;export
  print-raw-closure)

(import scheme)
(import (chicken base))
(import (chicken fixnum))
(import (chicken type))
(import (chicken foreign))
(import (chicken memory))
(import format)
(import (only (check-errors sys) check-procedure))

(: print-raw-closure (procedure fixnum #!optional output-port -> void))

;;; Helpers

(import (chicken fixnum))
(include-relative "object-uword-ref")

;;;

(define-inline (isgraphic x) (and (fx<= #x20 x) (fx<= x #x7e)))

(define-constant ROW-COLS 16)

(define (pointer-hexdump-row optr len stride out)
  ;(integer->char 48) ;=> #\0
  (format out "~16,48X  " (pointer->address optr))
  (do ((ptr optr (pointer+ ptr 1))
        (rem len (fx- rem 1)) )
      ((fx>= 0 rem) ;should never be negative!
        (do ((i (fx- stride len) (fx- i 1)))
            ((fx>= 0 i)) ;should never be negative!
          (format out "~2A " "") )
        (display " " out))
    (format out "~2,48X " (pointer-u8-ref ptr)) )
  (do ((ptr optr (pointer+ ptr 1))
       (rem len (fx- rem 1)) )
      ((fx>= 0 rem)
       (newline out))
    (let* ((byt (pointer-u8-ref ptr))
           (chr (if (isgraphic byt) (integer->char byt) #\.)) )
      (write chr out) ) ) )

;FIXME what if gc during?!
(define (pointer-hexdump ptr len #!optional (out (current-output-port)))
  (let ((stride ROW-COLS))
    (do ((off 0 (fx+ off stride)))
        ((fx>= off len)
         (let ((rem (fxmod len stride)))
           (and (fx< 0 rem)
                (let* ((rows (fx/ len stride))
                       (off (fx* rows stride)) )
                  (pointer-hexdump-row (pointer+ ptr off) rem stride out) ) ) ) )
      (pointer-hexdump-row (pointer+ ptr off) stride stride out) ) ) )

;;;

(define (print-raw-closure proc len #!optional (out (current-output-port)))
  (pointer-hexdump (object->pointer proc) len 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 (fx< 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