/[cmucl]/src/code/fdefinition.lisp
ViewVC logotype

Contents of /src/code/fdefinition.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (show annotations)
Tue Apr 20 17:57:44 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.28: +2 -2 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/fdefinition.lisp,v 1.29 2010/04/20 17:57:44 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Functions that hack on the global function namespace (primarily
13 ;;; concerned with SETF functions here). Also, function encapsulation
14 ;;; and routines that set and return definitions disregarding whether
15 ;;; they might be encapsulated.
16 ;;;
17 ;;; Written by Rob MacLachlan
18 ;;; Modified by Bill Chiles (wrote encapsulation stuff)
19 ;;; Modified more by William Lott (added ``fdefn'' objects)
20 ;;;
21
22 (in-package "EXTENSIONS")
23
24 (intl:textdomain "cmucl")
25
26 (export '(encapsulate unencapsulate encapsulated-p
27 basic-definition argument-list *setf-fdefinition-hook*
28 define-function-name-syntax valid-function-name-p))
29
30
31 (in-package "KERNEL")
32
33 (export '(fdefn make-fdefn fdefn-p fdefn-name fdefn-function fdefn-makunbound
34 fdefn-or-lose %coerce-to-function raw-definition))
35
36
37 (in-package "LISP")
38
39 (export '(fdefinition fboundp fmakunbound))
40
41
42
43 ;;;; Function names.
44
45 (defvar *valid-function-names* ())
46
47 (defun %define-function-name-syntax (name syntax-checker)
48 (let ((found (assoc name *valid-function-names* :test #'eq)))
49 (if found
50 (setf (cdr found) syntax-checker)
51 (setq *valid-function-names*
52 (acons name syntax-checker *valid-function-names*)))))
53
54 (defmacro define-function-name-syntax (name (var) &body body)
55 "Define (NAME ...) to be a valid function name whose syntax is checked
56 by BODY. In BODY, VAR is bound to an actual function name of the
57 form (NAME ...) to check. BODY should return two values.
58 First value true means the function name is valid. Second value
59 is the name, a symbol, of the function for use in the BLOCK of DEFUNs
60 and in similar situations."
61 (let ((syntax-checker (symbolicate '%check- name '-function-name)))
62 `(progn
63 (defun ,syntax-checker (,var) ,@body)
64 (%define-function-name-syntax ',name #',syntax-checker))))
65
66 (defun valid-function-name-p (name)
67 "First value is true if NAME has valid function name syntax.
68 Second value is the name, a symbol, to use as a block name in DEFUNs
69 and in similar situations."
70 (typecase name
71 (cons
72 (cond
73 ((and (symbolp (car name))
74 (consp (cdr name)))
75 (let ((syntax-checker (cdr (assoc (car name) *valid-function-names*
76 :test #'eq))))
77 (if syntax-checker
78 (funcall syntax-checker name)
79 (values nil name))))
80 (t
81 (values nil name))))
82 (symbol (values t name))
83 (otherwise (values nil name))))
84
85 (define-function-name-syntax setf (name)
86 (destructuring-bind (setf fn &rest rest) name
87 (declare (ignore setf))
88 (if rest
89 (values nil name)
90 (typecase fn
91 (symbol
92 (values t fn))
93 (cons
94 (cond ((eq 'setf (car fn))
95 (values nil fn))
96 (t
97 (valid-function-name-p fn))))
98 (otherwise
99 (values nil fn))))))
100
101 (define-function-name-syntax :macro (name)
102 (when (eql 2 (length name))
103 (valid-function-name-p (second name))))
104
105 (define-function-name-syntax :compiler-macro (name)
106 (when (eql 2 (length name))
107 (valid-function-name-p (second name))))
108
109 (define-function-name-syntax flet (name)
110 (valid-function-name-p (cadr name)))
111
112 (define-function-name-syntax labels (name)
113 (valid-function-name-p (cadr name)))
114
115
116 ;;;; Fdefinition (fdefn) objects.
117
118 (defun make-fdefn (name)
119 (make-fdefn name))
120
121 (defun fdefn-name (fdefn)
122 (declare (type fdefn fdefn))
123 (fdefn-name fdefn))
124
125 (defun fdefn-function (fdefn)
126 (declare (type fdefn fdefn)
127 (values (or function null)))
128 (fdefn-function fdefn))
129
130 (defun (setf fdefn-function) (fun fdefn)
131 (declare (type function fun)
132 (type fdefn fdefn)
133 (values function))
134 (setf (fdefn-function fdefn) fun))
135
136 (defun fdefn-makunbound (fdefn)
137 (declare (type fdefn fdefn))
138 (fdefn-makunbound fdefn))
139
140
141 ;;; FDEFN-INIT -- internal interface.
142 ;;;
143 ;;; This function is called by %INITIAL-FUNCTION after the globaldb has been
144 ;;; initialized, but before anything else. We need to install these fdefn
145 ;;; objects into the globaldb *before* any top level forms run, or we will
146 ;;; end up with two different fdefn objects being used for the same function
147 ;;; name. *INITIAL-FDEFN-OBJECTS* is set up by GENESIS.
148 ;;;
149 (defvar *initial-fdefn-objects*)
150
151 (defun fdefn-init ()
152 (setq *valid-function-names* nil)
153 (dolist (fdefn *initial-fdefn-objects*)
154 (setf (info function definition (fdefn-name fdefn)) fdefn))
155 (makunbound '*initial-fdefn-objects*))
156
157 ;;; FDEFINITION-OBJECT -- internal interface.
158 ;;;
159 (defun fdefinition-object (name create)
160 "Return the fdefn object for NAME. If it doesn't already exist and CREATE
161 is non-NIL, create a new (unbound) one."
162 (declare (values (or fdefn null)))
163 (multiple-value-bind (valid-name-p fname)
164 (valid-function-name-p name)
165 (unless valid-name-p
166 (error 'simple-type-error
167 :datum fname
168 :expected-type '(satisfies valid-function-name-p)
169 :format-control (intl:gettext "Invalid function name: ~S")
170 :format-arguments (list name))))
171 (let ((fdefn (info function definition name)))
172 (if (and (null fdefn) create)
173 (setf (info function definition name) (make-fdefn name))
174 fdefn)))
175
176 (declaim (inline fdefn-or-lose))
177 (defun fdefn-or-lose (name)
178 "Return the FDEFN of NAME. Signal an error if there is none
179 or if it's function is null."
180 (let ((fdefn (fdefinition-object name nil)))
181 (unless (and fdefn (fdefn-function fdefn))
182 (error 'undefined-function :name name))
183 fdefn))
184
185 ;;; %COERCE-TO-FUNCTION -- public.
186 ;;;
187 ;;; The compiler emits calls to this when someone tries to funcall a symbol.
188 ;;;
189 (defun %coerce-to-function (name)
190 "Returns the definition for name, including any encapsulations. Settable
191 with SETF."
192 (fdefn-function (fdefn-or-lose name)))
193
194 ;;; RAW-DEFINITION -- public.
195 ;;;
196 ;;; Just another name for %coerce-to-function.
197 ;;;
198 (declaim (inline raw-definition))
199 (defun raw-definition (name)
200 (declare (optimize (inhibit-warnings 3)))
201 ;; We know that we are calling %coerce-to-function, so don't tell us about
202 ;; it.
203 (%coerce-to-function name))
204
205 (defun (setf raw-definition) (function name)
206 (let ((fdefn (fdefinition-object name t)))
207 (setf (fdefn-function fdefn) function)))
208
209
210 ;;;; FDEFINITION.
211
212 (defun fdefinition (function-name)
213 "Return FUNCTION-NAME's global function definition.
214 If FUNCTION-NAME is fwrapped, return the primary function definition
215 stored in the innermost fwrapper."
216 (let* ((fdefn (fdefn-or-lose function-name))
217 (last (fwrappers:last-fwrapper fdefn)))
218 (if last
219 (fwrappers:fwrapper-next last)
220 (fdefn-function fdefn))))
221
222 (defvar *setf-fdefinition-hook* nil
223 "This holds functions that (SETF FDEFINITION) invokes before storing the
224 new value. These functions take the function name and the new value.")
225
226 (defun %set-fdefinition (function-name new-value)
227 "Set FUNCTION-NAME's global function definition to NEW-VALUE.
228 If FUNCTION-NAME is fwrapped, set the primary function stored
229 in the innermost fwrapper."
230 (declare (type function new-value) (optimize (safety 1)))
231 (let ((fdefn (fdefinition-object function-name t)))
232 (when (boundp '*setf-fdefinition-hook*)
233 (dolist (f *setf-fdefinition-hook*)
234 (funcall f function-name new-value)))
235 (let ((last (fwrappers:last-fwrapper fdefn)))
236 (if last
237 (setf (fwrappers:fwrapper-next last) new-value)
238 (setf (fdefn-function fdefn) new-value)))))
239
240 (defsetf fdefinition %set-fdefinition)
241
242
243
244 ;;;; FBOUNDP and FMAKUNBOUND.
245
246 (defun fboundp (name)
247 "Return true if name has a global function definition."
248 (let ((fdefn (fdefinition-object name nil)))
249 (and fdefn (fdefn-function fdefn) t)))
250
251 (defun fmakunbound (name)
252 "Make Name have no global function definition."
253 (let ((fdefn (fdefinition-object name nil)))
254 (when fdefn
255 (fdefn-makunbound fdefn)))
256 (kernel:undefine-function-name name)
257 name)

  ViewVC Help
Powered by ViewVC 1.1.5