/[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.2.1 - (show annotations)
Fri Oct 4 23:13:35 2002 UTC (11 years, 6 months ago) by pmai
Branch: UNICODE-BRANCH
Changes since 1.6: +32 -2 lines
Checked in Brian Spilsbury's experimental Unicode, locales, and dialect
support patchset.  This lives on its own branch, so that people can
play with it and tweak it, without disturbing 18e release engineering
on the main branch.  Bootstrapping has only been tried on LINKAGE_TABLE
x86/Linux builds.  A working cross-compile script is checked in under
bootfiles/19a/boot1-cross-unicode.lisp.  The script still leaves you
with some interactive errors, on the cross compile, which you should
answer with 2.  See the mailing list for more information.
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.6.2.1 2002/10/04 23:13:35 pmai Exp $")
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
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 #+fundamental-types-bootstrap
39 (defmacro do-old-external-symbols ((var &optional (package '*package*) result-form)
40 &body (body decls))
41 "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
42 Executes the FORMs once for each external symbol in the given PACKAGE with
43 VAR bound to the current symbol."
44 (let ((flet-name (gensym "DO-SYMBOLS-")))
45 `(block nil
46 ; body
47 (flet ((,flet-name (,var)
48 ,@decls
49 (tagbody ,@body)))
50 (let* ((package (find-package ,package))
51 (table (cl::package-external-symbols (truly-the package package)))
52 (hash-vec (cl::package-hashtable-hash (truly-the package-hashtable table)))
53 (sym-vec (cl::package-hashtable-table (truly-the package-hashtable table))))
54 (declare (type (simple-array (unsigned-byte 8) (*)) hash-vec)
55 (type simple-vector sym-vec))
56 (dotimes (i (length sym-vec))
57 (when (>= (aref hash-vec i) 2)
58 (,flet-name (aref sym-vec i))))))
59 ; return
60 (let ((,var nil))
61 (declare (ignorable ,var))
62 ,@decls
63 ,result-form))))
64
65 (defmacro define-setters (packages &rest ignore)
66 (collect ((res))
67 (dolist (pkg packages)
68 (#-fundamental-types-bootstrap
69 do-external-symbols
70 #+fundamental-types-bootstrap
71 do-old-external-symbols (sym pkg)
72 (when (and (fboundp sym)
73 (eq (info function kind sym) :function)
74 (or (info setf inverse sym)
75 (info setf expander sym))
76 (not (member sym ignore)))
77 (let ((type (type-specifier (info function type sym))))
78 (assert (consp type))
79 (res `(declaim (inline (setf ,sym))))
80 (res (compute-one-setter sym type))))))
81 `(progn ,@(res))))
82
83 ); eval-when (compile eval)
84
85 (define-setters ("LISP")
86 ;; Semantically silly...
87 getf apply ldb mask-field logbitp subseq values
88 ;; Have explicit redundant definitions...
89 setf bit sbit get aref gethash)

  ViewVC Help
Powered by ViewVC 1.1.5