/[gcl]/gcl/lsp/gcl_setf.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_setf.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.9 by pfdietz, Wed Aug 24 12:49:32 2005 UTC revision 1.10 by pfdietz, Sat Aug 27 00:11:18 2005 UTC
# Line 29  Line 29 
29  (export '(setf psetf shiftf rotatef  (export '(setf psetf shiftf rotatef
30            define-modify-macro defsetf            define-modify-macro defsetf
31            getf remf incf decf push pushnew pop            getf remf incf decf push pushnew pop
32            define-setf-method get-setf-method get-setf-method-multiple-value))            define-setf-method
33              define-setf-expander
34              get-setf-method
35              get-setf-expansion
36              get-setf-method-multiple-value))
37    
38    
39  (in-package 'system)  (in-package 'system)
# Line 78  Line 82 
82          (t (setq args (cons (gensym) args))          (t (setq args (cons (gensym) args))
83             (push `(declare (ignore ,(car args))) body)))             (push `(declare (ignore ,(car args))) body)))
84    `(eval-when (compile eval load)    `(eval-when (compile eval load)
85            (si:putprop ',access-fn #'(lambda ,args ,@ body) 'setf-method)            (si:putprop ',access-fn
86                          #'(lambda ,args (block ,access-fn ,@ body))
87                          'setf-method)
88            (remprop ',access-fn 'setf-lambda)            (remprop ',access-fn 'setf-lambda)
89            (remprop ',access-fn 'setf-update-fn)            (remprop ',access-fn 'setf-update-fn)
90            (si:putprop ',access-fn            (si:putprop ',access-fn
# Line 86  Line 92 
92                        'setf-documentation)                        'setf-documentation)
93            ',access-fn))            ',access-fn))
94    
95    (defmacro define-setf-expander (access-fn &rest rest)
96      `(define-setf-method ,access-fn ,@rest))
97    
98  ;;; GET-SETF-METHOD.  ;;; GET-SETF-METHOD.
99  ;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE  ;;; It just calls GET-SETF-METHOD-MULTIPLE-VALUE
# Line 97  Line 105 
105              (error "Multiple store-variables are not allowed."))              (error "Multiple store-variables are not allowed."))
106      (values vars vals stores store-form access-form)))      (values vars vals stores store-form access-form)))
107    
108    (defun get-setf-expansion (form &optional env)
109      (get-setf-method form env))
110    
111  ;;;; GET-SETF-METHOD-MULTIPLE-VALUE.  ;;;; GET-SETF-METHOD-MULTIPLE-VALUE.
112    

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.10

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26