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

Contents of /src/code/fwrappers.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (hide annotations)
Tue Apr 20 17:57:44 2010 UTC (3 years, 11 months 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.7: +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 gerd 1.1 ;;; Copyright (C) 2003 Gerd Moellmann <gerd.moellmann@t-online.de>
2     ;;; All rights reserved.
3     ;;;
4     ;;; Redistribution and use in source and binary forms, with or without
5     ;;; modification, are permitted provided that the following conditions
6     ;;; are met:
7     ;;;
8     ;;; 1. Redistributions of source code must retain the above copyright
9     ;;; notice, this list of conditions and the following disclaimer.
10     ;;; 2. Redistributions in binary form must reproduce the above copyright
11     ;;; notice, this list of conditions and the following disclaimer in the
12     ;;; documentation and/or other materials provided with the distribution.
13     ;;; 3. The name of the author may not be used to endorse or promote
14     ;;; products derived from this software without specific prior written
15     ;;; permission.
16     ;;;
17     ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS
18     ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
19     ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
20     ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE
21     ;;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
22     ;;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT
23     ;;; OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
24     ;;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
25     ;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
26     ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
27     ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
28     ;;; DAMAGE.
29    
30 rtoy 1.8 (ext:file-comment "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/fwrappers.lisp,v 1.8 2010/04/20 17:57:44 rtoy Rel $")
31 gerd 1.1
32     (in-package :fwrappers)
33    
34 rtoy 1.6 (intl:textdomain "cmucl")
35    
36 gerd 1.1 (defstruct (fwrapper
37     (:alternate-metaclass kernel:funcallable-instance
38     kernel:funcallable-structure-class
39     kernel:make-funcallable-structure-class)
40     (:type kernel:funcallable-structure)
41     (:constructor make-fwrapper (constructor type user-data))
42     (:print-function print-fwrapper))
43 rtoy 1.6 _N"A funcallable instance used to implement fwrappers.
44 gerd 1.1 The CONSTRUCTOR slot is a function defined with DEFINE-FWRAPPER.
45     This function returns an instance closure closing over an
46     fwrapper object, which is installed as the funcallable-instance
47     function of the fwrapper object."
48     (next #'null :type function)
49     (type nil :type t)
50     (constructor #'null :type function)
51     (user-data nil :type t))
52    
53     (defun print-fwrapper (fwrapper stream depth)
54 rtoy 1.7 "Print-function for struct FWRAPPER."
55 gerd 1.1 (declare (ignore depth))
56     (print-unreadable-object (fwrapper stream :type t :identity t)
57     (format stream "~s" (fwrapper-type fwrapper))))
58    
59     (declaim (inline fwrapper-or-nil))
60     (defun fwrapper-or-nil (fun)
61 rtoy 1.7 "Return FUN if it is an fwrapper or nil if it isn't."
62 gerd 1.1 (and (functionp fun)
63     ;; Necessary for cold-load reasons.
64     (= (get-type fun) vm:funcallable-instance-header-type)
65     (fwrapper-p fun)
66     fun))
67    
68     (defmacro do-fwrappers ((var fdefn &optional result) &body body)
69 rtoy 1.7 "Evaluate BODY with VAR bound to consecutive fwrappers of
70 gerd 1.1 FDEFN. Return RESULT at the end."
71     `(loop for ,var = (fwrapper-or-nil (fdefn-function ,fdefn))
72     then (fwrapper-or-nil (fwrapper-next ,var))
73     while ,var do (locally ,@body)
74     finally (return ,result)))
75    
76     (declaim (inline last-fwrapper))
77     (defun last-fwrapper (fdefn)
78 rtoy 1.7 "Return tha last encapsulation of FDEFN or NIL if none."
79 gerd 1.1 (do-fwrappers (f fdefn)
80     (when (null (fwrapper-or-nil (fwrapper-next f)))
81     (return f))))
82    
83     (defun push-fwrapper (f function-name)
84 rtoy 1.7 "Prepend encapsulation F to the definition of FUNCTION-NAME.
85 gerd 1.1 Signal an error if FUNCTION-NAME is an undefined function."
86     (declare (type fwrapper f))
87     (let ((fdefn (fdefn-or-lose function-name)))
88     (setf (fwrapper-next f) (fdefn-function fdefn))
89     (setf (fdefn-function fdefn) f)))
90    
91     (defun delete-fwrapper (f function-name)
92 rtoy 1.7 "Remove fwrapper F from the definition of FUNCTION-NAME."
93 gerd 1.1 (set-fwrappers function-name
94     (delete f (list-fwrappers function-name))))
95    
96     (defun list-fwrappers (function-name)
97 rtoy 1.7 "Return a list of all fwrappers of FUNCTION-NAME, ordered
98 gerd 1.1 from outermost to innermost."
99     (collect ((result))
100     (do-fwrappers (f (fdefn-or-lose function-name) (result))
101     (result f))))
102    
103     (defun set-fwrappers (function-name fwrappers)
104 rtoy 1.7 "Set FUNCTION-NAMES's fwrappers to elements of the list
105 gerd 1.1 FWRAPPERS, which is assumed to be ordered from outermost to
106     innermost. FWRAPPERS null means remove all fwrappers."
107     (let ((fdefn (fdefn-or-lose function-name))
108     (primary-function (fdefinition function-name)))
109     (setf (fdefn-function fdefn) primary-function)
110     (dolist (f (reverse fwrappers))
111     (push-fwrapper f function-name))))
112    
113     (defun fwrap (function-name constructor &key type user-data)
114 rtoy 1.7 "Wrap the function named FUNCTION-NAME in an fwrapper of type TYPE,
115 gerd 1.3 created by calling CONSTRUCTOR. CONSTRUCTOR is a function
116     defined with DEFINE-FWRAPPER, or the name of such a function.
117 gerd 1.1 Return the fwrapper created. USER-DATA is arbitrary data to be
118     associated with the fwrapper. It is accessible in wrapper
119     functions defined with DEFINE-FWRAPPER as (FWRAPPER-USER-DATA
120     FWRAPPER)."
121 gerd 1.3 (let ((f (make-fwrapper (coerce constructor 'function) type user-data)))
122 gerd 1.1 (update-fwrapper f)
123     (push-fwrapper f function-name)))
124    
125     (defun funwrap (function-name &key (type nil type-p) test)
126 rtoy 1.7 "Remove fwrappers from the function named FUNCTION-NAME.
127 gerd 1.1 If TYPE is supplied, remove fwrappers whose type is equal to TYPE.
128 gerd 1.4 If TEST is supplied, remove fwrappers satisfying TEST.
129     If both are not specified, remove all fwrappers."
130 gerd 1.1 (collect ((new))
131 gerd 1.4 (when (or type-p test)
132     (do-fwrappers (f (fdefn-or-lose function-name))
133     (when (or (not type-p) (not (equal type (fwrapper-type f))))
134     (when (or (null test) (not (funcall test f)))
135     (new f))))
136     (set-fwrappers function-name (new)))))
137 gerd 1.1
138     (defun update-fwrapper (f)
139 rtoy 1.7 "Update the funcallable instance function of fwrapper F from its
140 gerd 1.1 constructor."
141     (setf (kernel:funcallable-instance-function f)
142     (funcall (fwrapper-constructor f) f)))
143    
144     (defun update-fwrappers (function-name &key (type nil type-p) test)
145 rtoy 1.7 "Update fwrapper function definitions of FUNCTION-NAME.
146 gerd 1.1 If TYPE is supplied, update fwrappers whose type is equal to TYPE.
147     If TEST is supplied, update fwrappers satisfying TEST."
148     (do-fwrappers (f (fdefn-or-lose function-name))
149     (when (or (not type-p) (not (equal type (fwrapper-type f))))
150     (when (or (null test) (not (funcall test f)))
151     (update-fwrapper f)))))
152    
153     (defun find-fwrapper (function-name &key (type nil type-p) test)
154 rtoy 1.7 "Find an fwrapper of FUNCTION-NAME.
155 gerd 1.1 If TYPE is supplied, find an fwrapper whose type is equal to TYPE.
156     If TEST is supplied, find an fwrapper satisfying TEST."
157     (do-fwrappers (f (fdefn-or-lose function-name))
158     (when (or (not type-p) (equal type (fwrapper-type f)))
159     (when (or (null test) (funcall test f))
160     (return f)))))
161    
162     (defmacro define-fwrapper (name lambda-list &body body &environment env)
163 rtoy 1.7 "Like DEFUN, but define a function wrapper.
164 gerd 1.1 In BODY, the symbol FWRAPPERS:FWRAPPERS refers to the currently
165     executing fwrapper. FWRAPPERS:CALL-NEXT-FUNCTION can be used
166     in BODY to call the next fwrapper or the primary function. When
167     called with no arguments, CALL-NEXT-FUNCTION invokes the next
168     function with the original args to the fwrapper, otherwise it
169     invokes the next function with the supplied args."
170     (expand-define-fwrapper name lambda-list body env))
171    
172     (eval-when (:compile-toplevel :load-toplevel :execute)
173     (defun expand-define-fwrapper (name lambda-list body env)
174 rtoy 1.7 "Return the expansion of a DEFINE-FWRAPPER."
175 gerd 1.1 (multiple-value-bind (required optional restp rest keyp keys allowp
176     aux morep)
177     (kernel:parse-lambda-list lambda-list)
178     (when morep
179 rtoy 1.8 (error (intl:gettext "&MORE not supported in fwrapper lambda lists")))
180 gerd 1.1 (multiple-value-bind (body declarations documentation)
181     (system:parse-body body env t)
182     (multiple-value-bind (lambda-list call-next)
183     (flet ((make-call-next (restp)
184     `(multiple-value-call (fwrapper-next fwrapper)
185     (values ,@required)
186     ,(if restp
187     `(values-list ,rest)
188     `(c:%more-arg-values .c. 0 .n.))))
189     (make-lambda-list (optp restp)
190     `(,@required
191     ,@(when (and optp optional) `(&optional ,@optional))
192     ,@(cond ((eq restp t) `(&rest ,rest))
193     ((null restp) `(c:&more .c. .n.))
194     (t nil))
195     ,@(when keyp `(&key))
196     ,@(when (and optp keys) `(,@keys))
197     ,@(when allowp `(&allow-other-keys))
198     ,@(when aux `(&aux ,@aux)))))
199     (if (or restp keys optional)
200     (multiple-value-bind (used-p rest-used-p)
201     (uses-vars-p `(progn . ,body) optional keys rest env)
202     (values (make-lambda-list used-p rest-used-p)
203     (make-call-next rest-used-p)))
204     (values (make-lambda-list nil :none)
205     `(funcall (fwrapper-next fwrapper) ,@required))))
206     `(defun ,name (fwrapper)
207     ,@(when documentation `(,documentation))
208     #'(kernel:instance-lambda ,lambda-list
209     ,@declarations
210     (flet ((%call-next-function ()
211     ,call-next))
212     (declare (ignorable #'%call-next-function))
213     (macrolet ((call-next-function (&rest args)
214     (if args
215     `(funcall (fwrapper-next fwrapper) ,@args)
216     `(%call-next-function))))
217     ,@body))))))))
218    
219     (defun uses-vars-p (body optionals keys rest env)
220 rtoy 1.7 "First value is true if BODY refers to any of the variables in
221 gerd 1.1 OPTIONALS, KEYS or REST, which are what KERNEL:PARSE-LAMBDA-LIST
222     returns. Second value is true if BODY refers to REST."
223     (collect ((vars))
224     (dolist (v (append optionals keys))
225     (etypecase v
226     (cons
227     (destructuring-bind (v &optional value supplied-p) v
228     (declare (ignore value))
229     (vars (if (consp v) (cadr v) v))
230     (when supplied-p (vars supplied-p))))
231     (symbol
232     (vars v))))
233     (when rest
234     (vars rest))
235     (let (used-p rest-used-p)
236     (flet ((walk (form context env)
237     (when (and (eq context :eval)
238     (symbolp form)
239     (memq form (vars))
240     (not (walker:variable-lexical-p form env)))
241     (setq used-p t)
242     (setq rest-used-p (or rest-used-p (eq form rest))))
243     form))
244     (walker:walk-form body env #'walk)
245     (values used-p rest-used-p)))))
246 toy 1.5 )
247 gerd 1.1
248    
249     ;;;
250     ;;; Compatibility with old encapsulation API.
251     ;;;
252    
253     (define-fwrapper encapsulation-fwrapper (&rest args)
254 rtoy 1.7 "Fwrapper for old-style encapsulations."
255 gerd 1.1 (let ((basic-definition (fwrapper-next fwrapper))
256     (argument-list args))
257     (declare (special basic-definition argument-list))
258     (eval (fwrapper-user-data fwrapper))))
259    
260     (defun encapsulate (name type body)
261 rtoy 1.7 "This function is deprecated; use fwrappers instead."
262 gerd 1.1 (fwrap name #'encapsulation-fwrapper :type type :user-data body))
263    
264     (defun unencapsulate (name type)
265 rtoy 1.7 "This function is deprecated; use fwrappers instead."
266 gerd 1.1 (funwrap name :type type))
267    
268     (defun encapsulated-p (name type)
269 rtoy 1.7 "This function is deprecated; use fwrappers instead."
270 gerd 1.2 (not (null (find-fwrapper name :type type))))
271 gerd 1.1
272     ;;; end of file

  ViewVC Help
Powered by ViewVC 1.1.5