/[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 - (hide 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 ram 1.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 ram 1.4 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/setf-funs.lisp,v 1.4 1993/08/25 01:15:05 ram Exp $")
11 ram 1.1 ;;;
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 ram 1.2 ;; Semantically silly...
59 ram 1.4 getf apply ldb mask-field logbitp subseq
60 ram 1.3 ;; Have explicit redundant definitions...
61 ram 1.4 setf bit sbit get aref gethash)

  ViewVC Help
Powered by ViewVC 1.1.5