nyacc: fixed more CPP issues
[mes.git] / module / nyacc / lang / c99 / pprint.scm
1 ;;; nyacc/lang/c99/pprint.scm
2 ;;;
3 ;;; Copyright (C) 2015,2016 Matthew R. Wette
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or modify
6 ;;; it under the terms of the GNU General Public License as published by 
7 ;;; the Free Software Foundation, either version 3 of the License, or 
8 ;;; (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;;; GNU General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU General Public License
16 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18 (define-module (nyacc lang c99 pprint)
19   #:export (pretty-print-c99)
20   #:use-module ((srfi srfi-1) #:select (pair-for-each))
21   #:use-module (nyacc lang util)
22   #:use-module (sxml match)
23   #:use-module (ice-9 pretty-print)
24   )
25
26 (define op-sym
27   (let ((ot '(("=" . eq) ("+=" . pl-eq) ("-=" . mi-eq) ("*=" . ti-eq)
28               ("/=" . di-eq) ("%=" . mo-eq) ("<<=" . ls-eq) (">>=" . rs-eq)
29               ("&=" . ba-eq) ("^=" . bx-eq) ("|=" bo-eq))))
30     (lambda (name)
31       (assoc-ref ot name))))
32
33 (define op-prec
34   ;; in order of decreasing precedence
35   '((p-expr ident fixed float string)
36     (comp-lit post-inc post-dec i-sel d-sel fctn-call array-ref)
37     (de-ref ref-to neg pos not bitwise-not sizeof pre-inc pre-dec)
38     (cast)
39     (mul div mod)
40     (add sub)
41     (lshift rshift)
42     (lt gt le ge)
43     (eq ne)
44     (bitwise-and)
45     (bitwise-xor)
46     (bitwise-or)
47     (and)
48     (or)
49     (cond-expr)
50     (assn-expr)
51     (comma)))
52
53 (define op-assc
54   '((left array-ref d-sel i-sel post-inc post-dec comp-lit mul div mod add sub
55           lshift rshift lt gt le ge bitwise-and bitwise-xor bitwise-or and or)
56     (right pre-inc pre-dec sizeof bitwise-not not pos neg ref-to de-ref cast
57            cond assn-expr)
58     (nonassoc)))
59
60 (define protect-expr? (make-protect-expr op-prec op-assc))
61
62 ;; @deffn pretty-print-c99 tree [#:indent-level 2]
63 ;; Convert and print a C99 sxml tree to the current output port.
64 ;; The optional keyword argument @code{#:indent-level} provides the
65 ;; indent level, with default of 2.
66 (define* (pretty-print-c99 tree #:key (indent-level 2) (ugly #f))
67
68   ;;(define fmtr (make-pp-formatter))
69   (define fmtr (if ugly (make-pp-formatter/ugly) (make-pp-formatter)))
70   (define (push-il)(fmtr 'push))
71   (define (pop-il) (fmtr 'pop))
72
73   (define (sf . args) (apply fmtr args))
74
75   (define (cpp-ppx tree)
76     (fmtr 'nlin)
77     (sxml-match tree
78       ((define (name ,name) (args . ,args) (repl ,repl))
79        (sf "#define ~A(" name)
80        (pair-for-each
81         (lambda (pair) (sf "~A" (car pair)) (if (pair? (cdr pair)) (sf ",")))
82         args)
83        (sf ") ~A\n" repl))
84       ((define (name ,name) (repl ,repl))
85        (sf "#define ~A ~A\n" name repl))
86       ((if ,text) (sf "#if ~A\n" text))
87       ((elif ,text) (sf "#elif ~A\n" text))
88       ((else ,text) (sf "#else ~A\n" text))
89       ((else) (sf "#else\n"))
90       ((endif ,text) (sf "#endif ~A\n" text))
91       ((endif) (sf "#endif\n"))
92       ((include . ,rest) (sf "#include ~A\n" (sx-ref tree 1)))
93       ((error ,text) (sf "#error ~A\n" text))
94       ((pragma ,text) (sf "#pragma ~A\n" text))
95       (,otherwise
96        (simple-format #t "\n*** pprint/cpp-ppx: NO MATCH: ~S\n" tree))
97       )
98     (fmtr 'nlin))
99
100   (define (unary/l op rep rval)
101     (sf rep)
102     (if (protect-expr? 'rt op rval)
103         (ppx/p rval)
104         (ppx rval)))
105   
106   (define (unary/r op rep lval)
107     (if (protect-expr? 'lt op lval)
108         (ppx/p lval)
109         (ppx lval))
110     (sf rep))
111   
112   (define (binary op rep lval rval)
113     (if (protect-expr? 'lt op lval)
114         (ppx/p lval)
115         (ppx lval))
116     (sf rep)
117     (if (protect-expr? 'rt op rval)
118         (ppx/p rval)
119         (ppx rval)))
120
121   (define (comp declr initr)
122     (let ((iexpr (and initr (sx-ref initr 1))))
123       (ppx declr)
124       (when initr
125         (sf " = ")
126         (case (sx-tag iexpr)
127           ((initzer-list)
128            (sf "{")
129            (for-each
130             (lambda (expr) (ppx (sx-ref expr 1)) (sf ", "))
131             (sx-tail iexpr 1))
132            (sf "}"))
133           (else
134            (ppx iexpr))))))
135
136   (define (struct-union-def struct-or-union name fields)
137     (if name
138         (sf "~A ~A {\n" struct-or-union name)
139         (sf "~A {\n" struct-or-union))
140     (push-il)
141     (for-each ppx fields)
142     (pop-il)
143     (sf "}"))
144
145   (define (ppx/p tree) (sf "(") (ppx tree) (sf ")"))
146
147   ;; TODO: comp-lit
148   (define (ppx-1 tree)
149     (sxml-match tree
150
151       ((p-expr ,expr) (ppx expr))
152       ((ident ,name) (sf "~A" name))
153       ((char ,value) (sf "'~A'" (sx-ref tree 1)))
154       ((fixed ,value) (sf "~A" value))
155       ((float ,value) (sf "~A" value))
156
157       ((string . ,value-l)
158        (pair-for-each
159         (lambda (pair)
160           (sf "~S" (car pair))
161           (if (pair? (cdr pair)) (sf " ")))
162         value-l))
163
164       ((comment ,text) (sf "/*~A*/\n" text))
165
166       ((scope ,expr) (sf "(") (ppx expr) (sf ")"))
167       
168       ((array-ref ,dim ,expr)
169        (ppx expr) (sf "[") (ppx dim) (sf "]"))
170
171       ((d-sel ,id ,ex) (binary 'd-del "." ex id))
172       ((i-sel ,id ,ex) (binary 'i-del "->" ex id))
173
174       ((pre-inc ,expr) (unary/l 'pre-inc "++" expr))
175       ((pre-dec ,expr) (unary/l 'pre-dec "--" expr))
176       ((ref-to ,expr) (unary/l 'ref-to "&" expr))
177       ((de-ref ,expr) (unary/l 'de-ref "*" expr))
178       ((pos ,expr) (unary/l 'pos "+" expr))
179       ((neg ,expr) (unary/l 'neg "-" expr))
180       ((bitwise-not ,expr) (unary/l 'bitwise-not "~" expr))
181       ((not ,expr) (unary/l 'not "!" expr))
182       ((sizeof-expr ,expr) (sf "sizeof(") (ppx expr) (sf ")"))
183       ((sizeof-type ,type) (sf "sizeof(") (ppx type) (sf ")"))
184
185       ((cast ,tn ,ex)
186        (sf "(") (ppx tn) (sf ")")
187        (if (protect-expr? 'rt 'cast ex)
188            (ppx/p ex)
189            (ppx ex)))
190
191       ((add ,lval ,rval) (binary 'add " + " lval rval))
192       ((sub ,lval ,rval) (binary 'sub " - " lval rval))
193       ((mul ,lval ,rval) (binary 'mul "*" lval rval))
194       ((div ,lval ,rval) (binary 'div "/" lval rval))
195       ((mod ,lval ,rval) (binary 'mod "%" lval rval))
196
197       ((lshift ,lval ,rval) (binary 'lshift "<<" lval rval))
198       ((rshift ,lval ,rval) (binary 'lshift "<<" lval rval))
199
200       ((lt ,lval ,rval) (binary 'lt " < " lval rval))
201       ((gt ,lval ,rval) (binary 'gt " > " lval rval))
202
203       ((le ,lval ,rval) (binary 'le " <= " lval rval))
204       ((ge ,lval ,rval) (binary 'ge " >= " lval rval))
205       ((eq ,lval ,rval) (binary 'eq " == " lval rval))
206       ((ne ,lval ,rval) (binary 'ne " != " lval rval))
207       
208       ((bitwise-and ,lval ,rval) (binary 'bitwise-and " & " lval rval))
209       ((bitwise-or ,lval ,rval) (binary 'bitwise-and " | " lval rval))
210       ((bitwise-xor ,lval ,rval) (binary 'bitwise-xor " ^ " lval rval))
211
212       ((and ,lval ,rval) (binary 'and " && " lval rval))
213       ((or ,lval ,rval) (binary 'and " || " lval rval))
214
215       ;; CHECK THIS
216       ((cond-expr ,cond ,tval ,fval)
217        (ppx cond) (sf "? ") (ppx tval) (sf ": ") (ppx fval))
218
219       ((post-inc ,expr) (unary/r 'post-inc "++" expr))
220       ((post-dec ,expr) (unary/r 'post-dec "--" expr))
221
222       ;; TODO: check protection 
223       ((fctn-call ,expr ,arg-list)
224        (if (protect-expr? 'rt 'fctn-call expr)
225            (ppx/p expr)
226            (ppx expr))
227        (sf "(")
228        (ppx arg-list)
229        (sf ")"))
230
231       ((expr-list . ,expr-l)
232        (pair-for-each
233         (lambda (pair)
234           (ppx (car pair))
235           (if (pair? (cdr pair)) (sf ", ")))
236         expr-l))
237       
238       ((assn-expr ,lval ,op ,rval)
239        (binary (car op) (simple-format #f " ~A " (cadr op)) lval rval))
240
241       ;; TODO: check protection
242       ((comma-expr . ,expr-list)
243        (pair-for-each
244         (lambda (pair)
245           (cond
246            ((pair? (cdr pair))
247             (if (protect-expr? 'rt 'comma-expr (car pair))
248                 (ppx/p (car pair))
249                 (ppx (car pair)))
250             (sf ", "))
251            (else (ppx (car pair)))))
252         expr-list))
253
254       ;; #|
255       ;; gotta break up ppx because sxml-match seems to eat stack space:
256       ;; everthing together results in SIGABRT from vm_error_stack_overflow()
257       (,otherwise
258        (ppx-2 tree))))
259   
260   (define (ppx-2 tree)
261     
262     (sxml-match tree
263       ;; sxml-match continues here to avoid stack overflow
264       ;; |#
265       
266       ((decl ,decl-spec-list)
267        (ppx decl-spec-list) (sf ";\n"))
268       ((decl ,decl-spec-list ,init-declr-list)
269        (ppx decl-spec-list) (ppx init-declr-list) (sf ";\n"))
270       ((decl ,decl-spec-list ,init-declr-list ,comment)
271        (ppx decl-spec-list) (ppx init-declr-list) (sf "; ") (ppx comment))
272       ((decl-no-newline ,decl-spec-list ,init-declr-list) ; for (int i = 0;
273        (ppx decl-spec-list) (ppx init-declr-list) (sf ";"))
274
275       ((comp-decl ,spec-qual-list ,declr-list)
276        (ppx spec-qual-list) (ppx declr-list) (sf ";\n"))
277       ((comp-decl ,spec-qual-list ,declr-list ,comment)
278        (ppx spec-qual-list) (ppx declr-list) (sf "; ") (ppx comment))
279
280       ((decl-spec-list . ,dsl)
281        (let iter ((dsl dsl))
282          (when (pair? dsl)
283            (case (sx-tag (car dsl))
284              ((stor-spec) (sf "~A " (car (sx-ref (car dsl) 1))))
285              ((type-qual) (sf "~A " (sx-ref (car dsl) 1)))
286              ((type-spec) (ppx (car dsl)))
287              (else (sf "[?:~S] " (car dsl))))
288            ;;(if (pair? (cdr dsl)) (sf " "))
289            (iter (cdr dsl)))))
290
291       ((init-declr-list . ,rest)
292        (pair-for-each
293         (lambda (pair)
294           (sf " ")
295           (ppx (car pair))
296           (if (pair? (cdr pair)) (sf ",")))
297         rest))
298       ((comp-declr-list . ,rest)
299        (pair-for-each
300         (lambda (pair)
301           (sf " ")
302           (ppx (car pair))
303           (if (pair? (cdr pair)) (sf ",")))
304         rest))
305
306       ((init-declr ,declr ,initr) (comp declr initr))
307       ((init-declr ,declr) (comp declr #f))
308       ((comp-declr ,declr) (comp declr #f))
309       ((param-declr ,declr) (comp declr #f))
310
311       ((type-spec ,arg)
312        (case (sx-tag arg)
313          ((fixed-type) (sf "~A" (sx-ref arg 1)))
314          ((float-type) (sf "~A" (sx-ref arg 1)))
315          ((struct-ref) (ppx arg))
316          ((struct-def) (ppx arg))
317          ((union-ref) (ppx arg))
318          ((union-def) (ppx arg))
319          ((enum-def) (ppx arg))
320          ((typename) (sf "~A" (sx-ref arg 1)))
321          ((void) (sf "void"))
322          (else (error "missing " arg))))
323
324       ((struct-ref (ident ,name)) (sf "struct ~A" name))
325       ((union-ref (ident ,name)) (sf "union ~A" name))
326       
327       ((struct-def (ident ,name) (field-list . ,fields))
328        (struct-union-def 'struct name fields))
329       ((struct-def (field-list . ,fields))
330        (struct-union-def 'struct #f fields))
331       ((union-def (ident ,name) (field-list . ,fields))
332        (struct-union-def 'union name fields))
333       ((union-def (field-list . ,fields))
334        (struct-union-def 'union #f fields))
335
336       ((enum-def (ident ,name) (enum-def-list . ,edl))
337        (sf "enum ~A " name) (ppx `(enum-def-list . ,edl)))
338
339       ((enum-def (enum-def-list . ,edl))
340        (sf "enum ") (ppx `(enum-def-list . ,edl)))
341
342       ((enum-def-list . ,defns)
343        (sf "{\n") (push-il)
344        (for-each ppx defns)
345        (pop-il) (sf "}"))
346
347       ((enum-defn (ident ,name) (p-expr (fixed ,value)))
348        (sf "~A = ~A,\n" name value))
349       ((enum-defn (ident ,name))
350        (sf "~A,\n" name))
351
352       ((fctn-spec "inline")
353        (sf "inline "))
354
355       ((ptr-declr ,ptr ,dir-declr)
356        (ppx ptr) (ppx dir-declr))
357
358       ((pointer) (sf "*"))
359       ((pointer ,one) (sf "*") (ppx one))
360       ((pointer ,one ,two) (sf "*") (ppx one) (ppx two))
361
362       ((array-of ,dir-declr ,arg)
363        (ppx dir-declr) (sf "[") (ppx arg) (sf "]"))
364       ((array-of ,dir-declr)
365        (ppx dir-declr) (sf "[]"))
366       ;; MORE TO GO
367       
368       ((ftn-declr ,dir-declr ,param-list)
369        (ppx dir-declr) (sf "(") (ppx param-list) (sf ")"))
370
371       ((type-name ,spec-qual-list ,abs-declr)
372        (ppx spec-qual-list) (ppx abs-declr))
373       ((type-name ,decl-spec-list)
374        (ppx decl-spec-list))
375
376       ((abs-declr ,pointer ,dir-abs-declr) (ppx pointer) (ppx dir-abs-declr))
377       ((abs-declr ,one-of-above) (ppx one-of-above))
378
379       ((compd-stmt (block-item-list . ,items))
380        (sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "}\n"))
381       ((compd-stmt-no-newline (block-item-list . ,items))
382        (sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "} "))
383       
384       ;; #|
385       ;; gotta break up ppx because sxml-match seems to eat stack space:
386       ;; everthing together results in SIGABRT from vm_error_stack_overflow()
387       (,otherwise
388        (ppx-3 tree))))
389   
390   (define (ppx-3 tree)
391
392     (sxml-match tree
393       ;; sxml-match continues here to avoid stack overflow
394       ;; |#
395       
396       ;; expression-statement
397       ((expr-stmt) (sf ";\n"))
398       ((expr-stmt ,expr) (ppx expr) (sf ";\n"))
399       ((expr-stmt ,expr ,comm) (ppx expr) (sf "; ") (ppx comm))
400       
401       ((expr) (sf ""))          ; for lone expr-stmt and return-stmt
402
403       ;; selection-statement
404       ((if . ,rest)
405        (let ((cond-part (sx-ref tree 1))
406              (then-part (sx-ref tree 2)))
407          (sf "if (") (ppx cond-part) (sf ") ")
408          (ppx then-part)
409          (let iter ((else-l (sx-tail tree 3)))
410            (cond
411             ((null? else-l) #t)
412             ((eqv? 'else-if (caar else-l))
413              (sf "else if (") (ppx (sx-ref (car else-l) 1)) (sf ") ")
414              (ppx (sx-ref (car else-l) 2))
415              (iter (cdr else-l)))
416             (else
417              (sf "else ")
418              (ppx (car else-l)))))))
419
420       ((switch ,expr (compd-stmt (block-item-list . ,items)))
421        (sf "switch (") (ppx expr) (sf ") {\n")
422        (for-each
423         (lambda (item)
424           (unless (memq (car item) '(case default)) (push-il))
425           (ppx item)
426           (unless (memq (car item) '(case default)) (pop-il)))
427         items)
428        (sf "}\n"))
429
430       ;; labeled-statement
431       ((case ,expr ,stmt)
432        (sf "case ") (ppx expr) (sf ":\n")
433        (push-il) (ppx stmt) (pop-il))
434
435       ((default ,stmt)
436        (sf "default:\n")
437        (push-il) (ppx stmt) (pop-il))
438
439       ;; CHECK THIS
440       ((while ,expr ,stmt)
441        (sf "while (") (ppx expr) (sf ") ") (ppx stmt)
442        )
443
444       ;; This does not meet the convention of "} while" on same line. 
445       ((do-while ,stmt ,expr)
446        (sf "do ")
447        (if (eqv? 'compd-stmt (sx-tag stmt)) 
448            (ppx `(compd-stmt-no-newline ,(sx-ref stmt 1)))
449            (ppx stmt))
450        (sf "while (") (ppx expr) (sf ");\n"))
451       
452       ;; for
453       ((for (decl . ,rest) ,test ,iter ,stmt)
454        (sf "for (") (ppx `(decl-no-newline . ,rest))
455        (sf " ") (ppx test) (sf "; ") (ppx iter) (sf ") ")
456        (ppx stmt))
457
458       ((for (decl . ,rest) ,expr2 ,expr3 ,stmt)
459        (sf "for (")
460        (ppx `(decl . ,rest)) (sf " ") (ppx expr2) (sf "; ") (ppx expr3)
461        (sf ") ") (ppx stmt))
462       ((for ,expr1 ,expr2 ,expr3 ,stmt)
463        (sf "for (")
464        (ppx expr1) (sf "; ") (ppx expr2) (sf "; ") (ppx expr3)
465        (sf ") ") (ppx stmt))
466
467       ;; jump-statement
468       ((goto ,where)
469        (pop-il)                 ; unindent
470        (sf "goto ~A;" (sx-ref where 1))
471        ;; comment?
472        (sf "\n")
473        (push-il))                       ; re-indent
474
475       ((continue) (sf "continue;\n"))
476       ((break) (sf "break;\n"))
477       ((return ,expr) (sf "return ") (ppx expr) (sf ";\n"))
478       ((return) (sf "return;\n"))
479
480       ((trans-unit . ,items)
481        (pair-for-each
482         (lambda (pair)
483           (let ((this (car pair))
484                 (next (and (pair? (cdr pair)) (cadr pair))))
485             (ppx this)
486             (cond ;; add blank line if next is different or fctn defn
487              ((not next))
488              ((not (eqv? (sx-tag this) (sx-tag next))) (sf "\n"))
489              ((eqv? (sx-tag next) 'fctn-defn) (sf "\n")))))
490         items))
491
492       ((fctn-defn . ,rest) ;; but not yet (knr-fctn-defn)
493        (let* ((decl-spec-list (sx-ref tree 1))
494               (declr (sx-ref tree 2))
495               (compd-stmt (sx-ref tree 3)))
496          (ppx decl-spec-list)
497          (sf " ")
498          (ppx declr)
499          (sf " ")
500          (ppx compd-stmt)))
501
502       ((ptr-declr . ,rest)
503        (ppx (sx-ref tree 1)) (ppx (sx-ref tree 2)))
504       
505       ((ftn-declr . ,rest)
506        (ppx (sx-ref tree 1))    ; direct-declarator
507        (sf "(") (ppx (sx-ref tree 2)) (sf ")"))
508
509       ((param-list . ,params)
510        (pair-for-each
511         (lambda (pair) (ppx (car pair)) (if (pair? (cdr pair)) (sf ", ")))
512         params))
513
514       ((ellipsis)       ;; should work
515        (sf "..."))
516
517       ((param-decl ,decl-spec-list ,param-declr)
518        (ppx decl-spec-list) (sf " ") (ppx param-declr))
519       ((param-decl ,decl-spec-list)
520        (ppx decl-spec-list))
521       
522       ((cpp-stmt . ,rest)
523        (cpp-ppx (sx-ref tree 1)))
524
525       ((extern-block ,begin ,guts ,end) (ppx begin) (ppx guts) (ppx end))
526       ((extern-begin ,lang) (sf "extern \"~A\" {\n" lang))
527       ((extern-end) (sf "}\n"))
528
529       (,otherwise
530        (simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree)))
531       ))
532
533   (define ppx ppx-1)
534
535   (if (not (pair? tree)) (error "expecing sxml tree"))
536   (ppx tree)
537   (if ugly (newline)))
538
539 ;; --- last line ---