Coverage report: /home/ellis/comp/core/lib/syn/gen/proto.lisp

KindCoveredAll%
expression14278 5.0
branch462 6.5
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; proto.lisp --- SYN/GEN Protocol
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :syn/gen)
7
 
8
 (defvar *indent* "  ")
9
 (defgeneric load-gen (self))
10
 (defgeneric unload-gen (self))
11
 (defgeneric gen-package (self))
12
 (defgeneric gen-reader (self))
13
 (defgeneric gen-reader-switch (self))
14
 
15
 (defnode function-call () (function arguments))
16
 (defmethod ast ((self function-call)) 
17
   (list (slot-value self 'function) (slot-value self 'arguments)))
18
 (defnode src-location (ast) (line file info))
19
 (defexpr ident (literal-expr) ())
20
 (defmethod id ((self ident)) (val self))
21
 (defexpr str-literal (literal-expr) ())
22
 (defexpr num-literal (literal-expr) ())
23
 (defexpr char-literal (literal-expr) ())
24
 (defnode proxy (ast) (info))
25
 (defnode empty () ())
26
 
27
 ;; Inverts the case when interning a string.
28
 ;; This is needed to keep the correct internal (inverted) case.
29
 ;; Use this function for all c depending code.
30
 (defun cintern (name &optional package)
31
   (macrolet ((case-test (test string)
32
                `(reduce #'(lambda (a b) (and a b))
33
                         (mapcar (lambda(x) (or (not (both-case-p x)) (,test x)))
34
                                 (coerce ,string 'list)))))
35
     (let ((string (cond ((case-test upper-case-p name) (string-downcase name))
36
                         ((case-test lower-case-p name) (string-upcase name))
37
                         (t name))))
38
       (if package
39
           (intern string package)
40
           (intern string)))))
41
 
42
 (defmacro defsyntax (tags langs lambda-list &body body)
43
   "Define syntax for tags from specific langs."
44
   (let ((tags (if (consp tags) tags (list tags))))
45
     `(progn
46
        ,@(loop for i in tags 
47
                append
48
                   (loop for k in langs
49
                         collect
50
                            `(let ((tag ',i))
51
                               (declare (ignorable tag))
52
                               (defmacro ,(intern (format nil "~:@(~a~)" i) (gen-package k)) ,lambda-list
53
                                 ,@body)))))))
54
 
55
 ;;; Utils
56
 (defmacro quoty (item &environment env)
57
   "Quote undefined symbols, build functions from unknown lists."
58
   (cond ((eql item nil)
59
          (values))
60
         ((listp item)
61
          (if (or (listp (car item))
62
                  (not (fboundp! (car item) env)))
63
              `(make-instance 'function-call 
64
                 :function (make-node ,(car item))
65
                 :arguments (make-nodes ,(cdr item)))
66
              item))
67
         ((symbolp item)
68
          (if (vboundp! item env)
69
              item
70
              `',item))
71
         (t item)))
72
 
73
 (defmacro make-nodes (nodes &key prepend quoty)
74
   "Build general or specific AST."
75
   (let ((prepend (if (listp prepend) prepend `(,prepend))))
76
     `(make-instance 'ast
77
        :ast 
78
        (list ,@(loop for i in nodes 
79
                      collect
80
                         (if prepend
81
                             (if quoty
82
                                 `(,@prepend (quoty ,i))
83
                                 `(,@prepend ,i))
84
                             `(%make-node (quoty ,i))))))))
85
 
86
 (defmacro make-node (item)
87
   "Try to identify and make a NODE from ITEM."
88
   `(%make-node (quoty ,item)))
89
 
90
 (defun %make-node (item)
91
   "Build NODE from ITEM."
92
   (cond
93
     ;; no item
94
     ((eql item nil) (values))
95
     ;; item is already c-mera node
96
     ((typep item 'node) item)
97
     ;; Item is most possibly an atom or a quoted symbol
98
     ((symbolp item) (make-instance 'ident :val item))
99
     ((numberp item) (make-instance 'num-literal :val item))
100
     ((stringp item) (make-instance 'str-literal :val item))
101
     ((characterp item) (make-instance 'char-literal :val item))
102
     ;; Item is not a known atom
103
     (t (error "code generator encountered an unknown atom: ~a" item))))
104
 
105
 (defclass ast-traverser () ())
106
 
107
 (defmethod traverse :before ((self ast-traverser) (item ast) level)
108
   "remove unnecessary trees"
109
   (declare (ignore level))
110
   (with-slots (nodes) item
111
     (loop 
112
       do (if (not (= (length nodes) 1))
113
              (loop-finish)
114
              (cond 
115
                ((eql (class-of (first nodes)) (find-class 'ast))
116
                 (setf nodes (slot-value nodes 'ast)))
117
                ((eql (class-of (first nodes)) (find-class 'src-location))
118
                 (if (eql (class-of (slot-value (first nodes) 'subnode)) (find-class 'ast))
119
                     (setf nodes (slot-value (slot-value (first nodes) 'subnode) 'nodes))
120
                     (loop-finish)))
121
                (t (loop-finish)))))))
122
 
123
 (defclass code-printer ()
124
   ((indent :initform 0)
125
    (sign-stack :initform nil)
126
    (info-stack :initform nil)
127
    (stream :initform t :initarg :stream :accessor stream-of)))
128
 
129
 ;;; Printer
130
 
131
 ;; The PRINT-CODE and WRITE-CODE functions are defined here in addition to
132
 ;; several macros which may be used to define new lang-specific dispatch
133
 ;; tables, printer methods, and printer dispatch entries.
134
 (defvar *code-dispatch-table* (copy-pprint-dispatch *ast-dispatch-table*))
135
 
136
 (defun write-code (expr &rest args)
137
   (apply 'write expr :pprint-dispatch *code-dispatch-table* args))
138
 
139
 (defun print-code (tree)
140
   (let ((pp (make-instance 'code-printer))
141
         (d (make-instance 'debug-traverser)))
142
     (traverse d tree 0)
143
     (traverse pp tree 0)))
144
 
145
 (defmacro define-code-printer (qual node &body body)
146
   (if (eql :self qual)
147
       `(defmethod traverse ((self code-printer)
148
                             (node ,node)
149
                             level)
150
          (declare (ignorable level))
151
          ,@body)
152
       `(defmethod traverse ,qual ((self code-printer) (node ,node) level)
153
          (declare (ignorable level))
154
          ,@body)))
155
 
156
 (defmacro delete-code-printer (qual node)
157
   (let ((quali (if (eql qual :self)
158
                    '()
159
                    `(,qual))))
160
     `(remove-method #'traverser
161
                     (find-method #'traverser
162
                                  ',quali
163
                                  (list
164
                                   ,(find-class 'code-printer)
165
                                   (find-class ',node)
166
                                   ,(find-class t))))))
167
 
168
 (defmacro with-code-printer (&body body)
169
   `(symbol-macrolet ((stream (slot-value self 'stream))
170
                      (indent (format nil "~{~A~}"
171
                                      (loop for i
172
                                            from 1 
173
                                            to (slot-value self 'indent)
174
                                            collect *indent*)))
175
                      (%self self)
176
                      (%level level)
177
                      (--indent (decf (slot-value self 'indent)))
178
                      (++indent (incf (slot-value self 'indent))))
179
      (macrolet ((push-sign (x) `(push ,x (slot-value self 'sign-stack)))
180
                 (pop-sign () `(pop (slot-value self 'sign-stack)))
181
                 (top-sign () `(car (slot-value self 'sign-stack)))
182
                 (find-sign (x) `(find ,x (slot-value self 'sign-stack)))
183
                 (push-info (x) `(push ,x (slot-value self 'info-stack)))
184
                 (pop-info () `(pop (slot-value self 'info-stack)))
185
                 (top-info () `(car (slot-value self 'info-stack)))
186
                 (find-info (x) `(find ,x (slot-value self 'info-stack)))
187
                 (info-size () `(length (slot-value self 'info-stack)))
188
                 (node-slot (x) `(slot-value node ',x)))
189
        ,@body)))
190
 
191
 (with-code-printer
192
   (define-code-printer :self literal-expr
193
     (let ((val (val node)))
194
       (when val
195
         (cond 
196
           ((stringp val)
197
            (format stream "\"~a\"" val))
198
           ((characterp val)
199
            (cond
200
              ((eql val #\tab)
201
               (format stream "'\\t'"))
202
              ((or (eql val #\nul) (eql val #\null))
203
               (format stream "'\\0'"))
204
              ((eql val #\return)
205
               (format stream "'\\r'"))
206
              ((eql val #\newline)
207
               (format stream "'\\n'"))
208
              ((eql val #\')
209
               (format stream "'\\''"))
210
              (t (format stream "'~a'" val))))
211
           ((floatp val) (format stream "~a"
212
                                 (substitute #\e #\d
213
                                             (format nil "~,8e" val))))
214
           (t (format stream "~a" val)))))))
215
 
216
 ;; TODO 2024-10-20: gen-file-header
217
 ;; (defclass gen-file-header (file-header)
218
 ;;   ())