src/code/alien-type.lisp

   1 ;;;; ALIEN-related type system stuff, done later
   2 ;;;; than other type system stuff because it depends on the definition
   3 ;;;; of the ALIEN-VALUE target structure type
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; This software is derived from the CMU CL system, which was
   9 ;;;; written at Carnegie Mellon University and released into the
  10 ;;;; public domain. The software is in the public domain and is
  11 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  12 ;;;; files for more information.
  13
  14 (in-package "SB!KERNEL")
  15
  16 (/show0 "code/alien-type.lisp 16")
  17
  18 (sb!xc:defstruct (alien-value (:constructor %sap-alien (sap type)))
  19   (sap nil :type sb!sys:system-area-pointer)
  20   (type nil :type sb!alien::alien-type))
  21 (sb!xc:proclaim '(freeze-type alien-value))
  22
  23 (!begin-collecting-cold-init-forms)
  24
  25 (!define-type-class alien :enumerable nil :might-contain-other-types nil)
  26
  27 (!define-type-method (alien :negate) (type) (make-negation-type type))
  28
  29 (!define-type-method (alien :unparse) (type)
  30   `(alien ,(unparse-alien-type (alien-type-type-alien-type type))))
  31
  32 (!define-type-method (alien :simple-subtypep) (type1 type2)
  33   (values (alien-subtype-p (alien-type-type-alien-type type1)
  34                            (alien-type-type-alien-type type2))
  35           t))
  36
  37 ;;; KLUDGE: This !DEFINE-SUPERCLASSES gets executed much later than the
  38 ;;; others (toplevel form time instead of cold load init time) because
  39 ;;; ALIEN-VALUE itself is a structure which isn't defined until fairly
  40 ;;; late.
  41 (!define-superclasses alien ((alien-value)) progn)
  42
  43 (!define-type-method (alien :simple-=) (type1 type2)
  44   (let ((alien-type-1 (alien-type-type-alien-type type1))
  45         (alien-type-2 (alien-type-type-alien-type type2)))
  46     (values (or (eq alien-type-1 alien-type-2)
  47                 (alien-type-= alien-type-1 alien-type-2))
  48             t)))
  49
  50 (!def-type-translator alien (&optional (alien-type nil))
  51   (typecase alien-type
  52     (null
  53      (make-alien-type-type))
  54     (alien-type
  55      (make-alien-type-type alien-type))
  56     (t
  57      (make-alien-type-type (parse-alien-type alien-type (make-null-lexenv))))))
  58
  59 (defun make-alien-type-type (&optional alien-type)
  60   (if alien-type
  61       (let ((lisp-rep-type (compute-lisp-rep-type alien-type)))
  62         (if lisp-rep-type
  63             (single-value-specifier-type lisp-rep-type)
  64             (%make-alien-type-type alien-type)))
  65       *universal-type*))
  66
  67 (!defun-from-collected-cold-init-forms !alien-type-cold-init)
  68
  69 (/show0 "code/alien-type.lisp end of file")