/[cmucl]/src/pcl/seal.lisp
ViewVC logotype

Contents of /src/pcl/seal.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Fri Mar 19 15:19:03 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, 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-04, 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.3: +4 -3 lines
Merge intl-branch 2010-03-18 to HEAD.  To build, you need to use
boot-2010-02-1 as the bootstrap file.  You should probably also use
the new -P option for build.sh to generate and update the po files
while building.
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 (file-comment "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/seal.lisp,v 1.4 2010/03/19 15:19:03 rtoy Rel $")
31
32 (in-package "PCL")
33 (intl:textdomain "cmucl")
34
35 (define-condition sealed-error (simple-program-error)
36 ()
37 (:report (lambda (condition stream)
38 (format stream
39 (format nil "~~@<Sealing error: ~?~~@:>"
40 (simple-condition-format-control condition)
41 (simple-condition-format-arguments condition))))))
42
43 (defun sealed-error (format-control &rest args)
44 (error 'sealed-error :format-control format-control
45 :format-arguments args))
46
47 (defgeneric check-seal (object action seal))
48 (defgeneric applicable-seal-p (seal action))
49 (defgeneric make-seal (type name action spec))
50 (defgeneric seal-quality->type (quality))
51
52
53 ;;; *****************************************
54 ;;; Adding, Removing, Checking Seals *******
55 ;;; *****************************************
56
57 (defmacro seal (name &rest specifiers)
58 `(progn
59 (eval-when (:load-toplevel :execute)
60 (%seal ',name ',specifiers 'load))
61 (eval-when (:compile-toplevel)
62 (%seal ',name ',specifiers 'compile))))
63
64 (defun %seal (name specifiers time)
65 (loop for spec in specifiers
66 as quality = (if (consp spec) (car spec) spec)
67 as type = (seal-quality->type quality)
68 as seal = (make-seal type name quality spec) do
69 (ecase time
70 (compile
71 (push seal (seal-info-seals (seal-info-or-make name))))
72 (load
73 (let ((object (ecase type
74 (class (find-class name))
75 (generic-function (gdefinition name)))))
76 (push seal (plist-value object 'seals)))))))
77
78 (defun unseal (object)
79 (let ((name nil))
80 (when (symbolp object)
81 (setq name object)
82 (let ((class (find-class object nil)))
83 (when class
84 (setf (plist-value object 'seals) nil))))
85 (when (generic-function-name-p object)
86 (setq name object)
87 (setf (plist-value (gdefinition object) 'seals) nil))
88 (typecase object
89 (class (setq name (class-name object)))
90 (generic-function (setq name (generic-function-name object))))
91 (when name
92 (let ((info (seal-info name)))
93 (when info
94 (setf (seal-info-seals info) nil))))))
95
96 (defun check-seals (object action)
97 (let ((seals (if (or (symbolp object) (consp object))
98 (let ((info (seal-info object)))
99 (when info
100 (seal-info-seals info)))
101 (plist-value object 'seals))))
102 (dolist (seal seals)
103 (when (applicable-seal-p seal action)
104 (check-seal seal object action)))))
105
106
107 ;;; ***********************
108 ;;; Built-in Seals *******
109 ;;; ***********************
110
111 (defvar *seal-quality->type*
112 '((:subclasses . class)
113 (:methods . generic-function)))
114
115 (defvar *seal-quality->actions*
116 '((:subclasses . (add-direct-subclass remove-direct-subclass
117 expand-defclass))))
118
119 (defmethod seal-quality->type (quality)
120 (or (cdr (assq quality *seal-quality->type*))
121 (error _"~@<Invalid sealing specifier ~s.~@:>" quality)))
122
123 (defmethod make-seal (type name quality spec)
124 (declare (ignore type name spec))
125 (make-instance 'seal :quality quality))
126
127 (defmethod applicable-seal-p ((seal seal) action)
128 (memq action (cdr (assq (seal-quality seal) *seal-quality->actions*))))
129
130 (defmethod check-seal ((seal seal) object action)
131 (declare (ignore action))
132 (sealed-error _"~s is sealed wrt ~a" object (seal-quality seal)))
133
134 ;;; end of seal.lisp

  ViewVC Help
Powered by ViewVC 1.1.5