rcl/decode.lisp

   1 ;; Copyright (c) 2006 Carlos Ungil
   2
   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:
  10
  11 ;; The above copyright notice and this permission notice shall be
  12 ;; included in all copies or substantial portions of the Software.
  13
  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.
  21
  22 (in-package :rcl)
  23
  24 (defvar *extract-single-element* t
  25   "If a list contains a single element, return the element instead")
  26
  27 (defun r-type-decode (n)
  28   (cdr (assoc n *r-types*)))
  29
  30 (defun r-type (sexp)
  31   (let ((sxpinfo (sxpinfo-decode (sxpinfo-bitfield (sexp-sxpinfo sexp)))))
  32     (r-type-decode (first sxpinfo))))
  33
  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)
  40
  41 #+cffi-features:ppc32
  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)))
  54
  55 #-cffi-features:ppc32
  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)))
  68
  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)))
  75           type))))
  76
  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)))))
  80         (result
  81          (case (r-type sexp)
  82            (:symbol
  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)))))
  92            (:null nil)
  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)))
 106     (if attributes
 107         (values result attributes)
 108       result)))