Learn how easy it is to sync an existing GitHub or Google Code repo to a SourceForge project! See Demo

Close

[5be366]: src / clos / slot.lsp Maximize Restore History

Download this file

slot.lsp    158 lines (144 with data), 5.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
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLOS -*-
;;;;
;;;; Copyright (c) 1992, Giuseppe Attardi.
;;;; 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")
(defconstant +initform-unsupplied+ '+initform-unsupplied+)
;;; ----------------------------------------------------------------------
;;; SLOT descriptors
;;;
(defun make-simple-slotd (class
&key name (initform +initform-unsupplied+) initfunction
(type 'T) (allocation :instance)
initargs readers writers documentation location)
(when (and (eq allocation :class)
(functionp initfunction))
(setf initfunction (constantly (funcall initfunction))))
(with-early-make-instance +slot-definition-slots+
(slotd class
:name name
:initform initform
:initfunction (if (listp initfunction) (eval initfunction) initfunction)
:type type
:allocation allocation
:initargs initargs
:readers readers
:writers writers
:documentation documentation
:location location)
slotd))
(defun freeze-class-slot-initfunction (slotd)
(when (eq (getf slotd :allocation) :class)
(let ((initfunc (getf slotd :initfunction)))
(when initfunc
(setf (getf slotd :initfunction)
(constantly (funcall initfunc))))))
slotd)
(defun canonical-slot-to-direct-slot (class slotd)
;; Class slot init functions must be called right away
(setf slotd (freeze-class-slot-initfunction slotd))
(if (find-class 'slot-definition nil)
(apply #'make-instance
(apply #'direct-slot-definition-class class
(freeze-class-slot-initfunction slotd))
slotd)
(apply #'make-simple-slotd class slotd)))
(defun direct-slot-to-canonical-slot (slotd)
(list . #.(loop for (name . rest) in +slot-definition-slots+
collect (getf rest :initarg)
collect `(,(getf rest :accessor) slotd))))
(loop with all-slots = '#.+slot-definition-slots+
for slotd in all-slots
for i from 0
for fname = (getf (rest slotd) :accessor)
do (let ((name (first slotd)))
(setf (fdefinition fname)
#'(lambda (x)
(if (consp x)
(nth position x)
(slot-value x name)))
(fdefinition `(setf ,fname))
#'(lambda (v x)
(if (consp x)
(setf (nth position x) v)
(setf (slot-value x name) v))))))
;;; ----------------------------------------------------------------------
;;;
;;; (PARSE-SLOTS slot-definition-form) => slot-definition-object
;;;
;;; This routine is the one responsible for parsing the definition of
;;; a slot in DEFCLASS.
;;;
(defun make-function-initform (form)
;; INITFORM is a form that is to be evaluated at runtime. If it is a
;; constant value, we output simply a quoted form. If it is not,
;; we output a function that can be invoked at runtime to retrieve
;; the value.
;;
;; Output => (FUNCTION (LAMBDA () form))
;; => (QUOTE ...)
;;
(if (constantp form)
`(constantly ,form)
`#'(lambda () ,form)))
(defun parse-slot (slot &optional (full nil))
(declare (si::c-local))
(if (symbolp slot)
(list* :name slot
(when full (list :initform '+INITFORM-UNSUPPLIED+ :initfunction nil
:initargs nil :readers nil :writers nil
:allocation :instance :documentation nil
:type 'T)))
(do* ((output (parse-slot (first slot) full))
(options (rest slot))
(value nil)
(extra nil))
((null options)
(nconc output extra))
(let ((option (pop options)))
(when (endp options)
(si::simple-program-error
"In the slot description ~S,~%the option ~S is missing an argument"
slot option))
(let ((value (pop options)))
(when (and (member option '(:allocation :initform :type :documentation))
(getf options option))
(si::simple-program-error
"In the slot description ~S,~%the option ~S is duplicated"
slot option))
(case option
(:initarg (push value (getf output :initargs)))
(:initform (setf (getf output :initform) value
(getf output :initfunction)
(make-function-initform value)))
(:accessor (push value (getf output :readers))
(push `(setf ,value) (getf output :writers)))
(:reader (push value (getf output :readers)))
(:writer (push value (getf output :writers)))
(:allocation (setf (getf output :allocation) value))
(:type (setf (getf output :type) value))
(:documentation (push value (getf output :documentation)))
(otherwise (if (or (getf extra option)
(getf options option))
(push value (getf extra option))
(setf (getf extra option) value)))))))))
(defun parse-slots (slots)
(do ((scan slots (cdr scan))
(collect))
((null scan) (nreverse collect))
(let* ((slotd (parse-slot (first scan)))
(name (getf slotd :name)))
(dolist (other-slotd collect)
(when (eq name (getf other-slotd :name))
(si::simple-program-error
"A definition for the slot ~S appeared twice in a DEFCLASS form"
name)))
(push slotd collect))))
;;; ----------------------------------------------------------------------