From 00a814be5b4de5d7417dd47cdb4c4aac0f1d4613 Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 12 Nov 2023 14:33:38 +0900 Subject: [PATCH] micros/walker: add loop-form (wip) --- contrib/walker/example.lisp | 11 ++ contrib/walker/loop-form.lisp | 219 ++++++++++++++++++++++++++++++++ contrib/walker/tests/tests.lisp | 64 +++++++++- contrib/walker/walker.lisp | 18 +-- micros.asd | 3 +- 5 files changed, 299 insertions(+), 16 deletions(-) create mode 100644 contrib/walker/loop-form.lisp diff --git a/contrib/walker/example.lisp b/contrib/walker/example.lisp index 2ebed29..2536f05 100644 --- a/contrib/walker/example.lisp +++ b/contrib/walker/example.lisp @@ -116,3 +116,14 @@ (with-open-file (in filename) (read-line in)) + +(let ((x 0)) + (loop (f x))) + +(loop :with x := 0 + :with y := x + :with z := (f x y)) + +(loop :with x := 0 + :return :it + :return (f x)) diff --git a/contrib/walker/loop-form.lisp b/contrib/walker/loop-form.lisp new file mode 100644 index 0000000..2b1c6a0 --- /dev/null +++ b/contrib/walker/loop-form.lisp @@ -0,0 +1,219 @@ +(in-package :micros/walker) + +(defclass simple-loop-form (ast) + ((body :initarg :body + :type implict-progn-form + :reader ast-body))) + +(defclass loop-form (ast) + ((named :initarg :named + :type variable-symbol + :reader loop-form-named) + (with-clauses :initarg :with-clauses + :type (proper-list with-clause) + :reader loop-form-with-clauses) + (initial-clauses :initarg :initial-clauses + :type (proper-list initial-clause) + :reader loop-form-initial-clauses) + (fianl-clauses :initarg :final-clauses + :type (proper-list final-clause) + :reader loop-form-final-clauses) + (doing-forms :initarg :doing-forms + :type (proper-list ast) + :reader loop-form-doing-forms) + (return-forms :initarg :return-forms + :type (proper-list ast) + :reader loop-form-return-forms))) + +(defclass with-clause (ast ) + ((binding :initarg :binding + :reader ast-binding) + (value :initarg :value + :reader ast-value))) + +(defclass initial-clause (ast) + ((forms :initarg :forms + :type (proper-list ast) + :reader ast-forms))) + +(defclass final-clause (ast) + ((forms :initarg :forms + :type (proper-list ast) + :reader ast-forms))) + +(defclass it-form (ast) + ()) + +(defmethod walk-complex-loop-form ((walker walker) form env path) + (assert (and (proper-list-p form) (eq 'loop (first form)))) + (let ((pos 0) + (exps (rest form)) + (named-binding nil) + (with-clauses '()) + (initial-clauses '()) + (final-clauses '()) + (doing-forms '()) + (return-forms '())) + (labels ((lookahead () + (first exps)) + (next () + (walker-assert (not (null exps))) + (incf pos) + (pop exps)) + (accept (name) + (when (and (typep (lookahead) '(or symbol string)) + (string= name (lookahead))) + (next) + t)) + (exact-var () + (let ((var (next))) + (assert-type var 'variable-symbol) + var)) + + (name-clause () + (when (accept :named) + (let ((named (next))) + (assert-type named 'variable-symbol) + (setf named-binding (make-instance 'block-binding :name named)) + (extend-env env named-binding)))) + (variable-clause () + (when (or (with-clause) + (initial-final) + (for-as-clause)) + t)) + (variable-clause* () + (loop :while (variable-clause))) + (with-clause () + (when (accept :with) + (let ((with-clauses* + (loop :for var := (exact-var) ; TODO: d-var-spec + :do (type-spec) + :collect (make-instance + 'with-clause + :path (cons pos path) + :binding (make-instance 'lexical-variable-binding + :name var) + :value (when (accept :=) + (let ((value (walk walker + (next) + env + (cons pos path)))) + value))) + :while (accept :and)))) + (setf env (extend-env* env (mapcar #'ast-binding with-clauses*))) + (setf with-clauses (append with-clauses with-clauses*))))) + (main-clause () + (or (unconditional) + (accumulation) + (conditional) + (termination-test) + (initial-final) + )) + (main-clause* () + (loop :while (main-clause))) + (initial-final () + (cond ((accept :initially) + (push (make-instance 'initial-clause :forms (compound-forms)) + initial-clauses)) + ((accept :finally) + (push (make-instance 'final-clause :forms (compound-forms)) + final-clauses)))) + (unconditional () + (cond ((or (accept :do) + (accept :doing)) + (setf doing-forms (append doing-forms (compound-forms)))) + ((accept :return) + (if (accept :it) + (push (make-instance 'it-form :path (cons pos path)) + return-forms) + (let ((form (next))) + (push (walk walker form env (cons pos path)) + return-forms)))))) + (accumulation () + ;; TODO + ) + (conditional () + ;; TODO + ) + (termination-test () + ;; TODO + ) + (for-as-clause () + (loop :while (or (accept :for) (accept :as)) + :collect (for-as-subclause))) + (for-as-subclause () + (let ((var (exact-var))) + (type-spec) + (let ((binding (make-instance 'lexical-variable-binding :name var))) + (declare (ignore binding)) + (cond ((accept :in) + ) + ((accept :on) + ) + ((accept :=) + ) + ((accept :across) + ) + ((accept :being) + ) + (t + ;; TODO: error + ))))) + (type-spec () + (cond ((member (lookahead) '(t nil fixnum float)) + (next) + t) + ((accept :of-type) + (next) + t) + (t + nil))) + (compound-forms () + (let ((exp (next))) + (walker-assert (consp exp)) + (cons (walk walker exp env (cons pos path)) + (loop :for exp := (lookahead) + :while (consp exp) + :collect (walk walker exp env (cons pos path)) + :do (next)))))) + (name-clause) + (variable-clause*) + (main-clause*) + (make-instance 'loop-form + :named named-binding + :with-clauses (nreverse with-clauses) + :initial-clauses (nreverse initial-clauses) + :final-clauses (nreverse final-clauses) + :doing-forms (nreverse doing-forms) + :return-forms (nreverse return-forms))))) + +(defmethod walk-form ((walker walker) (name (eql 'loop)) form env path) + (with-walker-bindings (&body forms) (rest form) + (if (and forms (symbolp (first forms))) + (walk-complex-loop-form walker form env path) + (make-instance 'simple-loop-form + :body (make-instance 'implict-progn-form + :path path + :forms (walk-forms walker forms env path 1)))))) + +(defmethod visit (visitor (ast loop-form)) + (visit-foreach visitor (loop-form-with-clauses ast)) + (visit-foreach visitor (loop-form-initial-clauses ast)) + (visit-foreach visitor (loop-form-final-clauses ast)) + (visit-foreach visitor (loop-form-doing-forms ast)) + (visit-foreach visitor (loop-form-return-forms ast))) + +(defmethod visit (visitor (ast with-clause)) + (visit visitor (ast-value ast))) + +(defmethod visit (visitor (ast initial-clause)) + (visit-foreach visitor (ast-forms ast))) + +(defmethod visit (visitor (ast final-clause)) + (visit-foreach visitor (ast-forms ast))) + +(defmethod visit (visitor (ast it-form)) + nil) + +(defmethod visit (visitor (ast simple-loop-form)) + (visit visitor (ast-body ast))) diff --git a/contrib/walker/tests/tests.lisp b/contrib/walker/tests/tests.lisp index fd9f96f..858e3cc 100644 --- a/contrib/walker/tests/tests.lisp +++ b/contrib/walker/tests/tests.lisp @@ -1736,7 +1736,69 @@ ((LAMBDA (COMMON-LISP-USER::A) (DECLARE (SPECIAL COMMON-LISP-USER::A)) COMMON-LISP-USER::A)) COMMON-LISP-USER::A) (3 0 3)) - ((3 0 4) (0 1 0 4) (3 0 3) (0 1 0 3))))) + ((3 0 4) (0 1 0 4) (3 0 3) (0 1 0 3))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LET ((X 0)) + (LOOP (F X))) + (1 1 2)) + ((1 1 2) (0 0 1))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LET ((X 0)) + (LOOP (F X))) + (0 0 1)) + ((1 1 2) (0 0 1))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :WITH Y := X + :WITH Z := (F X Y)) + (2 12)) + ((6) (2 12))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :WITH Y := X + :WITH Z := (F X Y)) + (1 12)) + ((2) (8) (1 12))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :WITH Y := X + :WITH Z := (F X Y)) + (8)) + ((2) (8) (1 12))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :WITH Y := X + :WITH Z := (F X Y)) + (10)) + ((10))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :WITH Y := X + :WITH Z := (F X Y)) + (6)) + ((6) (2 12))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :WITH Y := X + :WITH Z := (F X Y)) + (2)) + ((2) (8) (1 12))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :DO (F X)) + (1 6)) + ((1 6) (2))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS + (LOOP :WITH X := 0 + :DO (F X)) + (2)) + ((1 6) (2))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LOOP :WITH X := 0 :RETURN :IT :RETURN (F X)) (6)) + NIL) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LOOP :WITH X := 0 :RETURN :IT :RETURN (F X)) (1 8)) + ((1 8) (2))) + ((MICROS/WALKER:COLLECT-HIGHLIGHT-PATHS (LOOP :WITH X := 0 :RETURN :IT :RETURN (F X)) (2)) + ((1 8) (2))))) (deftest random (loop :for (act-form expected) :in *test-cases* diff --git a/contrib/walker/walker.lisp b/contrib/walker/walker.lisp index 25c68e9..3887758 100644 --- a/contrib/walker/walker.lisp +++ b/contrib/walker/walker.lisp @@ -717,7 +717,7 @@ path 2)))))))) -(defun walk-macro-1 (walker form path env lambda-list) +(defun walk-macro (walker form path env lambda-list) (let ((body-pos (position '&body lambda-list))) (cond (;; (with-* (var &rest forms) &body body) (and (string-prefix-p "WITH-" (string (first form))) @@ -736,13 +736,6 @@ (1+ body-pos))) (error 'unimplemented :context form)))))) -(defmethod walk-macro ((walker walker) form env path expansion) - (walk-macro-1 walker - form - path - env - (micros/backend:arglist (first form)))) - (defmethod walk-lambda-call-form ((walker walker) form env path) (with-walker-bindings (lambda-form &rest args) form (make-instance 'lambda-call-form @@ -754,14 +747,11 @@ (defmethod walk-form ((walker walker) name form env path) (let ((macrolet-binding (lookup-macrolet-binding env name))) (if macrolet-binding - (walk-macro-1 walker - form - path - env - (macrolet-binding-lambda-list macrolet-binding)) + (walk-macro walker form path env (macrolet-binding-lambda-list macrolet-binding)) (multiple-value-bind (expansion expanded) (macroexpand-1 form) + (declare (ignore expansion)) (if expanded - (walk-macro walker form env path expansion) + (walk-macro walker form path env (micros/backend:arglist (first form))) (let ((name (first form))) (if (consp name) (walk-lambda-call-form walker form env path) diff --git a/micros.asd b/micros.asd index b8186b6..144c20a 100644 --- a/micros.asd +++ b/micros.asd @@ -53,7 +53,8 @@ (:file "types") (:file "walker") (:file "defun-form") - (:file "defmethod-form"))))) + (:file "defmethod-form") + (:file "loop-form"))))) (:file "lsp-api"))) (defsystem "micros/tests"