mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 13:49:17 +02:00
923 lines
31 KiB
Scheme
923 lines
31 KiB
Scheme
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; additional state information
|
|
|
|
(define-syntax define-state-variables
|
|
(syntax-rules ()
|
|
((define-state-variables var ...)
|
|
(begin
|
|
(define var
|
|
(make-state-variable 'var #f #f))
|
|
...))))
|
|
|
|
(define-state-variables
|
|
expression? in-cond? in-macro? return? non-spaced-ops?
|
|
braceless-bodies? newline-before-brace? no-wrap? macro-vars
|
|
expr-writer switch-indent-space indent-space
|
|
indent default-type dot op)
|
|
|
|
(define (c-in-expr proc) (with ((expression? #t)) (c-expr proc)))
|
|
(define (c-in-stmt proc) (with ((expression? #f)) (c-expr proc)))
|
|
(define (c-in-test proc) (with ((in-cond? #t)) (c-in-expr proc)))
|
|
(define (c-with-op new-op proc) (with ((op new-op)) proc))
|
|
|
|
(define nl-str (call-with-output-string newline))
|
|
(define (make-nl-space n) (string-append nl-str (make-string n #\space)))
|
|
(define (make-space n) (make-string n #\space))
|
|
|
|
(define (call-with-output-string proc)
|
|
(let ((out (open-output-string)))
|
|
(proc out)
|
|
(let ((res (get-output-string out)))
|
|
(close-output-port out)
|
|
res)))
|
|
|
|
(define (display-to-string x)
|
|
(if (string? x)
|
|
x
|
|
(call-with-output-string (lambda (out) (display x out)))))
|
|
|
|
(define (write-to-string x)
|
|
(call-with-output-string (lambda (out) (write x out))))
|
|
|
|
(define (string-find/index str pred i)
|
|
(string-cursor->index
|
|
str
|
|
(string-find str pred (string-index->cursor str i))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; be smart about operator precedence
|
|
|
|
(define (c-op-precedence x)
|
|
(if (string? x)
|
|
(cond
|
|
((or (string=? x ".") (string=? x "->")) 10)
|
|
((or (string=? x "++") (string=? x "--")) 20)
|
|
((string=? x "|") 65)
|
|
((string=? x "||") 75)
|
|
((string=? x "|=") 85)
|
|
((or (string=? x "+=") (string=? x "-=")) 85)
|
|
(else (c-op-precedence (string->symbol x))))
|
|
(case x
|
|
((zero) 0)
|
|
;;((|::|) 5) ; C++
|
|
((paren bracket) 5)
|
|
((dot arrow post-decrement post-increment) 10)
|
|
((**) 15) ; Perl
|
|
((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ --
|
|
((=~ !~) 25) ; Perl
|
|
((* / %) 30)
|
|
((+ -) 35)
|
|
((<< >>) 40)
|
|
((< > <= >=) 45)
|
|
((lt gt le ge) 45) ; Perl
|
|
((== !=) 50)
|
|
((eq ne cmp) 50) ; Perl
|
|
((&) 55)
|
|
((^) 60)
|
|
;;((|\||) 65) ; SCSH
|
|
((&&) 70)
|
|
;;((|\|\||) 75) ; SCSH
|
|
;;((.. ...) 77) ; Perl
|
|
((? if) 80)
|
|
((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ; += -=
|
|
((comma) 90)
|
|
((=>) 90) ; Perl
|
|
((not) 92) ; Perl
|
|
((and) 93) ; Perl
|
|
((or xor) 94) ; Perl
|
|
(else 95))))
|
|
|
|
(define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y)))
|
|
(define (c-op<= x y) (<= (c-op-precedence x) (c-op-precedence y)))
|
|
|
|
(define (c-paren x)
|
|
(each "(" x ")"))
|
|
|
|
(define (c-maybe-paren x-op x)
|
|
(fn ((orig-op op))
|
|
(let ((x (with ((op x-op)) x)))
|
|
(if (c-op<= orig-op x-op)
|
|
(c-paren x)
|
|
x))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; default literals writer
|
|
|
|
(define (c-control-operator? x)
|
|
(memq x '(if while switch repeat do for fun begin)))
|
|
|
|
(define (c-literal? x)
|
|
(or (number? x) (string? x) (char? x) (boolean? x)))
|
|
|
|
(define (char->c-char c)
|
|
(string-append "'" (c-escape-char c #\') "'"))
|
|
|
|
(define (c-escape-char c quote-char)
|
|
(let ((n (char->integer c)))
|
|
(if (<= 32 n 126)
|
|
(if (or (eqv? c quote-char) (eqv? c #\\))
|
|
(string #\\ c)
|
|
(string c))
|
|
(case n
|
|
((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
|
|
((11) "\\v") ((12) "\\f") ((13) "\\r")
|
|
(else (string-append "\\x" (number->string (char->integer c) 16)))))))
|
|
|
|
(define (c-format-number x)
|
|
(if (and (integer? x) (exact? x))
|
|
(fn (radix)
|
|
(case radix
|
|
((16) (each "0x" (string-upcase-ascii (number->string x 16))))
|
|
((8) (each "0" (number->string x 8)))
|
|
(else (each (number->string x)))))
|
|
(each (number->string x))))
|
|
|
|
(define (c-format-string s)
|
|
(each "\"" (each-in-list (c-string-escaped s)) "\""))
|
|
|
|
(define (c-string-escaped s)
|
|
(let ((start (string-cursor-start s)))
|
|
(let lp ((parts '()) (i (string-cursor-end s)))
|
|
(let ((j (string-find-right s c-needs-string-escape? start i)))
|
|
(cond
|
|
((string-cursor>? j start)
|
|
(lp (cons (c-escape-char (string-cursor-ref s (string-cursor-prev s j)) #\")
|
|
(cons (substring-cursor s j i) parts))
|
|
(string-cursor-prev s j)))
|
|
(else
|
|
(cons (substring-cursor s start i) parts)))))))
|
|
|
|
(define (c-needs-string-escape? c)
|
|
(if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t))
|
|
|
|
(define (c-simple-literal x)
|
|
(c-wrap-stmt
|
|
(cond ((char? x) (each (char->c-char x)))
|
|
((boolean? x) (each (if x "1" "0")))
|
|
((number? x) (c-format-number x))
|
|
((string? x) (c-format-string x))
|
|
((null? x) (each "NULL"))
|
|
((eof-object? x) (each "EOF"))
|
|
(else (each (write-to-string x))))))
|
|
|
|
(define (c-literal x)
|
|
(fn (op in-macro? macro-vars)
|
|
(if (and in-macro? (memq x macro-vars))
|
|
(c-paren (c-simple-literal x))
|
|
(c-simple-literal x))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; default expression generator
|
|
|
|
(define (c-expr/sexp x)
|
|
(cond
|
|
((procedure? x)
|
|
x)
|
|
((pair? x)
|
|
(case (car x)
|
|
((if) (apply c-if (cdr x)))
|
|
((for) (apply c-for (cdr x)))
|
|
((while) (apply c-while (cdr x)))
|
|
((switch) (apply c-switch (cdr x)))
|
|
((case) (apply c-case (cdr x)))
|
|
((case/fallthrough) (apply c-case/fallthrough (cdr x)))
|
|
((default) (apply c-default (cdr x)))
|
|
((break) c-break)
|
|
((continue) c-continue)
|
|
((return) (apply c-return (cdr x)))
|
|
((goto) (apply c-goto (cdr x)))
|
|
((typedef) (apply c-typedef (cdr x)))
|
|
((struct union class) (apply c-struct/aux x))
|
|
((enum) (apply c-enum (cdr x)))
|
|
((inline auto restrict register volatile extern static)
|
|
(each (car x) " " (apply c-begin (cdr x))))
|
|
;; non C-keywords must have some character invalid in a C
|
|
;; identifier to avoid conflicts - by default we prefix %
|
|
((vector-ref)
|
|
(c-wrap-stmt
|
|
(each (c-expr (cadr x)) "[" (c-expr (caddr x)) "]")))
|
|
((vector-set!)
|
|
(c= (c-in-expr
|
|
(each (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
|
|
(c-expr (cadddr x))))
|
|
((extern/C) (apply c-extern/C (cdr x)))
|
|
((%apply) (apply c-apply (cdr x)))
|
|
((%define) (apply cpp-define (cdr x)))
|
|
((%include) (apply cpp-include (cdr x)))
|
|
((%fun %lambda) (apply c-fun (cdr x)))
|
|
((%cond)
|
|
(let lp ((ls (cdr x)) (res '()))
|
|
(if (null? ls)
|
|
(apply c-if (reverse res))
|
|
(lp (cdr ls)
|
|
(cons (if (pair? (cddar ls))
|
|
(apply c-begin (cdar ls))
|
|
(cadar ls))
|
|
(cons (caar ls) res))))))
|
|
((%prototype) (apply c-prototype (cdr x)))
|
|
((%var) (apply c-var (cdr x)))
|
|
((%begin) (apply c-begin (cdr x)))
|
|
((%attribute) (apply c-attribute (cdr x)))
|
|
((%line) (apply cpp-line (cdr x)))
|
|
((%pragma %error %warning)
|
|
(apply cpp-generic (substring (symbol->string (car x)) 1) (cdr x)))
|
|
((%if %ifdef %ifndef %elif)
|
|
(apply cpp-if/aux (substring (symbol->string (car x)) 1) (cdr x)))
|
|
((%endif) (apply cpp-endif (cdr x)))
|
|
((%block) (apply c-braced-block (cdr x)))
|
|
((%comment) (apply c-comment (cdr x)))
|
|
((:) (apply c-label (cdr x)))
|
|
((%cast) (apply c-cast (cdr x)))
|
|
((+ - & * / % ! ~ ^ && < > <= >= == != << >>
|
|
= *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
|
|
(apply c-op x))
|
|
((bitwise-and bit-and) (apply c-op '& (cdr x)))
|
|
((bitwise-ior bit-or) (apply c-op "|" (cdr x)))
|
|
((bitwise-xor bit-xor) (apply c-op '^ (cdr x)))
|
|
((bitwise-not bit-not) (apply c-op '~ (cdr x)))
|
|
((arithmetic-shift) (apply c-op '<< (cdr x)))
|
|
((bitwise-ior= bit-or=) (apply c-op "|=" (cdr x)))
|
|
((%and) (apply c-op "&&" (cdr x)))
|
|
((%or) (apply c-op "||" (cdr x)))
|
|
((%. %field) (apply c-op "." (cdr x)))
|
|
((%->) (apply c-op "->" (cdr x)))
|
|
(else
|
|
(cond
|
|
((eq? (car x) (string->symbol "."))
|
|
(apply c-op "." (cdr x)))
|
|
((eq? (car x) (string->symbol "->"))
|
|
(apply c-op "->" (cdr x)))
|
|
((eq? (car x) (string->symbol "++"))
|
|
(apply c-op "++" (cdr x)))
|
|
((eq? (car x) (string->symbol "--"))
|
|
(apply c-op "--" (cdr x)))
|
|
((eq? (car x) (string->symbol "+="))
|
|
(apply c-op "+=" (cdr x)))
|
|
((eq? (car x) (string->symbol "-="))
|
|
(apply c-op "-=" (cdr x)))
|
|
(else (c-apply x))))))
|
|
((vector? x)
|
|
(c-wrap-stmt
|
|
(each "{" (joined c-expr (vector->list x) ", ") "}")))
|
|
(else
|
|
(c-literal x))))
|
|
|
|
(define (try-fitted2 proc fail)
|
|
(fn (width (orig-output output))
|
|
(let ((out (open-output-string)))
|
|
(call-with-current-continuation
|
|
(lambda (abort)
|
|
;; Modify output to accumulate to an output string port,
|
|
;; and escape immediately with failure if we exceed the
|
|
;; column width.
|
|
(define (output* str)
|
|
(fn (col)
|
|
(let lp ((i 0) (col col))
|
|
(let ((nli (string-find/index str #\newline i))
|
|
(len (string-length str)))
|
|
(if (< nli len)
|
|
(if (> (+ (- nli i) col) width)
|
|
(abort fail)
|
|
(lp (+ nli 1) 0))
|
|
(let ((col (+ (- len i) col)))
|
|
(cond
|
|
((> col width)
|
|
(abort fail))
|
|
(else
|
|
(output-default str)))))))))
|
|
(forked
|
|
(with ((output output*)
|
|
(port out))
|
|
proc)
|
|
;; fitted successfully
|
|
(fn () (orig-output (get-output-string out)))))))))
|
|
|
|
(define (try-fitted proc . fail)
|
|
(let lp ((proc proc) (ls fail))
|
|
(if (null? ls)
|
|
proc
|
|
(try-fitted2 proc (lp (car ls) (cdr ls))))))
|
|
|
|
(define (c-apply ls)
|
|
(c-wrap-stmt
|
|
(with ((op 'comma))
|
|
(each
|
|
(c-expr (car ls))
|
|
(let ((flat (with ((no-wrap? #t)) (joined c-expr (cdr ls) ", "))))
|
|
(fn (no-wrap?)
|
|
(if no-wrap?
|
|
(c-paren flat)
|
|
(c-paren
|
|
(try-fitted
|
|
flat
|
|
(fn (col)
|
|
(let ((sep (string-append "," (make-nl-space col))))
|
|
(joined c-expr (cdr ls) sep))))))))))))
|
|
|
|
(define (c-expr x)
|
|
(fn (expr-writer) ((or expr-writer c-expr/sexp) x)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; comments, with Emacs-friendly escaping of nested comments
|
|
|
|
(define (make-comment-writer output)
|
|
(lambda (str)
|
|
(let ((start (string-cursor-start str))
|
|
(end (string-cursor-prev str (string-cursor-end str))))
|
|
(let lp ((i start))
|
|
(let ((j (string-find str #\/ i)))
|
|
(cond
|
|
((string-cursor>? j end)
|
|
(output (substring-cursor str i j)))
|
|
(else
|
|
(each
|
|
(cond
|
|
((and (string-cursor>? j start)
|
|
(eqv? #\* (string-cursor-ref str (string-cursor-prev str j))))
|
|
(each (output (substring-cursor str i j))
|
|
(output "\\/")))
|
|
(else
|
|
(output (substring-cursor str i (string-cursor-next str j)))))
|
|
(if (and (string-cursor<? j end)
|
|
(eqv? #\* (string-cursor-ref str (string-cursor-next str j))))
|
|
(output "\\")
|
|
nothing)
|
|
(lp (string-cursor-next str j))))))))))
|
|
|
|
(define (c-comment . args)
|
|
(each "/*" (fn ((orig-output output))
|
|
(with ((output (make-comment-writer orig-output)))
|
|
(each-in-list args)))
|
|
"*/"))
|
|
|
|
(define (make-block-comment-writer)
|
|
(lambda (str)
|
|
(fn (col (orig-output output))
|
|
(with ((output (make-comment-writer orig-output)))
|
|
(let ((end (string-cursor-end str))
|
|
(indent (string-append (make-nl-space (+ col 1)) "* ")))
|
|
(let lp ((i (string-cursor-start str)))
|
|
(let ((j (string-find str #\newline i)))
|
|
(each indent (substring-cursor str i j))
|
|
(if (string-cursor<? j end)
|
|
(lp (string-cursor-next str j))))))))))
|
|
|
|
(define (c-block-comment . args)
|
|
(fn (col (row1 row))
|
|
(let ((indent (c-indent-string col)))
|
|
(each "/* "
|
|
(with ((writer (make-block-comment-writer)))
|
|
(each-in-list args))
|
|
(fn ((row2 row))
|
|
(cond
|
|
((= row1 row2) (displayed " */"))
|
|
(else (each fl indent " */"))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; preprocessor
|
|
|
|
(define (make-cpp-writer output)
|
|
(lambda (str)
|
|
(let ((lim (string-length str)))
|
|
(let lp ((i 0))
|
|
(let ((j (string-find str #\newline i)))
|
|
(output (substring str i j))
|
|
(cond
|
|
((< j lim)
|
|
(output "\n")
|
|
(lp (+ j 1)))))))))
|
|
|
|
(define (cpp-include file)
|
|
(if (string? file)
|
|
(each fl "#include " (written file) fl)
|
|
(each fl "#include <" file ">" fl)))
|
|
|
|
(define (list-dot x)
|
|
(cond ((pair? x) (list-dot (cdr x)))
|
|
((null? x) #f)
|
|
(else x)))
|
|
|
|
(define (replace-tree from to x)
|
|
(let replace ((x x))
|
|
(cond ((eq? x from) to)
|
|
((pair? x) (cons (replace (car x)) (replace (cdr x))))
|
|
(else x))))
|
|
|
|
(define (cpp-define x . body)
|
|
(define (name-of x) (c-expr (if (pair? x) (cadr x) x)))
|
|
(fn ()
|
|
(let* ((body (cond
|
|
((and (pair? x) (list-dot x))
|
|
=> (lambda (dot)
|
|
(if (eq? dot '...)
|
|
body
|
|
(replace-tree dot '__VA_ARGS__ body))))
|
|
(else body)))
|
|
(tail
|
|
(if (pair? body)
|
|
(each " "
|
|
(fn (output)
|
|
(with ((writer (make-cpp-writer output))
|
|
(in-macro? (pair? x))
|
|
(macro-vars
|
|
(map (lambda (v) (if (pair? v) (cadr v) v))
|
|
(if (pair? x) x (list x))))
|
|
(op 'zero))
|
|
(c-in-expr (apply c-begin body)))))
|
|
"")))
|
|
(c-in-expr
|
|
(if (pair? x)
|
|
(each fl "#define " (name-of (car x))
|
|
(c-paren
|
|
(joined/dot name-of
|
|
(lambda (dot) (displayed "..."))
|
|
(cdr x)
|
|
", "))
|
|
tail fl)
|
|
(each fl "#define " (c-expr x) tail fl))))))
|
|
|
|
(define (cpp-expr x)
|
|
(if (or (symbol? x) (string? x)) (displayed x) (c-expr x)))
|
|
|
|
(define (cpp-if/aux name check . o)
|
|
(let* ((pass (and (pair? o) (car o)))
|
|
(comment
|
|
(if (member name '("ifdef" "ifndef"))
|
|
(each " "
|
|
(c-comment
|
|
" " (if (equal? name "ifndef") "! " "")
|
|
check " "))
|
|
""))
|
|
(endif (if pass (each fl "#endif" comment) ""))
|
|
(tail (cond
|
|
((and (pair? o) (pair? (cdr o)))
|
|
(if (pair? (cddr o))
|
|
(apply cpp-elif (cdr o))
|
|
(each (cpp-else) (cadr o) endif)))
|
|
(else endif))))
|
|
(fn ()
|
|
(each fl "#" name " " (cpp-expr check) fl
|
|
(or pass "")
|
|
tail fl))))
|
|
|
|
(define (cpp-if check . o)
|
|
(apply cpp-if/aux "if" check o))
|
|
(define (cpp-ifdef check . o)
|
|
(apply cpp-if/aux "ifdef" check o))
|
|
(define (cpp-ifndef check . o)
|
|
(apply cpp-if/aux "ifndef" check o))
|
|
(define (cpp-elif check . o)
|
|
(apply cpp-if/aux "elif" check o))
|
|
(define (cpp-else . o)
|
|
(each fl "#else " (if (pair? o) (c-comment (car o)) "") fl))
|
|
(define (cpp-endif . o)
|
|
(each fl "#endif " (if (pair? o) (c-comment (car o)) "") fl))
|
|
|
|
(define (cpp-wrap-header name . body)
|
|
(let ((name name)) ; consider auto-mangling
|
|
(cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl))))
|
|
|
|
(define (cpp-line num . o)
|
|
(each fl "#line " num (if (pair? o) (each " " (car o)) "") fl))
|
|
|
|
(define (cpp-generic name . ls)
|
|
(each fl "#" name (each-in-list ls) fl))
|
|
|
|
(define (cpp-undef . args) (apply cpp-generic "undef" args))
|
|
(define (cpp-pragma . args) (apply cpp-generic "pragma" args))
|
|
(define (cpp-error . args) (apply cpp-generic "error" args))
|
|
(define (cpp-warning . args) (apply cpp-generic "warning" args))
|
|
|
|
(define (cpp-stringify x)
|
|
(each "#" x))
|
|
|
|
(define (cpp-sym-cat . args)
|
|
(joined displayed args " ## "))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; general indentation and brace rules
|
|
|
|
(define (c-indent-string col . o)
|
|
(make-space (max 0 (+ col (if (pair? o) (car o) 0)))))
|
|
|
|
;; (c-indent [offset])
|
|
(define (c-indent . o)
|
|
(fn (col indent-space)
|
|
(displayed
|
|
(make-space (max 0 (+ (or indent-space 4)
|
|
(if (pair? o) (car o) 0)))))))
|
|
|
|
(define (c-indent/switch)
|
|
(fn (col switch-indent-space)
|
|
(displayed (make-space (max 0 (- (or switch-indent-space 0) col))))))
|
|
|
|
(define (c-open-brace)
|
|
(fn (col newline-before-brace?)
|
|
(if newline-before-brace?
|
|
(each nl (c-indent-string col) "{" nl)
|
|
(each " {" nl))))
|
|
|
|
(define (c-close-brace)
|
|
(displayed "}"))
|
|
|
|
(define (c-wrap-stmt x)
|
|
(fn (expression? return?)
|
|
(if expression?
|
|
(c-expr x)
|
|
(each (if return? "return " "")
|
|
(c-in-expr (c-expr x)) ";" nl))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; code blocks
|
|
|
|
(define (c-block . args)
|
|
(apply c-block/aux 0 args))
|
|
|
|
(define (c-block/aux offset header body0 . body)
|
|
(let ((inner (apply c-begin body0 body)))
|
|
(if (or (pair? body)
|
|
(not (or (c-literal? body0)
|
|
(and (pair? body0)
|
|
(not (c-control-operator? (car body0)))))))
|
|
(c-braced-block/aux offset header inner)
|
|
(fn (braceless-bodies?)
|
|
(if braceless-bodies?
|
|
(each header fl (c-indent offset) inner fl)
|
|
(c-braced-block/aux offset header inner))))))
|
|
|
|
(define (c-braced-block . args)
|
|
(fn (col) (apply c-braced-block/aux col args)))
|
|
|
|
(define (c-braced-block/aux offset header . body)
|
|
(fn ()
|
|
(each header (c-open-brace) (c-indent offset)
|
|
(apply c-begin body) fl
|
|
(c-indent-string offset)
|
|
(c-close-brace))))
|
|
|
|
(define (c-begin . args)
|
|
(apply c-begin/aux #f args))
|
|
|
|
(define (c-begin/aux ret? body0 . body)
|
|
(if (null? body)
|
|
(c-expr body0)
|
|
(fn (col expression?)
|
|
(if expression?
|
|
(with ((no-wrap? #t))
|
|
(joined c-expr (cons body0 body) ", "))
|
|
(let ((sep (each fl (c-indent-string col))))
|
|
(each
|
|
(with ((return? #f))
|
|
(joined c-expr (cons body0 (drop-right body 1)) sep))
|
|
sep
|
|
(with ((return? ret?))
|
|
(c-expr (last body)))))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; data structures
|
|
|
|
(define (c-struct/aux type x . o)
|
|
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
|
|
(body (if name (car o) x))
|
|
(o (if (null? o) o (cdr o))))
|
|
(c-wrap-stmt
|
|
(each
|
|
(c-braced-block
|
|
(each type
|
|
(if (and name (not (equal? name "")))
|
|
(each " " name)
|
|
nothing))
|
|
(each
|
|
(c-in-stmt
|
|
(if (list? body)
|
|
(apply c-begin (map c-wrap-stmt (map c-param body)))
|
|
(c-wrap-stmt (c-expr body))))))
|
|
(if (pair? o) (each " " (apply c-begin o)) nothing)))))
|
|
|
|
(define (c-struct . args) (apply c-struct/aux "struct" args))
|
|
(define (c-union . args) (apply c-struct/aux "union" args))
|
|
(define (c-class . args) (apply c-struct/aux "class" args))
|
|
|
|
(define (c-enum x . o)
|
|
(define (c-enum-one x)
|
|
(if (pair? x) (each (car x) " = " (c-expr (cadr x))) (displayed x)))
|
|
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
|
|
(vals (if name (car o) x)))
|
|
(fn (col indent-space)
|
|
(let ((sep (each ",\n" (c-indent-string (+ col (or indent-space 4))))))
|
|
(c-wrap-stmt
|
|
(each
|
|
(c-braced-block
|
|
(if name (each "enum " name) (displayed "enum"))
|
|
(joined c-enum-one vals sep))))))))
|
|
|
|
(define (c-attribute . args)
|
|
(each "__attribute__ ((" (joined c-expr args ", ") "))"))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; basic control structures
|
|
|
|
(define (c-while check . body)
|
|
(each (c-block (each "while (" (c-in-test check) ")")
|
|
(c-in-stmt (apply c-begin body)))
|
|
fl))
|
|
|
|
(define (c-for init check update . body)
|
|
(each
|
|
(c-block
|
|
(c-in-expr
|
|
(each "for (" (c-expr init) "; " (c-in-test check) "; "
|
|
(c-expr update ) ")"))
|
|
(c-in-stmt (apply c-begin body)))
|
|
fl))
|
|
|
|
(define (c-param x)
|
|
(cond
|
|
((procedure? x) x)
|
|
((pair? x) (c-type (car x) (cadr x)))
|
|
(else (fn (default-type) (c-type (or default-type 'int) x)))))
|
|
|
|
(define (c-param-list ls)
|
|
(c-in-expr (joined/dot c-param (fn (dot) (displayed "...")) ls ", ")))
|
|
|
|
(define (c-fun type name params . body)
|
|
(each (c-block (c-in-expr (c-prototype type name params))
|
|
(with ((return? (not (eq? 'void type))))
|
|
(c-in-stmt (apply c-begin body))))
|
|
fl))
|
|
|
|
(define (c-prototype type name params . o)
|
|
(c-wrap-stmt
|
|
(each (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
|
|
(joined/prefix c-expr o " "))))
|
|
|
|
(define (c-static x) (each "static " (c-expr x)))
|
|
(define (c-const x) (each "const " (c-expr x)))
|
|
(define (c-restrict x) (each "restrict " (c-expr x)))
|
|
(define (c-volatile x) (each "volatile " (c-expr x)))
|
|
(define (c-auto x) (each "auto " (c-expr x)))
|
|
(define (c-inline x) (each "inline " (c-expr x)))
|
|
(define (c-extern x) (each "extern " (c-expr x)))
|
|
(define (c-extern/C . body)
|
|
(each "extern \"C\" {" nl (apply c-begin body) nl "}" nl))
|
|
|
|
(define (c-type type . o)
|
|
(let ((name (and (pair? o) (car o))))
|
|
(cond
|
|
((pair? type)
|
|
(case (car type)
|
|
((%fun)
|
|
(each (c-type (cadr type) #f)
|
|
" (*" (or name "") ")("
|
|
(joined (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
|
|
((%array)
|
|
(let ((name (each name "[" (if (pair? (cddr type))
|
|
(c-expr (caddr type))
|
|
"")
|
|
"]")))
|
|
(c-type (cadr type) name)))
|
|
((%pointer *)
|
|
(let ((name (each "*" (if name (c-expr name) ""))))
|
|
(c-type (cadr type)
|
|
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
|
|
(c-paren name)
|
|
name))))
|
|
((enum) (apply c-enum name (cdr type)))
|
|
((struct union class)
|
|
(each (apply c-struct/aux (car type) (cdr type)) " " name))
|
|
(else (joined/last c-expr (lambda (x) (c-type x name)) type " "))))
|
|
((not type)
|
|
(fn (default-type) (c-type (or default-type 'int) name)))
|
|
(else
|
|
(each (if (eq? '%pointer type) '* type) (if name (each " " name) ""))))))
|
|
|
|
(define (c-var type name . init)
|
|
(c-wrap-stmt
|
|
(if (pair? init)
|
|
(each (c-type type name) " = " (c-expr (car init)))
|
|
(c-type type (if (pair? name)
|
|
(joined c-expr name ", ")
|
|
(c-expr name))))))
|
|
|
|
(define (c-cast type expr)
|
|
(each "(" (c-type type) ")" (c-expr expr)))
|
|
|
|
(define (c-typedef type alias . o)
|
|
(c-wrap-stmt
|
|
(each "typedef " (c-type type alias) (joined/prefix c-expr o " "))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Generalized IF: allows multiple tail forms for if/else if/.../else
|
|
;; blocks. A final ELSE can be signified with a test of #t or 'else,
|
|
;; or by simply using an odd number of expressions (by which the
|
|
;; normal 2 or 3 clause IF forms are special cases).
|
|
|
|
(define (c-if/stmt c p . rest)
|
|
(fn (col)
|
|
(let lp ((c c) (p p) (ls rest))
|
|
(if (or (eq? c 'else) (eq? c #t))
|
|
(if (not (null? ls))
|
|
(error "forms after else clause in IF" c p ls)
|
|
(each (c-block/aux col " else" p) fl))
|
|
(let ((tail (if (pair? ls)
|
|
(if (pair? (cdr ls))
|
|
(lp (car ls) (cadr ls) (cddr ls))
|
|
(lp 'else (car ls) '()))
|
|
fl)))
|
|
(each (c-block/aux
|
|
col
|
|
(each (if (eq? ls rest) nothing " else ")
|
|
"if (" (c-in-test (c-expr c)) ")")
|
|
p)
|
|
tail))))))
|
|
|
|
(define (c-if/expr c p . rest)
|
|
(let lp ((c c) (p p) (ls rest))
|
|
(cond
|
|
((or (eq? c 'else) (eq? c #t))
|
|
(if (not (null? ls))
|
|
(error "forms after else clause in IF" c p ls)
|
|
(c-expr p)))
|
|
((pair? ls)
|
|
(c-maybe-paren
|
|
'?
|
|
(with ((op '?))
|
|
(c-in-test (c-expr c))
|
|
" ? " (c-expr p) " : "
|
|
(if (pair? (cdr ls))
|
|
(lp (car ls) (cadr ls) (cddr ls))
|
|
(lp 'else (car ls) '())))))
|
|
(else
|
|
(c-or (c-in-test (c-expr c)) (c-expr p))))))
|
|
|
|
(define (c-if . args)
|
|
(fn (expression?)
|
|
(if expression?
|
|
(apply c-if/expr args)
|
|
(apply c-if/stmt args))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; switch statements, automatic break handling
|
|
|
|
(define (c-label name)
|
|
(fn (col)
|
|
(let ((indent (make-space (max 0 (- col 2)))))
|
|
(each fl indent name ":" fl))))
|
|
|
|
(define c-break
|
|
(c-wrap-stmt (displayed "break")))
|
|
(define c-continue
|
|
(c-wrap-stmt (displayed "continue")))
|
|
(define (c-return . result)
|
|
(if (pair? result)
|
|
(c-wrap-stmt (each "return " (c-expr (car result))))
|
|
(c-wrap-stmt (displayed "return"))))
|
|
(define (c-goto label)
|
|
(c-wrap-stmt (each "goto " (c-expr label))))
|
|
|
|
(define (c-switch val . clauses)
|
|
(fn (col)
|
|
(let ((sep (each fl (c-indent-string col))))
|
|
(each "switch (" (c-in-expr val) ")" (c-open-brace)
|
|
(c-indent/switch)
|
|
sep
|
|
(joined c-in-stmt
|
|
(map (lambda (x) (c-switch-clause x col))
|
|
clauses)
|
|
sep)
|
|
sep (c-close-brace) fl))))
|
|
|
|
(define (c-switch-clause/breaks x . o)
|
|
(fn (col indent indent-space return?)
|
|
(let* ((col (if (pair? o) (car o) col))
|
|
(break?
|
|
(and (car x)
|
|
(not (member (cadr x) '(case/fallthrough
|
|
default/fallthrough
|
|
else/fallthrough)))))
|
|
(explicit-case? (member (cadr x) '(case case/fallthrough)))
|
|
(indent-body (c-indent-string (+ col (or indent 4))))
|
|
(indent (c-indent-string col))
|
|
(sep (string-append ":" nl-str indent)))
|
|
(each (c-in-expr
|
|
(joined/suffix
|
|
displayed
|
|
(cond
|
|
((or explicit-case? (pair? (cadr x)))
|
|
(map (lambda (y) (each "case " (c-expr y)))
|
|
(if explicit-case?
|
|
(if (list? (third x))
|
|
(third x)
|
|
(list (third x)))
|
|
(cadr x))))
|
|
(else
|
|
(list (each "default"))))
|
|
sep))
|
|
(make-space (or indent-space 4))
|
|
(joined c-expr
|
|
(if explicit-case? (cdr (cddr x)) (cddr x))
|
|
indent-body)
|
|
(if (and break? (not return?))
|
|
(each fl indent-body c-break)
|
|
"")))))
|
|
|
|
(define (c-switch-clause x . o)
|
|
(if (procedure? x) x (apply c-switch-clause/breaks (cons #t x) o)))
|
|
(define (c-switch-clause/no-break x . o)
|
|
(if (procedure? x) x (apply c-switch-clause/breaks (cons #f x) o)))
|
|
|
|
(define (c-case x . body)
|
|
(c-switch-clause (cons (if (pair? x) x (list x)) body)))
|
|
(define (c-case/fallthrough x . body)
|
|
(c-switch-clause/no-break (cons (if (pair? x) x (list x)) body)))
|
|
(define (c-default . body)
|
|
(c-switch-clause/breaks (cons #t (cons 'else body))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; operators
|
|
|
|
(define (c-op op first . rest)
|
|
(if (null? rest)
|
|
(c-unary-op op first)
|
|
(apply c-binary-op op first rest)))
|
|
|
|
(define (c-binary-op op . ls)
|
|
(define (lit-op? x) (or (c-literal? x) (symbol? x)))
|
|
(let ((str (display-to-string op)))
|
|
(c-wrap-stmt
|
|
(c-maybe-paren
|
|
op
|
|
(if (or (equal? str ".") (equal? str "->"))
|
|
(joined c-expr ls str)
|
|
(let ((flat
|
|
(with ((no-wrap? #t))
|
|
(fn (non-spaced-ops?)
|
|
(joined c-expr
|
|
ls
|
|
(if (and non-spaced-ops?
|
|
(every lit-op? ls))
|
|
str
|
|
(string-append " " str " ")))))))
|
|
(fn (no-wrap?)
|
|
(if no-wrap?
|
|
flat
|
|
(try-fitted
|
|
flat
|
|
(fn (col)
|
|
(joined c-expr
|
|
ls
|
|
(each nl (make-space (+ 2 col)) str " ")
|
|
)))))))))))
|
|
|
|
(define (c-unary-op op x)
|
|
(c-wrap-stmt
|
|
(each (display-to-string op) (c-maybe-paren op (c-expr x)))))
|
|
|
|
;; some convenience definitions
|
|
|
|
(define (c++ . args) (apply c-op "++" args))
|
|
(define (c-- . args) (apply c-op "--" args))
|
|
(define (c+ . args) (apply c-op '+ args))
|
|
(define (c- . args) (apply c-op '- args))
|
|
(define (c* . args) (apply c-op '* args))
|
|
(define (c/ . args) (apply c-op '/ args))
|
|
(define (c% . args) (apply c-op '% args))
|
|
(define (c& . args) (apply c-op '& args))
|
|
;; (define (|c\|| . args) (apply c-op '|\|| args))
|
|
(define (c^ . args) (apply c-op '^ args))
|
|
(define (c~ . args) (apply c-op '~ args))
|
|
(define (c! . args) (apply c-op '! args))
|
|
(define (c&& . args) (apply c-op '&& args))
|
|
;; (define (|c\|\|| . args) (apply c-op '|\|\|| args))
|
|
(define (c<< . args) (apply c-op '<< args))
|
|
(define (c>> . args) (apply c-op '>> args))
|
|
(define (c== . args) (apply c-op '== args))
|
|
(define (c!= . args) (apply c-op '!= args))
|
|
(define (c< . args) (apply c-op '< args))
|
|
(define (c> . args) (apply c-op '> args))
|
|
(define (c<= . args) (apply c-op '<= args))
|
|
(define (c>= . args) (apply c-op '>= args))
|
|
(define (c= . args) (apply c-op '= args))
|
|
(define (c+= . args) (apply c-op "+=" args))
|
|
(define (c-= . args) (apply c-op "-=" args))
|
|
(define (c*= . args) (apply c-op '*= args))
|
|
(define (c/= . args) (apply c-op '/= args))
|
|
(define (c%= . args) (apply c-op '%= args))
|
|
(define (c&= . args) (apply c-op '&= args))
|
|
;; (define (|c\|=| . args) (apply c-op '|\|=| args))
|
|
(define (c^= . args) (apply c-op '^= args))
|
|
(define (c<<= . args) (apply c-op '<<= args))
|
|
(define (c>>= . args) (apply c-op '>>= args))
|
|
|
|
(define (c. . args) (apply c-op "." args))
|
|
(define (c-> . args) (apply c-op "->" args))
|
|
|
|
(define (c-bit-or . args) (apply c-op "|" args))
|
|
(define (c-or . args) (apply c-op "||" args))
|
|
(define (c-bit-or= . args) (apply c-op "|=" args))
|
|
|
|
(define (c++/post x)
|
|
(each (c-maybe-paren 'post-increment (c-expr x)) "++"))
|
|
(define (c--/post x)
|
|
(each (c-maybe-paren 'post-decrement (c-expr x)) "--"))
|