~ubuntu-branches/ubuntu/maverick/cl-closer-mop/maverick : revision 10

1

(in-package :closer-mop)

2

3

;; Some utility functions.

4

5

(defun required-args (lambda-list &optional (collector #'identity))

6

(loop for arg in lambda-list

7

until (member arg lambda-list-keywords)

8

collect (funcall collector arg)))

9

10

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

11

(if (typep class 'class)

12

(unless (class-finalized-p class)

13

(finalize-inheritance class))

14

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

15

class)

16

17

(defun subclassp (class superclass)

18

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

19

(class class)

20

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

21

22

(loop with class = (get-class class)

23

with superclass = (get-class superclass)

24

25

for superclasses = (list class)

26

then (set-difference

27

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

28

seen)

29

30

for current-class = (first superclasses)

31

32

while current-class

33

34

if (eq current-class superclass) return t

35

else collect current-class into seen

36

37

finally (return nil))))

38

39

;; We need a new standard-generic-function for various things.

40

41

(cl:defclass standard-generic-function (cl:standard-generic-function)

42

((initial-methods :initform '()))

43

(:metaclass clos:funcallable-standard-class))

44

45

;; The following ensures that the new standard-generic-function is used.

46

47

(defun ensure-generic-function

48

(name &rest args

49

&key (generic-function-class 'standard-generic-function)

50

&allow-other-keys)

51

(declare (dynamic-extent args))

52

(when (fboundp name)

53

(let ((function (fdefinition name)))

54

(unless (typep function 'generic-function)

55

(cerror "Discard existing definition and create generic function."

56

"~S is already fbound, but not as a generic function." name)

57

(fmakunbound name))))

58

(if (fboundp name)

59

(let ((function (fdefinition name)))

60

(apply #'ensure-generic-function-using-class

61

function name args))

62

(apply #'ensure-generic-function-using-class nil name

63

:generic-function-class generic-function-class

64

args)))

65

66

;; We need a new standard-class for various things.

67

68

(cl:defclass standard-class (cl:standard-class)

69

())

70

71

;; validate-superclass for metaclass classes is a little bit

72

;; more tricky than for class metaobject classes because

73

;; we don't want to make all standard-classes compatible to

74

;; each other.

75

76

;; Our validate-superclass may get passed a class-prototype

77

;; as its second argument, so don't expect its readers to

78

;; yield useful information. (In ANSI parlance, "the

79

;; consequences are undefined...")

80

81

(cl:defmethod validate-superclass

82

((class standard-class)

83

(superclass cl:standard-class))

84

(or (when (eq (class-of class) (find-class 'standard-class))

85

(or (eq (class-of superclass) (find-class 'cl:standard-class))

86

(eq (class-of superclass) (find-class 'standard-class))))

87

(call-next-method)

88

(when (eq (class-of superclass) (find-class 'cl:standard-class))

89

(validate-superclass class (class-prototype (find-class 'standard-class))))))

90

91

;; The following macro ensures that the new standard-class is used

92

;; by default. It would have been useful to fix other deficiencies

93

;; in a complete redefinition of defclass, but there is no portable

94

;; way to ensure the necessary compile-time effects as specified

95

;; by ANSI Common Lisp. Therefore, we just expand to the original

96

;; cl:defclass.

97

98

(defmacro defclass (name (&rest supers) &body options)

99

(if (member :metaclass options :key #'car)

100

`(cl:defclass ,name ,supers ,@options)

101

`(cl:defclass ,name ,supers ,@options

102

(:metaclass standard-class))))

103

104

;; We need a new funcallable-standard-class for various things.

105

106

(cl:defclass funcallable-standard-class (clos:funcallable-standard-class)

107

())

108

109

;; See the comment on validate-superclass for standard-class above.

110

111

(cl:defmethod validate-superclass

112

((class funcallable-standard-class)

113

(superclass clos:funcallable-standard-class))

114

(or (when (eq (class-of class) (find-class 'funcallable-standard-class))

115

(or (eq (class-of superclass) (find-class 'clos:funcallable-standard-class))

116

(eq (class-of superclass) (find-class 'funcallable-standard-class))))

117

(call-next-method)

118

(when (eq (class-of superclass) (find-class 'clos:funcallable-standard-class))

119

(validate-superclass class (class-prototype (find-class 'funcallable-standard-class))))))

120

121

#+lispworks5.0

122

(cl:defmethod validate-superclass

123

((class funcallable-standard-class)

124

(superclass (eql (find-class 'funcallable-standard-object))))

125

t)

126

127

;; We also need a new funcallable-standard-object because the default one

128

;; is not an instance of clos:funcallable-standard-class.

129

130

#-lispworks5.0

131

(cl:defclass funcallable-standard-object (clos:funcallable-standard-object)

132

()

133

(:metaclass clos:funcallable-standard-class))

134

135

;; The following code ensures that possibly incorrect lists of direct

136

;; superclasses are corrected.

137

138

#-lispworks5.0

139

(defun modify-superclasses (direct-superclasses &optional (standardp t))

140

(if (null direct-superclasses)

141

(list (if standardp

142

(find-class 'standard-object)

143

(find-class 'funcallable-standard-object)))

144

(let ((standard-object (if standardp

145

(find-class 'standard-object)

146

(find-class 'clos:funcallable-standard-object))))

147

(if (eq (car (last direct-superclasses)) standard-object)

148

(if standardp

149

direct-superclasses

150

(append (butlast direct-superclasses)

151

(list (find-class 'funcallable-standard-object))))

152

(remove standard-object direct-superclasses)))))

153

154

;; During class re/initialization, we take care of the following things:

155

;; - Optimization of slot accessors is deactivated.

156

;; - Lists of direct superclasses are corrected.

157

;; - Removal of direct subclasses.

158

159

(cl:defmethod initialize-instance :around

160

((class standard-class) &rest initargs

161

#-lispworks5.0 &key

162

#-lispworks5.0 (direct-superclasses ()))

163

(declare (dynamic-extent initargs))

164

(apply #'call-next-method class

165

#-lispworks5.0 :direct-superclasses

166

#-lispworks5.0 (modify-superclasses direct-superclasses)

167

:optimize-slot-access nil

168

initargs))

169

170

(cl:defmethod reinitialize-instance :around

171

((class standard-class) &rest initargs

172

#-lispworks5.0 &key

173

#-lispworks5.0 (direct-superclasses () direct-superclasses-p))

174

(declare (dynamic-extent initargs))

175

#-lispworks5.0

176

(progn

177

(when direct-superclasses-p

178

(setq direct-superclasses (modify-superclasses direct-superclasses))

179

(loop for superclass in (copy-list (class-direct-superclasses class))

180

unless (member superclass direct-superclasses)

181

do (remove-direct-subclass superclass class)))

182

(if direct-superclasses-p

183

(apply #'call-next-method class

184

:direct-superclasses direct-superclasses

185

:optimize-slot-access nil

186

initargs)

187

(apply #'call-next-method class

188

:optimize-slot-access nil

189

initargs)))

190

#+lispworks5.0

191

(apply #'call-next-method class

192

:optimize-slot-access nil

193

initargs))

194

195

(cl:defmethod initialize-instance :around

196

((class funcallable-standard-class) &rest initargs

197

#-lispworks5.0 &key

198

#-lispworks5.0 (direct-superclasses ()))

199

(declare (dynamic-extent initargs))

200

(apply #'call-next-method class

201

#-lispworks5.0 :direct-superclasses

202

#-lispworks5.0 (modify-superclasses direct-superclasses nil)

203

:optimize-slot-access nil

204

initargs))

205

206

(cl:defmethod reinitialize-instance :around

207

((class funcallable-standard-class) &rest initargs

208

#-lispworks5.0 &key

209

#-lispworks5.0 (direct-superclasses () direct-superclasses-p))

210

(declare (dynamic-extent initargs))

211

#-lispworks5.0

212

(progn

213

(when direct-superclasses-p

214

(setq direct-superclasses (modify-superclasses direct-superclasses nil))

215

(loop for superclass in (copy-list (class-direct-superclasses class))

216

unless (member superclass direct-superclasses)

217

do (remove-direct-subclass superclass class)))

218

(if direct-superclasses-p

219

(apply #'call-next-method class

220

:direct-superclasses direct-superclasses

221

:optimize-slot-access nil

222

initargs)

223

(apply #'call-next-method class

224

:optimize-slot-access nil

225

initargs)))

226

#+lispworks5.0

227

(apply #'call-next-method class

228

:optimize-slot-access nil

229

initargs))

230

231

;; The following is necessary for forward-referenced-classes.

232

;; Since we replace the original funcallable-standard-object with

233

;; a new one, we have to prevent LispWorks from trying to use

234

;; the original one when forward-ferenced-classes are resolved.

235

236

#-lispworks5.0

237

(cl:defmethod change-class :around

238

((class forward-referenced-class)

239

(new-class funcallable-standard-class)

240

&rest initargs

241

&key (direct-superclasses ()))

242

(declare (dynamic-extent initargs))

243

(apply #'call-next-method class new-class

244

:optimize-slot-access nil

245

:direct-superclasses (modify-superclasses direct-superclasses nil)

246

initargs))

247

248

;;; In LispWorks, the slot accessors (slot-value-using-class, etc.) are specialized

249

;;; on slot names instead of effective slot definitions. In order to fix this,

250

;;; we need to rewire the slot access protocol.

251

252

(cl:defmethod slot-value-using-class

253

((class standard-class) object (slot symbol))

254

(declare (optimize (speed 3) (debug 0) (safety 0)

255

(compilation-speed 0)))

256

(let ((slotd (find slot (class-slots class)

257

:test #'eq

258

:key #'slot-definition-name)))

259

(if slotd

260

(slot-value-using-class class object slotd)

261

(slot-missing class object slot 'slot-value))))

262

263

(cl:defmethod slot-value-using-class

264

((class standard-class) object (slotd standard-effective-slot-definition))

265

(declare (optimize (speed 3) (debug 0) (safety 0)

266

(compilation-speed 0)))

267

(slot-value-using-class

268

(load-time-value (class-prototype (find-class 'cl:standard-class)))

269

object

270

(slot-definition-name slotd)))

271

272

(cl:defmethod (setf slot-value-using-class)

273

(new-value (class standard-class) object (slot symbol))

274

(declare (optimize (speed 3) (debug 0) (safety 0)

275

(compilation-speed 0)))

276

(let ((slotd (find slot (class-slots class)

277

:test #'eq

278

:key #'slot-definition-name)))

279

(if slotd

280

(setf (slot-value-using-class class object slotd)

281

new-value)

282

(slot-missing class object slot 'setf new-value))))

283

284

(cl:defmethod (setf slot-value-using-class)

285

(new-value (class standard-class) object (slotd standard-effective-slot-definition))

286

(declare (optimize (speed 3) (debug 0) (safety 0)

287

(compilation-speed 0)))

288

(setf (slot-value-using-class

289

(load-time-value (class-prototype (find-class 'cl:standard-class)))

290

object

291

(slot-definition-name slotd))

292

new-value))

293

294

(cl:defmethod slot-boundp-using-class

295

((class standard-class) object (slot symbol))

296

(declare (optimize (speed 3) (debug 0) (safety 0)

297

(compilation-speed 0)))

298

(let ((slotd (find slot (class-slots class)

299

:test #'eq

300

:key #'slot-definition-name)))

301

(if slotd

302

(slot-boundp-using-class class object slotd)

303

(slot-missing class object slot 'slot-boundp))))

304

305

(cl:defmethod slot-boundp-using-class

306

((class standard-class) object (slotd standard-effective-slot-definition))

307

(declare (optimize (speed 3) (debug 0) (safety 0)

308

(compilation-speed 0)))

309

(slot-boundp-using-class

310

(load-time-value (class-prototype (find-class 'cl:standard-class)))

311

object

312

(slot-definition-name slotd)))

313

314

(cl:defmethod slot-makunbound-using-class

315

((class standard-class) object (slot symbol))

316

(declare (optimize (speed 3) (debug 0) (safety 0)

317

(compilation-speed 0)))

318

(let ((slotd (find slot (class-slots class)

319

:test #'eq

320

:key #'slot-definition-name)))

321

(if slotd

322

(slot-makunbound-using-class class object slotd)

323

(slot-missing class object slot 'slot-makunbound))))

324

325

(cl:defmethod slot-makunbound-using-class

326

((class standard-class) object (slotd standard-effective-slot-definition))

327

(declare (optimize (speed 3) (debug 0) (safety 0)

328

(compilation-speed 0)))

329

(slot-makunbound-using-class

330

(load-time-value (class-prototype (find-class 'cl:standard-class)))

331

object

332

(slot-definition-name slotd)))

333

334

;; In LispWorks, eql specializers are lists. We cannot change this

335

;; but we can soften some of the incompatibilities.

336

337

(deftype eql-specializer ()

338

'(or eql-specializer*

339

(satisfies clos:eql-specializer-p)))

340

341

(cl:defgeneric eql-specializer-object (eql-specializer)

342

(:method ((cons cons))

343

(if (clos:eql-specializer-p cons)

344

(cadr cons)

345

(error "~S is not an eql-specializer." cons))))

346

347

(defun intern-eql-specializer (object)

348

`(eql ,object))

349

350

(cl:defclass eql-specializer* (metaobject)

351

((obj :reader eql-specializer-object

352

:initarg eso

353

:initform (error "Use intern-eql-specializer to create eql-specializers."))

354

(direct-methods :reader specializer-direct-methods

355

:accessor es-direct-methods

356

:initform ())))

357

358

(defvar *eql-specializers* (make-hash-table))

359

360

(defun intern-eql-specializer* (object)

361

(or (gethash object *eql-specializers*)

362

(sys:with-hash-table-locked *eql-specializers*

363

(or (gethash object *eql-specializers*)

364

(setf (gethash object *eql-specializers*)

365

(make-instance 'eql-specializer* 'eso object))))))

366

367

(cl:defmethod add-direct-method ((specializer eql-specializer*) (method method))

368

(pushnew method (es-direct-methods specializer)))

369

370

(cl:defmethod remove-direct-method ((specializer eql-specializer*) (method method))

371

(removef (es-direct-methods specializer) method))

372

373

(cl:defgeneric specializer-direct-generic-functions (specializer)

374

(:method ((class class))

375

(remove-duplicates

376

(mapcar #'method-generic-function

377

(specializer-direct-methods class))))

378

(:method ((eql-specializer eql-specializer*))

379

(remove-duplicates

380

(mapcar #'method-generic-function

381

(specializer-direct-methods eql-specializer))))

382

(:method ((cons cons))

383

(specializer-direct-generic-functions

384

(intern-eql-specializer*

385

(eql-specializer-object cons)))))

386

387

;; The following method ensures that remove-method is called.

388

389

#-lispworks5.0

390

(cl:defmethod add-method :before ((gf standard-generic-function) (method method))

391

(when-let (old-method (find-method gf (method-qualifiers method)

392

(method-specializers method) nil))

393

(remove-method gf old-method)))

394

395

;; The following two methods ensure that add/remove-direct-method is called,

396

;; and that the dependent protocol for generic function works.

397

398

(cl:defmethod add-method :after ((gf standard-generic-function) (method method))

399

(loop for specializer in (method-specializers method)

400

if (consp specializer)

401

do (add-direct-method

402

(intern-eql-specializer*

403

(eql-specializer-object specializer))

404

method)

405

#-lispworks5.0 else

406

#-lispworks5.0 do

407

#-lispworks5.0 (add-direct-method specializer method))

408

#+lispworks4.3

409

(map-dependents

410

gf (lambda (dep) (update-dependent gf dep 'add-method method))))

411

412

(cl:defmethod remove-method :after ((gf standard-generic-function) (method method))

413

(loop for specializer in (method-specializers method)

414

if (consp specializer)

415

do (remove-direct-method

416

(intern-eql-specializer*

417

(eql-specializer-object specializer))

418

method)

419

#-lispworks5.0 else

420

#-lispworks5.0 do

421

#-lispworks5.0 (remove-direct-method specializer method))

422

#+lispworks4.3

423

(map-dependents

424

gf (lambda (dep) (update-dependent gf dep 'remove-method method))))

425

426

(cl:defgeneric find-method-combination (gf combi combi-options)

427

(:method ((gf generic-function) (combi symbol) combi-options)

428

(when combi-options

429

(error "This implementation of find-method-combination cannot handle method combination options."))

430

(clos::find-a-method-combination-type combi)))

431

432

;; In LispWorks, make-method-lambda expects different arguments than those

433

;; specified in AMOP. We just bridge this. The method lambda returned

434

;; still doesn't conform to AMOP, but may be good enough.

435

436

(cl:defgeneric make-method-lambda (gf method lambda-expression env)

437

(:method ((gf cl:standard-generic-function)

438

(method standard-method)

439

lambda-expression env)

440

(declare (ignorable env))

441

(destructuring-bind

442

(lambda (&rest args) &body body)

443

lambda-expression

444

(declare (ignore lambda))

445

(loop with documentation = :unbound

446

for (car . cdr) = body then cdr

447

while (or (and cdr (stringp car))

448

(and (consp car) (eq (car car) 'declare)))

449

if (stringp car)

450

do (setf documentation

451

(if (eq documentation :unbound) car

452

(error "Too many documentation strings in lambda expression ~S."

453

lambda-expression)))

454

else append (loop for declaration in (cdr car)

455

if (eq (car declaration) 'ignore)

456

collect `(ignorable ,@(cdr declaration))

457

and collect `(dynamic-extent ,@(cdr declaration))

458

else collect declaration) into declarations

459

finally (multiple-value-bind

460

(method-lambda method-args)

461

(clos:make-method-lambda

462

gf method args declarations

463

`(progn ,car ,@cdr) env)

464

(if (eq documentation :unbound)

465

(return (values method-lambda method-args))

466

(return (values

467

`(lambda ,(cadr method-lambda)

468

,documentation

469

,@(cddr method-lambda))

470

method-args))))))))

471

472

(defun ensure-method (gf lambda-expression

473

&key (method-class (generic-function-method-class gf))

474

(qualifiers ())

475

(lambda-list (cadr lambda-expression))

476

(specializers (required-args lambda-list (constantly (find-class 't)))))

477

(multiple-value-bind

478

(method-lambda method-args)

479

(make-method-lambda

480

gf (class-prototype method-class)

481

lambda-expression ())

482

(let ((method (apply #'make-instance

483

method-class

484

:qualifiers qualifiers

485

:lambda-list lambda-list

486

:specializers specializers

487

:function (compile nil method-lambda)

488

method-args)))

489

(add-method gf method)

490

method)))

491

492

;; helper function for creating a generic function lambda list

493

;; from a method lambda list.

494

(defun create-gf-lambda-list (method-lambda-list)

495

(loop with stop-keywords = '#.(remove '&optional lambda-list-keywords)

496

for arg in method-lambda-list

497

until (member arg stop-keywords)

498

collect arg into gf-lambda-list

499

finally (return (let (rest)

500

(cond ((member '&key method-lambda-list)

501

(nconc gf-lambda-list '(&key)))

502

((setq rest (member '&rest method-lambda-list))

503

(nconc gf-lambda-list (subseq rest 0 2)))

504

(t gf-lambda-list))))))

505

506

;; The defmethod macro is needed in order to ensure that make-method-lambda

507

;; is called. (Unfortunately, this doesn't work in the other CL implementations.)

508

509

(defmacro defmethod (&whole form name &body body &environment env)

510

(loop for tail = body then (cdr tail)

511

until (listp (car tail))

512

collect (car tail) into qualifiers

513

finally

514

(destructuring-bind

515

((&rest specialized-args) &body body) tail

516

(loop with documentation = :unbound

517

for (car . cdr) = body then cdr

518

while (or (stringp car)

519

(and (consp car) (eq (car car) 'declare)))

520

if (stringp car)

521

do (setq documentation

522

(if (eq documentation :unbound) car

523

(error "Too many documentation strings for defmethod form ~S." form)))

524

else append (cdr car) into declarations

525

finally

526

(let* ((lambda-list (extract-lambda-list specialized-args))

527

(gf-lambda-list (create-gf-lambda-list lambda-list))

528

(gf (if (fboundp name)

529

(ensure-generic-function name)

530

(ensure-generic-function name :lambda-list gf-lambda-list)))

531

(method-class (generic-function-method-class gf))

532

(lambda-expression `(lambda ,lambda-list

533

(declare ,@declarations)

534

(block ,name ,car ,@cdr))))

535

(if (equal (compute-applicable-methods

536

#'make-method-lambda

537

(list gf (class-prototype method-class)

538

lambda-expression env))

539

(list (find-method

540

#'make-method-lambda '()

541

(list (find-class 'cl:standard-generic-function)

542

(find-class 'standard-method)

543

(find-class 't)

544

(find-class 't))

545

nil)))

546

(return-from defmethod `(cl:defmethod ,@(rest form)))

547

(multiple-value-bind

548

(method-lambda method-args)

549

(make-method-lambda

550

gf (class-prototype method-class)

551

lambda-expression env)

552

(with-unique-names (gf method)

553

(return-from defmethod

554

`(let ((,gf (if (fboundp ',name)

555

(ensure-generic-function ',name)

556

(ensure-generic-function

557

',name :lambda-list ',gf-lambda-list)))

558

(,method

559

(make-instance

560

',method-class

561

:qualifiers ',qualifiers

562

:specializers

563

(list

564

,@(mapcar

565

(lambda (specializer-name)

566

(typecase specializer-name

567

(symbol `(find-class ',specializer-name))

568

(cons (cond

569

((> (length specializer-name) 2)

570

(error "Invalid specializer ~S in defmethod form ~S."

571

specializer-name form))

572

((eq (car specializer-name) 'eql)

573

`(intern-eql-specializer ,(cadr specializer-name)))

574

(t (error "Invalid specializer ~S in defmethod form ~S."

575

specializer-name form))))

576

(t (error "Invalid specializer ~S in defmethod form ~S."

577

specializer-name form))))

578

(extract-specializer-names specialized-args)))

579

:lambda-list ',lambda-list

580

:function (function ,method-lambda)

581

,@(unless (eq documentation :unbound)

582

(list :documentation documentation))

583

,@method-args)))

584

(add-method ,gf ,method)

585

,method))))))))))

586

587

;; The following macro ensures that the new standard-generic-function

588

;; is used by default. It also ensures that make-method-lambda is called

589

;; for the default methods, by expanding into defmethod forms.

590

591

(defmacro defgeneric (&whole form name (&rest args) &body options)

592

(unless (every #'consp options)

593

(error "Illegal generic functions options in defgeneric form ~S." form))

594

`(progn

595

(let ((generic-function (ignore-errors (fdefinition ',name))))

596

(when (and generic-function (typep generic-function 'standard-generic-function))

597

(loop for method in (slot-value generic-function 'initial-methods)

598

do (remove-method generic-function method))))

599

(eval-when (:compile-toplevel :load-toplevel :execute)

600

(cl:defgeneric ,name ,args

601

,@(remove :method options :key #'car :test #'eq)

602

,@(unless (member :generic-function-class options :key #'car :test #'eq)

603

'((:generic-function-class standard-generic-function)))))

604

(let ((generic-function (fdefinition ',name)))

605

(setf (slot-value generic-function 'initial-methods)

606

(list ,@(loop for method-spec in (remove :method options :key #'car :test-not #'eq)

607

collect `(defmethod ,name ,@(cdr method-spec)))))

608

generic-function)))

609

610

;; The following can be used in direct-slot-definition-class to get the correct initargs

611

;; for a slot. Use it like this:

612

;;

613

;; (defmethod direct-slot-definition-class

614

;; ((class my-standard-class) &rest initargs)

615

;; (declare (dynamic-extent initargs))

616

;; (destructuring-bind

617

;; (&key key-of-interest &allow-other-keys)

618

;; (fix-slot-initargs initargs)

619

;; ...))

620

621

(defvar *standard-slot-keys*

622

'(:name :documentation

623

:initargs :initform :initfunction

624

:readers :writers))

625

626

(defun fix-slot-initargs (initargs)

627

initargs)

628

629

;; Provide standard-instance-access and funcallable-standard-instance-access

630

631

(declaim (inline standard-instance-access

632

(setf standard-instance-access)))

633

634

(defun standard-instance-access (instance location)

635

(clos::fast-standard-instance-access instance location))

636

637

(defun (setf standard-instance-access) (new-value instance location)

638

(setf (clos::fast-standard-instance-access instance location) new-value))

639

640

(declaim (inline funcallable-instance-access))

641

642

(defun funcallable-instance-access (instance location &rest args)

643

(declare (dynamic-extent args))

644

(let* ((class (class-of instance))

645

(slot (find location (class-slots class)

646

:key #'slot-definition-location)))

647

(if slot

648

(apply #'clos::funcallable-instance-access instance (slot-definition-name slot) args)

649

(error "There is no slot with location ~S for instance ~S." location instance))))

650

651

(defun funcallable-standard-instance-access (instance location)

652

(funcallable-instance-access instance location))

653

654

(defun (setf funcallable-standard-instance-access) (new-value instance location)

655

(funcallable-instance-access instance location new-value))

656

657

(eval-when (:compile-toplevel :load-toplevel :execute)

658

(pushnew :closer-mop *features*))