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

Contents of /src/pcl/macros.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.29 - (hide annotations)
Wed Jun 18 09:23:09 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: double-double-array-base, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, unicode-string-buffer-base, sse2-packed-base, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, release-19c-base, label-2009-03-16, release-19f-base, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2007-06, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, double-double-init-x86, sse2-checkpoint-2008-10-01, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, unicode-string-buffer-branch, dynamic-extent, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.28: +2 -2 lines
	Remove package nicknames USER from COMMON-LISP-USER.  Add a new
	package COMMON-LISP which LISP uses, so that COMMON-LISP no longer
	has the non-ANSI nickname LISP.

	To bootstrap, use boot13.lisp as target:bootstrap.lisp with pmai's
	build scripts, and do a full compile.

	* src/bootfiles/18e/boot13.lisp: Change for all the package
	changes.

	* src/code/exports.lisp: New package common-lisp,
	which lisp uses.

	* src/tools/worldload.lisp:
	* src/tools/setup.lisp: Use cl-user instead of user.
	Use lisp:: instead of cl::.

	* src/tools/worldcom.lisp:
	* src/tools/snapshot-update.lisp:
	* src/tools/pclcom.lisp:
	* src/tools/mk-lisp:
	* src/tools/hemcom.lisp:
	* src/tools/config.lisp:
	* src/tools/comcom.lisp:
	* src/tools/clxcom.lisp:
	* src/tools/clmcom.lisp:
	* src/pcl/defsys.lisp:
	* src/motif/lisp/initial.lisp:
	* src/interface/initial.lisp:
	* src/hemlock/lispmode.lisp (setup-lisp-mode):
	Use cl-user instead of user.

	* src/code/save.lisp (assert-user-package):
	* src/code/print.lisp (%with-standard-io-syntax): Find
	cl-user package instead of user.

	* src/code/package.lisp (package-locks-init): Add lisp.
	(package-init): Don't add user nickname to cl-user.

	* src/code/ntrace.lisp (*trace-encapsulate-package-names*):
	Add common-lisp.

	* src/code/hash.lisp (toplevel):
	* src/code/hash-new.lisp (toplevel): Use in-package :lisp
	instead of :common-lisp.

	* src/code/float-trap.lisp (sigfpe-handler): Don't
	qualify floating-point-inexact with ext:.

	* src/pcl/simple-streams/strategy.lisp (sc):
	* src/pcl/simple-streams/null.lisp (null-read-char):
	* src/pcl/simple-streams/internal.lisp (allocate-buffer)
	(free-buffer):
	* src/pcl/simple-streams/impl.lisp (%check, %read-line)
	(%peek-char, %read-byte):
	* src/pcl/simple-streams/file.lisp (open-file-stream)
	(device-close):
	* src/pcl/simple-streams/classes.lisp (simple-stream)
	(device-close):
	* src/pcl/macros.lisp (toplevel):
	* src/pcl/braid.lisp (lisp::sxhash-instance):
	* src/pcl/env.lisp (toplevel):
	* src/compiler/generic/objdef.lisp (symbol-hash):
	* src/code/stream.lisp (read-sequence, write-sequence):
	* src/code/macros.lisp (defmacro, deftype):
	* src/code/eval.lisp (interpreted-function):
	* src/code/defstruct.lisp (defstruct):
	* src/code/debug.lisp (debug-eval-print): Use lisp:: instead
	of cl::.
1 wlott 1.1 ;;;-*-Mode:LISP; Package:(PCL (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
2     ;;;
3     ;;; *************************************************************************
4     ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5     ;;; All rights reserved.
6     ;;;
7     ;;; Use and copying of this software and preparation of derivative works
8     ;;; based upon this software are permitted. Any distribution of this
9     ;;; software or derivative works must comply with all applicable United
10     ;;; States export control laws.
11     ;;;
12     ;;; This software is made available AS IS, and Xerox Corporation makes no
13     ;;; warranty about the software, its performance or its conformity to any
14     ;;; specification.
15     ;;;
16     ;;; Any person obtaining a copy of this software is requested to send their
17     ;;; name and post office or electronic mail address to:
18     ;;; CommonLoops Coordinator
19     ;;; Xerox PARC
20     ;;; 3333 Coyote Hill Rd.
21     ;;; Palo Alto, CA 94304
22     ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23     ;;;
24     ;;; Suggestions, comments and requests for improvements are also welcome.
25     ;;; *************************************************************************
26     ;;;
27 pw 1.14
28 gerd 1.25 (file-comment
29 gerd 1.29 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/macros.lisp,v 1.29 2003/06/18 09:23:09 gerd Rel $")
30 dtc 1.10 ;;;
31 wlott 1.1 ;;; Macros global variable definitions, and other random support stuff used
32     ;;; by the rest of the system.
33     ;;;
34     ;;; For simplicity (not having to use eval-when a lot), this file must be
35     ;;; loaded before it can be compiled.
36     ;;;
37    
38 phg 1.6 (in-package :pcl)
39 wlott 1.1
40 gerd 1.22 (declaim (declaration class variable-rebinding method-name
41     method-lambda-list))
42 wlott 1.1
43 gerd 1.22 (eval-when (:compile-toplevel :load-toplevel :execute)
44    
45     ;; (CLASS-PREDICATE <CLASS-NAME>
46 gerd 1.25 (define-function-name-syntax class-predicate (name)
47 gerd 1.24 (when (symbolp (cadr name))
48     (values t (cadr name))))
49 gerd 1.22
50     ;; (SLOT-ACCESSOR <CLASS> <SLOT> <READER/WRITER/BOUNDP>)
51     ;; <CLASS> is :GLOBAL for functions used by ACCESSOR-SLOT-VALUE etc.
52 gerd 1.25 (define-function-name-syntax slot-accessor (name)
53 gerd 1.24 (values (and (symbolp (cadr name))
54     (consp (cddr name))
55     (symbolp (caddr name))
56     (consp (cdddr name))
57     (member (cadddr name) '(reader writer boundp)))
58     (caddr name)))
59 gerd 1.22
60     ;; (METHOD NAME QUALIFIERS (SPECIALIZERS))
61 gerd 1.25 (define-function-name-syntax method (name)
62     (valid-function-name-p (cadr name)))
63 gerd 1.22
64     ;; (FAST-METHOD NAME QUALIFIERS (SPECIALIZERS))
65 gerd 1.25 (define-function-name-syntax fast-method (name)
66     (valid-function-name-p (cadr name)))
67 gerd 1.22
68     ;; (EFFECTIVE-METHOD GF-NAME METHOD-SPEC ...)
69 gerd 1.25 (define-function-name-syntax effective-method (name)
70     (valid-function-name-p (cadr name))))
71 gerd 1.28
72     (defun pcl-internal-function-name-p (name)
73     (and (consp name)
74     (memq (car name)
75     '(class-predicate slot-accessor
76     method fast-method effective-method))))
77 gerd 1.22
78 gerd 1.29 (import '(lisp::make-keyword))
79 gerd 1.22
80 gerd 1.25 (defmacro posq (item list)
81     `(position ,item ,list :test #'eq))
82 wlott 1.1
83 gerd 1.25 (defmacro neq (x y)
84 emarsden 1.26 `(not (eq ,x ,y)))
85 ram 1.5
86 gerd 1.25 (declaim (inline car-safe))
87     (defun car-safe (obj)
88     (when (consp obj)
89     (car obj)))
90 wlott 1.1
91     (defmacro doplist ((key val) plist &body body &environment env)
92 pmai 1.19 (multiple-value-bind (bod decls doc)
93     (system:parse-body body env)
94 wlott 1.1 (declare (ignore doc))
95     `(let ((.plist-tail. ,plist) ,key ,val)
96     ,@decls
97     (loop (when (null .plist-tail.) (return nil))
98     (setq ,key (pop .plist-tail.))
99     (when (null .plist-tail.)
100     (error "Malformed plist in doplist, odd number of elements."))
101     (setq ,val (pop .plist-tail.))
102     (progn ,@bod)))))
103    
104 gerd 1.25
105 ram 1.5 ;;;
106     ;;; FIND-CLASS
107     ;;;
108     ;;; This is documented in the CLOS specification.
109     ;;;
110     (defvar *find-class* (make-hash-table :test #'eq))
111 wlott 1.1
112 ram 1.3 (defun function-returning-nil (x)
113     (declare (ignore x))
114     nil)
115    
116 ram 1.5 (defmacro find-class-cell-class (cell)
117     `(car ,cell))
118 ram 1.3
119 ram 1.5 (defmacro find-class-cell-predicate (cell)
120 phg 1.6 `(cadr ,cell))
121 ram 1.3
122 ram 1.5 (defmacro make-find-class-cell (class-name)
123     (declare (ignore class-name))
124 phg 1.6 '(list* nil #'function-returning-nil nil))
125 ram 1.5
126     (defun find-class-cell (symbol &optional dont-create-p)
127     (or (gethash symbol *find-class*)
128     (unless dont-create-p
129     (unless (legal-class-name-p symbol)
130 gerd 1.22 (error "~@<~S is not a legal class name.~@:>" symbol))
131 ram 1.5 (setf (gethash symbol *find-class*) (make-find-class-cell symbol)))))
132    
133     (defvar *create-classes-from-internal-structure-definitions-p* t)
134    
135     (defun find-class-from-cell (symbol cell &optional (errorp t))
136     (or (find-class-cell-class cell)
137     (and *create-classes-from-internal-structure-definitions-p*
138 gerd 1.22 (or (condition-type-p symbol) (structure-type-p symbol))
139     (ensure-non-standard-class symbol))
140 ram 1.5 (cond ((null errorp) nil)
141     ((legal-class-name-p symbol)
142 gerd 1.22 (error "No class named ~S." symbol))
143 ram 1.5 (t
144     (error "~S is not a legal class name." symbol)))))
145    
146     (defun find-class-predicate-from-cell (symbol cell &optional (errorp t))
147     (unless (find-class-cell-class cell)
148     (find-class-from-cell symbol cell errorp))
149     (find-class-cell-predicate cell))
150    
151     (defun legal-class-name-p (x)
152 gerd 1.22 (symbolp x))
153 ram 1.5
154     (defun find-class (symbol &optional (errorp t) environment)
155 pw 1.13 "Returns the PCL class metaobject named by SYMBOL. An error of type
156     SIMPLE-ERROR is signaled if the class does not exist unless ERRORP
157     is NIL in which case NIL is returned. SYMBOL cannot be a keyword."
158 ram 1.5 (declare (ignore environment))
159 gerd 1.22 (find-class-from-cell symbol (find-class-cell symbol t) errorp))
160 ram 1.5
161     (defun find-class-predicate (symbol &optional (errorp t) environment)
162     (declare (ignore environment))
163 phg 1.6 (find-class-predicate-from-cell
164     symbol (find-class-cell symbol errorp) errorp))
165 ram 1.5
166 pw 1.7 (defvar *boot-state* nil) ; duplicate defvar to defs.lisp
167    
168 gerd 1.22 ;;;
169     ;;; When compiling #+BOOTABLE, *BOOT-STATE* is COMPLETE because that's
170     ;;; the setting of the host PCL. We'd could use something like
171     ;;; *COMPILE-STATE* to tell the compiler macro when it should optimize
172     ;;; or not in such a setting. For simplicity we just don't optimize
173     ;;; in the bootable PCL.
174     ;;;
175     (define-compiler-macro find-class (&whole form symbol
176     &optional (errorp t) environment)
177 pw 1.7 (declare (ignore environment))
178     (if (and (constantp symbol)
179     (legal-class-name-p (eval symbol))
180     (constantp errorp)
181 gerd 1.22 (member *boot-state* '(braid complete))
182     (not (intersection '(:loadable-pcl :bootable-pcl) *features*)))
183 pw 1.7 (let ((symbol (eval symbol))
184     (errorp (not (null (eval errorp))))
185     (class-cell (make-symbol "CLASS-CELL")))
186     `(let ((,class-cell (load-time-value (find-class-cell ',symbol))))
187     (or (find-class-cell-class ,class-cell)
188     ,(if errorp
189     `(find-class-from-cell ',symbol ,class-cell t)
190     `(and (kernel:class-cell-class
191     ',(kernel:find-class-cell symbol))
192     (find-class-from-cell ',symbol ,class-cell nil))))))
193     form))
194    
195 gerd 1.23 (defun (setf find-class) (new-value name &optional errorp environment)
196     (declare (ignore errorp environment))
197     (if (legal-class-name-p name)
198     (let ((cell (find-class-cell name)))
199 phg 1.6 (setf (find-class-cell-class cell) new-value)
200 gerd 1.23 (when (and (eq *boot-state* 'complete) (null new-value))
201     (setf (kernel::find-class name) nil))
202     (when (memq *boot-state* '(complete braid))
203 pw 1.8 (when (and new-value (class-wrapper new-value))
204     (setf (find-class-cell-predicate cell)
205 gerd 1.22 (fdefinition (class-predicate-name new-value))))
206 gerd 1.23 (update-ctors 'setf-find-class :class new-value :name name))
207 pw 1.8 new-value)
208 gerd 1.23 (error "~S is not a legal class name." name)))
209 ram 1.5
210 dtc 1.11 (defun (setf find-class-predicate) (new-value symbol)
211 ram 1.5 (if (legal-class-name-p symbol)
212     (setf (find-class-cell-predicate (find-class-cell symbol)) new-value)
213     (error "~S is not a legal class name." symbol)))
214    
215 ram 1.3 (defmacro function-funcall (form &rest args)
216 pw 1.14 `(funcall (the function ,form) ,@args))
217 ram 1.3
218     (defmacro function-apply (form &rest args)
219 pw 1.14 `(apply (the function ,form) ,@args))
220 ram 1.3
221    
222     (defsetf slot-value set-slot-value)
223 gerd 1.22
224     (defvar *cold-boot-state* nil)
225    
226     #+pcl-debug
227     (defmacro %print (&rest args)
228     `(when *cold-boot-state*
229     (system:%primitive print ,@args)))
230    
231     #-pcl-debug
232     (defmacro %print (&rest args)
233     (declare (ignore args)))
234    
235     #+bootable-pcl
236     (defmacro /show (msg)
237     `(system:%primitive print ,msg))
238    
239     #-bootable-pcl
240     (defmacro /show (&rest args)
241 gerd 1.27 (declare (ignore args)))
242 ram 1.4

  ViewVC Help
Powered by ViewVC 1.1.5