1 ;; Copyright (c) 2006 Carlos Ungil
3 ;; Permission is hereby granted, free of charge, to any person obtaining
4 ;; a copy of this software and associated documentation files (the
5 ;; "Software"), to deal in the Software without restriction, including
6 ;; without limitation the rights to use, copy, modify, merge, publish,
7 ;; distribute, sublicense, and/or sell copies of the Software, and to
8 ;; permit persons to whom the Software is furnished to do so, subject to
9 ;; the following conditions:
11 ;; The above copyright notice and this permission notice shall be
12 ;; included in all copies or substantial portions of the Software.
14 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
24 (defvar *extract-single-element
* t
25 "If a list contains a single element, return the element instead")
27 (defun r-type-decode (n)
28 (cdr (assoc n
*r-types
*)))
31 (let ((sxpinfo (sxpinfo-decode (sxpinfo-bitfield (sexp-sxpinfo sexp
)))))
32 (r-type-decode (first sxpinfo
))))
34 ;; the first version worked on PPC, but not on Intel
35 ;; ppc: 671088768 #b 00101 0 00 0000000000000000 1 0 0 0 0 000
36 ;; intel: 16777221 #b 000 0 0 0 0 1 0000000000000000 00 0 00101
37 ;; there is something wrong with openmcl
38 ;; 134217728 #b 00001000 00000000 00000000 00000000
39 ;; (ldb version of sxpinfo-decode by Alexey Goldin)
42 (defun sxpinfo-decode (int)
43 (let ((type (ldb (byte 5 27) int
))
44 (obj (ldb (byte 1 26) int
))
45 (named (ldb (byte 2 24) int
))
46 (gp (ldb (byte 16 8) int
))
47 (mark (ldb (byte 1 7) int
))
48 (debug (ldb (byte 1 6) int
))
49 (trace (ldb (byte 1 5) int
))
50 (fin (ldb (byte 1 4) int
))
51 (gcgen (ldb (byte 1 3) int
))
52 (gccls (ldb (byte 3 0) int
)))
53 (list type obj named gp mark debug trace fin gcgen gccls
)))
56 (defun sxpinfo-decode (int)
57 (let ((type (ldb (byte 5 0) int
))
58 (obj (ldb (byte 1 5) int
))
59 (named (ldb (byte 2 6) int
))
60 (gp (ldb (byte 16 8) int
))
61 (mark (ldb (byte 1 24) int
))
62 (debug (ldb (byte 1 25) int
))
63 (trace (ldb (byte 1 26) int
))
64 (fin (ldb (byte 1 27) int
))
65 (gcgen (ldb (byte 1 28) int
))
66 (gccls (ldb (byte 3 29) int
)))
67 (list type obj named gp mark debug trace fin gcgen gccls
)))
69 (defmethod r-obj-describe (sexp)
70 (let ((sxpinfo (sxpinfo-decode (sxpinfo-bitfield (sexp-sxpinfo sexp
)))))
71 (let ((type (r-type-decode (first sxpinfo
))))
72 (if (member type
*r-vector-types
*)
73 (let ((vecsxp (sexp-vecsxp sexp
)))
74 (list type
(vecsxp-length vecsxp
) (vecsxp-true-length vecsxp
)))
77 (defmethod r-obj-decode (sexp)
78 (let ((attributes (unless (eq :null
(r-type (sexp-attrib sexp
)))
79 (attributes-list (r-obj-decode (sexp-attrib sexp
)))))
83 (let ((list (sexp-union sexp
)))
84 (make-instance 'r-symbol
85 :name
(r-obj-decode (symsxp-pname list
))
86 :value
(r-obj-decode (symsxp-value list
))
87 :internal
(r-obj-decode (symsxp-internal list
)))))
88 (:list-of-dotted-pairs
89 (let ((list (sexp-union sexp
)))
90 (mapcar #'r-obj-decode
91 (list (listsxp-car list
) (listsxp-cdr list
) (listsxp-tag list
)))))
93 (:scalar-string-type
(cffi:foreign-string-to-lisp
(cffi:inc-pointer sexp
24)))
94 (:generic-vector
(mapcar #'r-obj-decode
(get-data-sexps sexp
)))
95 (:logical-vector
(mapcar #'plusp
(get-data-integers sexp
)))
96 (:string-vector
(get-data-strings sexp
))
97 (:real-vector
(get-data-reals sexp
))
98 (:integer-vector
(get-data-integers sexp
))
99 (t (list :unknown
(r-type sexp
))))))
100 (when (and attributes
(not (equal :list-of-dotted-pairs
(r-type (sexp-attrib sexp
)))))
101 (error "I was expecting the type of the attributes to be :list-of-dotted-pairs, but I got ~A" (r-type (sexp-attrib sexp
))))
102 (when (and *print-attributes
* attributes
)
103 (print-attributes attributes
))
104 (when (and *extract-single-element
* (listp result
) (car result
) (not (cdr result
)))
105 (setf result
(car result
)))
107 (values result attributes
)