44639d16373e80972431f1c4fa7420f844391913
[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
99   (define (unary/l op rep rval)
100     (sf rep)
101     (if (protect-expr? 'rt op rval)
102         (ppx/p rval)
103         (ppx rval)))
104   
105   (define (unary/r op rep lval)
106     (sf rep)
107     (if (protect-expr? 'lt op lval)
108         (ppx/p lval)
109         (ppx lval)))
110   
111   (define (binary op rep lval rval)
112     (if (protect-expr? 'lt op lval)
113         (ppx/p lval)
114         (ppx lval))
115     (sf rep)
116     (if (protect-expr? 'rt op rval)
117         (ppx/p rval)
118         (ppx rval)))
119
120   (define (comp declr initr)
121     (let ((iexpr (and initr (sx-ref initr 1))))
122       (ppx declr)
123       (when initr
124         (sf " = ")
125         (case (sx-tag iexpr)
126           ((initzer-list)
127            (sf "{")
128            (sf "initzer-list")  ; TODO
129            (sf " }"))
130           (else
131            (ppx iexpr))))))
132
133   (define (struct-union-def struct-or-union name fields)
134     (if name
135         (sf "~A ~A {\n" struct-or-union name)
136         (sf "~A {\n" struct-or-union))
137     (push-il)
138     (for-each ppx fields)
139     (pop-il)
140     (sf "}"))
141
142   (define (ppx/p tree) (sf "(") (ppx tree) (sf ")"))
143
144   ;; TODO: comp-lit
145   (define (ppx-1 tree)
146     (sxml-match tree
147
148       ((p-expr ,expr) (ppx expr))
149       ((ident ,name) (sf "~A" name))
150       ((char ,value) (sf "'~A'" (sx-ref tree 1)))
151       ((fixed ,value) (sf "~A" value))
152       ((float ,value) (sf "~A" value))
153
154       ((string . ,value-l)
155        (pair-for-each
156         (lambda (pair)
157           (sf "~S" (car pair))
158           (if (pair? (cdr pair)) (sf " ")))
159         value-l))
160
161       ((comment ,text) (sf "/*~A */\n" text))
162
163       ((scope ,expr) (sf "(") (ppx expr) (sf ")"))
164       
165       ((array-ref ,dim ,expr)
166        (ppx expr) (sf "[") (ppx dim) (sf "]"))
167
168       ((d-sel ,id ,ex) (binary 'd-del "." ex id))
169       ((i-sel ,id ,ex) (binary 'i-del "->" ex id))
170
171       ((pre-inc ,expr) (unary/l 'pre-inc "++" expr))
172       ((pre-dec ,expr) (unary/l 'pre-dec "--" expr))
173       ((ref-to ,expr) (unary/l 'ref-to "&" expr))
174       ((de-ref ,expr) (unary/l 'de-ref "*" expr))
175       ((pos ,expr) (unary/l 'pos "+" expr))
176       ((neg ,expr) (unary/l 'neg "-" expr))
177       ((bitwise-not ,expr) (unary/l 'bitwise-not "~" expr))
178       ((not ,expr) (unary/l 'not "!" expr))
179       ((sizeof-expr ,expr) (sf "sizeof(") (ppx expr) (sf ")"))
180       ((sizeof-type ,type) (sf "sizeof(") (ppx type) (sf ")"))
181
182       ((cast ,tn ,ex)
183        (sf "(") (ppx tn) (sf ")")
184        (if (protect-expr? 'rt 'cast ex)
185            (ppx/p ex)
186            (ppx ex)))
187
188       ((add ,lval ,rval) (binary 'add " + " lval rval))
189       ((sub ,lval ,rval) (binary 'sub " - " lval rval))
190       ((mul ,lval ,rval) (binary 'mul "*" lval rval))
191       ((div ,lval ,rval) (binary 'div "/" lval rval))
192       ((mod ,lval ,rval) (binary 'mod "%" lval rval))
193
194       ((lt ,lval ,rval) (binary 'lt " < " lval rval))
195       ((gt ,lval ,rval) (binary 'gt " > " lval rval))
196
197       ((le ,lval ,rval) (binary 'le " <= " lval rval))
198       ((ge ,lval ,rval) (binary 'ge " >= " lval rval))
199       ((eq ,lval ,rval) (binary 'eq " == " lval rval))
200       ((ne ,lval ,rval) (binary 'ne " != " lval rval))
201       
202       ((bitwise-and ,lval ,rval) (binary 'bitwise-and " & " lval rval))
203       ((bitwise-or ,lval ,rval) (binary 'bitwise-and " | " lval rval))
204       ((bitwise-xor ,lval ,rval) (binary 'bitwise-xor " ^ " lval rval))
205
206       ((post-inc ,expr) (unary/r 'post-inc "++" expr))
207       ((post-dec ,expr) (unary/r 'post-dec "--" expr))
208
209       ;; TODO: check protection 
210       ((fctn-call ,expr ,arg-list)
211        (if (protect-expr? 'rt 'fctn-call expr)
212            (ppx/p expr)
213            (ppx expr))
214        (sf "(")
215        (ppx arg-list)
216        (sf ")"))
217
218       ((expr-list . ,expr-l)
219        (pair-for-each
220         (lambda (pair)
221           (ppx (car pair))
222           (if (pair? (cdr pair)) (sf ", ")))
223         expr-l))
224       
225       ((assn-expr ,lval ,op ,rval)
226        (binary (car op) (simple-format #f " ~A " (cadr op)) lval rval))
227
228       ;; TODO: check protection
229       ((comma-expr . ,expr-list)
230        (pair-for-each
231         (lambda (pair)
232           (cond
233            ((pair? (cdr pair))
234             (if (protect-expr? 'rt 'comma-expr (car pair))
235                 (ppx/p (car pair))
236                 (ppx (car pair)))
237             (sf ", "))
238            (else (ppx (car pair)))))
239         expr-list))
240
241       ;; #|
242       ;; gotta break up ppx because sxml-match seems to eat stack space:
243       ;; everthing together results in SIGABRT from vm_error_stack_overflow()
244       (,otherwise
245        (ppx-2 tree))))
246   
247   (define (ppx-2 tree)
248     
249     (sxml-match tree
250       ;; sxml-match continues here to avoid stack overflow
251       ;; |#
252       
253       ((decl ,decl-spec-list)
254        (ppx decl-spec-list) (sf ";\n"))
255       ((decl ,decl-spec-list ,init-declr-list)
256        (ppx decl-spec-list) (ppx init-declr-list) (sf ";\n"))
257       ((decl ,decl-spec-list ,init-declr-list ,comment)
258        (ppx decl-spec-list) (ppx init-declr-list) (sf "; ") (ppx comment))
259       ((decl-no-newline ,decl-spec-list ,init-declr-list) ; for (int i = 0;
260        (ppx decl-spec-list) (ppx init-declr-list) (sf ";"))
261
262       ((comp-decl ,spec-qual-list ,declr-list)
263        (ppx spec-qual-list) (ppx declr-list) (sf ";\n"))
264       ((comp-decl ,spec-qual-list ,declr-list ,comment)
265        (ppx spec-qual-list) (ppx declr-list) (sf "; ") (ppx comment))
266
267       ((decl-spec-list . ,dsl)
268        (let iter ((dsl dsl))
269          (when (pair? dsl)
270            (case (sx-tag (car dsl))
271              ((stor-spec) (sf "~A" (car (sx-ref (car dsl) 1))))
272              ((type-qual) (sf "qual=~A" (sx-ref (car dsl) 1)))
273              ((type-spec) (ppx (car dsl)))
274              (else (sf "[?:~S] " (car dsl))))
275            (if (pair? (cdr dsl)) (sf " "))
276            (iter (cdr dsl)))))
277
278       ((init-declr-list . ,rest)
279        (pair-for-each
280         (lambda (pair)
281           (sf " ")
282           (ppx (car pair))
283           (if (pair? (cdr pair)) (sf ",")))
284         rest))
285       ((comp-declr-list . ,rest)
286        (pair-for-each
287         (lambda (pair)
288           (sf " ")
289           (ppx (car pair))
290           (if (pair? (cdr pair)) (sf ",")))
291         rest))
292
293       ((init-declr ,declr ,initr) (comp declr initr))
294       ((init-declr ,declr) (comp declr #f))
295       ((comp-declr ,declr) (comp declr #f))
296       ((param-declr ,declr) (comp declr #f))
297
298       ((type-spec ,arg)
299        (case (sx-tag arg)
300          ((fixed-type) (sf "~A" (sx-ref arg 1)))
301          ((float-type) (sf "~A" (sx-ref arg 1)))
302          ((struct-ref) (ppx arg))
303          ((struct-def) (ppx arg))
304          ((union-ref) (ppx arg))
305          ((union-def) (ppx arg))
306          ((enum-def) (ppx arg))
307          ((typename) (sf "~A" (sx-ref arg 1)))
308          ((void) (sf "void"))
309          (else (error "missing " arg))))
310
311       ((struct-ref (ident ,name)) (sf "struct ~A" name))
312       ((union-ref (ident ,name)) (sf "union ~A" name))
313       
314       ((struct-def (ident ,name) (field-list . ,fields))
315        (struct-union-def 'struct name fields))
316       ((struct-def (field-list . ,fields))
317        (struct-union-def 'struct #f fields))
318       ((union-def (ident ,name) (field-list . ,fields))
319        (struct-union-def 'union name fields))
320       ((union-def (field-list . ,fields))
321        (struct-union-def 'union #f fields))
322
323       ((enum-def (ident ,name) (enum-def-list . ,edl))
324        (sf "enum ~A " name) (ppx `(enum-def-list . ,edl)))
325
326       ((enum-def-list . ,defns)
327        (sf "{\n") (push-il)
328        (for-each ppx defns)
329        (pop-il) (sf "}"))
330
331       ((enum-defn (ident ,name) (p-expr (fixed ,value)))
332        (sf "~A = ~A,\n" name value))
333       ((enum-defn (ident ,name))
334        (sf "~A,\n" name))
335
336       ((fctn-spec "inline")
337        (sf "inline "))
338
339       ((ptr-declr ,ptr ,dir-declr)
340        (ppx ptr) (ppx dir-declr))
341
342       ((pointer) (sf "*"))
343       ((pointer ,one) (sf "*") (ppx one))
344       ((pointer ,one ,two) (sf "*") (ppx one) (ppx two))
345
346       ((array-of ,dir-declr ,arg)
347        (ppx dir-declr) (sf "[") (ppx arg) (sf "]"))
348       ((array-of ,dir-declr)
349        (ppx dir-declr) (sf "[]"))
350       ;; MORE TO GO
351       
352       ((ftn-declr ,dir-declr ,param-list)
353        (ppx dir-declr) (sf "(") (ppx param-list) (sf ")"))
354
355       ((type-name ,spec-qual-list ,abs-declr)
356        (ppx spec-qual-list) (ppx abs-declr))
357       ((type-name ,decl-spec-list)
358        (ppx decl-spec-list))
359
360       ((abs-declr ,pointer ,dir-abs-declr) (ppx pointer) (ppx dir-abs-declr))
361       ((abs-declr ,one-of-above) (ppx one-of-above))
362
363       ((compd-stmt (block-item-list . ,items))
364        (sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "}\n"))
365       ((compd-stmt-no-newline (block-item-list . ,items))
366        (sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "} "))
367       
368       ;; #|
369       ;; gotta break up ppx because sxml-match seems to eat stack space:
370       ;; everthing together results in SIGABRT from vm_error_stack_overflow()
371       (,otherwise
372        (ppx-3 tree))))
373   
374   (define (ppx-3 tree)
375
376     (sxml-match tree
377       ;; sxml-match continues here to avoid stack overflow
378       ;; |#
379       
380       ;; expression-statement
381       ((expr-stmt ,expr) (ppx expr) (sf ";\n"))
382       ((expr-stmt ,expr ,comm) (ppx expr) (sf "; ") (ppx comm))
383       
384       ((expr) (sf ""))          ; for lone expr-stmt and return-stmt
385
386       ;; selection-statement
387       ((if . ,rest)
388        (let ((cond-part (sx-ref tree 1))
389              (then-part (sx-ref tree 2)))
390          (sf "if (") (ppx cond-part) (sf ") ")
391          (ppx then-part)
392          (let iter ((else-l (sx-tail tree 3)))
393            (cond
394             ((null? else-l) #t)
395             ((eqv? 'else-if (caar else-l))
396              (sf "else if (") (ppx (sx-ref (car else-l) 1)) (sf ") ")
397              (ppx (sx-ref (car else-l) 2))
398              (iter (cdr else-l)))
399             (else
400              (sf "else ")
401              (ppx (car else-l)))))))
402
403       ((switch ,expr (compd-stmt (block-item-list . ,items)))
404        (sf "switch (") (ppx expr) (sf ") {\n")
405        (for-each
406         (lambda (item)
407           (unless (memq (car item) '(case default)) (push-il))
408           (ppx item)
409           (unless (memq (car item) '(case default)) (pop-il)))
410         items)
411        (sf "}\n"))
412
413       ;; labeled-statement
414       ((case ,expr ,stmt)
415        (sf "case ") (ppx expr) (sf ":\n")
416        (push-il) (ppx stmt) (pop-il))
417
418       ((default ,stmt)
419        (sf "default:\n")
420        (push-il) (ppx stmt) (pop-il))
421
422       ;; This does not meet the convention of "} while" on same line. 
423       ((do-while ,stmt ,expr)
424        (sf "do ")
425        (if (eqv? 'compd-stmt (sx-tag stmt)) 
426            (ppx `(compd-stmt-no-newline ,(sx-ref stmt 1)))
427            (ppx stmt))
428        (sf "while (") (ppx expr) (sf ");\n"))
429       
430       ;; for
431       ((for (decl . ,rest) ,test ,iter ,stmt)
432        (sf "for (") (ppx `(decl-no-newline . ,rest))
433        (sf " ") (ppx test) (sf "; ") (ppx iter) (sf ") ")
434        (ppx stmt))
435
436       ((for (decl . ,rest) ,expr2 ,expr3 ,stmt)
437        (sf "for (")
438        (ppx `(decl . ,rest)) (sf " ") (ppx expr2) (sf "; ") (ppx expr3)
439        (sf ") ") (ppx stmt))
440       ((for ,expr1 ,expr2 ,expr3 ,stmt)
441        (sf "for (")
442        (ppx expr1) (sf "; ") (ppx expr2) (sf "; ") (ppx expr3)
443        (sf ") ") (ppx stmt))
444
445       ;; jump-statement
446       ((goto ,where)
447        (pop-il)                 ; unindent
448        (sf "goto ~A;" (sx-ref where 1))
449        ;; comment?
450        (sf "\n")
451        (push-il))                       ; re-indent
452
453       ((continue) (sf "continue;\n"))
454       ((break) (sf "break;\n"))
455       ((return ,expr) (sf "return ") (ppx expr) (sf ";\n"))
456       ((return) (sf "return;\n"))
457
458       ((trans-unit . ,items)
459        (pair-for-each
460         (lambda (pair)
461           (let ((this (car pair))
462                 (next (and (pair? (cdr pair)) (cadr pair))))
463             (ppx this)
464             (cond ;; add blank line if next is different or fctn defn
465              ((not next))
466              ((not (eqv? (sx-tag this) (sx-tag next))) (sf "\n"))
467              ((eqv? (sx-tag next) 'fctn-defn) (sf "\n")))))
468         items))
469
470       ((fctn-defn . ,rest) ;; but not yet (knr-fctn-defn)
471        (let* ((decl-spec-list (sx-ref tree 1))
472               (declr (sx-ref tree 2))
473               (compd-stmt (sx-ref tree 3)))
474          (ppx decl-spec-list)
475          (sf " ")
476          (ppx declr)
477          (sf " ")
478          (ppx compd-stmt)))
479
480       ((ptr-declr . ,rest)
481        (ppx (sx-ref tree 1)) (ppx (sx-ref tree 2)))
482       
483       ((ftn-declr . ,rest)
484        (ppx (sx-ref tree 1))    ; direct-declarator
485        (sf "(") (ppx (sx-ref tree 2)) (sf ")"))
486
487       ((param-list . ,params)
488        (pair-for-each
489         (lambda (pair) (ppx (car pair)) (if (pair? (cdr pair)) (sf ", ")))
490         params))
491
492       ((param-decl ,decl-spec-list ,param-declr)
493        (ppx decl-spec-list) (sf " ") (ppx param-declr))
494       ((param-decl ,decl-spec-list)
495        (ppx decl-spec-list))
496       
497       ((cpp-stmt . ,rest)
498        (cpp-ppx (sx-ref tree 1)))
499
500       ((extern-C-begin) (sf "extern \"C\" {\n"))
501       ((extern-C-end) (sf "}\n"))
502
503       (,otherwise
504        (simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree)))
505       ))
506
507   (define ppx ppx-1)
508   
509   (ppx tree)
510   (if ugly (newline)))
511
512 ;; --- last line ---