/[cmucl]/src/code/setf-funs.lisp
ViewVC logotype

Contents of /src/code/setf-funs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Apr 20 17:57:45 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 ;;; -*- Package: Kernel -*-
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/setf-funs.lisp,v 1.8 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Stuff to automatically generate SETF functions for all the standard
13 ;;; functions that are currently implemented with setf macros.
14 ;;;
15 (in-package "KERNEL")
16 (intl:textdomain "cmucl")
17
18 (eval-when (compile eval)
19
20 (defun compute-one-setter (name type)
21 (let* ((args (second type))
22 (res (type-specifier
23 (single-value-type
24 (values-specifier-type (third type)))))
25 (arglist (loop repeat (1+ (length args)) collect (gensym))))
26 (cond
27 ((null (intersection args lambda-list-keywords))
28 `(defun (setf ,name) ,arglist
29 (declare ,@(mapcar #'(lambda (arg type)
30 `(type ,type ,arg))
31 arglist
32 (cons res args)))
33 (setf (,name ,@(rest arglist)) ,(first arglist))))
34 (t
35 (warn (intl:gettext "Hairy setf expander for function ~S.") name)
36 nil))))
37
38
39 (defmacro define-setters (packages &rest ignore)
40 (collect ((res))
41 (dolist (pkg packages)
42 (do-external-symbols (sym pkg)
43 (when (and (fboundp sym)
44 (eq (info function kind sym) :function)
45 (or (info setf inverse sym)
46 (info setf expander sym))
47 (not (member sym ignore)))
48 (let ((type (type-specifier (info function type sym))))
49 (assert (consp type))
50 (res `(declaim (inline (setf ,sym))))
51 (res (compute-one-setter sym type))))))
52 `(progn ,@(res))))
53
54 ); eval-when (compile eval)
55
56 (define-setters ("LISP")
57 ;; Semantically silly...
58 getf apply ldb mask-field logbitp subseq values
59 ;; Have explicit redundant definitions...
60 setf bit sbit get aref gethash)

  ViewVC Help
Powered by ViewVC 1.1.5