Coverage report: /home/ellis/comp/core/lib/obj/meta/pkg.lisp

Kind	Covered	All	%
expression	16	227	7.0
branch	3	30	10.0

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; obj/meta/pkg.lisp --- Meta-objects

2

3

;;

4

5

;;; Commentary:

6

7

;;;; Notes:

8

9

;; ordered? https://www.reddit.com/r/lisp/comments/n88x59/metaclasses_using_structures_or_speeding_up_slot/

10

11

;;;; Ref:

12

13

;; https://franz.com/support/documentation/11.0/mop/concepts.html

14

15

;;; Code:

16

(defpackage :obj/meta

17

(:nicknames :meta)

18

(:use :cl :std)

19

(:export

20

:class-equalp

21

:*standard-metaobjects*

22

:find-slot-def-by-name

23

:find-direct-slot-def-by-name

24

:find-slot-defs-by-type

25

:find-slot-def-names-by-type

26

:struct-slots-and-values

27

:slots-and-values

28

:struct-constructor))

29

30

(defpackage :obj/meta/stealth

31

(:nicknames :meta/stealth :stealth)

32

(:use :cl :std :obj/meta :sb-mop)

33

(:export

34

#:add-mixin

35

#:define-stealth-mixin))

36

37

(defpackage :obj/meta/filtered

38

(:nicknames :meta/filtered :filtered)

39

(:use :cl :std :obj/meta :sb-mop)

40

(:export

41

:define-filtered-function :filtered :filtered-function :filtered-method

42

:generic-function-filter-expression :generic-function-filters :method-filter :simple-filtered-function))

43

44

(defpackage :obj/meta/sealed

45

(:nicknames :meta/sealed :sealed)

46

(:use :cl :std :obj/meta)

47

(:import-from :sb-pcl :eql-specializer :intern-eql-specializer

48

:eql-specializer-object :funcallable-standard-class)

49

(:import-from :sb-mop :class-finalized-p :finalize-inheritance

50

:class-precedence-list :class-direct-superclasses :specializer :method-specializers

51

    :generic-function-argument-precedence-order :generic-function-name :generic-function-methods :class-direct-subclasses

52

:class-prototype)

53

(:export

54

:ensure-specializer

55

:specializer-type

56

:specializer-prototype

57

:specializer-direct-superspecializers

58

:specializer-intersectionp

59

:specializer-subsetp

60

:domain

61

:ensure-domain

62

:method-domain

63

:domain-specializers

64

:domain-arity

65

:domain-equal

66

:domain-intersectionp

67

:domain-subsetp

68

69

:metaobject-sealable-p

70

:class-sealable-p

71

:generic-function-sealable-p

72

:method-sealable-p

73

:specializer-sealable-p

74

75

:metaobject-sealed-p

76

:class-sealed-p

77

:generic-function-sealed-p

78

:method-sealed-p

79

:specializer-sealed-p

80

81

:seal-class

82

:seal-generic-function

83

:seal-method

84

:seal-domain

85

:seal-specializer

86

87

:method-properties

88

:validate-method-property

89

90

:static-call-signature

91

:static-call-signature-types

92

:static-call-signature-prototypes

93

94

:sealed-domains

95

:compute-static-call-signatures

96

:externalizable-object-p

97

:sealable-class

98

:sealable-generic-function

99

:sealable-standard-generic-function

100

:potentially-sealable-method

101

:potentially-sealable-standard-method))

102

103

(defpackage :obj/meta/fast

104

(:nicknames :meta/fast :fast)

105

(:use :cl :std :obj/meta/sealed :obj/meta)

106

(:import-from :sb-int :gensymify)

107

(:import-from :sb-walker :macroexpand-all)

108

(:export :fast-generic-function :fast-method :inlineable :.lambda.))

109

110

(defpackage :obj/meta/lazy

111

(:nicknames :meta/lazy :lazy)

112

(:use :cl :std :obj/meta))

113

114

(defpackage :obj/meta/overloaded

115

(:nicknames :meta/overloaded :overloaded)

116

(:use :cl :std :obj/meta))

117

118

(defpackage :obj/meta/stored

119

(:nicknames :meta/stored :stored)

120

(:use :cl :std :obj/meta :sb-mop)

121

(:export

122

:stored-class :initialize-stored-class

123

:stored-slot

124

:stored

125

:stored-object

126

:stored-collection

127

:oid

128

:cid

129

:spec

130

:stored-p

131

:indexed-slot-names

132

:indexed-slot-defs

133

:stored-slot-definition

134

:indexed-slot-definition

135

:derived-slot-triggers

136

:derived-fn

137

:get-slot-def-index

138

:add-slot-def-index

139

:clear-slot-def-index

140

:indexed-slot-base

141

:indexed-slot-indices

142

:get-store-schemas

143

:get-class-indexing

144

:get-cache-style

145

:has-class-schema-p

146

:find-slot-defs-by-type

147

:migrate-class-index-p

148

:class-indexing-enabled-p

149

:defsclass

150

:get-class-schema

151

:drop-instance

152

:register-instance

153

:cache-instance

154

:get-cached-instance

155

:uncache-instance

156

:flush-instance-cache

157

:stored-slot-makunbound

158

:stored-slot-boundp

159

:stored-slot-writer

160

:stored-slot-reader

161

:get-store

162

:read-oid

163

:write-oid

164

:stored-slot-names

165

:all-stored-slot-names

166

:all-single-valued-slot-defs

167

:cached-slot-definition

168

:cached-direct-slot-definition

169

:transient-slot-definition

170

:cached-slot-names

171

:transient-p

172

:transient-slot-names

173

:database-allocation-p

174

:slot-definition-allocation

175

:association-slot-base

176

:association-type

177

:association-effective-slot-definition

178

:association-slot-definition

179

:association-slot-indices

180

:foreign-classname

181

:foreign-slotname

182

:foreign-class

183

:association-end-p

184

:association-slot-defs

185

:association-slot-names

186

:association-end-slot-names

187

:get-association-slot-index

188

:add-association-slot-index

189

:remove-association-slot-index

190

:set-valued-slot-definition

191

:set-valued-direct-slot-definition

192

:set-valued-effective-slot-definition))

193

194

(defpackage :obj/meta/typed

195

(:nicknames :meta/typed :typed)

196

(:use :cl :std :obj/meta :sb-mop :stored)

197

(:export

198

#:type-num

199

#:type<=

200

#:type<

201

#:type=

202

#:array-type=

203

#:array-type-from-byte

204

#:byte-from-array-type

205

#:int-byte-spec))

206

207

(defpackage :obj/meta/dynamic

208

(:nicknames :meta/dynamic :dynamic)

209

(:use :cl :std :obj/meta :std/macs)

210

(:export :dset :dref :dynamic-class

211

:slot-dlet :slot-dvar :slot-dvar*))

212

213

(defpackage :obj/meta/mix

214

(:use #:cl #:std)

215

(:export

216

#:mixin-class #:mixin-object #:mixin-classes

217

#:ensure-mix #:delete-from-mix #:mix

218

#:replace-class #:replace-class-in-mixin

219

#:set-mix-rule #:*class-ordering-rules*

220

#:%find-class

221

#:ensure-mixin

222

#:make-mix-list

223

#:mix-list))

224

225

(in-package :obj/meta)

226

227

(defun class-equalp (c1 c2)

228

(when (symbolp c1) (setf c1 (find-class c1)))

229

(when (symbolp c2) (setf c2 (find-class c2)))

230

(eq c1 c2))

231

232

(defun type-specifier-and (&rest type-specifiers)

233

(let ((relevant (remove t type-specifiers)))

234

(cond ((null relevant) t)

235

((null (cdr relevant)) (first relevant))

236

(t `(and ,@relevant)))))

237

238

(defun type-specifier-or (&rest type-specifiers)

239

(let ((relevant (remove nil type-specifiers)))

240

(cond ((null relevant) nil)

241

((null (cdr relevant)) (first relevant))

242

(t `(or ,@relevant)))))

243

244

(defun type-specifier-not (type-specifier)

245

(cond ((eql type-specifier t) nil)

246

((eql type-specifier nil) t)

247

(t `(not ,type-specifier))))

248

249

(defparameter *standard-metaobjects*

250

(list (find-class 'standard-object)

251

(find-class 'standard-class)

252

(find-class 'standard-generic-function)

253

(find-class 'standard-method)

254

(find-class 'built-in-class)))

255

256

(defgeneric struct-constructor (class)

257

(:documentation "Called to get the constructor name for a struct class. Users

258

should overload this when they want to serialize

259

non-standard constructor names. The default constructor

260

make-xxx will work by default. The argument is an eql style

261

type: i.e. of type (eql 'my-struct)"))

262

263

(defmethod struct-constructor ((class t))

264

(symbol-function (intern (concatenate 'string "MAKE-" (symbol-name class))

265

(symbol-package class))))

266

267

;;; From ARNESI - Messing with the MOP

268

269

 ;; https://bese.common-lisp.dev/docs/arnesi/html/Messing_0020with_0020the_0020MOP.html#wrapping-standard_0020method_0020combination

270

271

(define-method-combination wrapping-standard

272

(&key (around-order :most-specific-first)

273

(before-order :most-specific-first)

274

(primary-order :most-specific-first)

275

(after-order :most-specific-last)

276

(wrapping-order :most-specific-last)

277

(wrap-around-order :most-specific-last))

278

((wrap-around (:wrap-around))

279

(around (:around))

280

(before (:before))

281

(wrapping (:wrapping))

282

(primary () :required t)

283

(after (:after)))

284

"Same semantics as standard method combination but allows

285

\"wrapping\" methods. Ordering of methods:

286

287

(wrap-around

288

(around

289

(before)

290

(wrapping

291

(primary))

292

(after)))

293

294

:warp-around, :around, :wrapping and :primary methods call the

295

next least/most specific method via call-next-method (as in

296

standard method combination).

297

298

The various WHATEVER-order keyword arguments set the order in

299

which the methods are called and be set to either

300

:most-specific-last or :most-specific-first."

301

(labels ((effective-order (methods order)

302

(ecase order

303

(:most-specific-first methods)

304

(:most-specific-last (reverse methods))))

305

(call-methods (methods)

306

(mapcar (lambda (meth) `(call-method ,meth))

307

methods)))

308

(let* (;; reorder the methods based on the -order arguments

309

(wrap-around (effective-order wrap-around wrap-around-order))

310

(around (effective-order around around-order))

311

(wrapping (effective-order wrapping wrapping-order))

312

(before (effective-order before before-order))

313

(primary (effective-order primary primary-order))

314

(after (effective-order after after-order))

315

;; inital value of the effective call is a call its primary

316

;; method(s)

317

(form (case (length primary)

318

(1 `(call-method ,(first primary)))

319

(t `(call-method ,(first primary) ,(rest primary))))))

320

(when wrapping

321

;; wrap form in call to the wrapping methods

322

(setf form `(call-method ,(first wrapping)

323

(,@(rest wrapping) (make-method ,form)))))

324

(when before

325

;; wrap FORM in calls to its before methods

326

(setf form `(progn

327

,@(call-methods before)

328

,form)))

329

(when after

330

;; wrap FORM in calls to its after methods

331

(setf form `(multiple-value-prog1

332

,form

333

,@(call-methods after))))

334

(when around

335

;; wrap FORM in calls to its around methods

336

(setf form `(call-method ,(first around)

337

(,@(rest around)

338

(make-method ,form)))))

339

(when wrap-around

340

(setf form `(call-method ,(first wrap-around)

341

(,@(rest wrap-around)

342

(make-method ,form)))))

343

form)))

344

345

(defun find-class-for-direct-slot (class def)

346

(let ((list (sb-mop:compute-class-precedence-list class)))

347

(labels ((rec (super)

348

(if (null super)

349

nil

350

(aif (find-direct-slot-def-by-name super (sb-mop:slot-definition-name def))

351

(class-name super)

352

(rec (pop list))))))

353

(rec class))))

354

355

;;; Slot Helpers

356

(defun find-direct-slot-def-by-name (class slot-name)

357

(loop for slot-def in (sb-mop:class-direct-slots class)

358

when (eq (sb-mop:slot-definition-name slot-def) slot-name)

359

do (return slot-def)))

360

361

(defun find-slot-def-by-name (class slot-name)

362

(loop for slot-def in (sb-mop:class-slots class)

363

when (eq (sb-mop:slot-definition-name slot-def) slot-name)

364

do (return slot-def)))

365

366

(defgeneric find-slot-defs-by-type (class type &optional by-subtype))

367

(defgeneric find-slot-def-names-by-type (class type &optional by-subtype))

368

369

(defun slots-and-values (o)

370

"List of slot names followed by values for object"

371

(loop for sd in (sb-mop:compute-slots (class-of o))

372

for slot-name = (sb-mop:slot-definition-name sd)

373

with ret = ()

374

do

375

(when (and (slot-boundp o slot-name)

376

(eq :instance

377

(sb-mop:slot-definition-allocation sd)))

378

(push (slot-value o slot-name) ret)

379

(push slot-name ret))

380

finally (return ret)))

381

382

(defun struct-slots-and-values (object)

383

"List of slot names followed by values for structure object"

384

(let ((result nil)

385

(slots

386

(mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (class-of object)))))

387

(loop for slot in slots do

388

(push (slot-value object slot) result)

389

(push slot result))

390

result))