repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Speedup overload resolution and some other stuff for faster C++ method calling.
Annotate for file src/objects/class.lisp
2009-04-05 tobias
1
(in-package #:smoke)
15:36:29 '
2
2009-06-22 tobias
3
(defclass smoke-class ()
2009-07-08 tobias
4
((id :initform 0 :type smoke-index :reader id :initarg :id)
20:41:19 '
5
(smoke :type smoke-module :reader smoke :initarg :smoke)))
2009-04-05 tobias
6
2009-06-22 tobias
7
(defun make-smoke-class-from-id (smoke id)
2009-07-08 tobias
8
(make-instance 'smoke-class :id id :smoke smoke))
2009-04-05 tobias
9
2009-07-08 tobias
10
20:41:19 '
11
(declaim (inline smoke-class-pointer))
'
12
(defun smoke-class-pointer (class)
'
13
(mem-aref (the foreign-pointer (smoke-array-pointer (smoke-module-classes
'
14
(smoke class))))
'
15
'smoke-class
'
16
(the smoke-index (id class))))
2009-04-05 tobias
17
2009-05-26 tobias
18
(declaim (inline class-slot-value))
09:54:47 '
19
(defun class-slot-value (class slot-name)
2009-07-08 tobias
20
(foreign-slot-value (smoke-class-pointer class)
2009-04-05 tobias
21
'smoke-class slot-name))
15:36:29 '
22
2009-06-22 tobias
23
(define-compiler-macro class-slot-value (&whole form class slot-name)
12:18:08 '
24
(if (constantp slot-name)
2009-07-08 tobias
25
`(foreign-slot-value (smoke-class-pointer ,class)
2009-06-22 tobias
26
'smoke-class ,slot-name)
12:18:08 '
27
form))
'
28
2009-04-05 tobias
29
(defmethod name ((class smoke-class))
2009-05-26 tobias
30
(class-slot-value class 'name))
2009-04-05 tobias
31
15:36:29 '
32
(defun map-classes (function smoke)
2009-07-01 tobias
33
"Applies FUNCTION to the classes of SMOKE."
2009-05-14 tobias
34
(declare (function function)
12:07:00 '
35
(optimize (speed 3)))
2009-04-05 tobias
36
(let ((class (make-instance 'smoke-class
2009-05-14 tobias
37
:smoke smoke)))
2009-06-22 tobias
38
(loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do
2009-07-08 tobias
39
(setf (slot-value class 'id)
20:41:19 '
40
id)
2009-04-05 tobias
41
(funcall function class))))
15:36:29 '
42
'
43
(defun external-p (class)
'
44
"Returns T when CLASS is external in its module; NIL otherwise."
2009-08-02 tobias
45
(declare (optimize (speed 3)))
2009-05-26 tobias
46
(class-slot-value class 'external))
2009-04-05 tobias
47
2009-06-22 tobias
48
(defun get-class-flag (class flag)
12:18:08 '
49
(declare (optimize (speed 3)))
'
50
(logand (class-slot-value class 'flags)
'
51
(the fixnum (foreign-enum-value 'smoke-class-flags flag))))
2009-04-05 tobias
52
15:36:29 '
53
(defmethod constructor-p ((class smoke-class))
'
54
"Returns T when CLASS has a constructor; NIL otherwise."
2009-06-22 tobias
55
(/= 0 (get-class-flag class :constructor)))
2009-04-05 tobias
56
2009-05-24 tobias
57
(defun virtual-destructor-p (class)
11:30:05 '
58
"Returns T when CLASS has a virtual destructor and NIL otherwise."
2009-06-22 tobias
59
(/= 0 (get-class-flag class :virtual-destructor)))
2009-05-24 tobias
60
2009-04-05 tobias
61
(define-condition undefined-class (cell-error)
2010-01-17 tobias
62
((smoke-name :initarg :smoke-name
21:04:08 '
63
:initform nil
'
64
:documentation "The name of the Smoke module"))
2009-04-05 tobias
65
(:report (lambda (condition stream)
2010-01-17 tobias
66
(format stream "No Smoke class named ~S in the Smoke module ~S."
21:04:08 '
67
(cell-error-name condition)
'
68
(slot-value condition 'smoke-name))))
2009-04-05 tobias
69
(:documentation "A undefined Smoke class"))
15:36:29 '
70
2009-08-02 tobias
71
;smoke-find-class
2010-01-17 tobias
72
(defun make-smoke-class (smoke name)
21:04:08 '
73
"Returns the class named NAME of the smoke module SMOKE.
2009-04-05 tobias
74
Signals an undefined-class condition when there is no class for NAME."
15:36:29 '
75
(with-foreign-object (c 'smoke-module-index)
'
76
(do () (nil)
2010-01-17 tobias
77
(smoke-find-class c (smoke-module-pointer smoke) name)
2009-04-05 tobias
78
(restart-case
15:36:29 '
79
(if (null-pointer-p (foreign-slot-value c 'smoke-module-index 'smoke))
2010-01-17 tobias
80
(error (make-condition 'undefined-class :name name :smoke-name (smoke-get-module-name (smoke-module-pointer smoke))))
2009-04-05 tobias
81
(return))
15:36:29 '
82
(supply (new-name)
'
83
:report "Supply a new class name"
'
84
:interactive read-new-value
'
85
(setf name new-name))))
2010-01-10 tobias
86
(make-instance 'smoke-class
2009-07-08 tobias
87
:id (foreign-slot-value c 'smoke-module-index 'index)
2010-01-10 tobias
88
:smoke (gethash (pointer-address (foreign-slot-value c 'smoke-module-index 'smoke)) *smoke-modules*))))
2009-04-05 tobias
89
15:36:29 '
90
(defun real-class (class)
'
91
"Returns the same class like CLASS, but such that EXTERNAL-P returns NIL."
'
92
(if (external-p class)
2009-08-27 tobias
93
(make-smoke-class (smoke class) (name class))
2009-04-05 tobias
94
class))
15:36:29 '
95
'
96
(defun class-id (module class)
'
97
"Returns the class id of CLASS for the Smoke module MODULE."
'
98
(if (eq (smoke class) module)
'
99
(id class)
'
100
(smoke-class-id module (name class))))
'
101
2010-02-16 tobias
102
;(defun smoke-subclassp (class base-class) TODO
2009-04-05 tobias
103
(defun derived-p (class base-class)
15:36:29 '
104
"Returns T when CLASS is derived from BASE-CLASS and NIL when not."
2010-02-16 tobias
105
(values
21:52:02 '
106
(derived-real-p (real-class class) (real-class base-class))
'
107
T))
2009-04-05 tobias
108
15:36:29 '
109
(defun derived-real-p (class base-class)
2009-08-02 tobias
110
(smoke-is-derived-from (smoke-module-pointer (smoke class)) (id class)
10:12:41 '
111
(smoke-module-pointer (smoke base-class)) (id base-class)))
2009-04-05 tobias
112
15:36:29 '
113
'
114
(defun smoke-class-direct-superclasses (class)
2009-05-26 tobias
115
(smoke-add-superclass class nil (class-slot-value class 'parents)))
2009-04-05 tobias
116
15:36:29 '
117
(defun smoke-add-superclass (class classes index)
2009-06-22 tobias
118
(let ((class-index (mem-aref (smoke-module-inheritance-list
12:18:08 '
119
(smoke class))
'
120
'smoke-index
'
121
index)))
2009-07-22 tobias
122
(assert (<= class-index
22:26:05 '
123
(smoke-array-length
'
124
(smoke-module-classes (smoke class)))))
2009-04-05 tobias
125
(if (= 0 class-index)
15:36:29 '
126
classes
2009-07-22 tobias
127
(smoke-add-superclass class (append classes
22:26:05 '
128
(list
'
129
(make-smoke-class-from-id (smoke class)
'
130
class-index)))
'
131
(1+ index)))))