ARNESI

(defwalker-handler +atom-marker+ (form parent env)
  (declare (special *macroexpand*))
  (cond
    ((not (or (symbolp form) (consp form)))
     (make-instance 'constant-form :value form
                    :parent parent :source form))
    ((lookup env :let form)
     (make-instance 'local-variable-reference :name form
                    :parent parent :source form))
    ((lookup env :lexical-let form)
     (make-instance 'local-lexical-variable-reference :name form
                    :parent parent :source form))
    ((lookup env :symbol-macrolet form)
     (walk-form (lookup env :symbol-macrolet form) parent env))
    ((nth-value 1 (macroexpand-1 form))
     ;; a globaly defined symbol-macro
     (walk-form (macroexpand-1 form) parent env))
    (t
     (make-instance 'free-variable-reference :name form
                    :parent parent :source form))))

Function Applictation

Class APPLICATION-FORM

Class LOCAL-APPLICATION-FORM

Class LEXICAL-APPLICATION-FORM

Class FREE-APPLICATION-FORM

Class LAMBDA-APPLICATION-FORM

(defwalker-handler application (form parent env)
  (block nil
    (destructuring-bind (op &rest args)
        form
      (when (and (consp op)
                 (eq 'cl:lambda (car op)))
        (return
          (with-form-object (application lambda-application-form :parent parent :source form)
            (setf (operator application) (walk-form op application env)
                  (arguments application) (mapcar (lambda (form)
                                                    (walk-form form application env))
                                                  args)))))
      (when (lookup env :macrolet op)
        (return (walk-form (apply (lookup env :macrolet op) args) parent env)))
      (when (and (symbolp op) (macro-function op))
	(multiple-value-bind (expansion expanded)
	    (macroexpand-1 form nil)
	  (when expanded
	    (return (walk-form expansion parent env)))))
      (let ((app (if (lookup env :flet op)
                     (make-instance 'local-application-form :code (lookup env :flet op))
                     (if (lookup env :lexical-flet op)
			 (make-instance 'lexical-application-form)
			 (make-instance 'free-application-form)))))
        (setf (operator app) op
              (parent app) parent
              (source app) form
              (arguments app) (mapcar (lambda (form)
                                        (walk-form form app env))
                                      args))
        app))))

Functions

Class FUNCTION-FORM

Class LAMBDA-FUNCTION-FORM

Class FUNCTION-OBJECT-FORM

Class LOCAL-FUNCTION-OBJECT-FORM

Class FREE-FUNCTION-OBJECT-FORM

Class LEXICAL-FUNCTION-OBJECT-FORM

(defwalker-handler function (form parent env)
  (if (and (listp (second form))
           (eql 'cl:lambda (first (second form))))
      ;; (function (lambda ...))
      (walk-lambda (second form) parent env)
      ;; (function foo)
      (make-instance (if (lookup env :flet (second form))
                         'local-function-object-form
                         (if (lookup env :lexical-flet (second form))
			     'lexical-function-object-form
			     'free-function-object-form))
                     :name (second form)
                     :parent parent :source form)))

Function WALK-LAMBDA

Function WALK-LAMBDA-LIST

Class FUNCTION-ARGUMENT-FORM

Class REQUIRED-FUNCTION-ARGUMENT-FORM

Generic Function REQUIRED-FUNCTION-ARGUMENT-FORM-P

Function WALK-REQUIRED-ARGUMENT

Class SPECIALIZED-FUNCTION-ARGUMENT-FORM

Function WALK-SPECIALIZED-ARGUMENT-FORM

Class OPTIONAL-FUNCTION-ARGUMENT-FORM

Function WALK-OPTIONAL-ARGUMENT

Class KEYWORD-FUNCTION-ARGUMENT-FORM

Method (EFFECTIVE-KEYWORD-NAME KEYWORD-FUNCTION-ARGUMENT-FORM)

Function WALK-KEYWORD-ARGUMENT

Class ALLOW-OTHER-KEYS-FUNCTION-ARGUMENT-FORM

Class REST-FUNCTION-ARGUMENT-FORM

Function WALK-REST-ARGUMENT

BLOCK/RETURN-FROM

Class BLOCK-FORM

Class RETURN-FROM-FORM

(defwalker-handler block (form parent env)
  (destructuring-bind (block-name &rest body)
      (cdr form)
    (with-form-object (block block-form
                       :parent parent :source form
                       :name block-name)
      (setf (body block) (walk-implict-progn block
                                             body
                                             (register env :block block-name block))))))

(define-condition return-from-unknown-block (error)
  ((block-name :accessor block-name :initarg :block-name))
  (:report (lambda (condition stream)
             (format stream "Unable to return from block named ~S." (block-name condition)))))

(defwalker-handler return-from (form parent env)
  (destructuring-bind (block-name &optional (value '(values)))
      (cdr form)
    (if (lookup env :block block-name)
        (with-form-object (return-from return-from-form :parent parent :source form
                           :target-block (lookup env :block block-name))
          (setf (result return-from) (walk-form value return-from env)))
        (restart-case
            (error 'return-from-unknown-block :block-name block-name)
          (add-block ()
            :report "Add this block and continue."
            (walk-form form parent (register env :block block-name :unknown-block)))))))

CATCH/THROW

Class CATCH-FORM

Class THROW-FORM

(defwalker-handler catch (form parent env)
  (destructuring-bind (tag &body body)
      (cdr form)
    (with-form-object (catch catch-form :parent parent :source form)
      (setf (tag catch) (walk-form tag catch env)
            (body catch) (walk-implict-progn catch body env)))))

(defwalker-handler throw (form parent env)
  (destructuring-bind (tag &optional (result '(values)))
      (cdr form)
    (with-form-object (throw throw-form :parent parent :source form)
      (setf (tag throw) (walk-form tag throw env)
            (value throw) (walk-form result throw env)))))

EVAL-WHEN

Class EVAL-WHEN-FORM

(defwalker-handler eval-when (form parent env)
  (declare (ignore form parent env))
  (error "Sorry, EVAL-WHEN not yet implemented."))

Class IF-FORM

(defwalker-handler if (form parent env)
  (with-form-object (if if-form :parent parent :source form)
    (setf (consequent if) (walk-form (second form) if env)
          (then if) (walk-form (third form) if env)
          (else if) (walk-form (fourth form) if env))))

FLET/LABELS

Class FUNCTION-BINDING-FORM

Class FLET-FORM

Class LABELS-FORM

(defwalker-handler flet (form parent env)
  (destructuring-bind (binds &body body)
      (cdr form)
    (with-form-object (flet flet-form :parent parent :source form)
      ;;;; build up the objects for the bindings in the original env
      (loop
         for (name args . body) in binds
         collect (cons name (walk-form `(lambda ,args ,@body) flet env)) into bindings
         finally (setf (binds flet) bindings))
      ;;;; walk the body in the new env
      (multiple-value-setf ((body flet) nil (declares flet))
			   (walk-implict-progn flet
					       body
					       (loop
						  with env = env
						  for (name . lambda) in (binds flet)
						  do (extend env :flet name lambda)
						  finally (return env))
					       :declare t)))))

(defwalker-handler labels (form parent env)
  (destructuring-bind (binds &body body)
      (cdr form)
    (with-form-object (labels labels-form :parent parent :source form :binds '())
      ;; we need to walk over the bindings twice. the first pass
      ;; creates some 'empty' lambda objects in the environment so
      ;; that local-application-form and local-function-object-form
      ;; have something to point to. the second pass then walks the
      ;; actual bodies of the form filling in the previously created
      ;; objects.
      (loop
         for (name arguments . body) in binds
         for lambda = (make-instance 'lambda-function-form
                                     :parent labels
                                     :source (list* name arguments body))
         do (push (cons name lambda) (binds labels))
         do (extend env :flet name lambda))
      (setf (binds labels) (nreverse (binds labels)))
      (loop
         for form in binds
         for (arguments . body) = (cdr form)
         for binding in (binds labels)
         for lambda = (cdr binding)
         for tmp-lambda = (walk-lambda `(lambda ,arguments ,@body) labels env)
         do (setf (body lambda) (body tmp-lambda)
                  (arguments lambda) (arguments tmp-lambda)
		  (declares lambda) (declares tmp-lambda)))
      (multiple-value-setf ((body labels) nil (declares labels)) (walk-implict-progn labels body env :declare t)))))

LET/LET*

Class VARIABLE-BINDING-FORM

Class LET-FORM

(defwalker-handler let (form parent env)
  (with-form-object (let let-form :parent parent :source form)
    (setf (binds let) (mapcar (lambda (binding)
                                   (destructuring-bind (var &optional initial-value)
                                       (ensure-list binding)
                                     (cons var (walk-form initial-value let env))))
                                 (second form)))
    (dolist* ((var . value) (binds let))
      (declare (ignore value))
      (extend env :let var :dummy))
    (multiple-value-setf ((body let) nil (declares let)) (walk-implict-progn let (cddr form) env :declare t))))

Class LET*-FORM

(defwalker-handler let* (form parent env)
  (with-form-object (let* let*-form :parent parent :source form :binds '())
    (dolist* ((var &optional initial-value) (mapcar #'ensure-list (second form)))
      (push (cons var (walk-form initial-value let* env)) (binds let*))
      (extend env :let var :dummy))
    (setf (binds let*) (nreverse (binds let*)))
    (multiple-value-setf ((body let*) nil (declares let*)) (walk-implict-progn let* (cddr form) env :declare t))))

LOAD-TIME-VALUE

Class LOAD-TIME-VALUE-FORM

(defwalker-handler load-time-value (form parent env)
  (with-form-object (load-time-value load-time-value-form
                                     :parent parent :source form)
    (setf (value load-time-value) (walk-form (second form) load-time-value env)
          (read-only-p load-time-value) (third form))))

LOCALLY

Class LOCALLY-FORM

(defwalker-handler locally (form parent env)
  (with-form-object (locally locally-form :parent parent :source form)
    (multiple-value-setf ((body locally) nil (declares locally)) (walk-implict-progn locally (cdr form) env :declare t))))

MACROLET

Class MACROLET-FORM

(defwalker-handler macrolet (form parent env)
  (with-form-object (macrolet macrolet-form :parent parent :source form
                              :binds '())
    (dolist* ((name args &body body) (second form))
      (let ((handler (eval
                      ;; NB: macrolet arguments are a
                      ;; destructuring-bind list, not a lambda list
                      (with-unique-names (handler-args)
                        `(lambda (&rest ,handler-args)
                           (destructuring-bind ,args
                               ,handler-args
                             ,@body))))))
        (extend env :macrolet name handler)
        (push (cons name handler) (binds macrolet))))
    (setf (binds macrolet) (nreverse (binds macrolet)))
    (multiple-value-setf ((body macrolet) nil (declares macrolet))
      (walk-implict-progn macrolet (cddr form) env :declare t))))

MULTIPLE-VALUE-CALL

Class MULTIPLE-VALUE-CALL-FORM

(defwalker-handler multiple-value-call (form parent env)
  (with-form-object (m-v-c multiple-value-call-form :parent parent :source form)
    (setf (func m-v-c) (walk-form (second form) m-v-c env)
          (arguments m-v-c) (mapcar (lambda (f) (walk-form f m-v-c env))
                                    (cddr form)))))

MULTIPLE-VALUE-PROG1

Class MULTIPLE-VALUE-PROG1-FORM

(defwalker-handler multiple-value-prog1 (form parent env)
  (with-form-object (m-v-p1 multiple-value-prog1-form :parent parent :source form)
    (setf (first-form m-v-p1) (walk-form (second form) m-v-p1 env)
          (other-forms m-v-p1) (mapcar (lambda (f) (walk-form f m-v-p1 env))
                                       (cddr form)))))

PROGN

Class PROGN-FORM

(defwalker-handler progn (form parent env)
  (with-form-object (progn progn-form :parent parent :source form)
    (setf (body progn) (walk-implict-progn progn (cdr form) env))))

PROGV

Class PROGV-FORM

(defwalker-handler progv (form parent env)
  (with-form-object (progv progv-form :parent parent :source form)
    (setf (vars-form progv) (walk-form (cadr form) progv env))    
    (setf (values-form progv) (walk-form (caddr form) progv env))
    (setf (body progv) (walk-implict-progn progv (cdddr form) env))
    progv))

QUOTE

(defwalker-handler quote (form parent env)
  (make-instance 'constant-form :parent parent :source form :value (second form)))

SETQ

Class SETQ-FORM

(defwalker-handler setq (form parent env)
  ;; the SETQ handler needs to be able to deal with symbol-macrolets
  ;; which haven't yet been expanded and may expand into something
  ;; requiring setf and not setq.
  (let ((effective-code '()))
    (loop
       for (name value) on (cdr form) by #'cddr
       if (lookup env :symbol-macrolet name)
         do (push `(setf ,(lookup env :symbol-macrolet name) ,value) effective-code)
       else
         do (push `(setq ,name ,value) effective-code))
    (if (= 1 (length effective-code))
        ;; only one form, the "simple case"
        (destructuring-bind (type var value)
            (first effective-code)
          (ecase type
            (setq (with-form-object (setq setq-form :parent parent :source form
                                          :var var)
                    (setf (value setq) (walk-form value setq env))))
            (setf (walk-form (first effective-code) parent env))))
        ;; multiple forms
        (with-form-object (progn progn-form :parent parent :source form)
          (setf (body progn) (walk-implict-progn progn effective-code env))))))

SYMBOL-MACROLET

Class SYMBOL-MACROLET-FORM

(defwalker-handler symbol-macrolet (form parent env)
  (with-form-object (symbol-macrolet symbol-macrolet-form :parent parent :source form
                                     :binds '())
    (dolist* ((symbol expansion) (second form))
      (extend env :symbol-macrolet symbol expansion)
      (push (cons symbol expansion) (binds symbol-macrolet)))
    (setf (binds symbol-macrolet) (nreverse (binds symbol-macrolet))
          (body symbol-macrolet) (walk-implict-progn parent (cddr form) env))))

TAGBODY/GO

Class TAGBODY-FORM

Class GO-TAG-FORM

Generic Function GO-TAG-FORM-P

(defwalker-handler tagbody (form parent env)
  (with-form-object (tagbody tagbody-form :parent parent :source form :body (cdr form))
    (extend env :tagbody 'enclosing-tagbody tagbody)
    (flet ((go-tag-p (form)
             (or (symbolp form) (integerp form))))
      ;; the loop below destructuivly modifies the body of tagbody,
      ;; since it's the same object as the source we need to copy it.
      (setf (body tagbody) (copy-list (body tagbody)))
      (loop
         for part on (body tagbody)
         if (go-tag-p (car part))
           do (extend env :tag (car part) (cdr part)))
      (loop
         for part on (body tagbody)
         if (go-tag-p (car part))
           do (setf (car part) (make-instance 'go-tag-form :parent tagbody
                                              :source (car part)
                                              :name (car part)))
         else
           do (setf (car part) (walk-form (car part) tagbody env))))))

Class GO-FORM

(defwalker-handler go (form parent env)
  (make-instance 'go-form
                 :parent parent
                 :source form
                 :name (second form)
                 :target-progn (lookup env :tag (second form))
                 :enclosing-tagbody (lookup env :tagbody 'enclosing-tagbody)))

THE

Class THE-FORM

(defwalker-handler the (form parent env)
  (with-form-object (the the-form :parent parent :source form
                                  :type-form (second form))
    (setf (value the) (walk-form (third form) the env))))

UNWIND-PROTECT

Class UNWIND-PROTECT-FORM

(defwalker-handler unwind-protect (form parent env)
  (with-form-object (unwind-protect unwind-protect-form :parent parent
                                    :source form)
    (setf (protected-form unwind-protect) (walk-form (second form) unwind-protect env)
          (cleanup-form unwind-protect) (walk-implict-progn unwind-protect (cddr form) env))))

Implementation specific walkers

prev | up | next | toc

These are for forms which certain compilers treat specially but aren't macros or special-operators.

#+lispworks
(defwalker-handler compiler::internal-the (form parent env)
  (walk-form (third form) parent env))