Coverage report: /home/ellis/comp/core/lib/obj/ast.lisp

KindCoveredAll%
expression8217 3.7
branch014 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; ast.lisp --- Abstract Syntax Trees
2
 
3
 ;; AST Objects
4
 
5
 ;;; Commentary:
6
 
7
 ;; This package was initially isolated to the OBJ/QUERY AST machinery, but as
8
 ;; we are getting into codegen for C/CUDA/etc we now have a need to generalize
9
 ;; it into a unique package.
10
 
11
 ;; The objects in this package are probably not that useful in a Lisp-only
12
 ;; context, or even a Lisp -> Lisp transpiler where we can leverage
13
 ;; homoiconicity.
14
 
15
 ;; These objects are best suited for a Lisp <-> Non-Lisp environment - where
16
 ;; we want to be able to parse some Non-Lisp target language and write Lisp
17
 ;; that emits code in that language.
18
 
19
 ;; This package is depended on by OBJ/QUERY and Q for SQL and the like, as
20
 ;; well as SYN/GEN which contains support for our Non-Lisp programming
21
 ;; languages.
22
 
23
 ;;; Code:
24
 (in-package :obj/ast)
25
 
26
 (define-condition syntax-condition () ((ast :initarg :ast :initform nil :accessor ast)))
27
 
28
 (deferror syntax-error (syntax-condition error) ())
29
 (defwarning syntax-warning (syntax-condition warning) ())
30
 
31
 (defvar *ast* nil)
32
 
33
 (defvar *keep-ast* nil
34
   "Whether to keep the :ast slot stored with an object, or set it to nil so
35
 that it can be GC'd.")
36
 
37
 (defun formp (form)
38
   (or (consp form) (atom form)))
39
 
40
 (deftype form ()
41
   '(satisfies formp))
42
 
43
 (defgeneric build-ast (self &key &allow-other-keys)
44
   (:documentation "Build an AST of SELF and store it in the :ast
45
 slot."))
46
 
47
 (defgeneric load-ast (self)
48
   (:documentation "Load the object SELF from the :ast slot."))
49
 
50
 (defgeneric load-ast* (self context)
51
   (:documentation "load the object SELF from the :ast slot with additional CONTEXT."))
52
 
53
 (defgeneric wrap (self form)
54
   (:documentation "Wrap object FORM using SELF, usually sets the AST slot."))
55
 
56
 (defgeneric unwrap (self)
57
   (:documentation "Unwrap object SELF, usually returns the AST slot."))
58
 (defgeneric (setf unwrap) (new self))
59
 
60
 ;;; NODE objects
61
 
62
 ;; The 'DEF*' macros defined here are from C-MERA.
63
 
64
 ;; Symbols in 'subnodes' describe slots that contain nodes.
65
 ;; Slots with only atoms are listed in 'values'.
66
 (defclass node () ())
67
 
68
 (defmacro defnode (name supers slots &rest opts)
69
   "Define a new subclass of NODE."
70
   `(defclass! ,name ,(safe-superclasses 'node supers) ,slots ,@opts))
71
 
72
 ;;; AST Object
73
 (defclass ast (node)
74
   ((ast :initarg :ast :accessor ast)))
75
 
76
 (defmethod wrap ((self ast) form) (setf (slot-value self 'ast) form))
77
 
78
 (defmethod unwrap ((self ast)) (slot-value self 'ast))
79
 
80
 ;;; WRAP-OBJECT/UNWRAP-OBJECT
81
 (declaim (inline unwrap-object)) ;; inline -200
82
 (defun unwrap-object (obj &key (slots t) (methods nil)
83
                                (indirect nil) (tag nil)
84
                                (unboundp nil) (nullp nil)
85
                                (exclude nil))
86
   "Build and return a new `form' from OBJ by traversing the class
87
 definition. This differs from the generic function `unwrap' which
88
 always uses the ast slot as an internal buffer. We can also call this
89
 on any class instance (doesn't need to subclass AST).
90
 
91
 SLOTS specifies the slots to be included in the output. If the value
92
 is t, all slots are included. The ast slot is not included by default,
93
 but this behavior may change in future revisions.
94
 
95
 When INDIRECT is non-nil, also include methods which indirectly
96
 specialize on OBJ.
97
 
98
 When TAG is non-nil, return a cons where car is TAG and cdr is the
99
 output. If TAG is t, use the class-name symbol."
100
   (declare (type standard-object obj)
101
            (type (or list boolean) slots)
102
            (type (or list boolean) methods)
103
            (type boolean indirect)
104
            (type list exclude))
105
   (unless (or slots methods)
106
     (error "Required one missing key arg: SLOTS or METHODS"))
107
   (let* ((class (class-of obj))
108
          (res (when tag (list (if (eq t tag) (class-name class) tag)))))
109
     (block unwrap
110
       (when-let ((slots (when slots
111
                           (list-class-slots class slots exclude))))
112
         (let ((slot-vals (list-slot-values-using-class class obj (remove-if #'null slots) nullp unboundp)))
113
           (if methods
114
               (push slot-vals res)
115
               (return-from unwrap (push slot-vals res)))))
116
       (when-let ((methods (when methods (list-class-methods class methods indirect))))
117
         (push methods res)))
118
     (flatten res)))
119
 
120
 ;; TODO 2024-03-22: 
121
 (defun wrap-object (class form)
122
   "Given a CLASS prototype and an input FORM, return a new instance of
123
 CLASS. FORM is assumed to be the finalized lisp object which has
124
 already passed through `read' -- not a string or file-stream for
125
 example."
126
   (declare (class class)
127
            (form form)
128
            (ignore class form)))
129
 
130
 ;;; AST Traversal
131
 (defclass debug-traverser () ())
132
 
133
 (defclass copy-traverser ()
134
   ((stack :initform '())
135
    (result :initform nil)))
136
 
137
 (defgeneric traverse (self node level)
138
   (:method ((self t) (node node) level)
139
     (if (slot-exists-p node 'ast)
140
         (loop for i in (ast node)
141
               do (traverse self i (1+ level)))
142
         (call-next-method)))
143
   (:method ((self t) (node ast) level)
144
     (with-slots (ast) node
145
       (mapcar (lambda (x) (traverse self x level)) ast)))
146
   (:method ((self t) (node list) level)
147
     (mapcar (lambda (x) (traverse self x level)) node))
148
   (:method ((self t) (item t) level)
149
     (declare (ignore level)))
150
   (:method ((self debug-traverser) (node t) level)
151
     (format *trace-output* "~&traverse:  ~A~%" (class-name (class-of node))))
152
   (:method :before ((copy copy-traverser) (item node) level)
153
     (declare (ignore level))
154
     (with-slots (stack) copy
155
       (push '() stack)))
156
   (:method :after ((copy copy-traverser) (item node) level)
157
     (with-slots (stack result) copy
158
       (with-slots (values subnodes) item
159
         (let ((node-type (class-of item)))
160
           (let ((node-copy nil)
161
                 (subnodes subnodes) ; changes can occur
162
                 (subnode-copies (reverse (pop stack))))
163
             (if (eq node-type (find-class 'nodelist))
164
                 (setf node-copy (make-instance 'nodelist
165
                                   :nodes subnode-copies
166
                                   :values '()
167
                                   :subnodes '(nodes)))
168
                 (progn
169
                   (setf node-copy (allocate-instance node-type))
170
                   (dolist (slot (mapcar #'sb-pcl::slot-definition-name 
171
                                         (sb-pcl::class-slots node-type)))
172
                     (when (slot-boundp item slot)
173
                       (when (eq (slot-value item slot) nil)
174
                         (setf subnodes (remove slot subnodes))) 
175
                       (let ((position (position slot subnodes)))
176
                         (setf (slot-value node-copy slot)
177
                               (if position
178
                                   (nth position subnode-copies)
179
                                   (slot-value item slot))))))))
180
             (if (eq level 0)
181
                 (setf result node-copy)
182
                 (push node-copy (first stack)))))))))
183
 
184
 ;;; EXPRESSION Objects
185
 (defgeneric op (self))
186
 (defgeneric lhs (self))
187
 (defgeneric (setf lhs) (new self))
188
 (defgeneric rhs (self))
189
 (defgeneric (setf rhs) (new self))
190
 
191
 (defclass expr (node) ()
192
   (:documentation "Base Expression Object."))
193
 
194
 (defmacro defexpr (name supers slots &rest opts)
195
   `(defclass! ,name ,(safe-superclasses 'expr supers) ,slots ,@opts))
196
 
197
 (defclass literal-expr (expr) 
198
   ((val :initarg :val :accessor literal-val)))
199
 (defmethod ast ((self literal-expr)) (literal-val self))
200
 (defclass logical-expr (expr) ())
201
 (defclass physical-expr (expr) ())
202
 
203
 (defclass unary-expr (expr)
204
   ((expr :initarg :expr :accessor expr)))
205
 (defmethod ast ((self unary-expr)) (literal-val self))
206
 (defclass binary-expr (expr)
207
   ((lhs :initarg :lhs :accessor lhs)
208
    (rhs :initarg :rhs :accessor rhs)))
209
 (defmethod ast ((self binary-expr)) (list (lhs self) (rhs self)))
210
 ;;; Statements
211
 (defclass stmt (node) ())
212
 
213
 (defmacro defstmt (name supers slots &rest opts)
214
   `(defclass! ,name ,(safe-superclasses 'stmt supers) ,slots ,@opts))
215
 
216
 ;;; Read/Write
217
 (defgeneric read-ast (self stream &key &allow-other-keys))
218
 
219
 (defgeneric write-ast (self stream &key &allow-other-keys))
220
 
221
 ;;; Printer
222
 
223
 ;; primitive support for printing AST Nodes is provided here and implemented
224
 ;; by higher-level packages. We use the Pretty Printer machinery as much as
225
 ;; possible.
226
 
227
 ;; ref: https://dl.acm.org/doi/pdf/10.1145/1039991.1039996
228
 
229
 ;;; Write
230
 (defvar *ast-dispatch-table* (copy-pprint-dispatch))
231
 (defun pprint-ast (sexpr &rest args)
232
   (apply 'write sexpr :pretty t :pprint-dispatch *ast-dispatch-table* args))