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