diff --git a/src/c/assignment.d b/src/c/assignment.d
index a059dc08a..ea23f46f1 100644
--- a/src/c/assignment.d
+++ b/src/c/assignment.d
@@ -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)
diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h
index d7913d4b2..c65458539 100755
--- a/src/c/symbols_list.h
+++ b/src/c/symbols_list.h
@@ -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}};
diff --git a/src/c/symbols_list2.h b/src/c/symbols_list2.h
index 37e2dccf9..0fa88f481 100644
--- a/src/c/symbols_list2.h
+++ b/src/c/symbols_list2.h
@@ -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}};
diff --git a/src/cmp/proclamations.lsp b/src/cmp/proclamations.lsp
index d6c741913..100224355 100644
--- a/src/cmp/proclamations.lsp
+++ b/src/cmp/proclamations.lsp
@@ -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
diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index c0a071288..e9608bc9b 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -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
diff --git a/src/h/external.h b/src/h/external.h
index 91908920b..380613a35 100755
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -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, ...));
diff --git a/src/lsp/defstruct.lsp b/src/lsp/defstruct.lsp
index 34575fd09..1fa57adf8 100644
--- a/src/lsp/defstruct.lsp
+++ b/src/lsp/defstruct.lsp
@@ -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
diff --git a/src/lsp/describe.lsp b/src/lsp/describe.lsp
index 89dc412f7..8c7951075 100644
--- a/src/lsp/describe.lsp
+++ b/src/lsp/describe.lsp
@@ -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
diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp
index 7006e4140..731924e1a 100644
--- a/src/lsp/setf.lsp
+++ b/src/lsp/setf.lsp
@@ -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)