[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
3600 walk-template patch
- To: CommonLoops.pa@Xerox.COM
- Subject: 3600 walk-template patch
- From: kanderso@WILMA.BBN.COM
- Date: Tue, 12 Apr 88 13:53:33 -0400
- Cc: kanderson@WILMA.BBN.COM
- Redistributed: CommonLoops.pa
;;; 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))))))))