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

KindCoveredAll%
expression293768 38.2
branch35110 31.8
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; read.lisp --- Lisp Readers which return C AST Nodes
2
 
3
 ;; 
4
 
5
 ;;; Code:
6
 (in-package :syn/gen/c)
7
 
8
 (defun fix-case (parent child)
9
   "Fix case for dissected symbols.
10
    Required because of our inverted readtable."
11
   ;; check every single character's case
12
   (macrolet ((case-test (test string)
13
                `(eval `(and ,@(mapcar (lambda(x) (or (not (both-case-p x))
14
                                                      (,test x)))
15
                                       (coerce ,string 'list)))))
16
              (special-case (string)
17
                `(eval `(and ,@(mapcar (lambda(x) (not (both-case-p x)))
18
                                       (coerce ,string 'list))))))
19
     (let
20
         ;; parent upper
21
         ((pu (case-test upper-case-p parent))
22
          ;; parent lower
23
          (pl (case-test lower-case-p parent))
24
          ;; child upper
25
          (cu (case-test upper-case-p child))
26
          ;; child lower
27
          (cl (case-test lower-case-p child))
28
          ;; child special
29
          (cs (special-case child)))
30
       ;; adjust cases
31
       (let ((parent
32
               ;; fix parent case if root symbol had mixed case
33
               (cond
34
                 ;; special cases
35
                 ((and pu cs) (intern (string-upcase parent)))
36
                 ((and pl cs) (intern (string-downcase parent)))
37
                 ;; parend upper case
38
                 ;; child lower or mixed case
39
                 ((or (and pu cl) (and pu (not (or cu cl))))
40
                  (intern (string-downcase parent)))
41
                 ;; parent lower case
42
                 ;; child upper or mixed case
43
                 ((or (and pl cu) (and pl (not (or cu cl))))
44
                  (intern (string-upcase parent)))
45
                 ;; default
46
                 (t (intern parent))))
47
             ;; fix child case if root symbol had mixed case
48
             (child
49
               (cond
50
                 ;; child lower case
51
                 ;; parent upper or mixed case
52
                 ((or (and pu cl) (and (not (or pu pl)) cl))
53
                  (intern (string-upcase child)))
54
                 ;; child upper case
55
                 ;; parent loer or mixed case
56
                 ((or (and pl cu) (and (not (or pu pl)) cu))
57
                  (intern (string-downcase child)))
58
                 ;; default
59
                 (t (intern child)))))
60
         (list parent child)))))
61
 
62
 (defun read-float (item)
63
   "perace correct float print"
64
   (let* ((name (symbol-name item))
65
          (len (length name)))
66
     ;; Inspired by:  Bozhidar Batsov, batsov.com/articles/2011/04/30/parsing-numbers-from-string-in-lisp
67
     (with-input-from-string (in (subseq name 0 (- len 1)))
68
       `(float ,(read in)))))
69
 
70
 (defun split-unary (item)
71
   "prepare ++i or the like to unary node cration: ++i => (prefix i ++)"
72
   (let* ((name (symbol-name item))
73
          (len (length name))
74
          (>2 (> len 2))
75
          (>1 (> len 1)))
76
     (if (not >1)
77
         item
78
         (let ((pos-inc (equalp (subseq name (- len 2) len) "++"))
79
               (pos-dec (equalp (subseq name (- len 2) len) "--"))
80
               (pre-inc (equalp (subseq name 0 2) "++"))
81
               (pre-dec (equalp (subseq name 0 2) "--"))
82
               (minus   (equalp (subseq name 0 1) "-"))
83
               (plus    (equalp (subseq name 0 1) "+"))
84
               (not     (equalp (subseq name 0 1) "!"))
85
               (not2    (equalp (subseq name 0 1) "~"))
86
               (ast     (equalp (subseq name (- len 1) len) "*")))
87
 
88
           (cond
89
             ((and pos-inc >2) `(postfix++ ,(dissect (intern (subseq name 0 (- len 2))) :quoty t)))
90
             ((and pos-dec >2) `(postfix-- ,(dissect (intern (subseq name 0 (- len 2))) :quoty t)))
91
             ((and ast >1)     `(postfix*  ,(dissect (intern (subseq name 0 (- len 1))) :quoty t)))
92
             ((and pre-inc >2) `(prefix++  ,(dissect (intern (subseq name 2 len)) :quoty t)))
93
             ((and pre-dec >2) `(prefix--  ,(dissect (intern (subseq name 2 len)) :quoty t)))
94
             ((and minus >1)   `(-  ,(dissect (intern (subseq name 1 len)) :quoty t)))
95
             ((and plus >1)    `(+  ,(dissect (intern (subseq name 1 len)) :quoty t)))
96
             ((and not >1)     `(!  ,(dissect (intern (subseq name 1 len)) :quoty t)))
97
             ((and not2 >1)    `(~  ,(dissect (intern (subseq name 1 len)) :quoty t)))
98
             (t item))))))
99
 
100
 (defun split-addrof (name)
101
   "prepare addr-of node: &foo => (addr-of foo)"
102
   (let ((name (symbol-name name)))
103
     `(addr-of ,(dissect (intern (subseq name 1 (length name))) :quoty t))))
104
 
105
 (defun split-targof (name)
106
   "prepare targ-of node: *foo => (targ-of foo)"
107
   (let ((name (symbol-name name)))
108
     `(targ-of ,(dissect (intern (subseq name 1 (length name))) :quoty t))))
109
 
110
 (defun split-oref (name)
111
   "prepare oref node: foo.baz => (oref foo baz)"
112
   (let* ((name-string (symbol-name name))
113
          (pos (search "." name-string :from-end t))
114
          (names (fix-case (subseq name-string 0 pos) (subseq name-string (+ 1 pos)))))
115
     `(oref ,(dissect (first names) :quoty t)
116
                   ,(dissect (second names) :quoty t))))
117
 
118
 (defun split-pref (name)
119
   "prepare pref node: a->b => (pref a b)"
120
   (let* ((name-string (symbol-name name))
121
          (pos (search "->" name-string :from-end t))
122
          (names (fix-case (subseq name-string 0 pos) (subseq name-string (+ 2 pos)))))
123
     (if (eql pos 0)
124
         name ;; function definition arrow, dont touch
125
         `(pref ,(dissect (first names) :quoty t)
126
                       ,(dissect (second names) :quoty t)))))
127
 
128
 (defun split-aref (name)
129
   "make aref node: a[b][c] => (aref (aref a b) c)"
130
   (let* ((name-string (symbol-name name))
131
          (name-list (reverse (coerce name-string 'list))))
132
     (let ((pos 0)
133
           (counter 0)
134
           (names nil))
135
 
136
       ;; get position of matching '[ for last ']
137
       (loop for i in name-list do
138
         (progn
139
           (cond 
140
             ((eql i #\]) (incf counter))
141
             ((eql i #\[) (decf counter)))
142
           (incf pos)
143
           (when (eql  counter 0)
144
             (return))))
145
       (setf pos (- (length name-string) pos))
146
       (setf names (fix-case (subseq name-string 0 pos)
147
                             (subseq name-string (1+ pos) (1- (length name-string)))))
148
       (if (not (equal "" (symbol-name (second names))))
149
           ;; index not empty
150
           `(aref ,(dissect (first names) :quoty t)
151
                         ,(dissect (second names) :quoty t))
152
           ;; index empty
153
           `(aref ,(dissect (first names) :quoty t))))))
154
 
155
 (defun pre-process (stream char)
156
   "Pre process symbols in STREAM."
157
   (declare (ignore char))
158
   (let ((peek (peek-char nil stream nil nil nil)))
159
     ;; stop at whitespace and comments
160
     (if (not (or (eql peek #\))
161
                  (eql peek #\;)
162
                  (eql peek #\#)
163
                  (eql peek #\Space)
164
                  (eql peek #\Newline)
165
                  (eql peek #\Tab)))
166
         (dissect (read stream nil nil nil))
167
         (values))))
168
 
169
 (defun pre-process-heads (stream char)
170
   "Pre process list heads in STREAM."
171
   (declare (ignore char))
172
   (let ((peek (peek-char nil stream nil nil nil))
173
         (list (read-delimited-list #\) stream t)))
174
     (let ((first (first list)))
175
       ;; stop at whitespace and comments
176
       (if (not (or (eql peek #\()
177
                    (eql peek #\))
178
                    (eql peek #\;)
179
                    (eql peek #\#)
180
                    (eql peek #\Space)
181
                    (eql peek #\Newline)
182
                    (eql peek #\Tab)
183
                    (and (symbolp first)
184
                         (std/sym:fboundp! first))))
185
           (append (list (dissect first)) (rest list))
186
           list))))
187
 
188
 ;;; Needs further analysis
189
 ;;(defun comment-reader (stream char)
190
 ;;  "Rread lisp comments and emmit c-mera comments"
191
 ;;  (let ((peek (peek-char nil stream nil nil nil)))
192
 ;;    (if (not (eql peek #\;))
193
 ;;      `(comment ,(read-string stream #\Newline))
194
 ;;      (values))))
195
 
196
 (defun dissect (form &key quoty)
197
   "starts the appropriate preprocessing for the given form"
198
   (cond
199
     ((symbolp form)
200
      (cond
201
        ((and (eql (first (coerce (symbol-name form) 'list)) #\")
202
              (eql (first (reverse (coerce (symbol-name form) 'list))) #\"))
203
         form)
204
        ((and (eql (first (coerce (symbol-name form) 'list)) #\<)
205
              (eql (first (reverse (coerce (symbol-name form) 'list))) #\>))
206
         form)
207
        ((and (eql (first (coerce (symbol-name form) 'list)) #\*)
208
              (eql (first (reverse (coerce (symbol-name form) 'list))) #\*))
209
         form)
210
        ;; check/(fix package 
211
        ((or (eql form '&optional)
212
             (eql form '&key)
213
             (eql form '&environment)
214
             (eql form '&body)
215
             (eql form '&rest))
216
         form)
217
        ((and (> (length (symbol-name form)) 1)
218
              (eql (first (coerce (symbol-name form) 'list)) #\&))
219
         (split-addrof form))
220
        ((and (> (length (symbol-name form)) 1)
221
              (eql (first (coerce (symbol-name form) 'list)) #\*)
222
              (not (eql (first (reverse (coerce (symbol-name form) 'list))) #\*)))
223
         (split-targof form))
224
        (t 
225
         (let* ((name-string (symbol-name form))
226
                (num-pos (position-if #'numberp (mapcar #'digit-char-p (coerce name-string 'list))))
227
                (f-pos (search "F" name-string :from-end t))
228
                (-pos  (search "-" name-string))
229
                (dot-pos2 (search "." name-string)) ;hack
230
                (dot-pos (search "." name-string :from-end t))
231
                (arrow-pos (search "->" name-string :from-end t))
232
                (bracket-pos (search "]" name-string :from-end t)))
233
           (labels ((pos-cond (a b c) (if a (and (if b (> a b) t) (if c (> a c) t)) nil)))
234
             (cond
235
               ((and (eql f-pos (- (length name-string) 1)) (or (eql num-pos 0)
236
                                                                (eql -pos 0)
237
                                                                (eql dot-pos2 0)))
238
                (read-float form))
239
               ((pos-cond dot-pos arrow-pos bracket-pos) (split-oref form))
240
               ((pos-cond arrow-pos dot-pos bracket-pos) (split-pref form))
241
               ((pos-cond bracket-pos arrow-pos dot-pos) (split-aref form))
242
               ((or (search "+" name-string)
243
                    (search "-" name-string)
244
                    (search "!" name-string)
245
                    (search "*" name-string)
246
                    (search "~" name-string))
247
                (split-unary form))
248
               (t (if (not (find-if-not #'digit-char-p (symbol-name form)))
249
                      (parse-integer (symbol-name form))
250
                      (if quoty
251
                          `(quoty ,form)
252
                          form)))))))))
253
     (t form)))
254
 
255
 ;;; Readers
256
 (define-code-reader
257
   :file-reader read-gen-c-file
258
   :string-reader read-gen-c-string
259
   :macro-character
260
   ((set-macro-character #\Space #'pre-process)
261
    (set-macro-character #\Tab #'pre-process)
262
    (set-macro-character #\Newline #'pre-process)
263
    (set-macro-character #\( #'pre-process-heads)))
264
 
265
 ;; Define a start-up function
266
 (define-code-processor gen-c
267
   :file-reader   read-gen-c-file
268
   :string-reader read-gen-c-string
269
   :traverse
270
   (nested-ast-remover
271
    else-if-traverser
272
    if-blocker
273
    decl-blocker
274
    renamer))
275
 
276
 ;;; Switches
277
 (define-code-switch c-reader-switch
278
   :macro-character
279
   ((set-macro-character #\Space #'pre-process)
280
    (set-macro-character #\Tab #'pre-process)
281
    (set-macro-character #\Newline #'pre-process)
282
    (set-macro-character #\( #'pre-process-heads)))
283
 
284
 (define-code-switches
285
   :cl-reader cl-reader
286
   :code-reader c-reader
287
   :macro-character
288
   ((set-macro-character #\Space #'pre-process)
289
    (set-macro-character #\Tab #'pre-process)
290
    (set-macro-character #\Newline #'pre-process)
291
    (set-macro-character #\( #'pre-process-heads)))
292
 
293
 (defmethod gen-reader ((self (eql :c))) (function c-reader))
294
 (defmethod gen-reader-switch ((self (eql :c))) (function c-reader-switch))
295
 
296
 (defmethod load-gen ((self (eql :c))) 
297
   (init-gen :c)
298
   (c-reader))
299
 
300
 (defmethod unload-gen ((self (eql :c)))
301
   (init-gen nil)
302
   (cl-reader))
303
 
304
 (defmethod gen-package ((self (eql :c))) (find-package :syn/gen/c/sym))