/[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.6.56.1 - (hide annotations)
Thu Feb 25 20:34:52 2010 UTC (4 years, 1 month ago) by rtoy
Branch: intl-2-branch
Changes since 1.6: +3 -2 lines
Restart internalization work.  This new branch starts with code from
the intl-branch on date 2010-02-12 18:00:00+0500.  This version works
and

LANG=en@piglatin bin/lisp

works (once the piglatin translation is added).
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 rtoy 1.6.56.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/setf-funs.lisp,v 1.6.56.1 2010/02/25 20:34:52 rtoy 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 rtoy 1.6.56.1 (intl:textdomain "cmucl")
17 ram 1.1
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 rtoy 1.6.56.1 (warn _"Hairy setf expander for function ~S." name)
36 ram 1.1 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 ram 1.2 ;; Semantically silly...
58 dtc 1.6 getf apply ldb mask-field logbitp subseq values
59 ram 1.3 ;; Have explicit redundant definitions...
60 ram 1.4 setf bit sbit get aref gethash)

  ViewVC Help
Powered by ViewVC 1.1.5