mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-16 06:12:25 -08:00
Code Issues Projects Releases Packages Wiki Activity

Eliminated SETF-LAMBDA functions, replacing them with a wrapper that transforms them into SETF-METHODs.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2011-12-13 00:32:34 +01:00
parent 3679e2620b
commit 42a9abf551
9 changed files with 63 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/c/assignment.d
View file

@ -66,7 +66,6 @@ cl_set(cl_object var, cl_object val)
if (mflag)
FEerror("~S is not a valid name for a macro.", 1, fname);
si_put_sysprop(sym, @'si::setf-symbol', def);
si_rem_sysprop(sym, @'si::setf-lambda');
si_rem_sysprop(sym, @'si::setf-method');
}
@(return def)
@ -98,7 +97,6 @@ cl_fmakunbound(cl_object fname)
ecl_symbol_type_set(sym, ecl_symbol_type(sym) & ~stp_macro);
} else {
si_rem_sysprop(sym, @'si::setf-symbol');
si_rem_sysprop(sym, @'si::setf-lambda');
si_rem_sysprop(sym, @'si::setf-method');
}
@(return fname)

4
src/c/symbols_list.h
View file

@ -1247,7 +1247,6 @@ cl_symbols[] = {
#else
{EXT_ "SETENV", EXT_ORDINARY, NULL, -1, OBJNULL},
#endif
{SYS_ "SETF-LAMBDA", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "SETF-METHOD", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "SETF-NAMEP", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "SETF-SYMBOL", SI_ORDINARY, NULL, -1, OBJNULL},
@ -2200,5 +2199,8 @@ cl_symbols[] = {
{SYS_ "REPORT-FUNCTION", SI_ORDINARY, NULL, -1, OBJNULL},
{SYS_ "DO-DEFSETF", SI_ORDINARY, ECL_NAME(si_do_defsetf), 2, OBJNULL},
{SYS_ "DO-DEFINE-SETF-METHOD", SI_ORDINARY, ECL_NAME(si_do_define_setf_method), 2, OBJNULL},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

4
src/c/symbols_list2.h
View file

@ -1247,7 +1247,6 @@ cl_symbols[] = {
#else
{EXT_ "SETENV",NULL},
#endif
{SYS_ "SETF-LAMBDA",NULL},
{SYS_ "SETF-METHOD",NULL},
{SYS_ "SETF-NAMEP",NULL},
{SYS_ "SETF-SYMBOL",NULL},
@ -2200,5 +2199,8 @@ cl_symbols[] = {
{SYS_ "REPORT-FUNCTION",NULL},
{SYS_ "DO-DEFSETF","ECL_NAME(si_do_defsetf)"},
{SYS_ "DO-DEFINE-SETF-METHOD","ECL_NAME(si_do_define_setf_method)"},
/* Tag for end of list */
{NULL,NULL}};

2
src/cmp/proclamations.lsp
View file

@ -188,6 +188,8 @@
;; ECL extensions:
(proclamation si:specialp (symbol) gen-bool :predicate)
(proclamation si::do-defsetf (symbol function) t)
(proclamation si::do-define-setf-method (symbol function) t)
;;;
;;; 4. TYPES AND CLASSES

2
src/cmp/sysfun.lsp
View file

@ -895,6 +895,8 @@
nsubstitute nsubstitute-if nsubstitute-if-not find find-if find-if-not
position position-if position-if-not remove-duplicates
delete-duplicates mismatch search sort stable-sort merge constantly
;; setf.lsp
si::do-defsetf si::do-define-setf-method
;; process.lsp
ext:system
;; pprint.lsp

5
src/h/external.h
View file

@ -1992,6 +1992,11 @@ extern ECL_API cl_object cl_typep _ARGS((cl_narg narg, cl_object V1, cl_object V
extern ECL_API cl_object cl_coerce(cl_object V1, cl_object V2);
extern ECL_API cl_object cl_subtypep _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
/* setf.lsp */
extern ECL_API cl_object si_do_defsetf(cl_object name, cl_object function);
extern ECL_API cl_object si_do_define_setf_method(cl_object name, cl_object function);
/* seq.lsp */
extern ECL_API cl_object cl_make_sequence _ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));

1
src/lsp/defstruct.lsp
View file

@ -46,7 +46,6 @@
(t (error "~S is an illegal structure type." type)))
(if read-only
(progn
(rem-sysprop access-function 'SETF-LAMBDA)
(rem-sysprop access-function 'SETF-SYMBOL)
(set-documentation access-function 'SETF nil))
(progn

5
src/lsp/describe.lsp
View file

@ -543,11 +543,6 @@ Prints information about OBJECT to STREAM."
(cond ((setq x (si::get-documentation symbol 'SETF))
(doc1 x "[Setf]"))
((setq x (get-sysprop symbol 'SETF-LAMBDA))
(let ((*package* (good-package)))
(doc1 (format nil "~%Defined as: ~S~%See the doc of DEFSETF."
`(defsetf ,symbol ,@(get-sysprop symbol 'SETF-LAMBDA)))
"[Setf]")))
((setq x (get-sysprop symbol 'SETF-METHOD))
(let ((*package* (good-package)))
(doc1

78
src/lsp/setf.lsp
View file

@ -19,13 +19,35 @@
(unless (= (length stores-list) n)
(error "~d store-variables expected in setf form ~a." n context)))
(defun do-defsetf-short (access-fn function)
(do-defsetf-long access-fn
#'(lambda (store &rest args) `(,function ,@args ,store))))
(defun rename-arguments (vars)
(declare (si::c-local))
(let ((names '())
(values '())
(all-args '()))
(dolist (item vars)
(unless (or (fixnump item) (keywordp item))
(push item values)
(setq item (gensym))
(push item names))
(push item all-args))
(values (gensym) (nreverse names) (nreverse values) (nreverse all-args))))
(defun do-defsetf-long (access-fn function)
(put-sysprop access-fn 'SETF-LAMBDA function)
(rem-sysprop access-fn 'SETF-METHOD))
(defun setf-method-wrapper (name setf-lambda)
(declare (si::c-local))
#'(lambda (env &rest args)
(multiple-value-bind (store vars inits all)
(rename-arguments args)
(values vars inits (list store)
(apply setf-lambda store all) ; store-form
(cons name all))))) ; access-form
(defun do-defsetf (access-fn function)
(if (symbolp function)
(do-defsetf access-fn #'(lambda (store &rest args) `(,function ,@args ,store)))
(do-define-setf-method access-fn (setf-method-wrapper access-fn function))))
(defun do-define-setf-method (access-fn function)
(put-sysprop access-fn 'SETF-METHOD function))
;;; DEFSETF macro.
(defmacro defsetf (&whole whole access-fn &rest rest)
@ -41,22 +63,20 @@ where REST is the value of the last FORM with parameters in LAMBDA-LIST bound
to the symbols TEMP1 ... TEMPn and with STORE-VAR bound to the symbol TEMP0.
The doc-string DOC, if supplied, is saved as a SETF doc and can be retrieved
by (documentation 'SYMBOL 'setf)."
(cond ((and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
`(eval-when (compile load eval)
,(ext:register-with-pde whole `(do-defsetf-short ',access-fn ',(car rest)))
,@(si::expand-set-documentation access-fn 'setf (cadr rest))
',access-fn))
(t
(let* ((store (second rest))
(args (first rest))
(body (cddr rest))
(doc (find-documentation body))
(lambda `#'(lambda-block ,access-fn (,@store ,@args) ,@body)))
(check-stores-number 'DEFSETF store 1)
`(eval-when (compile load eval)
,(ext:register-with-pde whole `(do-defsetf-long ',access-fn ,lambda))
,@(si::expand-set-documentation access-fn 'setf doc)
',access-fn)))))
(let (function documentation)
(if (and (car rest) (or (symbolp (car rest)) (functionp (car rest))))
(setq function `',(car rest)
documentation (cadr rest))
(let* ((store (second rest))
(args (first rest))
(body (cddr rest)))
(setq documentation (find-documentation body)
function `#'(lambda-block ,access-fn (,@store ,@args) ,@body))
(check-stores-number 'DEFSETF store 1)))
`(eval-when (compile load eval)
,(ext:register-with-pde whole `(do-defsetf ',access-fn ,function))
,@(si::expand-set-documentation access-fn 'setf documentation)
',access-fn)))
;;; DEFINE-SETF-METHOD macro.
@ -90,11 +110,10 @@ by (DOCUMENTATION 'SYMBOL 'SETF)."
(setq args (cons env args))
(push `(declare (ignore ,env)) body))))
`(eval-when (compile load eval)
(put-sysprop ',access-fn 'SETF-METHOD #'(ext::lambda-block ,access-fn ,args ,@body))
(rem-sysprop ',access-fn 'SETF-LAMBDA)
,@(si::expand-set-documentation access-fn 'setf
(find-documentation body))
',access-fn))
(do-define-setf-method ',access-fn #'(ext::lambda-block ,access-fn ,args ,@body))
,@(si::expand-set-documentation access-fn 'setf
(find-documentation body))
',access-fn))
;;;; get-setf-expansion.
@ -129,8 +148,6 @@ Does not check if the third gang is a single-element list."
(setq writer
(cond ((setq f (get-sysprop name 'STRUCTURE-ACCESS))
(setf-structure-access (car all) (car f) (cdr f) store))
((setq f (get-sysprop (car form) 'SETF-LAMBDA))
(apply f store all))
((and (setq f (macroexpand-1 form env)) (not (equal f form)))
(return-from get-setf-expansion
(get-setf-expansion f env)))
@ -296,7 +313,8 @@ Does not check if the third gang is a single-element list."
`(mask-field ,btemp ,access-form)))))
(defun trivial-setf-form (place vars stores store-form access-form)
(declare (si::c-local))
(declare (si::c-local)
(optimize (speed 3) (safety 0)))
(and (atom place)
(null vars)
(eq access-form place)