%tc2-int 2)
(define %tc3-imm24 4)

(define %tc3-cons 0)
(define %tc3-int1 %tc2-int)
(define %tc3-int2 (+ %tc2-int 4))

(define %tc8-char (+ 8 %tc3-imm24))
(define %tc8-flag (+ %tc3-imm24 0))

;; Cell types.
(define %tc3-struct #x01)
(define %tc7-symbol #x05)
(define %tc7-variable #x07)
(define %tc7-vector #x0d)
(define %tc7-wvect #x0f)
(define %tc7-string #x15)
(define %tc7-number #x17)
(define %tc7-hashtable #x1d)
(define %tc7-pointer #x1f)
(define %tc7-fluid #x25)
(define %tc7-stringbuf #x27)
(define %tc7-dynamic-state #x2d)
(define %tc7-frame #x2f)
(define %tc7-keyword #x35)
(define %tc7-syntax #x3d)
(define %tc7-program #x45)
(define %tc7-vm-continuation #x47)
(define %tc7-bytevector #x4d)
(define %tc7-weak-set #x55)
(define %tc7-weak-table #x57)
(define %tc7-array #x5d)
(define %tc7-bitvector #x5f)
(define %tc7-port #x7d)
(define %tc7-smob #x77)

(define %tc16-bignum (+ %tc7-number (* 1 256)))
(define %tc16-real (+ %tc7-number (* 2 256)))
(define %tc16-complex (+ %tc7-number (* 3 256)))
(define %tc16-fraction (+ %tc7-number (* 4 256)))


;; "Stringbufs".
(define-record-type <stringbuf>
  (stringbuf string)
  stringbuf?
  (string stringbuf-contents))

(set-record-type-printer! <stringbuf>
                          (lambda (stringbuf port)
                            (display "#<stringbuf " port)
                            (write (stringbuf-contents stringbuf) port)
                            (display "#>" port)))

;; Structs.
(define-record-type <inferior-struct>
  (inferior-struct name fields)
  inferior-struct?
  (name   inferior-struct-name)
  (fields inferior-struct-fields set-inferior-struct-fields!))

(define print-inferior-struct
  (let ((%printed-struct (make-parameter vlist-null)))
    (lambda (struct port)
      (if (vhash-assq struct (%printed-struct))
          (format port "#-1#")
          (begin
            (format port "#<struct ~a"
                    (inferior-struct-name struct))
            (parameterize ((%printed-struct
                            (vhash-consq struct #t (%printed-struct))))
              (for-each (lambda (field)
                          (if (eq? field struct)
                              (display " #0#" port)
                              (format port " ~s" field)))
                        (inferior-struct-fields struct)))
            (format port " ~x>" (object-address struct)))))))

(set-record-type-printer! <inferior-struct> print-inferior-struct)

;; Object type to represent complex objects from the inferior process that
;; cannot be really converted to usable Scheme objects in the current
;; process.
(define-record-type <inferior-object>
  (%inferior-object kind sub-kind address)
  inferior-object?
  (kind     inferior-object-kind)
  (sub-kind inferior-object-sub-kind)
  (address  inferior-object-address))

(define inferior-object
  (case-lambda
    "Return an object representing an inferior object at ADDRESS, of type
KIND/SUB-KIND."
    ((kind address)
     (%inferior-object kind #f address))
    ((kind sub-kind address)
     (%inferior-object kind sub-kind address))))

(set-record-type-printer! <inferior-object>
                          (lambda (io port)
                            (match io
                              (($ <inferior-object> kind sub-kind address)
                               (format port "#<~a ~:[~*~;~a ~]~x>"
                                       kind sub-kind sub-kind
                                       address)))))

(define (inferior-smob backend type-number address)
  "Return an object representing the SMOB at ADDRESS whose type is
TYPE-NUMBER."
  (inferior-object 'smob
                   (or (type-number->name backend 'smob type-number)
                       type-number)
                   address))

(define (inferior-port-type backend address)
  "Return an object representing the 'scm_t_port_type' structure at
ADDRESS."
  (inferior-object 'port-type
                   ;; The 'name' field lives at offset 0.
                   (let ((name (dereference-word backend address)))
                     (if (zero? name)
                         "(nameless)"
                         (read-c-string backend name)))
                   address))

(define (inferior-port backend type-number address)
  "Return an object representing the port at ADDRESS whose type is
TYPE-NUMBER."
  (inferior-object 'port
                   (let ((address (+ address (* 3 %word-size))))
                     (inferior-port-type backend
                                         (dereference-word backend address)))
                   address))

(define %visited-cells
  ;; Vhash of mapping addresses of already visited cells to the
  ;; corresponding inferior object.  This is used to detect and represent
  ;; cycles.
  (make-parameter vlist-null))

(define-syntax visited
  (syntax-rules (->)
    ((_ (address -> object) body ...)
     (parameterize ((%visited-cells (vhash-consv address object
                                                 (%visited-cells))))
       body ...))))

(define (address->inferior-struct address vtable-data-address backend)
  "Read the struct at ADDRESS using BACKEND.  Return an 'inferior-struct'
object representing it."
  (define %vtable-layout-index 0)
  (define %vtable-name-index 5)

  (let* ((layout-address (+ vtable-data-address
                            (* %vtable-layout-index %word-size)))
         (layout-bits    (dereference-word backend layout-address))
         (layout         (scm->object layout-bits backend))
         (name-address   (+ vtable-data-address
                            (* %vtable-name-index %word-size)))
         (name-bits      (dereference-word backend name-address))
         (name           (scm->object name-bits backend)))
    (if (symbol? layout)
        (let* ((layout (symbol->string layout))
               (len    (/ (string-length layout) 2))
               (slots  (dereference-word backend (+ address %word-size)))
               (port   (memory-port backend slots (* len %word-size)))
               (fields (get-bytevector-n port (* len %word-size)))
               (result (inferior-struct name #f)))

          ;; Keep track of RESULT so callees can refer to it if we are
          ;; decoding a circular struct.
          (visited (address -> result)
            (let ((values (map (cut scm->object <> backend)
                               (bytevector->uint-list fields
                                                      (native-endianness)
                                                      %word-size))))
              (set-inferior-struct-fields! result values)
              result)))
        (inferior-object 'invalid-struct address))))

(define* (cell->object address #:optional (backend %ffi-memory-backend))
  "Return an object representing the object at ADDRESS, reading from memory
using BACKEND."
  (or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
      (let ((port (memory-port backend address)))
        (match-cell port
          (((vtable-data-address & 7 = %tc3-struct))
           (address->inferior-struct address
                                     (- vtable-data-address %tc3-struct)
                                     backend))
          (((_ & #x7f = %tc7-symbol) buf hash props)
           (match (cell->object buf backend)
             (($ <stringbuf> string)
              (string->symbol string))))
          (((_ & #x7f = %tc7-variable) obj)
           (inferior-object 'variable address))
          (((_ & #x7f = %tc7-string) buf start len)
           (match (cell->object buf backend)
             (($ <stringbuf> string)
              (substring string start (+ start len)))))
          (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
           (stringbuf (iconv:bytevector->string buf "ISO-8859-1")))
          (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
            len (bytevector buf (* 4 len)))
           (stringbuf (iconv:bytevector->string buf
                                                (match (native-endianness)
                                                  ('little "UTF-32LE")
                                                  ('big "UTF-32BE")))))
          (((_ & #x7f = %tc7-bytevector) len address)
           (let ((bv-port (memory-port backend address len)))
             (get-bytevector-n bv-port len)))
          ((((len << 8) || %tc7-vector))
           (let ((words  (get-bytevector-n port (* len %word-size)))
                 (vector (make-vector len)))
             (visited (address -> vector)
               (fold (lambda (element index)
                       (vector-set! vector index element)
                       (+ 1 index))
                     0
                     (map (cut scm->object <> backend)
                          (bytevector->uint-list words (native-endianness)
                                                 %word-size)))
               vector)))
          (((_ & #x7f = %tc7-wvect))
           (inferior-object 'weak-vector address))   ; TODO: show elements
          (((_ & #x7f = %tc7-fluid) init-value)
           (inferior-object 'fluid address))
          (((_ & #x7f = %tc7-dynamic-state))
           (inferior-object 'dynamic-state address))
          ((((flags << 8) || %tc7-port))
           (inferior-port backend (logand flags #xff) address))
          (((_ & #x7f = %tc7-program))
           (inferior-object 'program address))
          (((_ & #xffff = %tc16-bignum))
           (inferior-object 'bignum address))
          (((_ & #xffff = %tc16-real) pad)
           (let* ((address (+ address (* 2 %word-size)))
                  (port    (memory-port backend address (sizeof double)))
                  (words   (get-bytevector-n port (sizeof double))))
             (bytevector-ieee-double-ref words 0 (native-endianness))))
          (((_ & #x7f = %tc7-number) mpi)
           (inferior-object 'number address))
          (((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
           (inferior-object 'hash-table address))
          (((_ & #x7f = %tc7-pointer) address)
           (make-pointer address))
          (((_ & #x7f = %tc7-keyword) symbol)
           (symbol->keyword (cell->object symbol backend)))
          (((_ & #x7f = %tc7-syntax) expression wrap module)
           (cond-expand
             (guile-2.2
              (make-syntax (cell->object expression backend)
                           (cell->object wrap backend)
                           (cell->object module backend)))
             (else
              (inferior-object 'syntax address))))
          (((_ & #x7f = %tc7-vm-continuation))
           (inferior-object 'vm-continuation address))
          (((_ & #x7f = %tc7-weak-set))
           (inferior-object 'weak-set address))
          (((_ & #x7f = %tc7-weak-table))
           (inferior-object 'weak-table address))
          (((_ & #x7f = %tc7-array))
           (inferior-object 'array address))
          (((_ & #x7f = %tc7-bitvector))
           (inferior-object 'bitvector address))
          ((((smob-type << 8) || %tc7-smob) word1)
           (inferior-smob backend smob-type address))))))


(define* (scm->object bits #:optional (backend %ffi-memory-backend))
  "Return the Scheme object corresponding to BITS, the bits of an 'SCM'
object."
  (match-scm bits
    (((integer << 2) || %tc2-int)
     integer)
    ((address & 6 = %tc3-cons)
     (let* ((type  (dereference-word backend address))
            (pair? (not (bit-set? 0 type))))
       (if pair?
           (or (and=> (vhash-assv address (%visited-cells)) cdr)
               (let ((car    type)
                     (cdrloc (+ address %word-size))
                     (pair   (cons *unspecified* *unspecified*)))
                 (visited (address -> pair)
                   (set-car! pair (scm->object car backend))
                   (set-cdr! pair
                             (scm->object (dereference-word backend cdrloc)
                                          backend))
                   pair)))
           (cell->object address backend))))
    (((char << 8) || %tc8-char)
     (integer->char char))
    (((flag << 8) || %tc8-flag)
     (case flag
       ((0)  #f)
       ((1)  #nil)
       ((3)  '())
       ((4)  #t)
       ((8)  (if #f #f))
       ((9)  (inferior-object 'undefined bits))
       ((10) (eof-object))
       ((11) (inferior-object 'unbound bits))))))

;;; Local Variables:
;;; eval: (put 'match-scm 'scheme-indent-function 1)
;;; eval: (put 'match-cell 'scheme-indent-function 1)
;;; eval: (put 'visited 'scheme-indent-function 1)
;;; End:

;;; types.scm ends here