repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cleanup C++ to Lisp translation
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
(and t ;(pointer-eq (smoke type1)
11:43:13 '
62
; (smoke type2))
'
63
(= (id type1)
'
64
(id type2))))
2009-04-05 tobias
65
2009-06-22 tobias
66
(defun get-type-flag (type flag)
12:18:08 '
67
(declare (optimize (speed 3)))
2009-05-25 tobias
68
(logand (type-slot-value type 'flags)
2009-06-22 tobias
69
#xF0 ;; = !0x0F
12:18:08 '
70
(the fixnum (foreign-enum-value 'smoke-type-flags flag))))
2009-05-24 tobias
71
2009-06-22 tobias
72
(define-compiler-macro get-type-flag (&whole form type flag)
12:18:08 '
73
(if (constantp flag)
'
74
`(logand (type-slot-value ,type 'flags)
'
75
#xF0
'
76
,(foreign-enum-value 'smoke-type-flags flag))
'
77
form))
'
78
'
79
(defmacro allocation-flag-p (type flag)
2009-08-02 tobias
80
;; Can't just use #'get-type-flag since it can only be one of
10:12:41 '
81
;; :stack, :reference and :pointer.
2009-06-22 tobias
82
;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30)
12:18:08 '
83
`(= ,(foreign-enum-value 'smoke-type-flags flag)
'
84
(logand #x30
'
85
(type-slot-value ,type 'flags))))
2009-04-05 tobias
86
2009-06-22 tobias
87
(declaim (inline stack-p))
2009-04-05 tobias
88
(defun stack-p (type)
15:36:29 '
89
"Returns T when TYPE is stored on the stack; NIL otherwise."
2009-06-22 tobias
90
(allocation-flag-p type :stack))
2009-04-05 tobias
91
15:36:29 '
92
(defun reference-p (type)
'
93
"Returns T when TYPE is a reference ('type&'); NIL otherwise."
2009-06-22 tobias
94
(allocation-flag-p type :reference))
2009-04-05 tobias
95
15:36:29 '
96
(defun pointer-p (type)
'
97
"Returns T when TYPE is a pointer ('type*'); NIL otherwise."
2009-06-22 tobias
98
(allocation-flag-p type :pointer))
2009-04-05 tobias
99
2009-05-27 tobias
100
(defgeneric const-p (object)
12:20:30 '
101
(:method ((type smoke-type))
'
102
"Returns T when TYPE is const; NIL otherwise."
2009-06-22 tobias
103
(/= 0 (get-type-flag type :const))))
2009-04-05 tobias
104
15:36:29 '
105
(defun class-p (type)
'
106
"Returns T when TYPE is a smoke class"
'
107
(and (eql (type-id type) 13)
2009-09-09 tobias
108
(/= -1 (type-slot-value type 'class))))
2009-04-05 tobias
109
15:36:29 '
110
(defun type-id (type)
'
111
"Returns the ID of TYPE."
2009-06-22 tobias
112
(declare (smoke-type type)
12:18:08 '
113
(optimize (speed 3) (safety 0)))
'
114
(logand (the (c-integer :unsigned-short) (type-slot-value type 'flags))
'
115
#.(foreign-enum-value 'smoke-type-flags :type-id)))
2009-04-05 tobias
116
15:36:29 '
117
(defun void-p (type)
'
118
"Return T when TYPE is a void type (no value)."
2009-05-26 tobias
119
;; void is an empty string.
2009-07-01 tobias
120
;; For efficiency just check if the first byte is a null byte;
2009-05-26 tobias
121
;; No need to convert the entire C string to lisp like in:
09:54:47 '
122
;; (null (name type)))
2009-08-27 tobias
123
(declare (optimize (speed 3)))
2009-08-02 tobias
124
(zerop (mem-ref (mem-aref (smoke-array-pointer
10:12:41 '
125
(smoke-module-types (smoke type)))
'
126
'smoke-type
'
127
(the smoke-index (id type)))
'
128
:char)))
2009-05-26 tobias
129
2009-04-05 tobias
130
15:36:29 '
131
(defgeneric get-class (smoke-symbol)
'
132
(:documentation "Returns the smoke-class associated with SMOKE-SYMBOL."))
'
133
'
134
(defmethod get-class ((type smoke-type))
'
135
"Return the smoke-class of TYPE."
2009-08-02 tobias
136
(assert (class-p type)
2009-04-05 tobias
137
(type)
2009-08-02 tobias
138
"The type ~S is not a smoke class." type)
10:12:41 '
139
(make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))