diff --git a/contrib/walker/example.lisp b/contrib/walker/example.lisp index e0aa059..29e752f 100644 --- a/contrib/walker/example.lisp +++ b/contrib/walker/example.lisp @@ -286,3 +286,10 @@ (defvar x (let ((foo 0)) foo)) + +(tagbody + (uiop:println 1) + (go foo) + (uiop:println 2) + foo + (uiop:println 3)) diff --git a/contrib/walker/tests/test-cases.lisp b/contrib/walker/tests/test-cases.lisp index 46911d3..b15e9b7 100644 --- a/contrib/walker/tests/test-cases.lisp +++ b/contrib/walker/tests/test-cases.lisp @@ -3779,3 +3779,33 @@ MICROS/WALKER::B) (0 0 1)) ((2) (0 0 1))) +((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (TAGBODY + (UIOP/STREAM:PRINTLN 1) + (GO MICROS/WALKER::FOO) + (GO MICROS/WALKER::FOO) + (UIOP/STREAM:PRINTLN 2) + MICROS/WALKER::FOO + (UIOP/STREAM:PRINTLN 3)) + (5)) + ((5) (1 3) (1 2))) +((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (TAGBODY + (UIOP/STREAM:PRINTLN 1) + (GO MICROS/WALKER::FOO) + (GO MICROS/WALKER::FOO) + (UIOP/STREAM:PRINTLN 2) + MICROS/WALKER::FOO + (UIOP/STREAM:PRINTLN 3)) + (1 3)) + ((5) (1 3) (1 2))) +((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (TAGBODY + (UIOP/STREAM:PRINTLN 1) + (GO MICROS/WALKER::FOO) + (GO MICROS/WALKER::FOO) + (UIOP/STREAM:PRINTLN 2) + MICROS/WALKER::FOO + (UIOP/STREAM:PRINTLN 3)) + (1 2)) + ((5) (1 3) (1 2))) diff --git a/contrib/walker/walker.lisp b/contrib/walker/walker.lisp index 4a497b2..5b25f3e 100644 --- a/contrib/walker/walker.lisp +++ b/contrib/walker/walker.lisp @@ -44,6 +44,7 @@ (defclass special-variable-binding (binding) ()) (defclass lexical-variable-binding (binding) ()) (defclass lexical-function-binding (binding) ()) +(defclass tagbody-binding (binding) ()) (defclass block-binding (binding) ()) (defclass macrolet-binding (binding) ((lambda-list :initarg :lambda-list @@ -71,6 +72,9 @@ (defun lookup-macrolet-binding (env name) (lookup-binding env name 'macrolet-binding)) +(defun lookup-tagbody-binding (env name) + (lookup-binding env name 'tagbody-binding)) + (defun lookup-block-binding (env name) (lookup-binding env name 'block-binding)) @@ -218,6 +222,21 @@ (value :initarg :value :reader ast-value))) +(defclass tagbody-form (ast) + ((statements :type (proper-list (or ast tag)) + :initarg :statements + :reader ast-statements))) + +(defclass tag (ast ) + ((binding :type tagbody-binding + :initarg :binding + :reader ast-binding))) + +(defclass go-form (ast) + ((tag :type tag + :initarg :tag + :reader ast-tag))) + (defclass the-form (ast) ((value-type :initarg :value-type :reader ast-value-type) @@ -670,10 +689,30 @@ (unimplemented name :form form :path path)) (defmethod walk-form ((walker walker) (name (eql 'tagbody)) form env path) - (unimplemented name :form form :path path)) + (with-walker-bindings (&rest statements) (rest form) + (let* ((bindings (mapcar (lambda (tag) + (make-instance 'tagbody-binding :name tag)) + (remove-if-not #'symbolp statements))) + (env (extend-env* env bindings)) + (statements + (loop :for statement :in statements + :for n :from 1 + :collect (if (symbolp statement) + (make-instance 'tag + :binding (lookup-tagbody-binding env statement) + :path (cons n path)) + (walk walker statement env (cons n path)))))) + (make-instance 'tagbody-form + :path (cons 0 path) + :statements statements)))) (defmethod walk-form ((walker walker) (name (eql 'go)) form env path) - (unimplemented name :form form :path path)) + (with-walker-bindings (tag) (rest form) + (make-instance 'go-form + :tag (make-instance 'tag + :binding (lookup-tagbody-binding env tag) + :path (cons 1 path)) + :path (cons 0 path)))) (defmethod walk-form ((walker walker) (name (eql 'the)) form env path) (with-walker-bindings (value-type form) (rest form) @@ -872,6 +911,18 @@ (visit visitor (ast-proctected-form ast)) (visit-foreach visitor (ast-cleanup-forms ast))) +(defmethod visit (visitor (ast tagbody-form)) + (visit-foreach visitor (ast-statements ast))) + +(defmethod visit (visitor (ast tag)) + (values)) + +(defmethod visit (visitor (ast go-form)) + (visit visitor (ast-tag ast))) + +(defmethod visit (visitor (ast return-from-form)) + (values)) + (defmethod visit (visitor (ast block-name-form)) (values))