119 lines
4.1 KiB
Common Lisp
119 lines
4.1 KiB
Common Lisp
#|
|
|
This file is a part of stoe project.
|
|
Copyright (c) 2015 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|
|
|#
|
|
|
|
(uiop:define-package :stoe/shader/walker
|
|
(:use :cl :stoe/core/utils)
|
|
(:export #:walk-1
|
|
#:walk-list
|
|
#:walk
|
|
#:defhandler))
|
|
(in-package :stoe/shader/walker)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(defvar *form-handlers* (make-hash-table)
|
|
"A special variable containing the handlers for our dsl keywords."))
|
|
|
|
(defvar *default-handler* nil
|
|
"A special variable containing the default handler used for unknown function symbols.")
|
|
|
|
(defvar *symbol-handler* nil
|
|
"A special variable containing the default handler used for single symbols.")
|
|
|
|
(defvar *env* nil
|
|
"A special variable used as a container for the macro environment.")
|
|
|
|
(defun form-handler (first)
|
|
"Retreive the handler for the symbol FIRST."
|
|
(gethash (intern (symbol-name first) :keyword)
|
|
*form-handlers* *default-handler*))
|
|
|
|
(defun binding-to-symbol (binding)
|
|
(let ((name (safe-first binding)))
|
|
(cond ((listp name)
|
|
(assert (eq 'setf (first name)))
|
|
(check-type (second name) symbol)
|
|
(second name))
|
|
(t
|
|
name))))
|
|
|
|
(defmacro with-imposed-bindings (&body body)
|
|
#-sbcl
|
|
`(locally ,@body)
|
|
#+sbcl
|
|
(destructuring-bind ((binder bindings &rest binder-body))
|
|
body
|
|
`(locally
|
|
(declare (sb-ext:disable-package-locks
|
|
,@(mapcar 'binding-to-symbol bindings)))
|
|
(,binder ,bindings ,@binder-body))))
|
|
|
|
(defun function-name-p (name)
|
|
"Return whether NAME is the name of a function."
|
|
(or (symbolp name)
|
|
(and (listp name) (eq (first name) 'setf) (symbolp (second name))
|
|
(not (cddr name)))))
|
|
|
|
(defun compiler-macroexpand-1 (form &optional env)
|
|
"Try and expand the compiler macro defined for the first element of FORM if it exists."
|
|
(let ((cm (and (listp form) (function-name-p (first form))
|
|
(compiler-macro-function (first form) env))))
|
|
(if cm
|
|
(funcall *macroexpand-hook* cm form env)
|
|
form)))
|
|
|
|
(defun walk-1 (form)
|
|
"Walk across the specified form."
|
|
(flet ((handle (form)
|
|
(apply (form-handler (first form)) form)))
|
|
(cond ((and (listp form) (gethash (intern (symbol-name (first form)) :keyword)
|
|
*form-handlers*))
|
|
(handle form))
|
|
(t
|
|
(multiple-value-bind (form expanded)
|
|
(macroexpand-1 form *env*)
|
|
(cond (expanded
|
|
(walk-1 form))
|
|
(t
|
|
(typecase form
|
|
(null nil)
|
|
(list
|
|
(let ((next (compiler-macroexpand-1 form)))
|
|
(if (eq form next)
|
|
(handle form)
|
|
(walk-1 next))))
|
|
(symbol (apply *symbol-handler* form))
|
|
(t
|
|
form)))))))))
|
|
|
|
(defun walk-list (list)
|
|
"Apply `walk-1' to all members of LIST."
|
|
(mapcar #'walk-1 list))
|
|
|
|
(defun default-form-handler (first &rest rest)
|
|
"Handle FORM when FIRST is not a special form."
|
|
(if (symbolp first)
|
|
`',first
|
|
(walk-1 first)) (walk-list rest))
|
|
|
|
(defmacro defhandler (symbol lambda-list &body body)
|
|
(let ((syms (safe-list symbol)))
|
|
(let ((func (intern (format nil "~a~a" 'handler- (first syms)))))
|
|
`(progn
|
|
(defun ,func ,lambda-list
|
|
,@body)
|
|
(setf ,@(loop for sym in syms
|
|
collect `(gethash ,(intern (symbol-name sym) :keyword)
|
|
,(intern (symbol-name '*form-handlers*)))
|
|
collect `',func))))))
|
|
|
|
(defun walk (form handlers default-handler symbol-handler env)
|
|
"Walk the sexp FORM and transform it according to the rules defined in HANDLERS.
|
|
When no known symbol is parsed, it is either handled by DEFAULT-HANDLER or by SYMBOL-HANDLER,
|
|
whether it is the first symbol of a form or just a single symbol."
|
|
(let ((*form-handlers* handlers)
|
|
(*default-handler* default-handler)
|
|
(*symbol-handler* symbol-handler)
|
|
(*env* env))
|
|
(walk-1 form)))
|