Login/Register to vote and to have access to more featuresYou are here: Root > By Topic > Language Extensions
Hacking CL into a Lisp-1 (an intro to code-walking)
Created by marc.battyani on: Thu, 29 Jun 2006 18:28:02 GMT, Last modification: Mon, 03 Jul 2006 09:08:39 GMT
This code snippet shows how to turn Common Lisp into a Lisp-1 by using a technique called code walking.
This code snippset has been posted by Hoan Ton-That in a comp.lang.lisp thread. The original post is here
(This is now included in Arnesi)
;;;; -*- lisp -*-
(in-package :it.bese.arnesi)
;;;; * Entry point
(defgeneric lisp1 (form)
(:documentation "Translate FORM from Lisp-1 to Lisp-2.
Define methods on this generic function with DEFLISP1-WALKER."))
(defmethod lisp1 (form)
"If FORM isn't a FORM object, we'll convert it to one, apply
the transformation and convert it back."
(unwalk-form (lisp1 (walk-form form))))
(defmacro with-lisp1 (form)
"Execute FORM as if it were run in a Lisp-1."
(lisp1 form))
(defmacro deflisp1-walker (class (&rest slots) &body body)
"Define a Lisp-1 to Lisp-2 walker.
It takes the class of a CL form object, and its slots as
arguments. It also captures the variable FORM for convenience."
`(defmethod lisp1 ((form ,class))
(with-slots ,slots form
,@body)))
;;;; * Special Variables
(defvar *vars-bound* nil
"When walking code, this variable contains a list of
variables (represented by symbols) which have been bound in
the variable namespace.
In essence these variables do not have to be sharp-quoted.")
(defvar *funs-bound* nil
"When walking code, this variable contains a list of
variables (represented by symbols) which have been bound in
the function namespace.
In essence these variables must be sharp-quoted.")
(defmacro with-vars-bound (vars &body body)
"Execute BODY with VARS added to the variable namespace and
VARS removed from the function namespace.
This should only be used when code-walking."
`(let ((*vars-bound* (append *vars-bound* ,vars))
(*funs-bound* (set-difference *funs-bound* ,vars)))
,@body))
(defmacro with-funs-bound (funs &body body)
"Execute BODY with FUNS added to the function namespace and
FUNS removed from the variable namespace.
This should only be used when code-walking."
`(let ((*funs-bound* (append *funs-bound* ,funs))
(*vars-bound* (set-difference *vars-bound* ,funs)))
,@body))
;;;; * Definers
(defmacro defun1 (name (&rest args) &body body)
"Define a function with BODY written in Lisp-1 style.
This is just like DEFUN."
(with-vars-bound (extract-argument-names args :allow-specializers nil)
`(defun ,name ,args
,(lisp1 `(block ,name ,@body)))))
(defmacro defmethod1 (name (&rest args) &body body)
"Define a method with BODY written in Lisp-1 style.
This is just like DEFMETHOD."
(with-vars-bound (extract-argument-names args :allow-specializers t)
`(defmethod ,name ,args
,(lisp1 `(block ,name ,@body)))))
;;;; * Utils
(defun lisp1s (forms)
"Convert a list of forms to Lisp-1 style."
(mapcar #'lisp1 forms))
(defun lisp1b (binds)
"Convert an alist of (VAR . FORM) to Lisp-1 style."
(mapcar (lambda (bind)
(cons (car bind)
(lisp1 (cdr bind))))
binds))
;;;; * Walkers
(deflisp1-walker form ()
;; By default all forms will stay the same.
form)
(deflisp1-walker if-form (consequent then else)
;; Transform the test and branches recursively.
(new 'if-form
:consequent (lisp1 consequent)
:then (lisp1 then)
:else (lisp1 else)))
(deflisp1-walker lambda-function-form (arguments body)
;; For any function-form (ie lambda), we just transform the body.
;; We also must add the parameters to the variable namespace, and
;; remove the parameters from the function namespace.
(with-vars-bound (mapcar #'name arguments)
(new 'lambda-function-form
:arguments arguments
:body (lisp1s body))))
(deflisp1-walker variable-reference (name)
;; If a free variable is bound in the toplevel, *and* not bound by
;; an enclosing lambda, then we'll return that function. Also, if
;; the variable has been bound by an enclosing function binding form
;; then we'll return that function. We take advantage of the fact
;; that the `name' slot is shared.
(if (or (and (fboundp name) (not (member name *vars-bound*)))
(member name *funs-bound*))
(change-class form 'free-function-object-form)
form))
(deflisp1-walker application-form (operator arguments)
;; We transform all applications so they use explicit funcall. We
;; also must take into account ((a b) c ...) which must also
;; transform the operator accordingly.
(new 'free-application-form
:operator 'funcall
:arguments (cons (if (not (typep operator 'form))
(lisp1 (walk-form operator))
(lisp1 operator))
(lisp1s arguments))))
(deflisp1-walker function-binding-form (binds body)
;; Add all the bindings to the function namespace to be sharp
;; quoted.
(with-funs-bound (mapcar #'car binds)
(new (class-name-of form)
:binds (lisp1b binds)
:body (lisp1s body))))
(deflisp1-walker variable-binding-form (binds body)
;; Add all the bindings to the variable namespace so they aren't
;; sharp-quoted.
(with-vars-bound (mapcar #'car binds)
(new (class-name-of form)
:binds (lisp1b binds)
:body (lisp1s body))))
;; Walking all the other Common Lisp forms is rather straight-forward.
(deflisp1-walker setq-form (var value)
(new 'setq-form
:var var
:value (lisp1 value)))
(deflisp1-walker progn-form (body)
(new 'progn-form
:body (lisp1s body)))
(deflisp1-walker progv-form (vars-form values-form)
(new 'progv-form
:vars-form vars-form
:values-form (lisp1s values-form)))
(deflisp1-walker block-form (name body)
(new 'block-form
:name name
:body (lisp1s body)))
(deflisp1-walker return-from-form (target-block result)
(new 'return-from-form
:target-block target-block
:result (lisp1 result)))
(deflisp1-walker catch-form (tag body)
(new 'catch-form
:tag tag
:body (lisp1s body)))
(deflisp1-walker throw-form (tag value)
(new 'throw-form
:tag tag
:value (lisp1 value)))
(deflisp1-walker eval-when-form (body eval-when-times)
(new 'eval-when-form
:eval-when-times eval-when-times
:body (lisp1s body)))
(deflisp1-walker multiple-value-call-form (func arguments)
(new 'multiple-value-call-form
:func (lisp1 func)
:arguments (lisp1s arguments)))
(deflisp1-walker multiple-value-prog1-form (first-form other-forms)
(new 'multiple-value-prog1-form
:first-form (lisp1 first-form)
:other-forms (lisp1s other-forms)))
(deflisp1-walker symbol-macrolet-form (binds body)
(new 'symbol-macrolet-form
:binds (lisp1b binds)
:body (lisp1s body)))
(deflisp1-walker tagbody-form (body)
(new 'tagbody-form
:body (lisp1s body)))
(deflisp1-walker the-form (type-form value)
(new 'the-form
:type-form type-form
:value (lisp1 value)))
(deflisp1-walker unwind-protect-form (protected-form cleanup-form)
(new 'unwind-protect-form
:protected-form (lisp1 protected-form)
:cleanup-form (lisp1s cleanup-form)))
;;;; http://groups.google.com/group/comp.lang.lisp/browse_thread/thread/82994055009163e9
;; Copyright (c) 2006, Hoan Ton-That
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Hoan Ton-That, nor the names of the
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Authors
Tags
Language Extensions | Code Snippets
See Also
0 Notes and 0 comments
0 Notes
You must be logged to add a note
0 Comments
You must be logged to add a comment