Coverage report: /home/ellis/comp/core/std/meta.lisp

Kind	Covered	All	%
expression	85	305	27.9
branch	9	34	26.5

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; std/meta.lisp --- Standard MOP Utilities

2

3

;;

4

5

;;; Code:

6

(in-package :std/meta)

7

8

;; make-specializer-form-using-class

9

;; make-method-lambda-using-specializers

10

11

(defgeneric start (self)

12

(:documentation "Start object SELF."))

13

(defgeneric started-p (self)

14

(:documentation "Return non-nil if object SELF has been started."))

15

(defgeneric stop (self &key &allow-other-keys)

16

(:documentation "Stop object SELF."))

17

(defgeneric stopped-p (self)

18

(:documentation "Return non-nil if object SELF has been stopped."))

19

(defgeneric shutdown (self)

20

(:documentation "Shutdown object SELF."))

21

(defgeneric reset (self &rest args &key &allow-other-keys)

22

(:documentation "Reset object SELF."))

23

(defgeneric data (self)

24

(:documentation "Return the data associated with SELF."))

25

(defgeneric (setf data) (new self))

26

(defgeneric name (self)

27

(:method ((self t))

28

(string self))

29

(:documentation "Return the name of object SELF."))

30

(defgeneric (setf name) (new self))

31

(defgeneric validate (obj self &key &allow-other-keys)

32

(:documentation "Validate OBJ against SELF."))

33

(defgeneric status (self &key &allow-other-keys)

34

(:documentation "Return the status of SELF."))

35

(defgeneric tags (self)

36

(:documentation "Return the tags associated with object SELF."))

37

(defgeneric run-object (self &key &allow-other-keys)

38

(:documentation "Explicitly run the object SELF."))

39

(defgeneric exec (self)

40

(:documentation "Execute object SELF."))

41

(defgeneric explore (self &key &allow-other-keys)

42

(:documentation "Explore object SELF."))

43

(defgeneric write-object (self stream &key &allow-other-keys)

44

(:documentation "Write object SELF to STREAM.")

45

(:method ((self t) (stream t) &key)

46

(write self :stream stream)))

47

(defgeneric version (self)

48

(:documentation "Return the version of object SELF."))

49

(defgeneric lock (self)

50

(:documentation "Return the lock associated with SELF."))

51

(defgeneric upgrade (self)

52

(:documentation "Return the upgrade-function associated with object SELF."))

53

(defgeneric bind (self)

54

(:documentation "Return the bindings associated with object SELF."))

55

(defgeneric (setf bind) (new self)

56

(:documentation "Set the bindings associated with object SELF to NEW."))

57

58

(defun slot-boundp* (self slot)

59

"Return T if SLOT is bound in object SELF, otherwise return NIL."

60

(when slot

61

(handler-bind ((sb-pcl::missing-slot nil))

62

(slot-boundp self slot))))

63

64

(defun shallow-copy-object (self)

65

"Create a 'shallow' copy of object SELF."

66

(let* ((class (class-of self))

67

(copy (allocate-instance class)))

68

(dolist (slot (mapcar #'slot-definition-name (class-slots class)))

69

(when (slot-boundp self slot)

70

(setf (slot-value copy slot)

71

(slot-value self slot))))

72

copy))

73

74

(defgeneric copy-object (self)

75

(:documentation "Return a copy of object SELF.")

76

(:method ((self standard-object))

77

(shallow-copy-object self)))

78

79

(defgeneric copy (from to)

80

(:documentation "Copy the contents of FROM into TO. Returns TO.")

81

(:method :before ((x array) (y array))

82

(assert (tree-equal (array-dimensions x) (array-dimensions y))

83

nil 'dimension-mismatch))

84

(:method ((from cons) (to cons))

85

(do ((flst from (cdr flst))

86

(tlst to (cdr tlst)))

87

((or (null flst) (null tlst)))

88

(setf (car tlst) (car flst)))

89

to)

90

(:method ((from t) (to cons))

91

(mapl #'(lambda (lst) (rplaca lst from)) to)

92

to))

93

94

(defgeneric swap (from to)

95

(:documentation "Swap the contents of FROM with the contents of TO, returning TO."))

96

97

(defun list-indirect-class-methods (class)

98

"List all indirect methods of CLASS."

99

(remove-duplicates (mapcan #'specializer-direct-generic-functions (compute-class-precedence-list class))))

100

101

(defun list-class-methods (class methods &optional indirect)

102

"List all methods specializing on CLASS modulo METHODS. When INDIRECT is

103

non-nil, also include indirect (parent) methods."

104

(if (eq methods t)

105

(if indirect

106

(list-indirect-class-methods class)

107

(specializer-direct-generic-functions class))

108

(mapcar

109

(lambda (s)

110

(car (member s (specializer-direct-generic-functions class) :key #'generic-function-name)))

111

methods)))

112

113

(defun list-class-slots (class slots &optional exclude)

114

"List the SLOTS found in CLASS, optionally excluding list EXCLUDE."

115

;; should probably convert slot-definition-name here

116

(let ((cs (remove-if

117

(lambda (s)

118

(or

119

(null s)

120

(member t (mapcar

121

(lambda (x)

122

(string= (slot-definition-name s) x))

123

exclude))))

124

(class-slots class))))

125

(if (eq slots t)

126

cs

127

(loop for s in slots

128

with sn = (symb s)

129

for c in cs

130

with cn = (symb (slot-definition-name c))

131

when (eq sn cn)

132

collect c))))

133

134

(definline slot-values (obj &optional (slots (mapcar 'slot-definition-name (class-slots (class-of obj)))))

135

"Returns a list containing slot-values of OBJ corresponding to symbols in the list SLOTS.

136

137

Example:

138

(defstruct obj a b)

139

140

(let ((thing (make-obj :a 1 :b 2)))

141

(slot-values thing '(a b)))

142

;; (1 2)"

143

(mapcar #'(lambda (s) (when (slot-boundp obj s) (slot-value obj s))) slots))

144

145

(defmacro with-fslots (slots instance &rest body)

146

(with-gensyms (obj args)

147

`(let ((,obj ,instance))

148

(flet (,@(mapcar #'(lambda (decl)

149

                             (destructuring-bind (name slot-name) (if (consp decl) decl (list decl decl))

150

                               `(,name (&rest ,args) (apply (the function (slot-value ,obj ',slot-name)) ,args))))

151

slots))

152

,@body))))

153

154

;; TODO 2023-09-09: slot exclusion from dynamic var

155

(defun list-slot-values-using-class (class obj slots &optional nullp unboundp)

156

"List the values of SLOTS bound in OBJ according to CLASS. When NULLP is T also

157

include NIL values. Likewise with UNBOUNDP for unbound slot values."

158

(remove-if

159

#'null

160

(mapcar

161

(lambda (s)

162

(let ((n (slot-definition-name s)))

163

(let ((ns (make-keyword (symbol-name n))))

164

(if (slot-boundp-using-class class obj s)

165

(let ((v (slot-value-using-class class obj s)))

166

(if nullp

167

`(,ns ,v)

168

(unless (null v)

169

`(,ns ,v))))

170

(when unboundp (list ns))))))

171

slots)))

172

173

(defmacro make-instance! (name &rest args)

174

`(defmacro ,(intern (format nil "~:@(~a~)" name)) (,@args)

175

(list 'make-instance '',name

176

,@(loop for i in args append `(,(intern (symbol-name i) :keyword) ,i)))))

177

178

(defmacro defclass! (name superclasses slots &rest options)

179

"Helper for DEFCLASS forms. Automatically adds INITARG based on NAME."

180

(let ((slots (loop for slot in slots

181

collect

182

(if (consp slot)

183

                          `(,(car slot) :initarg ,(sb-int:keywordicate (car slot)) ,@(cdr slot))

184

`(,slot :initarg ,(sb-int:keywordicate slot)))))

185

(fun (member :auto options :test #'std/condition::car-eql)))

186

(when fun

187

(setq options (remove (car fun) options))

188

(setq fun (cadar fun)))

189

`(prog1

190

(defclass ,name ,superclasses ,slots ,@options)

191

(when ',fun

192

(make-instance! ,name ,@(loop for s in slots collect (if (consp s) (car s) s)))))))

193

194

(defmacro defmethods (name &body forms)

195

"Define multiple methods for a generic function. Each member of FORMS is passed

196

directly to a DEFMETHOD form."

197

(eval-always

198

`(progn

199

,@(loop for form in forms

200

collect `(defmethod ,name ,@form)))))

201

202

(defmacro defaccessor (name-and-opts args &body expansion)

203

"Define a pair of methods - an accessor with NAME and setf method for that accessor

204

which simply expands to: (SETF EXPANSION %VAL)."

205

(let ((name (if (atom name-and-opts) name-and-opts (pop name-and-opts)))

206

(type (if (atom name-and-opts) t (pop name-and-opts))))

207

(eval-always

208

`(progn

209

(defmethod ,name ,args ,@expansion)

210

(defmethod (setf ,name) ,(push `(new ,type) args) (setf ,@expansion new))))))

211

212

(defmacro defaccessor* (name args expansion setf-args &body setf-expansion)

213

"Handle special case DEFACCESSOR forms. In higher-level packages we will

214

ocassionally have a more complex SETF expansion so here we support 2 additional arguments.

215

216

The first specifies arguments for the SETF expansion in addition to the simple

217

accessor, and the second specifies the setf expansion.

218

219

Due to these changes the EXPANSION argument is downgraded from an &rest

220

argument."

221

(eval-always

222

`(progn

223

(defmethod ,name ,args ,expansion)

224

(defmethod (setf ,name) ,setf-args ,@setf-expansion))))

225

226

;; closer-mop

227

(defun ensure-finalized (class &optional (errorp t))

228

"Ensure that CLASS is finalized returning an error if ERRORP is non-nil."

229

(if (typep class 'class)

230

(unless (class-finalized-p class)

231

(finalize-inheritance class))

232

(when errorp (error "~S is not a class." class)))

233

class)

234

235

(defun subclassp (class superclass)

236

"Return T if CLASS is a subclass of SUPERCLASS."

237

(flet ((get-class (class) (etypecase class

238

(class class)

239

(symbol (find-class class)))))

240

241

(loop with class = (get-class class)

242

with superclass = (get-class superclass)

243

244

for superclasses = (list class)

245

then (set-difference

246

(union (class-direct-superclasses current-class) superclasses)

247

seen)

248

249

for current-class = (first superclasses)

250

251

while current-class

252

253

if (eq current-class superclass) return t

254

else collect current-class into seen

255

256

finally (return nil))))

257

258

(defun safe-superclasses (super classes)

259

"Return a list of class symbols same as CLASSES if one of the members is a

260

subclass of SUPER."

261

(if (find super classes :test (lambda (x y) (subclassp y x)))

262

classes

263

(push super classes)))