Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

introduce walk-application to extend customizability (qq-js uses it)

  • Loading branch information...
commit e3c60ba297a947c13fcfe24fd4bfaf8c95a7c29c 1 parent bc39f36
@attila-lendvai attila-lendvai authored
Showing with 46 additions and 38 deletions.
  1. +46 −38 source/function.lisp
View
84 source/function.lisp
@@ -45,45 +45,53 @@
;; KLUDGE: The cadr is for getting rid of (function ...) which we can't have at the beginning of a form.
(cons (cadr (recurse operator)) (recurse-on-body arguments)))
+(def (layered-function e) walk-application (form parent operator arguments env)
+ (:method (-form- -parent- operator arguments -environment-)
+ (macrolet ((-lookup- (type name &key (otherwise nil))
+ `(%repository/find (env/walked-environment -environment-) ,type ,name :otherwise ,otherwise)))
+ (labels ((recurse (node &optional (parent -parent-))
+ (walk-form node :parent parent :environment -environment-))
+ (walk-arguments (application-form)
+ (loop
+ :for index :from 1
+ :for arg :in arguments
+ :collect (recurse arg application-form))))
+ (when (lambda-form? operator)
+ (return-from walk-application
+ (with-form-object (application 'lambda-application-form -parent-)
+ (setf (operator-of application) (walk-lambda operator application -environment-)
+ (arguments-of application) (walk-arguments application)))))
+ (bind ((lexenv (env/lexical-environment -environment-))
+ ((:values innermost-lexical-definition-type nil expander) (-lookup- nil operator)))
+ (awhen (eq :macro innermost-lexical-definition-type)
+ (bind ((*inside-macroexpansion* t)
+ (expansion (funcall expander -form- lexenv)))
+ (return-from walk-application (recurse expansion))))
+ (when (and (symbolp operator)
+ (macro-name? operator lexenv)
+ (not (member innermost-lexical-definition-type '(:function :unwalked-function))))
+ (bind (((:values expansion expanded?) (walker-macroexpand-1 -form- lexenv)))
+ (when expanded?
+ (bind ((*inside-macroexpansion* t))
+ (return-from walk-application (recurse expansion)))))))
+ (bind ((application-form (aif (-lookup- :function operator)
+ (make-instance 'walked-lexical-application-form :definition it)
+ (if (-lookup- :unwalked-function operator)
+ (make-instance 'unwalked-lexical-application-form)
+ (progn
+ (when (and (symbolp operator)
+ (not (function-name? operator)))
+ (handle-undefined-reference :function operator))
+ (make-instance 'free-application-form))))))
+ (setf (operator-of application-form) operator)
+ (setf (parent-of application-form) -parent-)
+ (setf (source-of application-form) -form-)
+ (setf (arguments-of application-form) (walk-arguments application-form))
+ application-form)))))
+
(def walker application
- (bind (((operator &rest args) -form-))
- (flet ((walk-arguments (application-form)
- (loop
- :for index :from 1
- :for arg :in args
- :collect (recurse arg application-form))))
- (when (lambda-form? operator)
- (return
- (with-form-object (application 'lambda-application-form -parent-)
- (setf (operator-of application) (walk-lambda operator application -environment-)
- (arguments-of application) (walk-arguments application)))))
- (bind ((lexenv (env/lexical-environment -environment-))
- ((:values innermost-lexical-definition-type nil expander) (-lookup- nil operator)))
- (awhen (eq :macro innermost-lexical-definition-type)
- (bind ((*inside-macroexpansion* t)
- (expansion (funcall expander -form- lexenv)))
- (return (recurse expansion))))
- (when (and (symbolp operator)
- (macro-name? operator lexenv)
- (not (member innermost-lexical-definition-type '(:function :unwalked-function))))
- (bind (((:values expansion expanded?) (walker-macroexpand-1 -form- lexenv)))
- (when expanded?
- (bind ((*inside-macroexpansion* t))
- (return (recurse expansion)))))))
- (bind ((application-form (aif (-lookup- :function operator)
- (make-instance 'walked-lexical-application-form :definition it)
- (if (-lookup- :unwalked-function operator)
- (make-instance 'unwalked-lexical-application-form)
- (progn
- (when (and (symbolp operator)
- (not (function-name? operator)))
- (handle-undefined-reference :function operator))
- (make-instance 'free-application-form))))))
- (setf (operator-of application-form) operator)
- (setf (parent-of application-form) -parent-)
- (setf (source-of application-form) -form-)
- (setf (arguments-of application-form) (walk-arguments application-form))
- application-form))))
+ (bind (((operator &rest arguments) -form-))
+ (walk-application -form- -parent- operator arguments -environment-)))
;;;; Functions
Please sign in to comment.
Something went wrong with that request. Please try again.