Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[88db3f]: src / clos / slotvalue.lsp Maximize Restore History

Download this file

slotvalue.lsp    77 lines (63 with data), 2.5 kB

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
;;;;
;;;; Copyright (c) 1992, Giuseppe Attardi.o
;;;; Copyright (c) 2001, Juan Jose Garcia Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "CLOS")
(defmethod class-prototype ((class class))
(unless (slot-boundp class 'prototype)
(setf (slot-value class 'prototype) (allocate-instance class)))
(slot-value class 'prototype))
(defun slot-makunbound (self slot-name)
(let* ((class (class-of self))
(slotd (find-slot-definition class slot-name)))
(if slotd
(slot-makunbound-using-class class self slotd)
(slot-missing class self slot-name 'SLOT-MAKUNBOUND))
self))
(defmethod slot-value-using-class ((class class) self slotd)
(slot-value self (slot-definition-name slotd)))
(defmethod slot-boundp-using-class ((class class) self slotd)
(declare (ignore class))
(slot-boundp self (slot-definition-name slotd)))
(defmethod (setf slot-value-using-class) (val (class class) self slotd)
(declare (ignore class))
(setf (slot-value self (slot-definition-name slotd)) val))
(defmethod slot-makunbound-using-class ((class class) instance slotd)
(declare (ignore class))
(ensure-up-to-date-instance instance)
(let* ((location (slot-definition-location slotd)))
(cond ((ext:fixnump location)
;; local slot
(si:sl-makunbound instance (truly-the fixnum location)))
((consp location)
;; shared slot
(setf (car location) (unbound)))
(t
(error "Effective slot definition lacks a valid location:~%~A"
slotd))))
instance)
;;;
;;; 3) Error messages related to slot access
;;;
(defmethod slot-missing ((class t) object slot-name operation
&optional new-value)
(declare (ignore operation new-value class))
(error "~A is not a slot of ~A" slot-name object))
(defmethod slot-unbound ((class t) object slot-name)
(declare (ignore class))
(error 'unbound-slot :instance object :name slot-name))
;;;
;;; For the next accessor we define a method.
;;;
(defmethod class-name ((class class))
(class-id class))
(defmethod (setf class-name) (new-value (class class))
(reinitialize-instance class :name new-value)
new-value)