[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

3600 walk-template patch



;;; From walk.lisp:

;;; RShapiro: On Symbolics (setf (foo bar) baz) macroexpands into
;;; (funcall #'(setf foo) bar baz) when foo is a flavor instance accessor.
;;; the walker would convert this to (funcal #'(setq foo) bar baz).
(defun walk-template (form template context env)
  (if (atom template)
      (ecase template
        ((EVAL FUNCTION TEST EFFECT RETURN)
         (walk-form-internal form :EVAL env))
        ((QUOTE NIL) form)
        (SET
          (walk-form-internal form :SET env))
        ((LAMBDA CALL)
	 (cond ((symbolp form) form)
	       #+symbolics
	       ((and (listp form) (eq (car form) 'setf) (null (cddr form)))
		form)
	       (t (walk-form-internal form context env)))))
      (case (car template)
        (REPEAT
          (walk-template-handle-repeat form
                                       (cdr template)
				       ;; For the case where nothing happens
				       ;; after the repeat optimize out the
				       ;; call to length.
				       (if (null (cddr template))
					   ()
					   (nthcdr (- (length form)
						      (length
							(cddr template)))
						   form))
                                       context
				       env))
        (IF
	  (walk-template form
			 (if (if (listp (cadr template))
				 (eval (cadr template))
				 (funcall (cadr template) form))
			     (caddr template)
			     (cadddr template))
			 context
			 env))
        (REMOTE
          (walk-template form (cadr template) context env))
        (otherwise
          (cond ((atom form) form)
                (t (recons form
                           (walk-template
			     (car form) (car template) context env)
                           (walk-template
			     (cdr form) (cdr template) context env))))))))