; [ʞ] sexpc.scm - sexp→c converter
; ~ lexi hale <lexi@hale>
; © GNU Affero GPL v3
; $ chicken-csc -O5 sexpc.scm; strip sexpc
; > ./sexpc <file>
; ? a tool to convert sheets of s-expressions into
; valid C, enabling the use of Scheme as a
; preprocessor language. it also generates C type
; definitions from a human-readable syntax,
; removing the difficulties introduced by C's
; legendarily inscrutable compound type syntax:
; e.g. (def r (array (const (ptr (char u128 ->
; (ptr (array 5 bool))))))),
; which represents an array of const pointers to
; functions taking a char and a 128-bit integer,
; and returning a pointer to an array of five bools.
; this emits the C type:
; _Bool (((*(*const (((v)[])))(char, unsigned
; __int128_t)))[5])
; (as i'm sure you immediately guessed)
;
; → no dependencies besides the lisp-macro.scm file
; bundled with it, and the chicken stdlib.
(import (chicken process-context))
(import (chicken condition))
(import (chicken pretty-print))
(import (chicken io))
(include "../scmlib/lisp-macro.scm")
(define (first fst . lst) fst)
(: string-reduce (list --> string))
(: words->string (list --> string))
(: separate (string list --> string))
(define (string-reduce lst) (foldl string-append "" lst))
(define (words->string lst) (foldl (lambda (a b) (string-append a " " b)) "" lst))
(define (separate delim lst) (foldl (lambda (a b)
(cond ((equal? a "") b)
((equal? b "") a)
(else (string-append a delim b)))) "" lst))
(: ensure-string ((or string symbol) -> string))
(define (ensure-string s) (if (string? s) s (if (symbol? s) (symbol->string s)
(abort '(exn bad-string-or-symbol)))))
(define (handle fn)
(define (err text) (string-append "\x1b[1;31m(fatal) \x1b[m" text))
(condition-case (fn)
[(exn file) (display (err "could not open file"))]
[var () (display (err "an unknown error occurred"))]))
(define (make-evaluator)
(let ((*eval-env* (interaction-environment)))
(lambda (lst) (eval lst *eval-env*))))
(define evaluate-list (make-evaluator))
(define (c-def-function body) "<FUNC>")
(define (c-declare body)
(cond ((>= (length body) 3)
(let ([fn-name (list-ref body 0)]
[fn-return (list-ref body 1)]
[fn-args (list-tail body 2)])
(c-function-decl fn-return fn-name fn-args)))
((eqv? (length body) 2) ((eval-type (cadr body)) (car body)))
(else (abort '(exn syntax declare)))))
(define (c-define body)
(cond
((and (list? (car body)) (>= (length body) 2))
(let ([contents (words->string (map (lambda(x) (eval-code #f x)) (cdr body)))])
(string-append (c-declare (car body))
(if (>= (length (car body)) 3) (string-append " {" contents "}")
(string-append " = " contents)))))
(else (abort '(exn syntax define)))))
(: c-call-function (list -> string))
(define (c-call-function body)
(unless (> (length body) 0) (abort '(exn parse call)))
(string-append
(eval-code #t (car body)) "(" (separate "," (map (lambda(x) (eval-code #t x)) (cdr body))) ")"))
(: c-array-index (list -> string))
(define (c-array-index body)
(unless (= (length body) 2) (abort '(exn parse call)))
(string-append
(eval-code #t (car body))
"[" (eval-code #t (cadr body)) "]"))
(: c-conditional (list -> string))
(define (c-conditional body)
(unless (> (length body) 0) (abort '(exn parse cond)))
(define (mk-block acc code)
(string-append
(if (eq? 'else (car code)) (string-append acc "else {")
(string-append acc
(if (equal? acc "") "if (" " else if (")
(eval-code #t (car code)) ") {"))
(string-reduce (map (lambda(x)(eval-code #f x)) (cdr code)))
"}"
))
(foldl mk-block "" body))
(define (c-cpp-include body)
(case (length body)
((1) (if (string? (car body)) (string-append "#include \"" (car body) "\"\n")
(abort '(exn syntax include))))
((2) (if (and (eqv? (car body) 'sys)
(string? (cadr body))) (string-append "#include <" (cadr body) ">\n")
(abort '(exn syntax include sys))))
(else (abort '(exn syntax include)))))
(define (and* . body)
(if (null? body) #t
(if (eq? #f (car body)) #f
(apply and* (cdr body)))))
(: c-function-decl (symbol
symbol
(list-of (or null
string
(pair (or symbol
(list-of symbol)) symbol))) -> string))
(define (c-function-decl ret name args)
(define (parse-arg a)
(cond ((null? a) "void")
((string? a) a)
((symbol? a) ((eval-type a)""))
((and (list? a) (= (length a) 2)) ((eval-type (cadr a)) (car a)))
((list? a) ((eval-type a)""))
(else (abort '(exn syntax function-declare argument)))))
(let ([arg-str (separate ", " (map parse-arg args))]
[ret-fn (eval-type ret)])
(ret-fn (string-append (ensure-string name) "(" arg-str ")"))))
(: c-statement (string -> string))
(define (c-statement s) (string-append s ";"))
(: eval-type ((or null symbol list) -> ((or symbol string) -> string)))
(define (eval-type t)
; a type object is a function that is called with a name to
; generate a definition. this is necessary for the case of
; arrays and function pointers, which require special syntax
(: simple ((or string symbol) --> string))
(define (simple x) (lambda (n) (if (equal? "" n) x (string-append x " " (ensure-string n)))))
(define (wrap ty name inner) (lambda (n)
(string-append (car ty) ((eval-type inner)
(string-append (cdr ty) (car name) (ensure-string n) (cdr name))))))
(define (parse-function-def t)
(if (>= (length t) 3) ; function def?)
(let ([arrow (list-ref t (- (length t) 2))])
(if (or (eqv? arrow '->) (eqv? arrow '→) (eqv? arrow '=>)) ; function def!
(let* ([args (butlast (butlast t))] ; rrrrrrgh
[ret (list-ref t (- (length t) 1))]
[arg-map (map (lambda (x) ((eval-type x)"")) args)])
(lambda (n) (c-function-decl ret n arg-map)))
#f))
#f))
(define (parse-type t)
(or (parse-function-def t)
; not a function
(case (car t)
('ptr (wrap '["".""] '["(*".")"] (cadr t)))
('ref (wrap '["".""] '["(&".")"] (cadr t))) ; for C++ support
('const (wrap '["".""] '["const (".")"] (cadr t)))
('struct (wrap '["struct ".""] '["".""] (cadr t)))
('enum (wrap '["enum ".""] '["".""] (cadr t)))
('volatile (wrap '["".""] '["volatile(".")"] (cadr t)))
('onlyptr (wrap '["".""] '["(*restrict ".")"] (cadr t)))
('static (wrap '["".""] '["static ".""] (cadr t)))
('array (if (null? (cddr t)) (wrap '["".""] '["((".")[])"]
(cadr t))
(wrap '["".""] [cons "((" (string-append ")[" (eval-code #t (cadr t)) "])" )]
(caddr t))))
(else (abort '(exn syntax))))))
(cond
((null? t) (simple "void"))
((symbol? t) (case t
('bool (simple "_Bool"))
('uchar (simple "unsigned char"))
('schar (simple "signed char"))
('ushort (simple "unsigned short"))
('uint (simple "unsigned int"))
('ulong (simple "unsigned long"))
('ullong (simple "unsigned long long"))
('llong (simple "long long"))
('ldouble (simple "long double"))
('u128 (simple "unsigned __int128_t"))
('s128 (simple "__int128_t"))
('ptr (simple "void*"))
(else (simple (symbol->string t)))))
((list? t) (parse-type t))
((string? t) (simple t))
(else (abort '(exn syntax)))))
(define (c-construct type name body)
(string-append type " " name " {"
(string-reduce (map (lambda(x) (eval-code #f x)) body))
"}"))
(define (c-fn-return body)
(string-append "return " (string-reduce (map (lambda(x) (eval-code #t x)) body))))
(define (c-binary-op op body)
(unless (= 2 (length body)) (abort '(exn syntax binary-op)))
(string-append "((" (eval-code #t (car body)) ")" op "(" (eval-code #t (cadr body)) "))"))
(define (c-unary-op op body)
(unless (= 1 (length body)) (abort '(exn syntax unary-op)))
(string-append "(" op "(" (eval-code #t (car body)) "))"))
(define (c-typecast body)
(unless (= 2 (length body)) (abort '(exn syntax binary-op)))
(string-append "((" ((eval-type (car body))"") ")" (eval-code #t (cadr body)) ")"))
(define (wiretap s x) (print* "-- " s ": ") (pretty-print x) x)
(: eval-code (boolean list -> string))
(define (eval-code inexpr data)
(define (ctx x) inexpr (if (eq? inexpr #t) x (c-statement x)))
(: dispatch (list -> string))
(define (dispatch form body)
(case form
('* (eval-code inexpr (evaluate-list body)))
('= (eval-code inexpr (evaluate-list (cons 'begin body))))
('@ (eval (cons 'begin body)) "")
('use (c-cpp-include body))
('def (first (c-statement (c-define body))) )
('decl (first (c-statement (c-declare body)) ))
('call (ctx (c-call-function body)))
('cond (c-statement (c-conditional body)))
('list (first (string-append "{" (separate "," (map (lambda(x) (eval-code #t x)) body)) "}") ))
('struct (first (ctx (c-construct "struct" (car form) (cdr form))) ))
('enum (first (ctx (c-construct "enum" (car form) (cdr form))) ))
('ret (c-statement (c-fn-return body)))
('cast (c-typecast body))
('idx (c-array-index body))
('add (c-binary-op "+" body))
('add-> (ctx (c-binary-op "+=" body)))
('sub (c-binary-op "-" body))
('sub-> (ctx (c-binary-op "-=" body)))
('mul (c-binary-op "*" body))
('mul-> (ctx (c-binary-op "*=" body)))
('div (c-binary-op "/" body))
('div-> (ctx (c-binary-op "/=" body)))
('ref (c-unary-op "&" body))
('eq (c-binary-op "==" body))
('neq (c-binary-op "!=" body))
('gte (c-binary-op ">=" body))
('lte (c-binary-op "<=" body))
('lt (c-binary-op "<" body))
('gt (c-binary-op ">" body))
('-> (ctx (c-binary-op "=" body)))
('→ (ctx (c-binary-op "=" body)))
('; ";")
(else (string-append "<UNFOUND FORM " (symbol->string form) ">"))
)))
(cond
((null? data) "")
((symbol? data) (symbol->string data))
((string? data) (string-append "\"" data "\""))
((char? data) (apply string (list #\' data #\')))
((number? data) (number->string data))
((list? data) (let ([form (car data)]
[body (cdr data)])
(dispatch form body)))
(else (abort '(exn syntax)))))
(define (parse-code file) (map (lambda(x) (eval-code #f x)) file))
(define (compile filename)
(let ([file (if (equal? filename "-") (read-list)
(handle (lambda()
(call-with-input-file filename read-list))))])
(string-reduce (parse-code file))))
(: usage (--> string))
(define (usage) "usage: sexpc <file>")
(define (cull-args args switches params)
(define (parse-switch switch)
(cond
((equal? switch "-") "-")
((eqv? (string-ref switch 1) #\-) (substring switch 2))
(else (map string (string->list (substring switch 1))))))
(define (is-switch arg)
(eqv? (string-ref arg 0) #\-))
(define (split p)
(cons (flatten (map parse-switch switches)) p))
(let* ([hd (if (null? args) '() (car args))]
[tl (if (null? hd) '() (cdr args))])
(cond
((null? args) (split params))
((equal? "--" hd) (split (append params tl)))
((is-switch hd) (cull-args tl (cons hd switches) params))
(else (cull-args tl switches
(cons hd params))))))
(define (main args)
(let* ([switches-and-params (cull-args args '() '())]
[switches (car switches-and-params)]
[params (cdr switches-and-params)])
(cond
((null? params) (usage))
((eqv? (length params) 1) (compile (car params)))
(else (usage)))))
(cond-expand (csi) (else (display (main (command-line-arguments)))))