141 lines
3.9 KiB
Scheme
141 lines
3.9 KiB
Scheme
(import brev-separate
|
|
(chicken pretty-print)
|
|
(chicken process-context)
|
|
(chicken string)
|
|
fmt
|
|
fmt-c
|
|
getopt-long
|
|
srfi-1 ; list routines
|
|
tree)
|
|
|
|
(define (unkebabify sym)
|
|
(string->symbol
|
|
(string-translate (symbol->string sym) #\- #\_)))
|
|
|
|
(define (atom-to-fmt-c atom)
|
|
(case atom
|
|
((fn) '%fun)
|
|
((var) '%var)
|
|
((begin) '%begin)
|
|
((pointer) '%pointer)
|
|
((array) '%array)
|
|
(([]) 'vector-ref)
|
|
((include) '%include)
|
|
((cast) '%cast)
|
|
(else
|
|
(if (symbol? atom)
|
|
(unkebabify atom)
|
|
atom))))
|
|
|
|
(define (tree-finder symbol)
|
|
(lambda (node)
|
|
(or (and (tree? node)
|
|
(eq? (car node) symbol))
|
|
#f)))
|
|
|
|
(define (walk-generic form)
|
|
(let loop ((tree (tree-map atom-to-fmt-c form)))
|
|
(let ((unquote-form (tree-find (tree-finder 'unquote) tree #f)))
|
|
(if unquote-form
|
|
(let ((inv (invert-tree tree)))
|
|
(loop (tree-replace inv unquote-form (eval (cadr unquote-form)))))
|
|
tree))))
|
|
|
|
(define (walk-function form static)
|
|
(if static
|
|
(list 'static (walk-generic form))
|
|
(walk-generic (cdr form))))
|
|
|
|
(define (walk-sex-tree form)
|
|
(case (car form)
|
|
((fn) (walk-function form #t))
|
|
((pub) (walk-function form #f))
|
|
((template) '()) ; TODO
|
|
((struct) (walk-generic form))
|
|
(else (walk-generic form))))
|
|
|
|
(define (process-form form)
|
|
(case (car form)
|
|
((define)
|
|
(eval form) '())
|
|
(else
|
|
(walk-sex-tree form))))
|
|
|
|
(define (process-raw-forms raw-forms acc)
|
|
(if (null? raw-forms) (filter (fn (not (null? x)))
|
|
(reverse acc))
|
|
(process-raw-forms (cdr raw-forms)
|
|
(cons (process-form (car raw-forms))
|
|
acc))))
|
|
|
|
(define (read-forms acc)
|
|
(let ((r (read)))
|
|
(if (eof-object? r) (reverse acc)
|
|
(read-forms (cons r acc)))))
|
|
|
|
(define (emit-c forms)
|
|
(map (lambda (form)
|
|
(fmt #t (c-expr form))
|
|
(fmt #t "\n"))
|
|
forms))
|
|
|
|
;;; Main function facilities
|
|
|
|
(define opts-grammar
|
|
`((output "Write output to file"
|
|
(required #f)
|
|
(value #t)
|
|
(single-char #\o))
|
|
(help "Show this help"
|
|
(required #f)
|
|
(value #f)
|
|
(single-char #\h))
|
|
(macro-expand "Emit macro-expanded Sex code instead of C"
|
|
(required #f)
|
|
(value #f)
|
|
(single-char #\m))))
|
|
|
|
(define (print-help)
|
|
(fmt #t "Usage: sexc [OPTIONS] [FILE]\n")
|
|
(fmt #t "Options: -o, --output <file> Write output to file. If omitted, write to stdout\n")
|
|
(fmt #t " -h, --help Show this help\n")
|
|
(fmt #t " -m, --macro-expand Emit macro-expanded Sex code instead of C\n"))
|
|
|
|
(define (help-arg? args)
|
|
(assoc 'help args))
|
|
|
|
(define (get-arg args arg-name default)
|
|
(let ((arg (assoc arg-name args)))
|
|
(if arg (cdr arg)
|
|
default)))
|
|
|
|
(define (get-input-file args)
|
|
(let ((rest-args (assoc '@ args)))
|
|
(if (= 1 (length rest-args))
|
|
'stdin
|
|
(cadr rest-args))))
|
|
|
|
(define (main)
|
|
(let* ((raw-args (command-line-arguments))
|
|
(args (getopt-long raw-args
|
|
opts-grammar))
|
|
(output (get-arg args 'output 'stdout))
|
|
(help (help-arg? args))
|
|
(input (get-input-file args)))
|
|
(if help (print-help)
|
|
(let* ((raw-forms
|
|
(if (eq? input 'stdin)
|
|
(read-forms (list))
|
|
(with-input-from-file input
|
|
(lambda () (read-forms (list))))))
|
|
(sex-forms (process-raw-forms raw-forms (list))))
|
|
(if (get-arg args 'macro-expand #f)
|
|
(map pp sex-forms)
|
|
(if (not (eq? output 'stdout))
|
|
(with-output-to-file output
|
|
(lambda ()
|
|
(emit-c sex-forms)))
|
|
(emit-c sex-forms)))))))
|
|
|
|
(main)
|