/[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.4 - (show annotations)
Wed Aug 25 01:15:05 1993 UTC (20 years, 7 months ago) by ram
Branch: MAIN
Changes since 1.3: +3 -3 lines
Fix compiler warnings.
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 ;;; If you want to use this code or any part of CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/setf-funs.lisp,v 1.4 1993/08/25 01:15:05 ram Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Stuff to automatically generate SETF functions for all the standard
15 ;;; functions that are currently implemented with setf macros.
16 ;;;
17 (in-package "KERNEL")
18
19 (eval-when (compile eval)
20
21 (defun compute-one-setter (name type)
22 (let* ((args (second type))
23 (res (type-specifier
24 (single-value-type
25 (values-specifier-type (third type)))))
26 (arglist (loop repeat (1+ (length args)) collect (gensym))))
27 (cond
28 ((null (intersection args lambda-list-keywords))
29 `(defun (setf ,name) ,arglist
30 (declare ,@(mapcar #'(lambda (arg type)
31 `(type ,type ,arg))
32 arglist
33 (cons res args)))
34 (setf (,name ,@(rest arglist)) ,(first arglist))))
35 (t
36 (warn "Hairy setf expander for function ~S." name)
37 nil))))
38
39
40 (defmacro define-setters (packages &rest ignore)
41 (collect ((res))
42 (dolist (pkg packages)
43 (do-external-symbols (sym pkg)
44 (when (and (fboundp sym)
45 (eq (info function kind sym) :function)
46 (or (info setf inverse sym)
47 (info setf expander sym))
48 (not (member sym ignore)))
49 (let ((type (type-specifier (info function type sym))))
50 (assert (consp type))
51 (res `(declaim (inline (setf ,sym))))
52 (res (compute-one-setter sym type))))))
53 `(progn ,@(res))))
54
55 ); eval-when (compile eval)
56
57 (define-setters ("LISP")
58 ;; Semantically silly...
59 getf apply ldb mask-field logbitp subseq
60 ;; Have explicit redundant definitions...
61 setf bit sbit get aref gethash)

  ViewVC Help
Powered by ViewVC 1.1.5