Mercurial > emacs

comparison lisp/emacs-lisp/cl-macs.el @ 90729:6588c6259dfb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge from emacs--devo--0 Patches applied: * emacs--devo--0 (patch 545-562) - Update from CVS - Update from erc--emacs--22 - Merge from gnus--rel--5.10 - erc-iswitchb: Temporarily enable iswitchb mode * gnus--rel--5.10 (patch 172-176) - Merge from emacs--devo--0 - Update from CVS - Update from CVS: lisp/legacy-gnus-agent.el: Add Copyright notice. Revision: emacs@sv.gnu.org/emacs--unicode--0--patch-156
author Miles Bader <miles@gnu.org>
date Sat, 16 Dec 2006 01:29:26 +0000
parents bb0e318b7c53 5d1c79927b08
children 95d0cdf160ea
comparison
equal deleted inserted replaced
90728:a65a92d83186 90729:6588c6259dfb
1 ;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*- 1 ;;; cl-macs.el --- Common Lisp macros -*-byte-compile-dynamic: t;-*-
2 2
3 ;; Copyright (C) 1993, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. 3 ;; Copyright (C) 1993, 2001, 2002, 2003, 2004, 2005, 2006
4 ;; Free Software Foundation, Inc.
4 5
5 ;; Author: Dave Gillespie <daveg@synaptics.com> 6 ;; Author: Dave Gillespie <daveg@synaptics.com>
6 ;; Version: 2.02 7 ;; Version: 2.02
7 ;; Keywords: extensions 8 ;; Keywords: extensions
8 9
2289 (push (cons accessor t) side-eff) 2290 (push (cons accessor t) side-eff)
2290 (push (list 'define-setf-method accessor '(cl-x) 2291 (push (list 'define-setf-method accessor '(cl-x)
2291 (if (cadr (memq :read-only (cddr desc))) 2292 (if (cadr (memq :read-only (cddr desc)))
2292 (list 'error (format "%s is a read-only slot" 2293 (list 'error (format "%s is a read-only slot"
2293 accessor)) 2294 accessor))
2294 (list 'cl-struct-setf-expander 'cl-x 2295 ;; If cl is loaded only for compilation,
2295 (list 'quote name) (list 'quote accessor) 2296 ;; the call to cl-struct-setf-expander would
2296 (and pred-check (list 'quote pred-check)) 2297 ;; cause a warning because it may not be
2297 pos))) 2298 ;; defined at run time. Suppress that warning.
2299 (list 'with-no-warnings
2300 (list 'cl-struct-setf-expander 'cl-x
2301 (list 'quote name) (list 'quote accessor)
2302 (and pred-check (list 'quote pred-check))
2303 pos))))
2298 forms) 2304 forms)
2299 (if print-auto 2305 (if print-auto
2300 (nconc print-func 2306 (nconc print-func
2301 (list (list 'princ (format " %s" slot) 'cl-s) 2307 (list (list 'princ (format " %s" slot) 'cl-s)
2302 (list 'prin1 (list accessor 'cl-x) 'cl-s))))))) 2308 (list 'prin1 (list accessor 'cl-x) 'cl-s)))))))