[bpt/guile.git] / module / system / base / types.scm

;;; 'SCM' type tag decoding.
;;; Copyright (C) 2014 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU Lesser General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public License
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(define-module (system base types)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-60)
  #:use-module (ice-9 match)
  #:use-module (ice-9 iconv)
  #:use-module (ice-9 format)
  #:use-module (ice-9 vlist)
  #:use-module (system foreign)
  #:export (%word-size

            memory-backend
            memory-backend?
            %ffi-memory-backend
            dereference-word
            memory-port
            type-number->name

            inferior-object?
            inferior-object-kind
            inferior-object-sub-kind
            inferior-object-address

            inferior-fluid?
            inferior-fluid-number

            inferior-struct?
            inferior-struct-name
            inferior-struct-fields

            scm->object))

;;; Commentary:
;;;
;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB.
;;;
;;; Code:

\f
;;;
;;; Memory back-ends.
;;;

(define %word-size
  ;; The pointer size.
  (sizeof '*))

(define-record-type <memory-backend>
  (memory-backend peek open type-name)
  memory-backend?
  (peek      memory-backend-peek)
  (open      memory-backend-open)
  (type-name memory-backend-type-name))           ; for SMOBs and ports

(define %ffi-memory-backend
  ;; The FFI back-end to access the current process's memory.  The main
  ;; purpose of this back-end is to allow testing.
  (let ()
    (define (dereference-word address)
      (let* ((ptr (make-pointer address))
             (bv  (pointer->bytevector ptr %word-size)))
        (bytevector-uint-ref bv 0 (native-endianness) %word-size)))

    (define (open address size)
      (define current-address address)

      (define (read-memory! bv index count)
        (let* ((ptr   (make-pointer current-address))
               (mem   (pointer->bytevector ptr count)))
          (bytevector-copy! mem 0 bv index count)
          (set! current-address (+ current-address count))
          count))

      (if size
          (let* ((ptr (make-pointer address))
                 (bv  (pointer->bytevector ptr size)))
            (open-bytevector-input-port bv))
          (let ((port (make-custom-binary-input-port "ffi-memory"
                                                     read-memory!
                                                     #f #f #f)))
            (setvbuf port _IONBF)
            port)))

    (memory-backend dereference-word open #f)))

(define-inlinable (dereference-word backend address)
  "Return the word at ADDRESS, using BACKEND."
  (let ((peek (memory-backend-peek backend)))
    (peek address)))

(define-syntax memory-port
  (syntax-rules ()
    "Return an input port to the SIZE bytes at ADDRESS, using BACKEND.  When
SIZE is omitted, return an unbounded port to the memory at ADDRESS."
    ((_ backend address)
     (let ((open (memory-backend-open backend)))
       (open address #f)))
    ((_ backend address size)
     (let ((open (memory-backend-open backend)))
       (open address size)))))

(define (get-word port)
  "Read a word from PORT and return it as an integer."
  (let ((bv (get-bytevector-n port %word-size)))
    (bytevector-uint-ref bv 0 (native-endianness) %word-size)))

(define-inlinable (type-number->name backend kind number)
  "Return the name of the type NUMBER of KIND, where KIND is one of
'smob or 'port, or #f if the information is unavailable."
  (let ((proc (memory-backend-type-name backend)))
    (and proc (proc kind number))))

\f
;;;
;;; Matching bit patterns and cells.
;;;

(define-syntax match-cell-words
  (syntax-rules (bytevector)
    ((_ port ((bytevector name len) rest ...) body)
     (let ((name      (get-bytevector-n port len))
           (remainder (modulo len %word-size)))
       (unless (zero? remainder)
         (get-bytevector-n port (- %word-size remainder)))
       (match-cell-words port (rest ...) body)))
    ((_ port (name rest ...) body)
     (let ((name (get-word port)))
       (match-cell-words port (rest ...) body)))
    ((_ port () body)
     body)))

(define-syntax match-bit-pattern
  (syntax-rules (& || = _)
    ((match-bit-pattern bits ((a || b) & n = c) consequent alternate)
     (let ((tag (logand bits n)))
       (if (= tag c)
           (let ((b tag)
                 (a (logand bits (bitwise-not n))))
             consequent)
           alternate)))
    ((match-bit-pattern bits (x & n = c) consequent alternate)
     (let ((tag (logand bits n)))
       (if (= tag c)
           (let ((x bits))
             consequent)
           alternate)))
    ((match-bit-pattern bits (_ & n = c) consequent alternate)
     (let ((tag (logand bits n)))
       (if (= tag c)
           consequent
           alternate)))
    ((match-bit-pattern bits ((a << n) || c) consequent alternate)
     (let ((tag (bitwise-and bits (- (expt 2 n) 1))))
       (if (= tag c)
           (let ((a (arithmetic-shift bits (- n))))
             consequent)
           alternate)))))

(define-syntax match-cell-clauses
  (syntax-rules ()
    ((_ port tag (((tag-pattern thing ...) body) rest ...))
     (match-bit-pattern tag tag-pattern
                        (match-cell-words port (thing ...) body)
                        (match-cell-clauses port tag (rest ...))))
    ((_ port tag ())
     (inferior-object 'unmatched-tag tag))))

(define-syntax match-cell
  (syntax-rules ()
    "Match a cell---i.e., a non-immediate value other than a pair.  The
cell's contents are read from PORT."
    ((_ port (pattern body ...) ...)
     (let ((port* port)
           (tag   (get-word port)))
       (match-cell-clauses port* tag
                           ((pattern (begin body ...))
                            ...))))))

(define-syntax match-scm-clauses
  (syntax-rules ()
    ((_ bits
        (bit-pattern body ...)
        rest ...)
     (match-bit-pattern bits bit-pattern
                        (begin body ...)
                        (match-scm-clauses bits rest ...)))
    ((_ bits)
     'unmatched-scm)))

(define-syntax match-scm
  (syntax-rules ()
    "Match BITS, an integer representation of an 'SCM' value, against
CLAUSES.  Each clause must have the form:

  (PATTERN BODY ...)

PATTERN is a bit pattern that may specify bitwise operations on BITS to
determine if it matches.  TEMPLATE specify the name of the variable to bind
the matching bits, possibly with bitwise operations to extract it from BITS."
    ((_ bits clauses ...)
     (let ((bits* bits))
       (match-scm-clauses bits* clauses ...)))))

\f
;;;
;;; Tags---keep in sync with libguile/tags.h!
;;;

;; Immediate values.
(define %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 1)
(define %tc7-symbol 5)
(define %tc7-vector 13)
(define %tc7-string 21)
(define %tc7-number 23)
(define %tc7-hashtable 29)
(define %tc7-pointer 31)
(define %tc7-fluid 37)
(define %tc7-stringbuf 39)
(define %tc7-dynamic-state 45)
(define %tc7-frame 47)
(define %tc7-objcode 53)
(define %tc7-vm 55)
(define %tc7-vm-continuation 71)
(define %tc7-bytevector 77)
(define %tc7-program 79)
(define %tc7-port 125)
(define %tc7-smob 127)

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

;; Fluids.
(define-record-type <inferior-fluid>
  (inferior-fluid number value)
  inferior-fluid?
  (number inferior-fluid-number)
  (value  inferior-fluid-value))

(set-record-type-printer! <inferior-fluid>
                          (lambda (fluid port)
                            (match fluid
                              (($ <inferior-fluid> number)
                               (format port "#<fluid ~a ~x>"
                                       number
                                       (object-address fluid))))))

;; 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 backend type-number address)
  "Return an object representing the port at ADDRESS whose type is
TYPE-NUMBER."
  (inferior-object 'port
                   (or (type-number->name backend 'port type-number)
                       type-number)
                   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-string) buf start len)
           (match (cell->object buf backend)
             (($ <stringbuf> string)
              (substring string start (+ start len)))))
          (((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
           (stringbuf (bytevector->string buf "ISO-8859-1")))
          (((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
            len (bytevector buf (* 4 len)))
           (stringbuf (bytevector->string buf "UTF-32LE")))
          (((_ & #x7f = %tc7-bytevector) len address)
           (let ((bv-port (memory-port backend address len)))
             (get-bytevector-all bv-port)))
          ((((len << 7) || %tc7-vector) weakv-data)
           (let* ((len    (arithmetic-shift len -1))
                  (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)))
          ((((n << 8) || %tc7-fluid) init-value)
           (inferior-fluid n #f))                    ; TODO: show current value
          (((_ & #x7f = %tc7-dynamic-state))
           (inferior-object 'dynamic-state address))
          ((((flags+type << 8) || %tc7-port))
           (inferior-port backend (logand flags+type #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-objcode))
           (inferior-object 'objcode address))
          (((_ & #x7f = %tc7-vm))
           (inferior-object 'vm address))
          (((_ & #x7f = %tc7-vm-continuation))
           (inferior-object 'vm-continuation 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
Commit	Line	Data
5f4b817d LC	1	;;; 'SCM' type tag decoding.
	2	;;; Copyright (C) 2014 Free Software Foundation, Inc.
	3	;;;
	4	;;; This library is free software; you can redistribute it and/or modify it
	5	;;; under the terms of the GNU Lesser General Public License as published by
	6	;;; the Free Software Foundation; either version 3 of the License, or (at
	7	;;; your option) any later version.
	8	;;;
	9	;;; This library is distributed in the hope that it will be useful, but
	10	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser
	12	;;; General Public License for more details.
	13	;;;
	14	;;; You should have received a copy of the GNU Lesser General Public License
	15	;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
	16
	17	(define-module (system base types)
	18	#:use-module (rnrs bytevectors)
	19	#:use-module (rnrs io ports)
	20	#:use-module (srfi srfi-1)
	21	#:use-module (srfi srfi-9)
	22	#:use-module (srfi srfi-9 gnu)
	23	#:use-module (srfi srfi-11)
	24	#:use-module (srfi srfi-26)
	25	#:use-module (srfi srfi-60)
	26	#:use-module (ice-9 match)
	27	#:use-module (ice-9 iconv)
	28	#:use-module (ice-9 format)
	29	#:use-module (ice-9 vlist)
	30	#:use-module (system foreign)
	31	#:export (%word-size
	32
	33	memory-backend
	34	memory-backend?
	35	%ffi-memory-backend
	36	dereference-word
	37	memory-port
	38	type-number->name
	39
	40	inferior-object?
	41	inferior-object-kind
	42	inferior-object-sub-kind
	43	inferior-object-address
	44
	45	inferior-fluid?
	46	inferior-fluid-number
	47
	48	inferior-struct?
	49	inferior-struct-name
	50	inferior-struct-fields
	51
	52	scm->object))
	53
	54	;;; Commentary:
	55	;;;
	56	;;; 'SCM' type tag decoding, primarily to support Guile debugging in GDB.
	57	;;;
	58	;;; Code:
	59
	60	\f
	61	;;;
	62	;;; Memory back-ends.
	63	;;;
	64
65	(define %word-size
66	;; The pointer size.
67	(sizeof '*))
68
69	(define-record-type <memory-backend>
70	(memory-backend peek open type-name)
71	memory-backend?
72	(peek memory-backend-peek)
73	(open memory-backend-open)
74	(type-name memory-backend-type-name)) ; for SMOBs and ports
75
76	(define %ffi-memory-backend
77	;; The FFI back-end to access the current process's memory. The main
78	;; purpose of this back-end is to allow testing.
79	(let ()
80	(define (dereference-word address)
81	(let* ((ptr (make-pointer address))
82	(bv (pointer->bytevector ptr %word-size)))
83	(bytevector-uint-ref bv 0 (native-endianness) %word-size)))
84
85	(define (open address size)
86	(define current-address address)
87
88	(define (read-memory! bv index count)
89	(let* ((ptr (make-pointer current-address))
90	(mem (pointer->bytevector ptr count)))
91	(bytevector-copy! mem 0 bv index count)
92	(set! current-address (+ current-address count))
93	count))
94
95	(if size
96	(let* ((ptr (make-pointer address))
97	(bv (pointer->bytevector ptr size)))
98	(open-bytevector-input-port bv))
99	(let ((port (make-custom-binary-input-port "ffi-memory"
100	read-memory!
101	#f #f #f)))
102	(setvbuf port _IONBF)
103	port)))
104
105	(memory-backend dereference-word open #f)))
106
107	(define-inlinable (dereference-word backend address)
108	"Return the word at ADDRESS, using BACKEND."
109	(let ((peek (memory-backend-peek backend)))
110	(peek address)))
111
112	(define-syntax memory-port
113	(syntax-rules ()
114	"Return an input port to the SIZE bytes at ADDRESS, using BACKEND. When
115	SIZE is omitted, return an unbounded port to the memory at ADDRESS."
116	((_ backend address)
117	(let ((open (memory-backend-open backend)))
118	(open address #f)))
119	((_ backend address size)
120	(let ((open (memory-backend-open backend)))
121	(open address size)))))
122
123	(define (get-word port)
124	"Read a word from PORT and return it as an integer."
125	(let ((bv (get-bytevector-n port %word-size)))
126	(bytevector-uint-ref bv 0 (native-endianness) %word-size)))
127
128	(define-inlinable (type-number->name backend kind number)
129	"Return the name of the type NUMBER of KIND, where KIND is one of
130	'smob or 'port, or #f if the information is unavailable."
131	(let ((proc (memory-backend-type-name backend)))
132	(and proc (proc kind number))))
133
134	\f
135	;;;
136	;;; Matching bit patterns and cells.
137	;;;
138
139	(define-syntax match-cell-words
140	(syntax-rules (bytevector)
141	((_ port ((bytevector name len) rest ...) body)
142	(let ((name (get-bytevector-n port len))
143	(remainder (modulo len %word-size)))
144	(unless (zero? remainder)
145	(get-bytevector-n port (- %word-size remainder)))
146	(match-cell-words port (rest ...) body)))
147	((_ port (name rest ...) body)
148	(let ((name (get-word port)))
149	(match-cell-words port (rest ...) body)))
150	((_ port () body)
151	body)))
152
153	(define-syntax match-bit-pattern
154	(syntax-rules (& \|\| = _)
155	((match-bit-pattern bits ((a \|\| b) & n = c) consequent alternate)
156	(let ((tag (logand bits n)))
157	(if (= tag c)
158	(let ((b tag)
159	(a (logand bits (bitwise-not n))))
160	consequent)
161	alternate)))
162	((match-bit-pattern bits (x & n = c) consequent alternate)
163	(let ((tag (logand bits n)))
164	(if (= tag c)
165	(let ((x bits))
166	consequent)
167	alternate)))
168	((match-bit-pattern bits (_ & n = c) consequent alternate)
169	(let ((tag (logand bits n)))
170	(if (= tag c)
171	consequent
172	alternate)))
173	((match-bit-pattern bits ((a << n) \|\| c) consequent alternate)
174	(let ((tag (bitwise-and bits (- (expt 2 n) 1))))
175	(if (= tag c)
176	(let ((a (arithmetic-shift bits (- n))))
177	consequent)
178	alternate)))))
179
180	(define-syntax match-cell-clauses
181	(syntax-rules ()
182	((_ port tag (((tag-pattern thing ...) body) rest ...))
183	(match-bit-pattern tag tag-pattern
184	(match-cell-words port (thing ...) body)
185	(match-cell-clauses port tag (rest ...))))
186	((_ port tag ())
187	(inferior-object 'unmatched-tag tag))))
188
189	(define-syntax match-cell
190	(syntax-rules ()
191	"Match a cell---i.e., a non-immediate value other than a pair. The
192	cell's contents are read from PORT."
193	((_ port (pattern body ...) ...)
194	(let ((port* port)
195	(tag (get-word port)))
196	(match-cell-clauses port* tag
197	((pattern (begin body ...))
198	...))))))
199
200	(define-syntax match-scm-clauses
201	(syntax-rules ()
202	((_ bits
203	(bit-pattern body ...)
204	rest ...)
205	(match-bit-pattern bits bit-pattern
206	(begin body ...)
207	(match-scm-clauses bits rest ...)))
208	((_ bits)
209	'unmatched-scm)))
210
211	(define-syntax match-scm
212	(syntax-rules ()
213	"Match BITS, an integer representation of an 'SCM' value, against
214	CLAUSES. Each clause must have the form:
215
216	(PATTERN BODY ...)
217
218	PATTERN is a bit pattern that may specify bitwise operations on BITS to
219	determine if it matches. TEMPLATE specify the name of the variable to bind
220	the matching bits, possibly with bitwise operations to extract it from BITS."
221	((_ bits clauses ...)
222	(let ((bits* bits))
223	(match-scm-clauses bits* clauses ...)))))
224
225	\f
226	;;;
227	;;; Tags---keep in sync with libguile/tags.h!
228	;;;
229
230	;; Immediate values.
231	(define %tc2-int 2)
232	(define %tc3-imm24 4)
233
234	(define %tc3-cons 0)
235	(define %tc3-int1 %tc2-int)
236	(define %tc3-int2 (+ %tc2-int 4))
237
238	(define %tc8-char (+ 8 %tc3-imm24))
239	(define %tc8-flag (+ %tc3-imm24 0))
240
241	;; Cell types.
242	(define %tc3-struct 1)
243	(define %tc7-symbol 5)
244	(define %tc7-vector 13)
245	(define %tc7-string 21)
246	(define %tc7-number 23)
247	(define %tc7-hashtable 29)
248	(define %tc7-pointer 31)
249	(define %tc7-fluid 37)
250	(define %tc7-stringbuf 39)
251	(define %tc7-dynamic-state 45)
252	(define %tc7-frame 47)
253	(define %tc7-objcode 53)
254	(define %tc7-vm 55)
255	(define %tc7-vm-continuation 71)
256	(define %tc7-bytevector 77)
257	(define %tc7-program 79)
258	(define %tc7-port 125)
259	(define %tc7-smob 127)
260
261	(define %tc16-bignum (+ %tc7-number (* 1 256)))
262	(define %tc16-real (+ %tc7-number (* 2 256)))
263	(define %tc16-complex (+ %tc7-number (* 3 256)))
264	(define %tc16-fraction (+ %tc7-number (* 4 256)))
265
266
267	;; "Stringbufs".
268	(define-record-type <stringbuf>
269	(stringbuf string)
270	stringbuf?
271	(string stringbuf-contents))
272
273	(set-record-type-printer! <stringbuf>
274	(lambda (stringbuf port)
275	(display "#<stringbuf " port)
276	(write (stringbuf-contents stringbuf) port)
277	(display "#>" port)))
278
279	;; Structs.
280	(define-record-type <inferior-struct>
281	(inferior-struct name fields)
282	inferior-struct?
283	(name inferior-struct-name)
284	(fields inferior-struct-fields set-inferior-struct-fields!))
285
286	(define print-inferior-struct
287	(let ((%printed-struct (make-parameter vlist-null)))
288	(lambda (struct port)
289	(if (vhash-assq struct (%printed-struct))
290	(format port "#-1#")
291	(begin
292	(format port "#<struct ~a"
293	(inferior-struct-name struct))
294	(parameterize ((%printed-struct
295	(vhash-consq struct #t (%printed-struct))))
296	(for-each (lambda (field)
297	(if (eq? field struct)
298	(display " #0#" port)
299	(format port " ~s" field)))
300	(inferior-struct-fields struct)))
301	(format port " ~x>" (object-address struct)))))))
302
303	(set-record-type-printer! <inferior-struct> print-inferior-struct)
304
305	;; Fluids.
306	(define-record-type <inferior-fluid>
307	(inferior-fluid number value)
308	inferior-fluid?
309	(number inferior-fluid-number)
310	(value inferior-fluid-value))
311
312	(set-record-type-printer! <inferior-fluid>
313	(lambda (fluid port)
314	(match fluid
315	(($ <inferior-fluid> number)
316	(format port "#<fluid ~a ~x>"
317	number
318	(object-address fluid))))))
319
320	;; Object type to represent complex objects from the inferior process that
321	;; cannot be really converted to usable Scheme objects in the current
322	;; process.
323	(define-record-type <inferior-object>
324	(%inferior-object kind sub-kind address)
325	inferior-object?
326	(kind inferior-object-kind)
327	(sub-kind inferior-object-sub-kind)
328	(address inferior-object-address))
329
330	(define inferior-object
331	(case-lambda
332	"Return an object representing an inferior object at ADDRESS, of type
333	KIND/SUB-KIND."
334	((kind address)
335	(%inferior-object kind #f address))
336	((kind sub-kind address)
337	(%inferior-object kind sub-kind address))))
338
339	(set-record-type-printer! <inferior-object>
340	(lambda (io port)
341	(match io
342	(($ <inferior-object> kind sub-kind address)
343	(format port "#<~a ~:[~*~;~a ~]~x>"
344	kind sub-kind sub-kind
345	address)))))
346
347	(define (inferior-smob backend type-number address)
348	"Return an object representing the SMOB at ADDRESS whose type is
349	TYPE-NUMBER."
350	(inferior-object 'smob
351	(or (type-number->name backend 'smob type-number)
352	type-number)
353	address))
354
355	(define (inferior-port backend type-number address)
356	"Return an object representing the port at ADDRESS whose type is
357	TYPE-NUMBER."
358	(inferior-object 'port
359	(or (type-number->name backend 'port type-number)
360	type-number)
361	address))
362
363	(define %visited-cells
364	;; Vhash of mapping addresses of already visited cells to the
365	;; corresponding inferior object. This is used to detect and represent
366	;; cycles.
367	(make-parameter vlist-null))
368
369	(define-syntax visited
370	(syntax-rules (->)
371	((_ (address -> object) body ...)
372	(parameterize ((%visited-cells (vhash-consv address object
373	(%visited-cells))))
374	body ...))))
375
376	(define (address->inferior-struct address vtable-data-address backend)
377	"Read the struct at ADDRESS using BACKEND. Return an 'inferior-struct'
378	object representing it."
379	(define %vtable-layout-index 0)
380	(define %vtable-name-index 5)
381
382	(let* ((layout-address (+ vtable-data-address
383	(* %vtable-layout-index %word-size)))
384	(layout-bits (dereference-word backend layout-address))
385	(layout (scm->object layout-bits backend))
386	(name-address (+ vtable-data-address
387	(* %vtable-name-index %word-size)))
388	(name-bits (dereference-word backend name-address))
389	(name (scm->object name-bits backend)))
390	(if (symbol? layout)
391	(let* ((layout (symbol->string layout))
392	(len (/ (string-length layout) 2))
393	(slots (dereference-word backend (+ address %word-size)))
394	(port (memory-port backend slots (* len %word-size)))
395	(fields (get-bytevector-n port (* len %word-size)))
396	(result (inferior-struct name #f)))
397
398	;; Keep track of RESULT so callees can refer to it if we are
399	;; decoding a circular struct.
400	(visited (address -> result)
401	(let ((values (map (cut scm->object <> backend)
402	(bytevector->uint-list fields
403	(native-endianness)
404	%word-size))))
405	(set-inferior-struct-fields! result values)
406	result)))
407	(inferior-object 'invalid-struct address))))
408
409	(define* (cell->object address #:optional (backend %ffi-memory-backend))
410	"Return an object representing the object at ADDRESS, reading from memory
411	using BACKEND."
412	(or (and=> (vhash-assv address (%visited-cells)) cdr) ; circular object
413	(let ((port (memory-port backend address)))
414	(match-cell port
415	(((vtable-data-address & 7 = %tc3-struct))
416	(address->inferior-struct address
417	(- vtable-data-address %tc3-struct)
418	backend))
419	(((_ & #x7f = %tc7-symbol) buf hash props)
420	(match (cell->object buf backend)
421	(($ <stringbuf> string)
422	(string->symbol string))))
423	(((_ & #x7f = %tc7-string) buf start len)
424	(match (cell->object buf backend)
425	(($ <stringbuf> string)
426	(substring string start (+ start len)))))
427	(((_ & #x047f = %tc7-stringbuf) len (bytevector buf len))
428	(stringbuf (bytevector->string buf "ISO-8859-1")))
429	(((_ & #x047f = (bitwise-ior #x400 %tc7-stringbuf))
430	len (bytevector buf (* 4 len)))
431	(stringbuf (bytevector->string buf "UTF-32LE")))
432	(((_ & #x7f = %tc7-bytevector) len address)
433	(let ((bv-port (memory-port backend address len)))
434	(get-bytevector-all bv-port)))
435	((((len << 7) \|\| %tc7-vector) weakv-data)
436	(let* ((len (arithmetic-shift len -1))
437	(words (get-bytevector-n port (* len %word-size)))
438	(vector (make-vector len)))
439	(visited (address -> vector)
440	(fold (lambda (element index)
441	(vector-set! vector index element)
442	(+ 1 index))
443	0
444	(map (cut scm->object <> backend)
445	(bytevector->uint-list words (native-endianness)
446	%word-size)))
447	vector)))
448	((((n << 8) \|\| %tc7-fluid) init-value)
449	(inferior-fluid n #f)) ; TODO: show current value
450	(((_ & #x7f = %tc7-dynamic-state))
451	(inferior-object 'dynamic-state address))
452	((((flags+type << 8) \|\| %tc7-port))
453	(inferior-port backend (logand flags+type #xff) address))
454	(((_ & #x7f = %tc7-program))
455	(inferior-object 'program address))
456	(((_ & #xffff = %tc16-bignum))
457	(inferior-object 'bignum address))
458	(((_ & #xffff = %tc16-real) pad)
459	(let* ((address (+ address (* 2 %word-size)))
460	(port (memory-port backend address (sizeof double)))
461	(words (get-bytevector-n port (sizeof double))))
462	(bytevector-ieee-double-ref words 0 (native-endianness))))
463	(((_ & #x7f = %tc7-number) mpi)
464	(inferior-object 'number address))
465	(((_ & #x7f = %tc7-hashtable) buckets meta-data unused)
466	(inferior-object 'hash-table address))
467	(((_ & #x7f = %tc7-pointer) address)
468	(make-pointer address))
469	(((_ & #x7f = %tc7-objcode))
470	(inferior-object 'objcode address))
471	(((_ & #x7f = %tc7-vm))
472	(inferior-object 'vm address))
473	(((_ & #x7f = %tc7-vm-continuation))
474	(inferior-object 'vm-continuation address))
475	((((smob-type << 8) \|\| %tc7-smob) word1)
476	(inferior-smob backend smob-type address))))))
477
478
479	(define* (scm->object bits #:optional (backend %ffi-memory-backend))
480	"Return the Scheme object corresponding to BITS, the bits of an 'SCM'
481	object."
482	(match-scm bits
483	(((integer << 2) \|\| %tc2-int)
484	integer)
485	((address & 6 = %tc3-cons)
486	(let* ((type (dereference-word backend address))
487	(pair? (not (bit-set? 0 type))))
488	(if pair?
489	(or (and=> (vhash-assv address (%visited-cells)) cdr)
490	(let ((car type)
491	(cdrloc (+ address %word-size))
492	(pair (cons unspecified unspecified)))
493	(visited (address -> pair)
494	(set-car! pair (scm->object car backend))
495	(set-cdr! pair
496	(scm->object (dereference-word backend cdrloc)
497	backend))
498	pair)))
499	(cell->object address backend))))
500	(((char << 8) \|\| %tc8-char)
501	(integer->char char))
502	(((flag << 8) \|\| %tc8-flag)
503	(case flag
504	((0) #f)
505	((1) #nil)
506	((3) '())
507	((4) #t)
508	((8) (if #f #f))
509	((9) (inferior-object 'undefined bits))
510	((10) (eof-object))
511	((11) (inferior-object 'unbound bits))))))
512
513	;;; Local Variables:
514	;;; eval: (put 'match-scm 'scheme-indent-function 1)
515	;;; eval: (put 'match-cell 'scheme-indent-function 1)
516	;;; eval: (put 'visited 'scheme-indent-function 1)
517	;;; End:
518
519	;;; types.scm ends here