/[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.5 - (hide annotations)
Mon Oct 31 04:11:27 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: RELEASE_18a
Branch point for: RELENG_18
Changes since 1.4: +1 -3 lines
Fix headed boilerplate.
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     ;;;
7     (ext:file-comment
8 ram 1.5 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/setf-funs.lisp,v 1.5 1994/10/31 04:11:27 ram Exp $")
9 ram 1.1 ;;;
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    
17     (eval-when (compile eval)
18    
19     (defun compute-one-setter (name type)
20     (let* ((args (second type))
21     (res (type-specifier
22     (single-value-type
23     (values-specifier-type (third type)))))
24     (arglist (loop repeat (1+ (length args)) collect (gensym))))
25     (cond
26     ((null (intersection args lambda-list-keywords))
27     `(defun (setf ,name) ,arglist
28     (declare ,@(mapcar #'(lambda (arg type)
29     `(type ,type ,arg))
30     arglist
31     (cons res args)))
32     (setf (,name ,@(rest arglist)) ,(first arglist))))
33     (t
34     (warn "Hairy setf expander for function ~S." name)
35     nil))))
36    
37    
38     (defmacro define-setters (packages &rest ignore)
39     (collect ((res))
40     (dolist (pkg packages)
41     (do-external-symbols (sym pkg)
42     (when (and (fboundp sym)
43     (eq (info function kind sym) :function)
44     (or (info setf inverse sym)
45     (info setf expander sym))
46     (not (member sym ignore)))
47     (let ((type (type-specifier (info function type sym))))
48     (assert (consp type))
49     (res `(declaim (inline (setf ,sym))))
50     (res (compute-one-setter sym type))))))
51     `(progn ,@(res))))
52    
53     ); eval-when (compile eval)
54    
55     (define-setters ("LISP")
56 ram 1.2 ;; Semantically silly...
57 ram 1.4 getf apply ldb mask-field logbitp subseq
58 ram 1.3 ;; Have explicit redundant definitions...
59 ram 1.4 setf bit sbit get aref gethash)

  ViewVC Help
Powered by ViewVC 1.1.5