darcs - smoke

1 (in-package #:smoke)

3 (defclass smoke-class ()

4 ((id :initform 0 :type smoke-index

5 :reader id :initarg :id)

6 (smoke :type smoke-module

7 :reader smoke :initarg :smoke)))

9 (defun make-smoke-class-from-id (smoke id)

10 (make-instance 'smoke-class :id id :smoke smoke))

12 (declaim (inline smoke-class-pointer))

13 (defun smoke-class-pointer (class)

14 (mem-aref (the foreign-pointer

15 (smoke-array-pointer (smoke-module-classes (smoke class))))

16 'smoke-class

17 (the smoke-index (id class))))

19 (declaim (inline class-slot-value))

20 (defun class-slot-value (class slot-name)

21 (foreign-slot-value (smoke-class-pointer class)

22 'smoke-class slot-name))

24 (define-compiler-macro class-slot-value (&whole form class slot-name)

25 (if (constantp slot-name)

26 `(foreign-slot-value (smoke-class-pointer ,class)

27 'smoke-class ,slot-name)

28 form))

30 (defmethod name ((class smoke-class))

31 (class-slot-value class 'name))

33 (defun name-pointer (class)

34 (mem-ref (foreign-slot-pointer (smoke-class-pointer class)

35 'smoke-class 'name)

36 :pointer))

38 (defun class-size (smoke-class)

39 (class-slot-value smoke-class 'size))

41 (defun map-classes (function smoke)

42 "Applies FUNCTION to the classes of SMOKE."

43 (declare (function function)

44 (optimize (speed 3)))

45 (let ((class (make-instance 'smoke-class

46 :smoke smoke)))

47 (loop for id from 1 to (smoke-array-length (smoke-module-classes smoke)) do

48 (setf (slot-value class 'id)

49 id)

50 (funcall function class))))

52 (defun external-p (class)

53 "Returns T when CLASS is external in its module; NIL otherwise."

54 (declare (type smoke-class class)

55 (optimize (speed 3)))

56 (class-slot-value class 'external))

58 (defun get-class-flag (class flag)

59 (declare (optimize (speed 3)))

60 (logand (class-slot-value class 'flags)

61 (the fixnum (foreign-enum-value 'smoke-class-flags flag))))

63 (defmethod constructor-p ((class smoke-class))

64 "Returns T when CLASS has a constructor; NIL otherwise."

65 (/= 0 (get-class-flag class :constructor)))

67 (defun copy-constructor-p (class)

68 (/= 0 (get-class-flag class :copy-constructor)))

70 (defun virtual-destructor-p (class)

71 "Returns T when CLASS has a virtual destructor and NIL otherwise."

72 (/= 0 (get-class-flag class :virtual-destructor)))

74 (define-condition undefined-class (cell-error)

75 ()

76 (:report (lambda (condition stream)

77 (format stream "No Smoke class named ~S."

78 (cell-error-name condition))))

79 (:documentation "A undefined Smoke class"))

81 (define-condition lisp-module-not-loaded (error)

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)))))

87 (defun make-smoke-class (name)

88 "Returns the class named NAME.

89 Signals an undefined-class condition when there is no class for NAME."

90 (with-foreign-object (c 'smoke-module-index)

91 (do () (nil)

92 (smoke-find-class c name)

93 (restart-case

94 (if (null-pointer-p (foreign-slot-value c 'smoke-module-index 'smoke))

95 (error (make-condition 'undefined-class :name name))

96 (return))

97 (supply (new-name)

98 :report "Supply a new class name"

99 :interactive read-new-value

100 (setf name new-name))))

101 (let ((class (make-instance

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)))

111

112 (defun real-class (class)

113 "Returns the same class like CLASS, but such that EXTERNAL-P returns NIL."

114 (if (external-p class)

115 (make-smoke-class (name class))

116 class))

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."

126 (handler-case (derived-real-p (real-class class) (real-class base-class))

127 ;; The class is external in every module => no derived.

128 (undefined-class () nil)))

129

130 (defun derived-real-p (class base-class)

131 (smoke-is-derived-from (smoke-module-pointer (smoke class))

132 (id class)

133 (smoke-module-pointer (smoke base-class))

134 (id base-class)))

135

136

137 (defun smoke-class-direct-superclasses (class)

138 (smoke-add-superclass class nil (class-slot-value class 'parents)))

139

140 (defun smoke-add-superclass (class classes index)

141 (let ((class-index (mem-aref (smoke-module-inheritance-list

142 (smoke class))

143 'smoke-index

144 index)))

145 (assert (<= class-index (smoke-array-length

146 (smoke-module-classes (smoke class)))))

147 (if (= 0 class-index)

148 classes

149 (smoke-add-superclass

150 class

151 (append classes

152 (list (make-smoke-class-from-id (smoke class) class-index)))

153 (1+ index)))))