repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cache overload resolution on sbcl
Annotate for file src/objects/type.lisp
2009-04-05 tobias
1
(in-package #:smoke)
15:36:29 '
2
2009-06-22 tobias
3
(declaim (inline smoke))
12:18:08 '
4
'
5
(defclass smoke-type ()
'
6
((id :reader id :initarg :id
'
7
:type smoke-index
'
8
:documentation "The objects index.")
'
9
(smoke :reader smoke :initarg :smoke
'
10
:type smoke-module
'
11
:documentation "Pointer to the Smoke module."))
2009-04-05 tobias
12
(:documentation "A type"))
15:36:29 '
13
2009-06-22 tobias
14
(defmethod print-object ((type smoke-type) stream)
12:18:08 '
15
(if (or (<= (id type) 0)
'
16
(null-pointer-p (smoke-module-pointer (smoke type))))
'
17
(call-next-method)
'
18
(print-unreadable-object (type stream :type t)
'
19
(princ (name type) stream))))
2009-05-14 tobias
20
2009-06-30 tobias
21
;; Clozure CL needs this
22:47:39 '
22
(defmethod make-load-form ((type smoke-type) &optional environment)
'
23
(declare (ignore environment))
'
24
`(make-instance 'smoke-type
'
25
:id ,(id type)
'
26
:smoke (eval ,(get-smoke-variable-for-pointer
'
27
(smoke-module-pointer (smoke type))))))
2009-04-05 tobias
28
2009-05-26 tobias
29
(declaim (inline type-slot-value))
2009-05-25 tobias
30
(defun type-slot-value (type slot-name)
18:39:33 '
31
(declare (smoke-type type)
'
32
(symbol slot-name)
'
33
(optimize (speed 3)))
2009-06-22 tobias
34
(foreign-slot-value (mem-aref (smoke-array-pointer
12:18:08 '
35
(smoke-module-types (smoke type)))
'
36
'smoke-type
'
37
(the smoke-index (id type)))
2009-04-05 tobias
38
'smoke-type slot-name))
15:36:29 '
39
2009-06-22 tobias
40
(define-compiler-macro type-slot-value (&whole form type slot-name)
12:18:08 '
41
(if (constantp slot-name)
'
42
`(foreign-slot-value (mem-aref (smoke-array-pointer
'
43
(smoke-module-types (smoke ,type)))
'
44
'smoke-type
'
45
(the smoke-index (id ,type)))
'
46
'smoke-type ,slot-name)
'
47
form))
'
48
'
49
2009-04-05 tobias
50
(defun make-smoke-type (smoke name)
15:36:29 '
51
"Returns the type in the Smoke module SMOKE named NAME."
'
52
(make-instance 'smoke-type
2009-06-22 tobias
53
:id (smoke-find-type (smoke-module-pointer smoke) name)
2009-04-05 tobias
54
:smoke smoke))
15:36:29 '
55
'
56
(defmethod name ((type smoke-type))
2009-06-22 tobias
57
(declare (optimize (speed 3)))
2009-05-25 tobias
58
(type-slot-value type 'name))
2009-04-05 tobias
59
2009-05-11 tobias
60
(defun smoke-type= (type1 type2)
2009-08-27 tobias
61
(if (eq (smoke type1) (smoke type2))
11:43:13 '
62
(= (id type1) (id type2))
'
63
(string= (name type1) (name type2))))
2009-04-05 tobias
64
2009-06-22 tobias
65
(defun get-type-flag (type flag)
12:18:08 '
66
(declare (optimize (speed 3)))
2009-05-25 tobias
67
(logand (type-slot-value type 'flags)
2009-06-22 tobias
68
#xF0 ;; = !0x0F
12:18:08 '
69
(the fixnum (foreign-enum-value 'smoke-type-flags flag))))
2009-05-24 tobias
70
2009-06-22 tobias
71
(define-compiler-macro get-type-flag (&whole form type flag)
12:18:08 '
72
(if (constantp flag)
'
73
`(logand (type-slot-value ,type 'flags)
'
74
#xF0
'
75
,(foreign-enum-value 'smoke-type-flags flag))
'
76
form))
'
77
'
78
(defmacro allocation-flag-p (type flag)
2009-08-02 tobias
79
;; Can't just use #'get-type-flag since it can only be one of
10:12:41 '
80
;; :stack, :reference and :pointer.
2009-06-22 tobias
81
;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30)
12:18:08 '
82
`(= ,(foreign-enum-value 'smoke-type-flags flag)
'
83
(logand #x30
'
84
(type-slot-value ,type 'flags))))
2009-04-05 tobias
85
2009-06-22 tobias
86
(declaim (inline stack-p))
2009-04-05 tobias
87
(defun stack-p (type)
15:36:29 '
88
"Returns T when TYPE is stored on the stack; NIL otherwise."
2009-06-22 tobias
89
(allocation-flag-p type :stack))
2009-04-05 tobias
90
15:36:29 '
91
(defun reference-p (type)
'
92
"Returns T when TYPE is a reference ('type&'); NIL otherwise."
2009-06-22 tobias
93
(allocation-flag-p type :reference))
2009-04-05 tobias
94
15:36:29 '
95
(defun pointer-p (type)
'
96
"Returns T when TYPE is a pointer ('type*'); NIL otherwise."
2009-06-22 tobias
97
(allocation-flag-p type :pointer))
2009-04-05 tobias
98
2009-05-27 tobias
99
(defgeneric const-p (object)
12:20:30 '
100
(:method ((type smoke-type))
'
101
"Returns T when TYPE is const; NIL otherwise."
2009-06-22 tobias
102
(/= 0 (get-type-flag type :const))))
2009-04-05 tobias
103
15:36:29 '
104
(defun class-p (type)
'
105
"Returns T when TYPE is a smoke class"
'
106
(and (eql (type-id type) 13)
2009-09-09 tobias
107
(not (zerop (type-slot-value type 'class)))))
2009-04-05 tobias
108
15:36:29 '
109
(defun type-id (type)
'
110
"Returns the ID of TYPE."
2009-06-22 tobias
111
(declare (smoke-type type)
12:18:08 '
112
(optimize (speed 3) (safety 0)))
'
113
(logand (the (c-integer :unsigned-short) (type-slot-value type 'flags))
'
114
#.(foreign-enum-value 'smoke-type-flags :type-id)))
2009-04-05 tobias
115
15:36:29 '
116
(defun void-p (type)
'
117
"Return T when TYPE is a void type (no value)."
2009-05-26 tobias
118
;; void is an empty string.
2009-07-01 tobias
119
;; For efficiency just check if the first byte is a null byte;
2009-05-26 tobias
120
;; No need to convert the entire C string to lisp like in:
09:54:47 '
121
;; (null (name type)))
2010-02-20 tobias
122
(declare (optimize (speed 3)))
2009-08-27 tobias
123
(null-pointer-p (mem-ref
2010-02-20 tobias
124
(foreign-slot-pointer
17:24:36 '
125
(mem-aref (smoke-array-pointer
'
126
(smoke-module-types (smoke type)))
'
127
'smoke-type
'
128
(the smoke-index (id type)))
'
129
'smoke-type 'name)
'
130
:pointer)))
2009-05-26 tobias
131
2009-04-05 tobias
132
15:36:29 '
133
(defgeneric get-class (smoke-symbol)
'
134
(:documentation "Returns the smoke-class associated with SMOKE-SYMBOL."))
'
135
'
136
(defmethod get-class ((type smoke-type))
'
137
"Return the smoke-class of TYPE."
2009-08-02 tobias
138
(assert (class-p type)
2009-04-05 tobias
139
(type)
2009-08-02 tobias
140
"The type ~S is not a smoke class." type)
10:12:41 '
141
(make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))
2010-01-23 tobias
142
;; Return the cffi keyword for the type
19:45:41 '
143
(defun type-foreign-keyword (smoke-type)
'
144
(intern (nsubstitute #\- #\ (nstring-upcase (name smoke-type)))
'
145
:keyword))
'
146
'
147
(defun type-size (smoke-type)
'
148
(if (class-p smoke-type)
'
149
(class-size (get-class smoke-type))
'
150
(foreign-type-size (type-foreign-keyword smoke-type))))
'
151