b76b3e9c11b9f5d9cdedb42bf2b187f72b9e545a
[sbcl.git] / 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 (!begin-collecting-cold-init-forms)
19
20 (defstruct (alien-type-type
21             (:include ctype
22                       (class-info (type-class-or-lose 'alien)))
23             (:constructor %make-alien-type-type (alien-type))
24             (:copier nil))
25   (alien-type nil :type alien-type))
26
27 (!define-type-class alien)
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             (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")