nyacc: misc updates; see ChangeLog
[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-list . ,defns)
340        (sf "{\n") (push-il)
341        (for-each ppx defns)
342        (pop-il) (sf "}"))
343
344       ((enum-defn (ident ,name) (p-expr (fixed ,value)))
345        (sf "~A = ~A,\n" name value))
346       ((enum-defn (ident ,name))
347        (sf "~A,\n" name))
348
349       ((fctn-spec "inline")
350        (sf "inline "))
351
352       ((ptr-declr ,ptr ,dir-declr)
353        (ppx ptr) (ppx dir-declr))
354
355       ((pointer) (sf "*"))
356       ((pointer ,one) (sf "*") (ppx one))
357       ((pointer ,one ,two) (sf "*") (ppx one) (ppx two))
358
359       ((array-of ,dir-declr ,arg)
360        (ppx dir-declr) (sf "[") (ppx arg) (sf "]"))
361       ((array-of ,dir-declr)
362        (ppx dir-declr) (sf "[]"))
363       ;; MORE TO GO
364       
365       ((ftn-declr ,dir-declr ,param-list)
366        (ppx dir-declr) (sf "(") (ppx param-list) (sf ")"))
367
368       ((type-name ,spec-qual-list ,abs-declr)
369        (ppx spec-qual-list) (ppx abs-declr))
370       ((type-name ,decl-spec-list)
371        (ppx decl-spec-list))
372
373       ((abs-declr ,pointer ,dir-abs-declr) (ppx pointer) (ppx dir-abs-declr))
374       ((abs-declr ,one-of-above) (ppx one-of-above))
375
376       ((compd-stmt (block-item-list . ,items))
377        (sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "}\n"))
378       ((compd-stmt-no-newline (block-item-list . ,items))
379        (sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "} "))
380       
381       ;; #|
382       ;; gotta break up ppx because sxml-match seems to eat stack space:
383       ;; everthing together results in SIGABRT from vm_error_stack_overflow()
384       (,otherwise
385        (ppx-3 tree))))
386   
387   (define (ppx-3 tree)
388
389     (sxml-match tree
390       ;; sxml-match continues here to avoid stack overflow
391       ;; |#
392       
393       ;; expression-statement
394       ((expr-stmt ,expr) (ppx expr) (sf ";\n"))
395       ((expr-stmt ,expr ,comm) (ppx expr) (sf "; ") (ppx comm))
396       
397       ((expr) (sf ""))          ; for lone expr-stmt and return-stmt
398
399       ;; selection-statement
400       ((if . ,rest)
401        (let ((cond-part (sx-ref tree 1))
402              (then-part (sx-ref tree 2)))
403          (sf "if (") (ppx cond-part) (sf ") ")
404          (ppx then-part)
405          (let iter ((else-l (sx-tail tree 3)))
406            (cond
407             ((null? else-l) #t)
408             ((eqv? 'else-if (caar else-l))
409              (sf "else if (") (ppx (sx-ref (car else-l) 1)) (sf ") ")
410              (ppx (sx-ref (car else-l) 2))
411              (iter (cdr else-l)))
412             (else
413              (sf "else ")
414              (ppx (car else-l)))))))
415
416       ((switch ,expr (compd-stmt (block-item-list . ,items)))
417        (sf "switch (") (ppx expr) (sf ") {\n")
418        (for-each
419         (lambda (item)
420           (unless (memq (car item) '(case default)) (push-il))
421           (ppx item)
422           (unless (memq (car item) '(case default)) (pop-il)))
423         items)
424        (sf "}\n"))
425
426       ;; labeled-statement
427       ((case ,expr ,stmt)
428        (sf "case ") (ppx expr) (sf ":\n")
429        (push-il) (ppx stmt) (pop-il))
430
431       ((default ,stmt)
432        (sf "default:\n")
433        (push-il) (ppx stmt) (pop-il))
434
435       ;; CHECK THIS
436       ((while ,expr ,stmt)
437        (sf "while (") (ppx expr) (sf ") ") (ppx stmt)
438        )
439
440       ;; This does not meet the convention of "} while" on same line. 
441       ((do-while ,stmt ,expr)
442        (sf "do ")
443        (if (eqv? 'compd-stmt (sx-tag stmt)) 
444            (ppx `(compd-stmt-no-newline ,(sx-ref stmt 1)))
445            (ppx stmt))
446        (sf "while (") (ppx expr) (sf ");\n"))
447       
448       ;; for
449       ((for (decl . ,rest) ,test ,iter ,stmt)
450        (sf "for (") (ppx `(decl-no-newline . ,rest))
451        (sf " ") (ppx test) (sf "; ") (ppx iter) (sf ") ")
452        (ppx stmt))
453
454       ((for (decl . ,rest) ,expr2 ,expr3 ,stmt)
455        (sf "for (")
456        (ppx `(decl . ,rest)) (sf " ") (ppx expr2) (sf "; ") (ppx expr3)
457        (sf ") ") (ppx stmt))
458       ((for ,expr1 ,expr2 ,expr3 ,stmt)
459        (sf "for (")
460        (ppx expr1) (sf "; ") (ppx expr2) (sf "; ") (ppx expr3)
461        (sf ") ") (ppx stmt))
462
463       ;; jump-statement
464       ((goto ,where)
465        (pop-il)                 ; unindent
466        (sf "goto ~A;" (sx-ref where 1))
467        ;; comment?
468        (sf "\n")
469        (push-il))                       ; re-indent
470
471       ((continue) (sf "continue;\n"))
472       ((break) (sf "break;\n"))
473       ((return ,expr) (sf "return ") (ppx expr) (sf ";\n"))
474       ((return) (sf "return;\n"))
475
476       ((trans-unit . ,items)
477        (pair-for-each
478         (lambda (pair)
479           (let ((this (car pair))
480                 (next (and (pair? (cdr pair)) (cadr pair))))
481             (ppx this)
482             (cond ;; add blank line if next is different or fctn defn
483              ((not next))
484              ((not (eqv? (sx-tag this) (sx-tag next))) (sf "\n"))
485              ((eqv? (sx-tag next) 'fctn-defn) (sf "\n")))))
486         items))
487
488       ((fctn-defn . ,rest) ;; but not yet (knr-fctn-defn)
489        (let* ((decl-spec-list (sx-ref tree 1))
490               (declr (sx-ref tree 2))
491               (compd-stmt (sx-ref tree 3)))
492          (ppx decl-spec-list)
493          (sf " ")
494          (ppx declr)
495          (sf " ")
496          (ppx compd-stmt)))
497
498       ((ptr-declr . ,rest)
499        (ppx (sx-ref tree 1)) (ppx (sx-ref tree 2)))
500       
501       ((ftn-declr . ,rest)
502        (ppx (sx-ref tree 1))    ; direct-declarator
503        (sf "(") (ppx (sx-ref tree 2)) (sf ")"))
504
505       ((param-list . ,params)
506        (pair-for-each
507         (lambda (pair) (ppx (car pair)) (if (pair? (cdr pair)) (sf ", ")))
508         params))
509
510       ((ellipsis)       ;; should work
511        (sf "..."))
512
513       ((param-decl ,decl-spec-list ,param-declr)
514        (ppx decl-spec-list) (sf " ") (ppx param-declr))
515       ((param-decl ,decl-spec-list)
516        (ppx decl-spec-list))
517       
518       ((cpp-stmt . ,rest)
519        (cpp-ppx (sx-ref tree 1)))
520
521       ((extern-C-begin) (sf "extern \"C\" {\n"))
522       ((extern-C-end) (sf "}\n"))
523
524       (,otherwise
525        (simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree)))
526       ))
527
528   (define ppx ppx-1)
529   
530   (ppx tree)
531   (if ugly (newline)))
532
533 ;; --- last line ---