darcs - smoke

1 (in-package #:smoke)

3 (declaim (inline smoke))

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

12 (:documentation "A type"))

14 (defmethod print-object ((type smoke-type) stream)

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

21 ;; Clozure CL needs this

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

29 (declaim (inline type-slot-value))

30 (defun type-slot-value (type slot-name)

31 (declare (smoke-type type)

32 (symbol slot-name)

33 (optimize (speed 3)))

34 (foreign-slot-value (mem-aref (smoke-array-pointer

35 (smoke-module-types (smoke type)))

36 'smoke-type

37 (the smoke-index (id type)))

38 'smoke-type slot-name))

40 (define-compiler-macro type-slot-value (&whole form type slot-name)

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

50 (defun make-smoke-type (smoke name)

51 "Returns the type in the Smoke module SMOKE named NAME."

52 (make-instance 'smoke-type

53 :id (smoke-find-type (smoke-module-pointer smoke) name)

54 :smoke smoke))

56 (defmethod name ((type smoke-type))

57 (declare (optimize (speed 3)))

58 (type-slot-value type 'name))

60 (defun smoke-type= (type1 type2)

61 (if (eq (smoke type1) (smoke type2))

62 (= (id type1) (id type2))

63 (string= (name type1) (name type2))))

65 (defun get-type-flag (type flag)

66 (declare (optimize (speed 3)))

67 (logand (type-slot-value type 'flags)

68 #xF0 ;; = !0x0F

69 (the fixnum (foreign-enum-value 'smoke-type-flags flag))))

71 (define-compiler-macro get-type-flag (&whole form type flag)

72 (if (constantp flag)

73 `(logand (type-slot-value ,type 'flags)

74 #xF0

75 ,(foreign-enum-value 'smoke-type-flags flag))

76 form))

78 (defmacro allocation-flag-p (type flag)

79 ;; Can't just use #'get-type-flag since it can only be one of

80 ;; :stack, :reference and :pointer.

81 ;; (:stack + :pointer = :reference) <=> (#x10 + #x20 = #x30)

82 `(= ,(foreign-enum-value 'smoke-type-flags flag)

83 (logand #x30

84 (type-slot-value ,type 'flags))))

86 (declaim (inline stack-p))

87 (defun stack-p (type)

88 "Returns T when TYPE is stored on the stack; NIL otherwise."

89 (allocation-flag-p type :stack))

91 (defun reference-p (type)

92 "Returns T when TYPE is a reference ('type&'); NIL otherwise."

93 (allocation-flag-p type :reference))

95 (defun pointer-p (type)

96 "Returns T when TYPE is a pointer ('type*'); NIL otherwise."

97 (allocation-flag-p type :pointer))

99 (defgeneric const-p (object)

100 (:method ((type smoke-type))

101 "Returns T when TYPE is const; NIL otherwise."

102 (/= 0 (get-type-flag type :const))))

103

104 (defun class-p (type)

105 "Returns T when TYPE is a smoke class"

106 (and (eql (type-id type) 13)

107 (not (zerop (type-slot-value type 'class)))))

108

109 (defun type-id (type)

110 "Returns the ID of TYPE."

111 (declare (smoke-type type)

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

115

116 (defun void-p (type)

117 "Return T when TYPE is a void type (no value)."

118 ;; void is an empty string.

119 ;; For efficiency just check if the first byte is a null byte;

120 ;; No need to convert the entire C string to lisp like in:

121 ;; (null (name type)))

122 (declare (optimize (speed 3)))

123 (null-pointer-p (mem-ref

124 (foreign-slot-pointer

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

131

132

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

138 (assert (class-p type)

139 (type)

140 "The type ~S is not a smoke class." type)

141 (make-smoke-class-from-id (smoke type) (type-slot-value type 'class)))

142

143 ;; Return the cffi keyword for the type

144 (defun type-foreign-keyword (smoke-type)

145 (intern (nsubstitute #\- #\ (nstring-upcase (name smoke-type)))

146 :keyword))

147

148 (defun type-size (smoke-type)

149 (if (class-p smoke-type)

150 (class-size (get-class smoke-type))

151 (foreign-type-size (type-foreign-keyword smoke-type))))