From cc0efc9176468244a53d7d4ec890433d1a68411c Mon Sep 17 00:00:00 2001 From: cxxxr Date: Sun, 3 Dec 2023 00:41:28 +0900 Subject: [PATCH] micros/walker: add something operators --- contrib/walker/TODO | 189 +++++++++++----------- contrib/walker/data-and-control-flow.lisp | 173 ++++++++++++++++---- contrib/walker/example.lisp | 26 +++ 3 files changed, 268 insertions(+), 120 deletions(-) diff --git a/contrib/walker/TODO b/contrib/walker/TODO index 86e25e5..5cc1100 100644 --- a/contrib/walker/TODO +++ b/contrib/walker/TODO @@ -1,91 +1,98 @@ -- [ ] DEFINE-MODIFY-MACRO -- [X] LOOP -- [X] NTH-VALUE -- [X] CHECK-TYPE -- [ ] COND -- [X] WITH-INPUT-FROM-STRING: with-single-binding-form -- [ ] DEFCONSTANT -- [ ] WITH-COMPILATION-UNIT -- [ ] DEFPARAMETER -- [ ] SETF -- [ ] DEFINE-METHOD-COMBINATION -- [ ] DEFINE-SYMBOL-MACRO -- [ ] WITH-STANDARD-IO-SYNTAX -- [ ] DEFSETF -- [ ] RETURN -- [ ] UNTRACE -- [ ] RESTART-BIND -- [ ] DEFSTRUCT -- [ ] WITH-OPEN-STREAM -- [ ] DO -- [ ] PUSH -- [ ] WITH-HASH-TABLE-ITERATOR -- [ ] DO-SYMBOLS -- [ ] TIME -- [ ] DEFMACRO -- [ ] PSETQ -- [ ] DO-EXTERNAL-SYMBOLS -- [ ] PROG* -- [ ] DEFINE-COMPILER-MACRO -- [ ] PPRINT-EXIT-IF-LIST-EXHAUSTED -- [X] OR -- [ ] DO-ALL-SYMBOLS -- [ ] TYPECASE -- [ ] IN-PACKAGE -- [ ] DOTIMES -- [ ] PROG2 -- [ ] DEFGENERIC -- [ ] MULTIPLE-VALUE-BIND -- [ ] DEFPACKAGE -- [ ] PUSHNEW -- [ ] DEFCLASS -- [ ] POP -- [ ] WITH-PACKAGE-ITERATOR -- [ ] CALL-METHOD -- [ ] WITH-CONDITION-RESTARTS -- [ ] HANDLER-BIND -- [X] WITH-OPEN-FILE: with-single-binding-form -- [ ] WITH-SLOTS -- [ ] SHIFTF -- [ ] PPRINT-POP -- [ ] ASSERT -- [X] LAMBDA -- [X] AND -- [ ] TRACE -- [X] WITH-OUTPUT-TO-STRING: with-single-binding-form -- [ ] ROTATEF -- [ ] CASE -- [ ] MULTIPLE-VALUE-SETQ -- [ ] MULTIPLE-VALUE-LIST -- [ ] ETYPECASE -- [ ] PPRINT-LOGICAL-BLOCK -- [ ] WITH-SIMPLE-RESTART -- [ ] PRINT-UNREADABLE-OBJECT -- [ ] FORMATTER -- [ ] PROG1 -- [ ] RESTART-CASE -- [ ] WHEN -- [ ] REMF -- [ ] CTYPECASE -- [ ] IGNORE-ERRORS -- [ ] LOOP-FINISH -- [ ] PROG -- [ ] UNLESS -- [ ] DECLAIM -- [ ] DEFINE-CONDITION -- [ ] DEFINE-SETF-EXPANDER -- [X] DEFUN -- [ ] HANDLER-CASE -- [ ] CCASE -- [ ] DO* -- [ ] ECASE -- [ ] WITH-ACCESSORS -- [ ] STEP -- [X] DECF -- [ ] DEFVAR -- [ ] DESTRUCTURING-BIND -- [X] DEFMETHOD -- [X] INCF -- [ ] PSETF -- [ ] DOLIST -- [ ] DEFTYPE +;; -*- mode:lisp -*- + +- [X] DEFUN 3154 +- [X] SETF 1685 +- [X] WHEN 1397 +- [X] OR 921 +- [X] AND 895 +- [X] DEFMETHOD 719 +- [X] LAMBDA 683 +- [X] LOOP 637 +- [X] UNLESS 581 +- [ ] DEFVAR 524 +- [X] RETURN 522 +- [ ] COND 446 +- [ ] DO 442 +- [X] IN-PACKAGE 379 +- [ ] DEFPACKAGE 272 +- [ ] DEFCLASS 235 +- [ ] PUSH 161 +- [ ] DOLIST 161 +- [ ] DEFGENERIC 158 +- [ ] ASSERT 158 +- [ ] MULTIPLE-VALUE-BIND 157 +- [ ] CHECK-TYPE 143 +- [ ] DEFMACRO 141 +- [ ] CASE 114 +- [X] INCF 113 +- [ ] HANDLER-CASE 100 +- [ ] DEFPARAMETER 97 +- [ ] DESTRUCTURING-BIND 91 +- [ ] DEFSTRUCT 90 +- [ ] WITH-OUTPUT-TO-STRING 68 +- [X] DECF 52 +- [ ] DOTIMES 48 +- [ ] ETYPECASE 42 +- [ ] PROG1 41 +- [ ] IGNORE-ERRORS 39 +- [ ] ECASE 38 +- [ ] DEFINE-CONDITION 37 +- [ ] WITH-SLOTS 35 +- [ ] DEFTYPE 30 +- [ ] POP 29 +- [ ] HANDLER-BIND 28 +- [ ] WITH-OPEN-FILE 24 +- [ ] MULTIPLE-VALUE-LIST 23 +- [ ] DEFCONSTANT 23 +- [ ] PUSHNEW 22 +- [ ] TIME 19 +- [ ] TYPECASE 18 +- [ ] WITH-INPUT-FROM-STRING 18 +- [ ] TRACE 17 +- [ ] ROTATEF 15 +- [X] NTH-VALUE 14 +- [ ] PRINT-UNREADABLE-OBJECT 12 +- [ ] DECLAIM 11 +- [ ] MULTIPLE-VALUE-SETQ 10 +- [ ] WITH-OPEN-STREAM 9 +- [ ] WITH-ACCESSORS 8 +- [ ] PROG 7 +- [ ] DEFINE-COMPILER-MACRO 5 +- [ ] RESTART-CASE 5 +- [ ] WITH-STANDARD-IO-SYNTAX 5 +- [ ] DEFINE-SYMBOL-MACRO 4 +- [ ] PROG2 4 +- [ ] STEP 3 +- [ ] DEFSETF 3 +- [ ] DEFINE-SETF-EXPANDER 3 +- [ ] DEFINE-MODIFY-MACRO 3 +- [ ] CCASE 3 +- [ ] CTYPECASE 3 +- [ ] RESTART-BIND 3 +- [ ] WITH-COMPILATION-UNIT 3 +- [ ] WITH-CONDITION-RESTARTS 3 +- [ ] DO-ALL-SYMBOLS 2 +- [ ] PPRINT-LOGICAL-BLOCK 2 +- [ ] PSETF 2 +- [ ] UNTRACE 2 +- [ ] DEFINE-METHOD-COMBINATION 2 +- [ ] WITH-HASH-TABLE-ITERATOR 2 +- [ ] WITH-PACKAGE-ITERATOR 2 +- [ ] WITH-SIMPLE-RESTART 2 +- [ ] DO-EXTERNAL-SYMBOLS 2 +- [ ] CALL-METHOD 1 +- [ ] DO-SYMBOLS 1 +- [ ] FORMATTER 1 +- [ ] LOOP-FINISH 1 +- [ ] PPRINT-EXIT-IF-LIST-EXHAUSTED 1 +- [ ] PPRINT-POP 1 +- [ ] PSETQ 1 +- [ ] REMF 1 +- [ ] SHIFTF 1 + +* ローカル関数の(setf ...)を扱えない +(let (storage) + (flet (((setf storage) (value) + (setf storage value))) + (setf (storage) 100)) + storage) diff --git a/contrib/walker/data-and-control-flow.lisp b/contrib/walker/data-and-control-flow.lisp index c2bd636..f59771c 100644 --- a/contrib/walker/data-and-control-flow.lisp +++ b/contrib/walker/data-and-control-flow.lisp @@ -1,51 +1,110 @@ (in-package #:micros/walker) (eval-when (:compile-toplevel :load-toplevel :execute) + (defstruct walker-lambda-list-spec + required-arguments + optional-arguments + optional-position + rest-variable + rest-pos) + + (defun all-arguments (spec) + (append (walker-lambda-list-spec-required-arguments spec) + (when (walker-lambda-list-spec-rest-variable spec) + (list (walker-lambda-list-spec-rest-variable spec))) + (walker-lambda-list-spec-optional-arguments spec))) + + (defun parse-walker-lambda-list (lambda-list) + (let ((rest-pos (or (position '&rest lambda-list) + (position '&body lambda-list))) + (optional-pos (position '&optional lambda-list))) + (make-walker-lambda-list-spec + :required-arguments (subseq lambda-list 0 (or optional-pos rest-pos)) + :optional-arguments (when optional-pos (subseq lambda-list (1+ optional-pos))) + :optional-position optional-pos + :rest-variable (when rest-pos (elt lambda-list (1+ rest-pos))) + :rest-pos rest-pos))) + (defun reader-name (symbol) (intern (format nil "AST-~A" symbol))) - (defun expand-simple-walker-defclass (walker-name arguments) + (defun expand-simple-walker-defclass (walker-name spec) `(defclass ,walker-name (ast) - ,(loop :for argument :in arguments + ,(loop :for argument + :in (all-arguments spec) :collect `(,argument :initarg ,(make-keyword argument) :reader ,(reader-name argument))))) (defun expand-simple-walker-defmethod-walk-form - (walker-name operator-name arguments) - (with-gensyms (walker name form env path) + (walker-name operator-name spec) + (with-gensyms (walker name form env path arg) `(defmethod walk-form ((,walker walker) (,name (eql ',operator-name)) ,form ,env ,path) - (make-instance ',walker-name - ,@(loop :for argument :in arguments - :for n :from 1 - :collect (make-keyword argument) - :collect `(walk ,walker - (elt ,form ,n) - ,env - (cons ,n ,path))))))) - - (defun expand-simple-walker-defmethod-visit (walker-name arguments) + (make-instance + ',walker-name + ,@(loop :for argument :in (walker-lambda-list-spec-required-arguments spec) + :for n :from 1 + :collect (make-keyword argument) + :collect `(walk ,walker + (elt ,form ,n) + ,env + (cons ,n ,path))) + ,@(when (walker-lambda-list-spec-optional-position spec) + (loop :for argument :in (walker-lambda-list-spec-optional-arguments spec) + :for n :from (1+ (walker-lambda-list-spec-optional-position spec)) + :collect (make-keyword argument) + :collect `(let ((,arg (nth ,n ,form))) + (when ,arg + (walk ,walker + ,arg + ,env + (cons ,n ,path)))))) + ,@(when (walker-lambda-list-spec-rest-variable spec) + (with-gensyms (var n) + `(,(make-keyword (walker-lambda-list-spec-rest-variable spec)) + (loop :for ,var :in (nthcdr ,(walker-lambda-list-spec-rest-pos spec) ,form) + :for ,n :from ,(walker-lambda-list-spec-rest-pos spec) + :collect (walk ,walker ,var ,env (cons ,n ,path)))))))))) + + (defun expand-simple-walker-defmethod-visit (walker-name spec) (with-gensyms (visitor ast) `(defmethod visit (,visitor (,ast ,walker-name)) - ,@(loop :for argument :in arguments - :collect `(visit ,visitor (,(reader-name argument) ,ast)))))) + ,@(loop :for argument :in (walker-lambda-list-spec-required-arguments spec) + :collect `(visit ,visitor (,(reader-name argument) ,ast))) + ,@(loop :for argument :in (walker-lambda-list-spec-optional-arguments spec) + :collect `(when (,(reader-name argument) ,ast) + (visit ,visitor (,(reader-name argument) ,ast)))) + ,(when (walker-lambda-list-spec-rest-variable spec) + `(visit-foreach ,visitor + (,(reader-name (walker-lambda-list-spec-rest-variable spec)) ,ast)))))) - (defun expand-simple-walker (walker-name operator-name arguments) - `(progn - ,(expand-simple-walker-defclass walker-name arguments) - ,(expand-simple-walker-defmethod-walk-form walker-name - operator-name - arguments) - ,(expand-simple-walker-defmethod-visit walker-name arguments)))) + (defun expand-simple-walker (walker-name operator-name lambda-list) + (let ((spec (parse-walker-lambda-list lambda-list))) + `(progn + ,(expand-simple-walker-defclass + walker-name + spec) + ,(expand-simple-walker-defmethod-walk-form + walker-name + operator-name + spec) + ,(expand-simple-walker-defmethod-visit + walker-name + spec))))) -(defmacro def-simple-walker (walker-name operator-name &rest arguments) - (expand-simple-walker walker-name operator-name arguments)) +(defmacro def-simple-walker (walker-name operator-name lambda-list) + (expand-simple-walker walker-name operator-name lambda-list)) -(def-simple-walker nth-value-form nth-value n form) -(def-simple-walker or-form or n form) -(def-simple-walker incf-form incf n form) -(def-simple-walker decf-form decf n form) +(def-simple-walker nth-value-form nth-value (n form)) +(def-simple-walker incf-form incf (n form)) +(def-simple-walker decf-form decf (n form)) +(def-simple-walker or-form or (&rest forms)) +(def-simple-walker and-form and (&rest forms)) +(def-simple-walker when-form when (test &body forms)) +(def-simple-walker unless-form unless (test &body forms)) +(def-simple-walker return-form return (&optional value)) +(def-simple-walker in-package-form in-package (string-designator)) ;; check-type (defclass check-type-form (ast) @@ -65,3 +124,59 @@ (defmethod visit (visitor (ast check-type-form)) (visit visitor (ast-place ast)) (visit visitor (ast-type-string ast))) + +;; setf +(defclass setf-form (ast) + ((forms :initarg :forms + :reader ast-forms))) + +(defclass setf-symbol-form (ast) + ((var :initarg :var + :type binding + :reader ast-var) + (value :initarg :value + :reader ast-value))) + +(defclass setf-complex-form (ast) + ((operator :initarg :operator + :type variable-symbol + :reader ast-operator) + (arguments :initarg :arguments + :reader ast-arguments) + (value :initarg :value + :reader ast-value))) + +(defmethod walk-form ((walker walker) (name (eql 'setf)) form env path) + (make-instance + 'setf-form + :path path + :forms (loop :for (place value) :on (rest form) :by #'cddr + :for n :from 1 :by 2 + :for walked-value := (walk walker + value + env + (cons (1+ n) path)) + :collect (if (symbolp place) + (make-instance 'setf-symbol-form + :var (walk-variable walker place env (cons n path)) + :value walked-value) + (make-instance 'setf-complex-form + :operator (first place) + :arguments (loop :for m :from 1 + :for arg :in (rest place) + :collect (walk walker + arg + env + (list* m n path))) + :value walked-value))))) + +(defmethod visit (visitor (ast setf-form)) + (visit-foreach visitor (ast-forms ast))) + +(defmethod visit (visitor (ast setf-symbol-form)) + (visit visitor (ast-var ast)) + (visit visitor (ast-value ast))) + +(defmethod visit (visitor (ast setf-complex-form)) + (visit-foreach visitor (ast-arguments ast)) + (visit visitor (ast-value ast))) diff --git a/contrib/walker/example.lisp b/contrib/walker/example.lisp index 93db367..e0aa059 100644 --- a/contrib/walker/example.lisp +++ b/contrib/walker/example.lisp @@ -260,3 +260,29 @@ b) a b) + +;; TOOD +(let (storage) + (flet (((setf storage) (value) + (setf storage value))) + (setf (storage) 100)) + storage) + +(let ((x 0)) + (setf (car x) 100)) + +(let (a b c) + (or a b c)) + +(let (x y z) + (when x + y + z) + ) + +(loop :for x :from 1 + :do (return x)) + +(defvar x + (let ((foo 0)) + foo))