Re: return-from in (defun (setf xxx)...)?

At 08:31 PM 3/7/03 -0500, Kenny Tilton wrote:
>This works in ACL and LispWorks:
>
>(defun (setf md-slot-value) (newvalue self slot-spec)
>    <snip>
>   (when (c-setting-p c)
>        (return-from md-slot-value newvalue))
>
>... but not in CormanLisp:
>
>;;; An error occurred in function %STRINGNODE:
>;;; Error: No enclosing block named MD-SLOT-VALUE was found
>;;; Entering Corman Lisp debug loop.
>
>I'll rewrite to avoid the return-from, but... bug? feature?

It's a bug.

In fact, its two bugs (see doc below).

In fact, its two bugs and a missing syntax check that got me
while I was testing my patch.  (see doc below)

Here's a patch file, and an example showing it working below it.

------------------------------------------------------------

(in-package :lisp)

;;; Problem:  Defining a function named (setf <any>) causes
;;;   -- a block named |(setf <any>)| to be established around
;;;      the body, instead of a block named <any>
;;;   -- DEFUN returns the symbol |(setf <any>)| instead of
;;;      the list (setf <any>), which it is supposed to do
;;;      according to the Hyperspec.

;;; Solution:  Add ORIGINAL-NAME and BLOCK-NAME internal variables,
;;; set them to the proper values, and use them where appropriate.

;;; Also turned IF for SETF name conditional into UNLESS and removed PROGN.
;;; Also merged the SETF and non-SETF branches of the code generation
;;; at the bottom since it differed only in one line.

;;; Also added a test to prevent things like (DEFUN (SETF X Y) ...)
;;; from getting through.

(defmacro defun (name lambda-list &rest forms)
   (let ((doc-form nil)
         (lambda-form nil)
         (declarations nil)
         (setf-form nil)
         (original-name name)
         (block-name name))

     (when (and (consp name) (eq (car name) 'setf))
       (unless (and (symbolp (cadr name)) (eql 2 (length name)))
         (error "Invalid function name: ~A" name))
       (setq setf-form (cadr name))
       (setq block-name (cadr name))
       (setq name (setf-function-symbol name))
       )

     ;; look for declarations and doc string
     (do* ((f forms (cdr f)))
         ((null f) (setq forms f))
       (if (and (typep (car f) 'string) (null doc-form) (cdr f))
           (setq doc-form
             `((setf (documentation ',name 'function) ,(car f))))
         (if (and (consp (car f)) (eq (caar f) 'declare))
             (push (car f) declarations)
           (progn (setq forms f) (return)))))

     (setq lambda-form
       `(lambda ,lambda-list ,@(nreverse declarations)
                (block ,block-name ,@forms)))

;     (if setf-form
;       `(progn
;          ,@doc-form
;          (setf (symbol-function ',name) (function ,lambda-form))
;          (cl::register-setf-function ',setf-form ',name)
;          ',original-name)

     `(progn
        ,@doc-form
        (setf (symbol-function ',name) (function ,lambda-form))
        ,@(when setf-form `((cl::register-setf-function ',setf-form ',name)))
        ',original-name)))

--------------------------------------------------------------

(defun (setf blarf) (increment place)
         (when (zerop increment) (return-from blarf nil))
         (do ((j place (cdr j))) ((null j))
                 (incf (car j) increment)))
(SETF BLARF)
(setq x '(1 2 3))
(1 2 3)
(setf (blarf x) 4)
NIL
x
(5 6 7)
(setf (blarf x) 0)
NIL
x
(5 6 7)