Plaster
New
List
Login
common-lisp
default
scymtym
2023.09.18 09:44:35
(cl:defpackage #:s-expression-syntax.examples.declarations (:use #:cl) (:local-nicknames (#:bp #:architecture.builder-protocol) (#:ses #:s-expression-syntax))) (cl:in-package #:s-expression-syntax.examples.declarations) (defun trace-tree (builder tree label &key (stream *trace-output*)) (format stream "~&~A~%~2@T" label) (pprint-logical-block (stream (list tree)) (architecture.builder-protocol.print-tree:print-tree builder tree stream))) (defclass builder (bp:forwarding-mixin) ()) (defmethod bp:relate ((builder builder) (relation cons) (left t) (right t) &rest args) (apply #'bp:relate builder (bp:normalize-relation relation) left right args)) ;;; Do not build `:declaration' nodes ;;; ;;; Make it so that nodes with kind `:declaration' are not build and ;;; that the nodes that would have been children of the `:declaration' ;;; node are instead children of the node that would have been the ;;; parent node of the `:declaration' node. ;; (defmethod bp:make-node ((builder builder) (kind (eql :declaration)) &key) ;; '()) ;; ;; (defmethod bp:finish-node ((builder builder) (kind (eql :declaration)) (node list)) ;; (nreverse node)) ;; ;; (defmethod bp:relate ((builder builder) ;; (relation (eql :declaration-specifier)) ;; (left list) ;; (right t) ;; &rest args) ;; (list* right left)) ;; ;; (defvar *thing* nil) ;; (defmethod bp:relate ((builder builder) ;; (relation (eql :declaration)) ;; (left t) ;; (right list) ;; &rest args) ;; (if *thing* ;; (call-next-method) ;; (let ((*thing* t)) ;; (reduce (lambda (node new-right) ;; (trace-tree builder new-right "Collecting declaration specifier") ;; (apply #'bp:relate builder relation node new-right args)) ;; right :initial-value left)))) ;;; Split `:declaration' nodes ;;; ;;; For `:declaration' nodes that contain multiple declaration ;;; specifiers, split the `:declaration' node into multiple ;;; `:declaration' nodes such that each of those nodes contains a ;;; single declaration specifier. (defvar *transform-declarations* t) (defmethod bp:make-node ((builder builder) (kind (eql :declaration)) &key) (if *transform-declarations* '() (call-next-method))) (defmethod bp:finish-node ((builder builder) (kind (eql :declaration)) (node list)) (if *transform-declarations* (nreverse node) (call-next-method))) (defmethod bp:relate ((builder builder) (relation (eql :declaration-specifier)) (left list) (right t) &rest args) (declare (ignore args)) ; TODO don't drop ARGS (if *transform-declarations* (list* right left) (call-next-method))) (defmethod bp:relate ((builder builder) (relation (eql :declaration)) (left t) (right list) &rest args) (if *transform-declarations* (let ((*transform-declarations* nil)) (reduce (lambda (node new-right) (trace-tree builder new-right "Collecting declaration specifier") (let ((new-declaration (bp:node (builder :declaration) (1 :declaration-specifier new-right)))) (apply #'bp:relate builder relation node new-declaration args))) right :initial-value left)) (call-next-method))) ;;; Canonicalize `:declaration-specifier' nodes ;;; ;;; (defvar *outer-call?* t) (defmethod bp:relate :around ((builder builder) (relation (eql :declaration-specifier)) (left t) (right t) &rest args) (if (not *outer-call?*) (call-next-method) (let ((*outer-call?* nil)) (trace-tree builder right "Canonicalizing declaration specifier") (let ((node-kind :declaration-specifier ; (bp:node-kind builder right) ) (kind (getf (bp:node-initargs builder right) :kind))) (multiple-value-bind (arguments arguments-args) (bp:node-relation builder :argument right) (multiple-value-bind (common-arguments individual-arguments) (split-declaration-arguments kind arguments) (loop :with result = left ; TODO phrase as `reduce'? :for argument :in individual-arguments ; TODO :for argument-args :in arguments-args :for singleton = (bp:node (builder node-kind :kind kind) (* (:argument . *) common-arguments) (1 (:argument . *) argument ; TODO argument-args )) :do (setf result (apply #'bp:relate builder relation result singleton args)) :finally (return result)))))))) (defmethod split-declaration-arguments ((kind t) (arguments t)) (values '() arguments)) (defmethod split-declaration-arguments ((kind (eql 'type)) (arguments t)) (values (list (first arguments)) (rest arguments))) ;;; Usage example (let* ((input '(defun foo () (declare (ignore x y) (type integer a b) (inline) (inline c d)) (random 10))) (builder (make-instance 'builder :target 'list)) (ast (ses:parse builder t input))) (trace-tree builder ast "Result"))
Raw
Annotate
Repaste
Annotations
common-lisp
default
scymtym
2023.09.18 09:45:26
Canonicalizing declaration specifier DECLARATION-SPECIFIER │ KIND: IGNORE │ SOURCE: (IGNORE X Y) ├─ARGUMENT: VARIABLE-NAME │ NAME: X │ SOURCE: X └─ARGUMENT: VARIABLE-NAME NAME: Y SOURCE: Y Canonicalizing declaration specifier DECLARATION-SPECIFIER │ KIND: TYPE │ SOURCE: (TYPE INTEGER A B) ├─ARGUMENT: ATOMIC-TYPE-SPECIFIER │ │ SOURCE: INTEGER │ └─NAME: TYPE-NAME │ NAME: INTEGER │ SOURCE: INTEGER ├─ARGUMENT: VARIABLE-NAME │ NAME: A │ SOURCE: A └─ARGUMENT: VARIABLE-NAME NAME: B SOURCE: B Canonicalizing declaration specifier DECLARATION-SPECIFIER KIND: INLINE SOURCE: (INLINE) Collecting declaration specifier DECLARATION-SPECIFIER │ KIND: IGNORE └─ARGUMENT: VARIABLE-NAME NAME: X SOURCE: X Canonicalizing declaration specifier DECLARATION-SPECIFIER │ KIND: IGNORE └─ARGUMENT: VARIABLE-NAME NAME: X SOURCE: X DECLARATION (DECLARATION (DECLARATION-SPECIFIER (((DECLARATION-SPECIFIER (ARGUMENT (((VARIABLE-NAME NIL NAME X SOURCE X)))) KIND IGNORE))))) Collecting declaration specifier DECLARATION-SPECIFIER │ KIND: IGNORE └─ARGUMENT: VARIABLE-NAME NAME: Y SOURCE: Y Canonicalizing declaration specifier DECLARATION-SPECIFIER │ KIND: IGNORE └─ARGUMENT: VARIABLE-NAME NAME: Y SOURCE: Y DECLARATION (DECLARATION (DECLARATION-SPECIFIER (((DECLARATION-SPECIFIER (ARGUMENT (((VARIABLE-NAME NIL NAME Y SOURCE Y)))) KIND IGNORE))))) Collecting declaration specifier DECLARATION-SPECIFIER │ KIND: TYPE ├─ARGUMENT: ATOMIC-TYPE-SPECIFIER │ │ SOURCE: INTEGER │ └─NAME: TYPE-NAME │ NAME: INTEGER │ SOURCE: INTEGER └─ARGUMENT: VARIABLE-NAME NAME: A SOURCE: A Canonicalizing declaration specifier DECLARATION-SPECIFIER │ KIND: TYPE ├─ARGUMENT: ATOMIC-TYPE-SPECIFIER │ │ SOURCE: INTEGER │ └─NAME: TYPE-NAME │ NAME: INTEGER │ SOURCE: INTEGER └─ARGUMENT: VARIABLE-NAME NAME: A SOURCE: A DECLARATION (DECLARATION (DECLARATION-SPECIFIER (((DECLARATION-SPECIFIER (ARGUMENT (((ATOMIC-TYPE-SPECIFIER (NAME (((TYPE-NAME NIL NAME INTEGER SOURCE INTEGER)))) SOURCE INTEGER)) ((VARIABLE-NAME NIL NAME A SOURCE A)))) KIND TYPE))))) Collecting declaration specifier DECLARATION-SPECIFIER │ KIND: TYPE ├─ARGUMENT: ATOMIC-TYPE-SPECIFIER │ │ SOURCE: INTEGER │ └─NAME: TYPE-NAME │ NAME: INTEGER │ SOURCE: INTEGER └─ARGUMENT: VARIABLE-NAME NAME: B SOURCE: B Canonicalizing declaration specifier DECLARATION-SPECIFIER │ KIND: TYPE ├─ARGUMENT: ATOMIC-TYPE-SPECIFIER │ │ SOURCE: INTEGER │ └─NAME: TYPE-NAME │ NAME: INTEGER │ SOURCE: INTEGER └─ARGUMENT: VARIABLE-NAME NAME: B SOURCE: B DECLARATION (DECLARATION (DECLARATION-SPECIFIER (((DECLARATION-SPECIFIER (ARGUMENT (((ATOMIC-TYPE-SPECIFIER (NAME (((TYPE-NAME NIL NAME INTEGER SOURCE INTEGER)))) SOURCE INTEGER)) ((VARIABLE-NAME NIL NAME B SOURCE B)))) KIND TYPE))))) Result DEFUN │ SOURCE: (DEFUN FOO () │ (DECLARE (IGNORE X Y) │ (TYPE INTEGER A B) │ (INLINE)) │ #1=(RANDOM 10)) ├─NAME: FUNCTION-NAME │ NAME: FOO │ SOURCE: FOO ├─LAMBDA-LIST: ORDINARY-LAMBDA-LIST │ SOURCE: NIL ├─DECLARATION: DECLARATION │ └─DECLARATION-SPECIFIER: DECLARATION-SPECIFIER │ │ KIND: IGNORE │ └─ARGUMENT: VARIABLE-NAME │ NAME: X │ SOURCE: X ├─DECLARATION: DECLARATION │ └─DECLARATION-SPECIFIER: DECLARATION-SPECIFIER │ │ KIND: IGNORE │ └─ARGUMENT: VARIABLE-NAME │ NAME: Y │ SOURCE: Y ├─DECLARATION: DECLARATION │ └─DECLARATION-SPECIFIER: DECLARATION-SPECIFIER │ │ KIND: TYPE │ ├─ARGUMENT: ATOMIC-TYPE-SPECIFIER │ │ │ SOURCE: INTEGER │ │ └─NAME: TYPE-NAME │ │ NAME: INTEGER │ │ SOURCE: INTEGER │ └─ARGUMENT: VARIABLE-NAME │ NAME: A │ SOURCE: A ├─DECLARATION: DECLARATION │ └─DECLARATION-SPECIFIER: DECLARATION-SPECIFIER │ │ KIND: TYPE │ ├─ARGUMENT: ATOMIC-TYPE-SPECIFIER │ │ │ SOURCE: INTEGER │ │ └─NAME: TYPE-NAME │ │ NAME: INTEGER │ │ SOURCE: INTEGER │ └─ARGUMENT: VARIABLE-NAME │ NAME: B │ SOURCE: B └─FORM: UNPARSED EXPRESSION: #1# CONTEXT: :FORM SOURCE: #1#
Raw
Repaste
common-lisp
default
scymtym
2023.09.18 10:19:28
(cl:defpackage #:s-expression-syntax.examples.declarations (:use #:cl) (:local-nicknames (#:bp #:architecture.builder-protocol) (#:ses #:s-expression-syntax))) (cl:in-package #:s-expression-syntax.examples.declarations) (defun trace-tree (builder tree label &key (stream *trace-output*)) (format stream "~&~A~%~2@T" label) (if (consp tree) (pprint-logical-block (stream (list tree)) (architecture.builder-protocol.print-tree:print-tree builder tree stream)) (progn (clouseau:inspect tree) (iconoclast-print-tree:print-tree tree)))) (defclass builder (bp:forwarding-mixin) ()) (defmethod bp:relate ((builder builder) (relation cons) (left t) (right t) &rest args) (apply #'bp:relate builder (bp:normalize-relation relation) left right args)) ;;; Do not build `:declaration' nodes ;;; ;;; Make it so that nodes with kind `:declaration' are not build and ;;; that the nodes that would have been children of the `:declaration' ;;; node are instead children of the node that would have been the ;;; parent node of the `:declaration' node. ;; (defmethod bp:make-node ((builder builder) (kind (eql :declaration)) &key) ;; '()) ;; ;; (defmethod bp:finish-node ((builder builder) (kind (eql :declaration)) (node list)) ;; (nreverse node)) ;; ;; (defmethod bp:relate ((builder builder) ;; (relation (eql :declaration-specifier)) ;; (left list) ;; (right t) ;; &rest args) ;; (list* right left)) ;; ;; (defvar *thing* nil) ;; (defmethod bp:relate ((builder builder) ;; (relation (eql :declaration)) ;; (left t) ;; (right list) ;; &rest args) ;; (if *thing* ;; (call-next-method) ;; (let ((*thing* t)) ;; (reduce (lambda (node new-right) ;; (trace-tree builder new-right "Collecting declaration specifier") ;; (apply #'bp:relate builder relation node new-right args)) ;; right :initial-value left)))) ;;; Split `:declaration' nodes ;;; ;;; For `:declaration' nodes that contain multiple declaration ;;; specifiers, split the `:declaration' node into multiple ;;; `:declaration' nodes such that each of those nodes contains a ;;; single declaration specifier. (defvar *transform-declarations* t) (defmethod bp:make-node ((builder builder) (kind (eql :declaration)) &key) (if *transform-declarations* '() (call-next-method))) (defmethod bp:finish-node ((builder builder) (kind (eql :declaration)) (node list)) (if *transform-declarations* (nreverse node) (call-next-method))) (defmethod bp:relate ((builder builder) (relation (eql :declaration-specifier)) (left list) (right t) &rest args) (declare (ignore args)) ; TODO don't drop ARGS (if *transform-declarations* (list* right left) (call-next-method))) (defmethod bp:relate ((builder builder) (relation (eql :declaration)) (left t) (right list) &rest args) (if *transform-declarations* (let ((*transform-declarations* nil)) (reduce (lambda (node new-right) ; (trace-tree builder new-right "Collecting declaration specifier") (let ((new-declaration (bp:node (builder :declaration) (1 :declaration-specifier new-right)))) (apply #'bp:relate builder relation node new-declaration args))) right :initial-value left)) (call-next-method))) ;;; Canonicalize `:declaration-specifier' nodes ;;; ;;; Call `split-declaration-arguments' with the kind and arguments of ;;; a declaration specifier and turn its return values into zero, one ;;; or multiple nodes of the same kind each of which has only a single ;;; argument. (defvar *outer-call?* t) (defmethod bp:relate :around ((builder builder) (relation (eql :declaration-specifier)) (left t) (right t) &rest args) (if (not *outer-call?*) (call-next-method) (let ((*outer-call?* nil)) ; (trace-tree builder right "Canonicalizing declaration specifier") (let ((node-kind :declaration-specifier ; (bp:node-kind builder right) ) (kind (getf (bp:node-initargs builder right) :kind))) (multiple-value-bind (arguments arguments-args) (bp:node-relation builder :argument right) (multiple-value-bind (common-arguments individual-arguments) (split-declaration-arguments kind arguments) (loop :with result = left ; TODO phrase as `reduce'? :for argument :in individual-arguments ; TODO :for argument-args :in arguments-args :for singleton = (bp:node (builder node-kind :kind kind) (* (:argument . *) common-arguments) (1 (:argument . *) argument ; TODO argument-args )) :do (setf result (apply #'bp:relate builder relation result singleton args)) :finally (return result)))))))) (defmethod split-declaration-arguments ((kind t) (arguments t)) (values '() arguments)) (defmethod split-declaration-arguments ((kind (eql 'type)) (arguments t)) (values (list (first arguments)) (rest arguments))) ;;; Usage example (let* ((input '(defun foo () (declare (ignore x y) (type integer a b) (inline) (inline c d)) (random 10))) (builder (make-instance 'builder :target (make-instance 'iconoclast-builder:builder))) (ast (ses:parse builder t input))) (clouseau:inspect ast) ; (trace-tree builder ast "Result") )
Raw
Repaste