mirror of
https://github.com/fosslinux/live-bootstrap.git
synced 2026-03-12 06:15:29 +01:00
649d7b68dc
mescc-tools-extra contains two important tools: - cp - chmod mes first builds itself from a mes 0.21 seed as used by guix, and then builds a mes 0.22 and then mes 0.22 using that created mes 0.22. It does /not/ use bootstrap.sh as we don't have a proper shell at this point, it has been manually adapted for kaem.
692 lines
21 KiB
Scheme
692 lines
21 KiB
Scheme
;;; nyacc/lang/c99/pprint.scm - C pretty-printer
|
|
|
|
;; Copyright (C) 2015-2018 Matthew R. Wette
|
|
;;
|
|
;; This library is free software; you can redistribute it and/or
|
|
;; modify it under the terms of the GNU Lesser General Public
|
|
;; License as published by the Free Software Foundation; either
|
|
;; version 3 of the License, or (at your option) any later version.
|
|
;;
|
|
;; This library is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;; Lesser General Public License for more details.
|
|
;;
|
|
;; You should have received a copy of the GNU Lesser General Public License
|
|
;; along with this library; if not, see <http://www.gnu.org/licenses/>
|
|
|
|
;;; Code:
|
|
|
|
(define-module (nyacc lang c99 pprint)
|
|
#:export (pretty-print-c99)
|
|
#:use-module ((srfi srfi-1) #:select (pair-for-each fold-right))
|
|
#:use-module (nyacc lang util)
|
|
#:use-module (nyacc lang sx-util)
|
|
#:use-module (ice-9 pretty-print)
|
|
)
|
|
(cond-expand ;; for MES
|
|
(guile-2 #t)
|
|
(else
|
|
(use-modules (ice-9 optargs))))
|
|
|
|
(define op-sym
|
|
(let ((ot '(("=" . eq) ("+=" . pl-eq) ("-=" . mi-eq) ("*=" . ti-eq)
|
|
("/=" . di-eq) ("%=" . mo-eq) ("<<=" . ls-eq) (">>=" . rs-eq)
|
|
("&=" . ba-eq) ("^=" . bx-eq) ("|=" bo-eq))))
|
|
(lambda (name)
|
|
(assoc-ref ot name))))
|
|
|
|
(define op-prec
|
|
;; in order of decreasing precedence
|
|
'((p-expr ident fixed float string)
|
|
(comp-lit post-inc post-dec i-sel d-sel fctn-call array-ref)
|
|
(de-ref ref-to neg pos not bitwise-not sizeof pre-inc pre-dec)
|
|
(cast)
|
|
(mul div mod)
|
|
(add sub)
|
|
(lshift rshift)
|
|
(lt gt le ge)
|
|
(eq ne)
|
|
(bitwise-and)
|
|
(bitwise-xor)
|
|
(bitwise-or)
|
|
(and)
|
|
(or)
|
|
(cond-expr)
|
|
(assn-expr)
|
|
(comma)))
|
|
|
|
(define op-assc
|
|
'((left array-ref d-sel i-sel post-inc post-dec comp-lit mul div mod add sub
|
|
lshift rshift lt gt le ge bitwise-and bitwise-xor bitwise-or and or)
|
|
(right pre-inc pre-dec sizeof bitwise-not not pos neg ref-to de-ref cast
|
|
cond assn-expr)
|
|
(nonassoc)))
|
|
|
|
;; @deffn {Procedure} scmchs->c scm-chr-str => c-chr-str
|
|
;; Convert 1-char scheme string into 1-char C string constant as typed by user.
|
|
;; That is, exscaped.
|
|
;; @example
|
|
;; (scmchstr->c "#x00") => "\\0"
|
|
;; @end example
|
|
;; @end deffn
|
|
(define (scmchs->c scm-chr-str)
|
|
(let ((ch (string-ref scm-chr-str 0)))
|
|
(case ch
|
|
((#\nul) "\\0") ((#\bel) "\\a") ((#\bs) "\\b") ((#\ht) "\\t")
|
|
((#\nl) "\\n") ((#\vt) "\\v") ((#\np) "\\f") ((#\cr) "\\r") ((#\\) "\\")
|
|
(else scm-chr-str))))
|
|
|
|
;; @deffn {Procedure} char->hex-list ch seed
|
|
;; to be documented
|
|
;; @end deffn
|
|
(define (char->hex-list ch seed)
|
|
(define (itox ival) (string-ref "0123456789ABCDEF" ival))
|
|
(let loop ((res seed) (ix 8) (val (char->integer ch)))
|
|
(cond
|
|
((zero? ix) (cons* #\\ #\U res))
|
|
((and (zero? val) (= ix 4)) (cons* #\\ #\u res))
|
|
(else
|
|
(loop (cons (itox (remainder val 16)) res) (1- ix) (quotient val 16))))))
|
|
|
|
(define (esc->ch ch)
|
|
(case ch ((#\nul) #\0) ((#\bel) #\a) ((#\bs) #\b) ((#\ht) #\t)
|
|
((#\nl) #\n) ((#\vt) #\v) ((#\np) #\f) ((#\cr) #\r)))
|
|
|
|
;; @deffn {Procedure} scmstr->c str
|
|
;; to be documented
|
|
;; @end deffn
|
|
(define (scmstr->c str)
|
|
(list->string
|
|
(string-fold-right
|
|
(lambda (ch chl)
|
|
(cond
|
|
((char-set-contains? char-set:printing ch) (cons ch chl))
|
|
((char=? ch #\space) (cons #\space chl))
|
|
((memq ch '(#\nul #\bel #\bs #\ht #\nl #\vt #\np #\cr))
|
|
(cons* #\\ (esc->ch ch) chl))
|
|
(else (char->hex-list ch chl))))
|
|
'() str)))
|
|
|
|
;;(define protect-expr? (make-protect-expr op-prec op-assc))
|
|
|
|
;; @deffn {Procedure} pretty-print-c99 tree [port] [options]
|
|
;; Convert and print a C99 sxml tree to the current output port.
|
|
;; The optional keyword argument @code{#:basic-offset} provides the
|
|
;; indent level, with default of 2.
|
|
;; @table code
|
|
;; @item #:basic-offset <n>
|
|
;; indent level for C code
|
|
;; @item #:per-line-prefix <string>
|
|
;; string
|
|
;; @item #:ugly #t|#f
|
|
;; pring ugly
|
|
;; @end table
|
|
;; @end deffn
|
|
(define* (pretty-print-c99 tree
|
|
#:optional (port (current-output-port))
|
|
#:key ugly per-line-prefix (basic-offset 2))
|
|
|
|
(define fmtr
|
|
((if ugly make-pp-formatter/ugly make-pp-formatter)
|
|
port #:per-line-prefix per-line-prefix #:basic-offset basic-offset))
|
|
(define (push-il)(fmtr 'push))
|
|
(define (pop-il) (fmtr 'pop))
|
|
|
|
(define (sf . args) (apply fmtr args))
|
|
|
|
(define (cpp-ppx tree)
|
|
(fmtr 'nlin)
|
|
(sx-match tree
|
|
((define (name ,name) (args . ,args) (repl ,repl))
|
|
(sf "#define ~A(" name)
|
|
(pair-for-each
|
|
(lambda (pair) (sf "~A" (car pair)) (if (pair? (cdr pair)) (sf ",")))
|
|
args)
|
|
(sf ") ~A\n" repl))
|
|
((define (name ,name) (repl ,repl))
|
|
(sf "#define ~A ~A\n" name repl))
|
|
((if ,text) (sf "#if ~A\n" text))
|
|
((elif ,text) (sf "#elif ~A\n" text))
|
|
((else ,text) (sf "#else ~A\n" text))
|
|
((else) (sf "#else\n"))
|
|
((endif ,text) (sf "#endif ~A\n" text))
|
|
((endif) (sf "#endif\n"))
|
|
((include ,file . ,rest) (sf "#include ~A\n" file))
|
|
((error ,text) (sf "#error ~A\n" text))
|
|
((pragma ,text) (sf "#pragma ~A\n" text))
|
|
(else (simple-format #t "\n*** pprint/cpp-ppx: NO MATCH: ~S\n" tree)))
|
|
(fmtr 'nlin))
|
|
|
|
(define protect-expr? (make-protect-expr op-prec op-assc))
|
|
|
|
(define (unary/l op rep rval)
|
|
(sf rep)
|
|
(if (protect-expr? 'rt op rval)
|
|
(ppx/p rval)
|
|
(ppx rval)))
|
|
|
|
(define (unary/r op rep lval)
|
|
(if (protect-expr? 'lt op lval)
|
|
(ppx/p lval)
|
|
(ppx lval))
|
|
(sf rep))
|
|
|
|
(define (binary op rep lval rval)
|
|
(if (protect-expr? 'lt op lval)
|
|
(ppx/p lval)
|
|
(ppx lval))
|
|
(sf rep)
|
|
(if (protect-expr? 'rt op rval)
|
|
(ppx/p rval)
|
|
(ppx rval)))
|
|
|
|
;; now ((comment xxx) (attributes "aaa;yyy;zzz"))
|
|
(define (pp-attr attr)
|
|
(string-join
|
|
(fold-right
|
|
(lambda (pair seed)
|
|
(if (eqv? 'attributes (car pair))
|
|
;; FIXME: should really parse-attributes, then ppx
|
|
(append (string-split (cadr pair) #\;) seed)
|
|
seed))
|
|
'() attr)
|
|
" "))
|
|
|
|
(define (struct-union-def struct-or-union attr name fields)
|
|
(if name
|
|
(if (pair? attr)
|
|
(sf "~A ~A ~A {\n" struct-or-union (pp-attr attr) name)
|
|
(sf "~A ~A {\n" struct-or-union name))
|
|
(if (pair? attr)
|
|
(sf "~A ~A {\n" struct-or-union (pp-attr attr))
|
|
(sf "~A {\n" struct-or-union)))
|
|
(push-il)
|
|
(for-each ppx fields)
|
|
(pop-il)
|
|
(sf "}"))
|
|
|
|
(define (comm+nl attr)
|
|
(cond
|
|
((assq 'comment attr) => (lambda (comm) (sf " ") (ppx comm)))
|
|
(else (sf "\n"))))
|
|
|
|
(define (ppx/p tree) (sf "(") (ppx tree) (sf ")"))
|
|
|
|
;; TODO: comp-lit
|
|
(define (ppx tree)
|
|
(sx-match tree
|
|
|
|
((p-expr ,expr) (ppx expr))
|
|
((ident ,name) (sf "~A" name))
|
|
((char (@ . ,al) ,value)
|
|
(let ((type (sx-attr-ref al 'type)))
|
|
(cond
|
|
((not type) (sf "'~A'" (scmchs->c value)))
|
|
((string=? type "wchar_t") (sf "L'~A'" (scmchs->c value)))
|
|
((string=? type "char16_t") (sf "u'~A'" (scmchs->c value)))
|
|
((string=? type "char32_t") (sf "U'~A'" (scmchs->c value)))
|
|
(else (throw 'c99-error "bad type")))))
|
|
((fixed ,value) (sf "~A" value))
|
|
((float ,value) (sf "~A" value))
|
|
|
|
((string . ,value-l)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(sf "\"~A\"" (scmstr->c (car pair)))
|
|
(if (pair? (cdr pair)) (sf " ")))
|
|
value-l))
|
|
|
|
((comment ,text)
|
|
(cond
|
|
((or (string-any #\newline text) (string-suffix? " " text))
|
|
(for-each (lambda (l) (sf (scmstr->c l)) (sf "\n"))
|
|
(string-split (string-append "/*" text "*/") #\newline)))
|
|
(else (sf (string-append "//" text "\n")))))
|
|
|
|
((scope ,expr) (sf "(") (ppx expr) (sf ")"))
|
|
|
|
((array-ref ,dim ,expr)
|
|
(ppx expr) (sf "[") (ppx dim) (sf "]"))
|
|
|
|
((d-sel ,id ,ex) (binary 'd-sel "." ex id))
|
|
((i-sel ,id ,ex) (binary 'i-sel "->" ex id))
|
|
|
|
((pre-inc ,expr) (unary/l 'pre-inc "++" expr))
|
|
((pre-dec ,expr) (unary/l 'pre-dec "--" expr))
|
|
((ref-to ,expr) (unary/l 'ref-to "&" expr))
|
|
((de-ref ,expr) (unary/l 'de-ref "*" expr))
|
|
((pos ,expr) (unary/l 'pos "+" expr))
|
|
((neg ,expr) (unary/l 'neg "-" expr))
|
|
((bitwise-not ,expr) (unary/l 'bitwise-not "~" expr))
|
|
((not ,expr) (unary/l 'not "!" expr))
|
|
((sizeof-expr ,expr) (sf "sizeof(") (ppx expr) (sf ")"))
|
|
((sizeof-type ,type) (sf "sizeof(") (ppx type) (sf ")"))
|
|
|
|
((pragma ,text)
|
|
(fmtr 'nlin)
|
|
(sf "#pragma ~A\n" text))
|
|
|
|
((cast ,tn ,ex)
|
|
(sf "(") (ppx tn) (sf ")")
|
|
(if (protect-expr? 'rt 'cast ex)
|
|
(ppx/p ex)
|
|
(ppx ex)))
|
|
|
|
((add ,lval ,rval) (binary 'add " + " lval rval))
|
|
((sub ,lval ,rval) (binary 'sub " - " lval rval))
|
|
((mul ,lval ,rval) (binary 'mul "*" lval rval))
|
|
((div ,lval ,rval) (binary 'div "/" lval rval))
|
|
((mod ,lval ,rval) (binary 'mod "%" lval rval))
|
|
|
|
((lshift ,lval ,rval) (binary 'lshift "<<" lval rval))
|
|
((rshift ,lval ,rval) (binary 'lshift "<<" lval rval))
|
|
|
|
((lt ,lval ,rval) (binary 'lt " < " lval rval))
|
|
((gt ,lval ,rval) (binary 'gt " > " lval rval))
|
|
|
|
((le ,lval ,rval) (binary 'le " <= " lval rval))
|
|
((ge ,lval ,rval) (binary 'ge " >= " lval rval))
|
|
((eq ,lval ,rval) (binary 'eq " == " lval rval))
|
|
((ne ,lval ,rval) (binary 'ne " != " lval rval))
|
|
|
|
((bitwise-and ,lval ,rval) (binary 'bitwise-and " & " lval rval))
|
|
((bitwise-or ,lval ,rval) (binary 'bitwise-and " | " lval rval))
|
|
((bitwise-xor ,lval ,rval) (binary 'bitwise-xor " ^ " lval rval))
|
|
|
|
((and ,lval ,rval) (binary 'and " && " lval rval))
|
|
((or ,lval ,rval) (binary 'and " || " lval rval))
|
|
|
|
;; CHECK THIS
|
|
((cond-expr ,cond ,tval ,fval)
|
|
(ppx cond) (sf "? ") (ppx tval) (sf ": ") (ppx fval))
|
|
|
|
((post-inc ,expr) (unary/r 'post-inc "++" expr))
|
|
((post-dec ,expr) (unary/r 'post-dec "--" expr))
|
|
|
|
;; TODO: check protection
|
|
((fctn-call ,expr ,arg-list)
|
|
(if (protect-expr? 'rt 'fctn-call expr)
|
|
(ppx/p expr)
|
|
(ppx expr))
|
|
(sf "(")
|
|
(ppx arg-list)
|
|
(sf ")"))
|
|
|
|
((expr-list . ,expr-l)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(ppx (car pair))
|
|
(if (pair? (cdr pair)) (sf ", ")))
|
|
expr-l))
|
|
|
|
((assn-expr ,lval ,op ,rval)
|
|
(binary (car op) (simple-format #f " ~A " (cadr op)) lval rval))
|
|
|
|
;; TODO: check protection
|
|
((comma-expr . ,expr-list)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(cond
|
|
((pair? (cdr pair))
|
|
(if (protect-expr? 'rt 'comma-expr (car pair))
|
|
(ppx/p (car pair))
|
|
(ppx (car pair)))
|
|
(sf ", "))
|
|
(else (ppx (car pair)))))
|
|
expr-list))
|
|
|
|
((udecl . ,rest)
|
|
(ppx `(decl . ,rest)))
|
|
((decl (@ . ,attr) ,decl-spec-list)
|
|
(ppx decl-spec-list) (sf ";") (comm+nl attr))
|
|
((decl (@ . ,attr) ,decl-spec-list ,init-declr-list)
|
|
(ppx decl-spec-list) (sf " ") (ppx init-declr-list) (sf ";")
|
|
(comm+nl attr))
|
|
((decl-no-newline ,decl-spec-list ,init-declr-list) ; for (int i = 0;
|
|
(ppx decl-spec-list) (sf " ") (ppx init-declr-list) (sf ";"))
|
|
|
|
((comp-decl (@ . ,attr) ,spec-qual-list (comp-declr-list . ,rest2))
|
|
(ppx spec-qual-list) (sf " ") (ppx (sx-ref tree 2)) (sf ";")
|
|
(comm+nl attr))
|
|
;; anon struct or union
|
|
((comp-decl (@ . ,attr) ,spec-qual-list)
|
|
(ppx spec-qual-list) (sf ";") (comm+nl attr))
|
|
|
|
((decl-spec-list . ,dsl)
|
|
(pair-for-each
|
|
(lambda (dsl)
|
|
(case (sx-tag (car dsl))
|
|
((stor-spec) (sf "~A" (car (sx-ref (car dsl) 1))))
|
|
((type-qual) (sf "~A" (sx-ref (car dsl) 1)))
|
|
((fctn-spec) (sf "~A" (sx-ref (car dsl) 1)))
|
|
((type-spec) (ppx (car dsl)))
|
|
(else (sf "[?:~S]" (car dsl))))
|
|
(if (pair? (cdr dsl)) (sf " ")))
|
|
dsl))
|
|
|
|
((init-declr-list . ,rest)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(ppx (car pair))
|
|
(if (pair? (cdr pair)) (sf ", ")))
|
|
rest))
|
|
((comp-declr-list . ,rest)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(ppx (car pair))
|
|
(if (pair? (cdr pair)) (sf ", ")))
|
|
rest))
|
|
|
|
((init-declr ,declr ,item2 ,item3) (ppx declr) (ppx item2) (ppx item3))
|
|
((init-declr ,declr ,item2) (ppx declr) (ppx item2))
|
|
((init-declr ,declr) (ppx declr))
|
|
((comp-declr ,declr ,item2) (ppx declr) (ppx item2))
|
|
((comp-declr ,declr) (ppx declr))
|
|
((param-declr ,declr ,item2) (ppx declr) (ppx item2))
|
|
((param-declr ,declr) (ppx declr))
|
|
|
|
((bit-field ,ident ,expr)
|
|
(ppx ident) (sf " : ") (ppx expr))
|
|
|
|
;;((type-spec ,arg)
|
|
((type-spec (@ . ,aattr) ,arg)
|
|
(case (sx-tag arg)
|
|
((fixed-type) (sf "~A" (sx-ref arg 1)))
|
|
((float-type) (sf "~A" (sx-ref arg 1)))
|
|
((struct-ref) (ppx arg))
|
|
((struct-def) (if (pair? aattr) (sf " ~S" (pp-attr aattr))) (ppx arg))
|
|
((union-ref) (ppx arg))
|
|
((union-def) (if (pair? aattr) (sf " ~S" (pp-attr aattr))) (ppx arg))
|
|
((enum-ref) (ppx arg))
|
|
((enum-def) (ppx arg))
|
|
((typename) (sf "~A" (sx-ref arg 1)))
|
|
((void) (sf "void"))
|
|
(else (error "missing " arg))))
|
|
|
|
((struct-ref (ident ,name)) (sf "struct ~A" name))
|
|
((union-ref (ident ,name)) (sf "union ~A" name))
|
|
|
|
((struct-def (@ . ,aattr) (ident ,name) (field-list . ,fields))
|
|
(struct-union-def 'struct aattr name fields))
|
|
((struct-def (@ . ,aattr) (field-list . ,fields))
|
|
(struct-union-def 'struct aattr #f fields))
|
|
((union-def (@ . ,aattr) (ident ,name) (field-list . ,fields))
|
|
(struct-union-def 'union aattr name fields))
|
|
((union-def (@ . ,aattr) (field-list . ,fields))
|
|
(struct-union-def 'union aattr #f fields))
|
|
|
|
((enum-ref (ident ,name))
|
|
(sf "enum ~A" name))
|
|
|
|
((enum-def (ident ,name) (enum-def-list . ,edl))
|
|
(sf "enum ~A " name) (ppx `(enum-def-list . ,edl))) ; SPACE ???
|
|
|
|
((enum-def (enum-def-list . ,edl))
|
|
(sf "enum ") (ppx `(enum-def-list . ,edl))) ; SPACE ???
|
|
|
|
((enum-def-list . ,defns)
|
|
(sf "{\n") (push-il)
|
|
(for-each ppx defns)
|
|
(pop-il) (sf "}"))
|
|
|
|
((enum-defn (@ . ,attr) (ident ,name) ,expr)
|
|
(sf "~A = " name) (ppx expr) (sf ",") (comm+nl attr))
|
|
((enum-defn (@ . ,attr) (ident ,name))
|
|
(sf "~A," name) (comm+nl attr))
|
|
|
|
;;((fctn-spec "inline")
|
|
((fctn-spec ,spec)
|
|
(sf "~S " spec)) ; SPACE ???
|
|
|
|
((attribute-list . ,attrs)
|
|
(sf " __attribute__((")
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(ppx (car pair))
|
|
(if (pair? (cdr pair)) (sf ",")))
|
|
attrs)
|
|
(sf "))"))
|
|
|
|
((attribute (ident ,name))
|
|
(sf "~A" name))
|
|
((attribute (ident ,name) ,attr-expr-list)
|
|
(sf "~A(" name) (ppx attr-expr-list) (sf ")"))
|
|
|
|
((attr-expr-list . ,items)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(ppx (car pair))
|
|
(if (pair? (cdr pair)) (sf ",")))
|
|
items))
|
|
|
|
((ptr-declr ,ptr ,dir-declr)
|
|
(ppx ptr) (ppx dir-declr))
|
|
|
|
((pointer) (sf "*"))
|
|
((pointer ,one) (sf "*") (ppx one))
|
|
((pointer ,one ,two) (sf "*") (ppx one) (ppx two))
|
|
|
|
((type-qual-list . ,tql) ; see decl-spec-list
|
|
(pair-for-each
|
|
(lambda (dsl)
|
|
(case (sx-tag (car dsl))
|
|
((type-qual) (sf "~A" (sx-ref (car dsl) 1)))
|
|
(else (sf "[?:~S]" (car dsl))))
|
|
(if (pair? (cdr dsl)) (sf " ")))
|
|
tql))
|
|
|
|
((array-of ,dir-declr ,arg)
|
|
(ppx dir-declr) (sf "[") (ppx arg) (sf "]"))
|
|
((array-of ,dir-declr)
|
|
(ppx dir-declr) (sf "[]"))
|
|
;; MORE TO GO
|
|
|
|
((ftn-declr ,dir-declr ,param-list)
|
|
(ppx dir-declr) (sf "(") (ppx param-list) (sf ")"))
|
|
|
|
((type-name ,spec-qual-list ,abs-declr)
|
|
(ppx spec-qual-list) (ppx abs-declr))
|
|
((type-name ,decl-spec-list)
|
|
(ppx decl-spec-list))
|
|
|
|
((abs-declr ,pointer ,dir-abs-declr) (ppx pointer) (ppx dir-abs-declr))
|
|
((abs-declr ,one-of-above) (ppx one-of-above))
|
|
|
|
;; declr-scope
|
|
((declr-scope ,abs-declr)
|
|
(sf "(") (ppx abs-declr) (sf ")"))
|
|
|
|
;; declr-array dir-abs-declr
|
|
;; declr-array dir-abs-declr assn-expr
|
|
;; declr-array dir-abs-declr type-qual-list
|
|
;; declr-array dir-abs-declr type-qual-list assn-expr
|
|
((declr-array ,dir-abs-declr)
|
|
(ppx dir-abs-declr) (sf "[]"))
|
|
((declr-array ,dir-abs-declr ,arg2)
|
|
(ppx dir-abs-declr) (sf "[") (ppx arg2) (sf "]"))
|
|
((declr-array ,dir-abs-declr ,arg2 ,arg3)
|
|
(ppx dir-abs-declr) (sf "[") (ppx arg2) (sf " ") (ppx arg3) (sf "]"))
|
|
|
|
;; declr-anon-array
|
|
;; declr-STAR
|
|
|
|
;; abs-ftn-declr
|
|
((abs-ftn-declr ,dir-abs-declr ,param-type-list)
|
|
(ppx dir-abs-declr) (sf "(") (ppx param-type-list) (sf ")"))
|
|
;; anon-ftn-declr
|
|
|
|
;; initializer
|
|
((initzer ,expr)
|
|
(sf " = ") (ppx expr))
|
|
|
|
;; initializer-list
|
|
((initzer-list . ,items)
|
|
(sf "{") ;; or "{ "
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(ppx (sx-ref (car pair) 1))
|
|
(if (pair? (cdr pair)) (sf ", ")))
|
|
items)
|
|
(sf "}")) ;; or " }"
|
|
|
|
((compd-stmt (block-item-list . ,items))
|
|
(sf "{\n") (push-il)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(let ((this (car pair)) (next (and (pair? (cdr pair)) (cadr pair))))
|
|
(ppx this)
|
|
(cond ;; add blank line if next is different or fctn defn
|
|
((not next))
|
|
((eqv? (sx-tag this) (sx-tag next)))
|
|
((eqv? (sx-tag this) 'comment))
|
|
((eqv? (sx-tag next) 'comment) (sf "\n")))))
|
|
items)
|
|
(pop-il) (sf "}\n"))
|
|
((compd-stmt-no-newline (block-item-list . ,items))
|
|
(sf "{\n") (push-il) (for-each ppx items) (pop-il) (sf "} "))
|
|
|
|
;; expression-statement
|
|
((expr-stmt) (sf ";\n")) ;; add comment?
|
|
((expr-stmt (@ . ,attr) ,expr) (ppx expr) (sf ";") (comm+nl attr))
|
|
|
|
((expr) (sf "")) ; for lone expr-stmt and return-stmt
|
|
|
|
;; selection-statement
|
|
((if . ,rest)
|
|
(let ((cond-part (sx-ref tree 1))
|
|
(then-part (sx-ref tree 2)))
|
|
(sf "if (") (ppx cond-part) (sf ") ")
|
|
(ppx then-part)
|
|
(let loop ((else-l (sx-tail tree 3)))
|
|
(cond
|
|
((null? else-l) #t)
|
|
((eqv? 'else-if (caar else-l))
|
|
(sf "else if (") (ppx (sx-ref (car else-l) 1)) (sf ") ")
|
|
(ppx (sx-ref (car else-l) 2))
|
|
(loop (cdr else-l)))
|
|
(else
|
|
(sf "else ")
|
|
(ppx (car else-l)))))))
|
|
|
|
((switch ,expr (compd-stmt (block-item-list . ,items)))
|
|
(sf "switch (") (ppx expr) (sf ") {\n")
|
|
(for-each
|
|
(lambda (item)
|
|
(unless (memq (car item) '(case default)) (push-il))
|
|
(ppx item)
|
|
(unless (memq (car item) '(case default)) (pop-il)))
|
|
items)
|
|
(sf "}\n"))
|
|
|
|
;; labeled-statement
|
|
((case ,expr ,stmt)
|
|
(sf "case ") (ppx expr) (sf ":\n")
|
|
(push-il) (ppx stmt) (pop-il))
|
|
|
|
((default ,stmt)
|
|
(sf "default:\n")
|
|
(push-il) (ppx stmt) (pop-il))
|
|
|
|
;; CHECK THIS
|
|
((while ,expr ,stmt)
|
|
(sf "while (") (ppx expr) (sf ") ") (ppx stmt)
|
|
)
|
|
|
|
;; This does not meet the convention of "} while" on same line.
|
|
((do-while ,stmt ,expr)
|
|
(sf "do ")
|
|
(if (eqv? 'compd-stmt (sx-tag stmt))
|
|
(ppx `(compd-stmt-no-newline ,(sx-ref stmt 1)))
|
|
(ppx stmt))
|
|
(sf "while (") (ppx expr) (sf ");\n"))
|
|
|
|
;; for
|
|
((for (decl . ,rest) ,test ,iter ,stmt)
|
|
(sf "for (") (ppx `(decl-no-newline . ,rest))
|
|
(sf " ") (ppx test) (sf "; ") (ppx iter) (sf ") ")
|
|
(ppx stmt))
|
|
|
|
((for (decl . ,rest) ,expr2 ,expr3 ,stmt)
|
|
(sf "for (")
|
|
(ppx `(decl . ,rest)) (sf " ") (ppx expr2) (sf "; ") (ppx expr3)
|
|
(sf ") ") (ppx stmt))
|
|
((for ,expr1 ,expr2 ,expr3 ,stmt)
|
|
(sf "for (")
|
|
(ppx expr1) (sf "; ") (ppx expr2) (sf "; ") (ppx expr3)
|
|
(sf ") ") (ppx stmt))
|
|
|
|
;; jump-statement
|
|
((goto ,where)
|
|
(pop-il) ; unindent
|
|
(sf "goto ~A;" (sx-ref where 1))
|
|
;; comment?
|
|
(sf "\n")
|
|
(push-il)) ; re-indent
|
|
|
|
((continue) (sf "continue;\n"))
|
|
((break) (sf "break;\n"))
|
|
((return ,expr) (sf "return ") (ppx expr) (sf ";\n"))
|
|
((return) (sf "return;\n"))
|
|
|
|
((trans-unit . ,items)
|
|
(pair-for-each
|
|
(lambda (pair)
|
|
(let ((this (car pair)) (next (and (pair? (cdr pair)) (cadr pair))))
|
|
(ppx this)
|
|
(cond ;; add blank line if next is different or fctn defn
|
|
((not next))
|
|
((eqv? (sx-tag this) (sx-tag next)))
|
|
((eqv? (sx-tag this) 'comment))
|
|
((eqv? (sx-tag next) 'comment) (sf "\n"))
|
|
((not (eqv? (sx-tag this) (sx-tag next))) (sf "\n"))
|
|
((eqv? (sx-tag next) 'fctn-defn) (sf "\n")))))
|
|
items))
|
|
|
|
((fctn-defn . ,rest) ;; but not yet (knr-fctn-defn)
|
|
(let* ((decl-spec-list (sx-ref tree 1))
|
|
(declr (sx-ref tree 2))
|
|
(compd-stmt (sx-ref tree 3)))
|
|
(ppx decl-spec-list)
|
|
(sf " ")
|
|
(ppx declr)
|
|
(sf " ")
|
|
(ppx compd-stmt)))
|
|
|
|
((ptr-declr . ,rest)
|
|
(ppx (sx-ref tree 1)) (ppx (sx-ref tree 2)))
|
|
|
|
((ftn-declr . ,rest)
|
|
(ppx (sx-ref tree 1)) ; direct-declarator
|
|
(sf "(") (ppx (sx-ref tree 2)) (sf ")"))
|
|
|
|
((param-list . ,params)
|
|
(pair-for-each
|
|
(lambda (pair) (ppx (car pair)) (if (pair? (cdr pair)) (sf ", ")))
|
|
params))
|
|
|
|
((ellipsis) ;; should work
|
|
(sf "..."))
|
|
|
|
((param-decl ,decl-spec-list ,param-declr)
|
|
(ppx decl-spec-list) (sf " ") (ppx param-declr))
|
|
((param-decl ,decl-spec-list)
|
|
(ppx decl-spec-list))
|
|
|
|
((cpp-stmt . ,rest)
|
|
(cpp-ppx (sx-ref tree 1)))
|
|
|
|
((extern-block ,begin ,guts ,end) (ppx begin) (ppx guts) (ppx end))
|
|
((extern-begin ,lang) (sf "extern \"~A\" {\n" lang))
|
|
((extern-end) (sf "}\n"))
|
|
|
|
(,_
|
|
(simple-format #t "\n*** pprint/ppx: NO MATCH: ~S\n" (car tree))
|
|
(pretty-print tree #:per-line-prefix " ")
|
|
)))
|
|
|
|
(if (not (pair? tree)) (error "expecing sxml tree"))
|
|
(ppx tree)
|
|
(if ugly (newline)))
|
|
|
|
;; --- last line ---
|