Compiler enhancements #2
18
Makefile
18
Makefile
@@ -1,19 +1,23 @@
|
||||
CHICKEN_C = csc
|
||||
|
||||
MODULES = sexc templates main
|
||||
MODULES = sexc modules templates utils fmt-c
|
||||
OBJ = $(MODULES:%=%.o)
|
||||
|
||||
# chicken flags
|
||||
CFLAGS = -compile-syntax
|
||||
|
||||
sexc: $(OBJ)
|
||||
sexc: main.o $(OBJ)
|
||||
$(CHICKEN_C) $^ -o $@
|
||||
|
||||
main.o: main.scm
|
||||
$(CHICKEN_C) $< -c -o $@
|
||||
|
||||
templates.o: templates.scm
|
||||
$(CHICKEN_C) $< -c -o $@ -compile-syntax
|
||||
|
||||
%.o: %.scm
|
||||
$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
|
||||
$(CHICKEN_C) $< -e -c -o $@
|
||||
|
||||
sex-tests: $(OBJ) tests/run.scm
|
||||
$(CHICKEN_C) tests/run.scm -c -o sex-tests.o
|
||||
$(CHICKEN_C) $(OBJ) sex-tests.o -o sex-tests
|
||||
|
||||
clean:
|
||||
rm -f $(OBJ) sexc
|
||||
rm -f $(OBJ) sexc sex-tests main.o sex-test.o
|
||||
|
||||
88
Readme.org
88
Readme.org
@@ -6,7 +6,7 @@ computations are written in Chicken.
|
||||
|
||||
And Chicken is [[https://call-cc.org][R5RS Scheme]].
|
||||
|
||||
* Compilation and usage
|
||||
* Compilation
|
||||
First, get yourself a Chicken. Second, some Chicken deps.
|
||||
|
||||
** Install Chicken Eggs
|
||||
@@ -14,53 +14,58 @@ By the way, there's a way to make Chicken install eggs non-globally. Refer to
|
||||
the documentation for more info:
|
||||
https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
|
||||
|
||||
~chicken-install fmt getopt-long brev-separate~
|
||||
~chicken-install fmt getopt-long brev-separate test tree srfi-1 srfi-13~
|
||||
|
||||
** Compilation
|
||||
~make~
|
||||
|
||||
** Usage
|
||||
You'll also need a C compiler, so pick any.
|
||||
* Usage
|
||||
** Summary
|
||||
#+begin_src
|
||||
cat hello-world.sex | sexc > hello_world.c
|
||||
cc hello_world.c -o hello_world
|
||||
Usage: sexc [options] filename [-- options-for-c-compiler]
|
||||
Options:
|
||||
--c-compiler=ARG Select C compiler. Defaults to value of SEX_CC
|
||||
environment variable, or if it is empty, to cc
|
||||
-c, --compile-object Compile object file instead of executable program
|
||||
-E, --preprocess Emit C code
|
||||
--public-interface Get module's public interface
|
||||
-h, --help Show this help
|
||||
-m, --macro-expand Emit macro-expanded Sex code
|
||||
-o, --output=ARG Write output to file. Default file name is a.out.
|
||||
If -E or -m options are provided, defaults to stdout
|
||||
#+end_src
|
||||
** Compiling Hello World
|
||||
#+begin_src
|
||||
sexc ./examples/hell-world.sex -o hello
|
||||
#+end_src
|
||||
|
||||
* Example
|
||||
Here is an example, demonstrating what Sex source looks like, and what
|
||||
it compiles too. An avid reader also shall notice how we call Chicken
|
||||
procedures in Sex source.
|
||||
That's it. Now you should have executable named ~hello~ in your
|
||||
directory. Sex uses C under the hood, the default C compiler is ~cc~,
|
||||
but you can pass any using ~--c-compiler~ option, or by setting
|
||||
~SEX_CC~ environment variable.
|
||||
|
||||
The Sex source:
|
||||
** Example
|
||||
An example of Sex source:
|
||||
#+begin_src
|
||||
(include stdio.h)
|
||||
|
||||
(define (foo)
|
||||
"Hello from Chicken code!\n")
|
||||
|
||||
(pub fn int main ((int argc) (char **argv))
|
||||
(puts "Hello from Sex!")
|
||||
(var (array char 512) name)
|
||||
(puts "What is your name?")
|
||||
(scanf "%s" &name)
|
||||
(scanf "%s" (cast char* &name))
|
||||
(printf "Hello, %s!\n" name)
|
||||
(printf ,(foo))
|
||||
0)
|
||||
#+end_src
|
||||
|
||||
The resulting C source:
|
||||
Compile and run:
|
||||
#+begin_src
|
||||
#include <stdio.h>
|
||||
|
||||
int main (int argc, char **argv) {
|
||||
puts("Hello from Sex!");
|
||||
char name[512];
|
||||
puts("What is your name?");
|
||||
scanf("%s", &name);
|
||||
printf("Hello, %s!\n", name);
|
||||
printf("Hello from Chicken code!\n");
|
||||
return 0;
|
||||
}
|
||||
~/dev/sex $ ./sexc ./example/hello-world.sex -o hello-world
|
||||
~/dev/sex $ ./hello-world
|
||||
Hello from Sex!
|
||||
What is your name?
|
||||
Alex
|
||||
Hello, Alex!
|
||||
#+end_src
|
||||
|
||||
* Features
|
||||
@@ -68,33 +73,28 @@ int main (int argc, char **argv) {
|
||||
Just ~(include "Your/Favourite/Library.h")~ and use it as you would
|
||||
have is C.
|
||||
|
||||
** Auto unkebabification
|
||||
For hardcore fans of traditional Lisp naming convention,
|
||||
Sex offers automatic unkebabification of all symbols, i.e. no more
|
||||
ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
|
||||
proper form: ~GL-ARRAY-BUFFER~.
|
||||
|
||||
** Auto typedef for structs
|
||||
Probably harmless idk. Example:
|
||||
#+begin_src
|
||||
(struct foo
|
||||
((float a)
|
||||
(int b)))
|
||||
#+end_src
|
||||
expands to
|
||||
#+begin_src
|
||||
typedef struct foo foo;
|
||||
** Modules
|
||||
Each source file is a module. Module can provide public interface and
|
||||
be imported by using ~(import path/to/module)~ expression. Module
|
||||
search path consists of two parts: first is relative to the source
|
||||
being compiled location, and the second is ~SEX_MODULE_PATH~
|
||||
environment variable.
|
||||
|
||||
struct foo {
|
||||
float a;
|
||||
int b;
|
||||
};
|
||||
#+end_src
|
||||
Module's public interface consists of everything declared
|
||||
~pub~. Structures, function, templates, types, variables can be
|
||||
public.
|
||||
|
||||
** Syntactic templates
|
||||
Sex has support for template substitutions. Any piece of code can be
|
||||
templated. Template declarations look like functions: they have a
|
||||
name, an argument list and a body. When declared template is
|
||||
encountered during reading of Sex code, its body will udergo syntactic
|
||||
encountered during reading of Sex code, its body will undergo syntactic
|
||||
rewriting using the provided values by the following rules:
|
||||
1. If the value is a symbol, all arguments in a body are replaced with
|
||||
the value, and also all /parts/ of any other symbol equal to the
|
||||
|
||||
9
example/hello-world.sex
Normal file
9
example/hello-world.sex
Normal file
@@ -0,0 +1,9 @@
|
||||
(include stdio.h)
|
||||
|
||||
(pub fn int main ((int argc) (char **argv))
|
||||
(puts "Hello from Sex!")
|
||||
(var (array char 512) name)
|
||||
(puts "What is your name?")
|
||||
(scanf "%s" (cast char* &name))
|
||||
(printf "Hello, %s!\n" name)
|
||||
(return 0))
|
||||
@@ -1,36 +0,0 @@
|
||||
(template (list-T ?T)
|
||||
(struct list-?T
|
||||
((?T value)
|
||||
((* list-?T) next))))
|
||||
|
||||
(template (make-list-T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn (* list-?T) make-list-?T ()
|
||||
(var (* list-?T) list (cast (* list-?T) (malloc (sizeof list-?T))))
|
||||
(= (-> list next) NULL)
|
||||
list))
|
||||
|
||||
(template (add-value-list-?T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn void add-value-list-?T ((list-?T *list) (T value))
|
||||
(while (!= (-> list next) NULL)
|
||||
(= list (-> list next)))
|
||||
(= (-> list next) (make-list-?T))
|
||||
(= (-> list value) value)))
|
||||
|
||||
(template (length-list-?T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn size-t length-list-?T ((list-?T *list))
|
||||
(var size-t n 0)
|
||||
(while (!= (-> list next) NULL)
|
||||
(= list (-> list next))
|
||||
(++ n))
|
||||
n))
|
||||
|
||||
(template (is-empty-list-?T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn bool is-empty-list-?T ((list-?T *list))
|
||||
(== (-> list next) NULL)))
|
||||
|
||||
(template (list-for-each list-var elt-var what-do)
|
||||
(var int elt-var (-> list-var value))
|
||||
(while (!= (-> list-var next) NULL)
|
||||
what-do
|
||||
(= list-var (-> list-var next))
|
||||
(= elt-var (-> list-var value))))
|
||||
37
example/list.sex
Normal file
37
example/list.sex
Normal file
@@ -0,0 +1,37 @@
|
||||
(pub template (list-T ?T)
|
||||
(struct list-?T
|
||||
((?T value)
|
||||
((* list-?T) next))))
|
||||
|
||||
(pub template (make-list-T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn (* list-?T) make-list-?T ()
|
||||
(var (* list-?T) list (cast (* list-?T) (malloc (sizeof list-?T))))
|
||||
(= (-> list next) NULL)
|
||||
list))
|
||||
|
||||
(pub template (add-value-list-T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn void add-value-list-?T ((list-?T *list) (?T value))
|
||||
(while (!= (-> list next) NULL)
|
||||
(= list (-> list next)))
|
||||
(= (-> list next) (make-list-?T))
|
||||
(= (-> list value) value)))
|
||||
|
||||
(pub template (length-list-T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn size-t length-list-?T ((list-?T *list))
|
||||
(var size-t n 0)
|
||||
(while (!= (-> list next) NULL)
|
||||
(= list (-> list next))
|
||||
(++ n))
|
||||
n))
|
||||
|
||||
(pub template (is-empty-list-T ?T is-public?)
|
||||
(,@(if 'is-public? '(pub) '()) fn bool is-empty-list-?T ((list-?T *list))
|
||||
(== (-> list next) NULL)))
|
||||
|
||||
(pub template (list-for-each list-type list-var elt-type elt-var what-do)
|
||||
(var (pointer list-type) list-var-2 list-var)
|
||||
(var elt-type elt-var (-> list-var-2 value))
|
||||
(while (!= (-> list-var-2 next) NULL)
|
||||
what-do
|
||||
(= list-var-2 (-> list-var-2 next))
|
||||
(= elt-var (-> list-var-2 value))))
|
||||
@@ -5,7 +5,7 @@
|
||||
|
||||
(chicken-import srfi-1 brev-separate) ; list routines, e.g. fold
|
||||
|
||||
(chicken-load "list.seh")
|
||||
(import list)
|
||||
|
||||
(chicken-define (imports-test a b c)
|
||||
(fold + 0 (list 1 2 3 a b c)))
|
||||
@@ -19,10 +19,10 @@
|
||||
(var foo f #((= .a-field 1.2)))
|
||||
|
||||
(list-T int)
|
||||
(make-list-T int)
|
||||
(add-value-list-T int)
|
||||
(length-list-T int)
|
||||
(is-empty-list-T int)
|
||||
(make-list-T int #f)
|
||||
(add-value-list-T int #f)
|
||||
(length-list-T int #f)
|
||||
(is-empty-list-T int #f)
|
||||
|
||||
(extern fn void puk ((int a) (float b)))
|
||||
(fn int bar () ,(imports-test 10 20 30))
|
||||
@@ -38,32 +38,13 @@
|
||||
(add-value-list-int l 3)
|
||||
(add-value-list-int l 4)
|
||||
(printf "Size of the list: %zu\n" (length-list-int l))
|
||||
(list-for-each l v
|
||||
(list-for-each list-int l int v
|
||||
(printf "%d " v))
|
||||
(printf "\n")
|
||||
(printf "%zu\n" l->next)
|
||||
(printf "Size of the list: %zu\n" (length-list-int l))
|
||||
(printf "%p\n" l->next)
|
||||
0)
|
||||
|
||||
(pub fn segs-renderer* create-renderer ())
|
||||
(pub fn void clear-command-buffer ((segs-renderer *r)))
|
||||
(pub fn void add-render-command ((segs-renderer *r) ((fn void ()) command)))
|
||||
(pub fn void commit-command-buffer ((segs-renderer *r)))
|
||||
|
||||
(template (list-T ?T)
|
||||
(struct list-?T
|
||||
((?T value)
|
||||
((* list-?T) next))))
|
||||
|
||||
(template (list-for-each type list-var elt-var body)
|
||||
(var type elt-var (-> list-var value))
|
||||
(while (!= (-> list-var next) NULL)
|
||||
body
|
||||
(= list-var (-> list-var next))
|
||||
(= elt-var (-> list-var value))))
|
||||
|
||||
; ... somewhere later
|
||||
(list-T int)
|
||||
|
||||
(pub fn void print-list (((const list-int) *l))
|
||||
(list-for-each int l v (printf "%d " v))
|
||||
(list-for-each (const list-int) l int v (printf "%d " v))
|
||||
(printf "\n"))
|
||||
|
||||
892
fmt-c.scm
Normal file
892
fmt-c.scm
Normal file
@@ -0,0 +1,892 @@
|
||||
;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
|
||||
;;
|
||||
;; Copyright (c) 2007 Alex Shinn. All rights reserved.
|
||||
;; BSD-style license: http://synthcode.com/license.txt
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; additional state information
|
||||
|
||||
(declare (unit fmt-c))
|
||||
|
||||
(import fmt
|
||||
srfi-13)
|
||||
|
||||
(define (fmt-in-macro? st) (fmt-ref st 'in-macro?))
|
||||
(define (fmt-macro-params st) (fmt-ref st 'macro-params))
|
||||
(define (fmt-expression? st) (fmt-ref st 'expression?))
|
||||
(define (fmt-return? st) (fmt-ref st 'return?))
|
||||
(define (fmt-default-type st) (fmt-ref st 'default-type 'int))
|
||||
(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?))
|
||||
(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?))
|
||||
(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?))
|
||||
(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?))
|
||||
(define (fmt-indent-space st) (fmt-ref st 'indent-space))
|
||||
(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space))
|
||||
(define (fmt-op st) (fmt-ref st 'op 'stmt))
|
||||
(define (fmt-gen st) (fmt-ref st 'gen))
|
||||
|
||||
(define (c-in-expr proc) (fmt-let 'expression? #t proc))
|
||||
(define (c-in-stmt proc) (fmt-let 'expression? #f proc))
|
||||
(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc)))
|
||||
(define (c-with-op op proc) (fmt-let 'op op proc))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 "&") 55)
|
||||
((string=? x "|") 65)
|
||||
((string=? x "&&") 70)
|
||||
((string=? x "||") 75)
|
||||
((string=? x "|=") 85)
|
||||
((or (string=? x "+=") (string=? x "-=")) 85)
|
||||
(else 95))
|
||||
(case x
|
||||
;;((|::|) 5) ; C++
|
||||
((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)
|
||||
((&& %and) 70)
|
||||
((%or) 75)
|
||||
;;((|\|\||) 75)
|
||||
;;((.. ...) 77) ; Perl
|
||||
((?) 80)
|
||||
((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ; += -=
|
||||
((comma) 90)
|
||||
((=>) 90) ; Perl
|
||||
((not) 92) ; Perl
|
||||
((and) 93) ; Perl
|
||||
((or xor) 94) ; Perl
|
||||
((paren bracket) 100)
|
||||
(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) (cat "(" (c-expr x) ")"))
|
||||
|
||||
(define (c-maybe-paren op x)
|
||||
(lambda (st)
|
||||
((fmt-let 'op op
|
||||
(if (c-op<= (fmt-op st) op)
|
||||
(c-paren x)
|
||||
x))
|
||||
st)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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))
|
||||
(lambda (st)
|
||||
((case (fmt-radix st)
|
||||
((16) (cat "0x" (string-upcase (number->string x 16))))
|
||||
((8) (cat "0" (number->string x 8)))
|
||||
(else (dsp (number->string x))))
|
||||
st))
|
||||
(dsp (number->string x))))
|
||||
|
||||
(define (c-format-string x)
|
||||
(lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st)))
|
||||
|
||||
(define (c-string-escaped x)
|
||||
(let loop ((parts '()) (idx (string-length x)))
|
||||
(cond ((string-index-right x c-needs-string-escape? 0 idx)
|
||||
=> (lambda (special-idx)
|
||||
(loop (cons (c-escape-char (string-ref x special-idx) #\")
|
||||
(cons (substring/shared x (+ special-idx 1) idx)
|
||||
parts))
|
||||
special-idx)))
|
||||
(else
|
||||
(cons (substring/shared x 0 idx) 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) (dsp (char->c-char x)))
|
||||
((boolean? x) (dsp (if x "1" "0")))
|
||||
((number? x) (c-format-number x))
|
||||
((string? x) (c-format-string x))
|
||||
((null? x) (dsp "NULL"))
|
||||
((eof-object? x) (dsp "EOF"))
|
||||
(else (dsp (write-to-string x))))))
|
||||
|
||||
(define (c-literal x)
|
||||
(lambda (st)
|
||||
((if (and (symbol? x) (memq x (or (fmt-macro-params st) '())))
|
||||
(c-paren (c-simple-literal x))
|
||||
(c-simple-literal x))
|
||||
st)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; default expression generator
|
||||
|
||||
(define (c-expr/sexp x)
|
||||
(if (procedure? x)
|
||||
x
|
||||
(lambda (st)
|
||||
(cond
|
||||
((pair? x)
|
||||
(case (car x)
|
||||
((if) ((apply c-if (cdr x)) st))
|
||||
((for) ((apply c-for (cdr x)) st))
|
||||
((while) ((apply c-while (cdr x)) st))
|
||||
((switch) ((apply c-switch (cdr x)) st))
|
||||
((case) ((apply c-case (cdr x)) st))
|
||||
((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st))
|
||||
((default) ((apply c-default (cdr x)) st))
|
||||
((break) (c-break st))
|
||||
((continue) (c-continue st))
|
||||
((return) ((apply c-return (cdr x)) st))
|
||||
((goto) ((apply c-goto (cdr x)) st))
|
||||
((typedef) ((apply c-typedef (cdr x)) st))
|
||||
((struct union class) ((apply c-struct/aux x) st))
|
||||
((enum) ((apply c-enum (cdr x)) st))
|
||||
((inline auto restrict register volatile extern static)
|
||||
((cat (car x) " " (apply c-begin (cdr x))) st))
|
||||
;; non C-keywords must have some character invalid in a C
|
||||
;; identifier to avoid conflicts - by default we prefix %
|
||||
((vector-ref)
|
||||
((c-wrap-stmt
|
||||
(cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
|
||||
st))
|
||||
((vector-set!)
|
||||
((c= (c-in-expr
|
||||
(cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
|
||||
(c-expr (cadddr x)))
|
||||
st))
|
||||
((extern/C) ((apply c-extern/C (cdr x)) st))
|
||||
((%apply) ((apply c-apply (cdr x)) st))
|
||||
((%define) ((apply cpp-define (cdr x)) st))
|
||||
((%include) ((apply cpp-include (cdr x)) st))
|
||||
((%fun) ((apply c-fun (cdr x)) st))
|
||||
((%cond)
|
||||
(let lp ((ls (cdr x)) (res '()))
|
||||
(if (null? ls)
|
||||
((apply c-if (reverse res)) st)
|
||||
(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)) st))
|
||||
((%var) ((apply c-var (cdr x)) st))
|
||||
((%begin) ((apply c-begin (cdr x)) st))
|
||||
((%attribute) ((apply c-attribute (cdr x)) st))
|
||||
((%line) ((apply cpp-line (cdr x)) st))
|
||||
((%pragma %error %warning)
|
||||
((apply cpp-generic (substring/shared (symbol->string (car x)) 1)
|
||||
(cdr x)) st))
|
||||
((%if %ifdef %ifndef %elif)
|
||||
((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1)
|
||||
(cdr x)) st))
|
||||
((%endif) ((apply cpp-endif (cdr x)) st))
|
||||
((%block) ((apply c-braced-block (cdr x)) st))
|
||||
((%comment) ((apply c-comment (cdr x)) st))
|
||||
((:) ((apply c-label (cdr x)) st))
|
||||
((%cast) ((apply c-cast (cdr x)) st))
|
||||
((+ - & * / % ! ~ ^ && < > <= >= == != << >>
|
||||
= *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
|
||||
((apply c-op x) st))
|
||||
((bitwise-and bit-and) ((apply c-op '& (cdr x)) st))
|
||||
((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st))
|
||||
((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st))
|
||||
((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st))
|
||||
((arithmetic-shift) ((apply c-op '<< (cdr x)) st))
|
||||
((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st))
|
||||
((%and) ((apply c-op "&&" (cdr x)) st))
|
||||
((%or) ((apply c-op "||" (cdr x)) st))
|
||||
((%. %field) ((apply c-op "." (cdr x)) st))
|
||||
((%->) ((apply c-op "->" (cdr x)) st))
|
||||
(else
|
||||
(cond
|
||||
((eq? (car x) (string->symbol "."))
|
||||
((apply c-op "." (cdr x)) st))
|
||||
((eq? (car x) (string->symbol "->"))
|
||||
((apply c-op "->" (cdr x)) st))
|
||||
((eq? (car x) (string->symbol "++"))
|
||||
((apply c-op "++" (cdr x)) st))
|
||||
((eq? (car x) (string->symbol "--"))
|
||||
((apply c-op "--" (cdr x)) st))
|
||||
((eq? (car x) (string->symbol "+="))
|
||||
((apply c-op "+=" (cdr x)) st))
|
||||
((eq? (car x) (string->symbol "-="))
|
||||
((apply c-op "-=" (cdr x)) st))
|
||||
(else ((c-apply x) st))))))
|
||||
((vector? x)
|
||||
((c-wrap-stmt
|
||||
(fmt-try-fit
|
||||
(fmt-let 'no-wrap? #t
|
||||
(cat "{" (fmt-join c-expr (vector->list x) ", ") "}"))
|
||||
(lambda (st)
|
||||
(let* ((col (fmt-col st))
|
||||
(sep (string-append "," (make-nl-space col))))
|
||||
((cat "{" (fmt-join c-expr (vector->list x) sep)
|
||||
"}" nl)
|
||||
st)))))
|
||||
st))
|
||||
(else
|
||||
((c-literal x) st))))))
|
||||
|
||||
(define (c-apply ls)
|
||||
(c-wrap-stmt
|
||||
(c-with-op
|
||||
'paren
|
||||
(cat (c-expr (car ls))
|
||||
(let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", "))))
|
||||
(fmt-if
|
||||
fmt-no-wrap?
|
||||
(c-paren flat)
|
||||
(c-paren
|
||||
(fmt-try-fit
|
||||
flat
|
||||
(lambda (st)
|
||||
(let* ((col (fmt-col st))
|
||||
(sep (string-append "," (make-nl-space col))))
|
||||
((fmt-join c-expr (cdr ls) sep) st)))))))))))
|
||||
|
||||
(define (c-expr x)
|
||||
(lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; comments, with Emacs-friendly escaping of nested comments
|
||||
|
||||
(define (make-comment-writer st)
|
||||
(let ((output (fmt-ref st 'writer)))
|
||||
(lambda (str st)
|
||||
(let ((lim (- (string-length str) 1)))
|
||||
(let lp ((i 0) (st st))
|
||||
(let ((j (string-index str #\/ i)))
|
||||
(if j
|
||||
(let ((st (if (and (> j 0)
|
||||
(eqv? #\* (string-ref str (- j 1))))
|
||||
(output
|
||||
"\\/"
|
||||
(output (substring/shared str i j) st))
|
||||
(output (substring/shared str i (+ j 1)) st))))
|
||||
(lp (+ j 1)
|
||||
(if (and (< j lim) (eqv? #\* (string-ref str (+ j 1))))
|
||||
(output "\\" st)
|
||||
st)))
|
||||
(output (substring/shared str i) st))))))))
|
||||
|
||||
(define (c-comment . args)
|
||||
(lambda (st)
|
||||
((cat "/*" (fmt-let 'writer (make-comment-writer st)
|
||||
(apply-cat args))
|
||||
"*/")
|
||||
st)))
|
||||
|
||||
(define (make-block-comment-writer st)
|
||||
(let ((output (make-comment-writer st))
|
||||
(indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* ")))
|
||||
(lambda (str st)
|
||||
(let ((lim (string-length str)))
|
||||
(let lp ((i 0) (st st))
|
||||
(let ((j (string-index str #\newline i)))
|
||||
(if j
|
||||
(lp (+ j 1)
|
||||
(output indent (output (substring/shared str i j) st)))
|
||||
(output (substring/shared str i) st))))))))
|
||||
|
||||
(define (c-block-comment . args)
|
||||
(lambda (st)
|
||||
(let ((col (fmt-col st))
|
||||
(row (fmt-row st))
|
||||
(indent (c-current-indent-string st)))
|
||||
((cat "/* "
|
||||
(fmt-let 'writer (make-block-comment-writer st) (apply-cat args))
|
||||
(lambda (st)
|
||||
(cond
|
||||
((= row (fmt-row st)) ((dsp " */") st))
|
||||
;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st))
|
||||
(else ((cat fl indent " */") st)))))
|
||||
st))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; preprocessor
|
||||
|
||||
(define (make-cpp-writer st)
|
||||
(let ((output (fmt-ref st 'writer)))
|
||||
(lambda (str st)
|
||||
(let lp ((i 0) (st st))
|
||||
(let ((j (string-index str #\newline i)))
|
||||
(if j
|
||||
(lp (+ j 1)
|
||||
(output
|
||||
nl-str
|
||||
(output " \\" (output (substring/shared str i j) st))))
|
||||
(output (substring/shared str i) st)))))))
|
||||
|
||||
(define (cpp-include file)
|
||||
(if (string? file)
|
||||
(cat fl "#include " (wrt file) fl)
|
||||
(cat fl "#include <" file ">" fl)))
|
||||
|
||||
(define (list-dot x)
|
||||
(cond ((pair? x) (list-dot (cdr x)))
|
||||
((null? x) #f)
|
||||
(else x)))
|
||||
|
||||
(define (flatten-list ls)
|
||||
(let lp ((ls ls) (res '()))
|
||||
(cond ((pair? ls) (lp (cdr ls) (cons (car ls) res)))
|
||||
((null? ls) (reverse res))
|
||||
(else (reverse (cons ls res))))))
|
||||
|
||||
(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)))
|
||||
(lambda (st)
|
||||
(let* ((body (cond
|
||||
((and (pair? x) (list-dot x))
|
||||
=> (lambda (dot)
|
||||
(if (eq? dot '...)
|
||||
body
|
||||
(replace-tree dot '__VA_ARGS__ body))))
|
||||
(else body)))
|
||||
(params (map (lambda (x) (if (pair? x) (cadr x) x))
|
||||
(flatten-list (if (pair? x) (cdr x) '()))))
|
||||
(tail
|
||||
(if (pair? body)
|
||||
(cat " "
|
||||
(fmt-let 'writer (make-cpp-writer st)
|
||||
(fmt-let 'macro-params params
|
||||
((if (or (not (pair? x))
|
||||
(and (null? (cdr body))
|
||||
(c-literal? (car body))))
|
||||
(lambda (x) x)
|
||||
c-paren)
|
||||
(c-in-expr (apply c-begin body))))))
|
||||
(lambda (x) x))))
|
||||
((c-in-expr
|
||||
(if (pair? x)
|
||||
(cat fl "#define " (name-of (car x))
|
||||
(c-paren
|
||||
(fmt-join/dot name-of
|
||||
(lambda (dot) (dsp "..."))
|
||||
(cdr x)
|
||||
", "))
|
||||
tail fl)
|
||||
(cat fl "#define " (c-expr x) tail fl)))
|
||||
st))))
|
||||
|
||||
(define (cpp-expr x)
|
||||
(if (or (symbol? x) (string? x)) (dsp x) (c-expr x)))
|
||||
|
||||
(define (cpp-if/aux name check . o)
|
||||
(let* ((pass (and (pair? o) (car o)))
|
||||
(comment (if (member name '("ifdef" "ifndef"))
|
||||
(cat " "
|
||||
(c-comment
|
||||
" " (if (equal? name "ifndef") "! " "")
|
||||
check " "))
|
||||
""))
|
||||
(endif (if pass (cat fl "#endif" comment) ""))
|
||||
(tail (cond
|
||||
((and (pair? o) (pair? (cdr o)))
|
||||
(if (pair? (cddr o))
|
||||
(apply cpp-elif (cdr o))
|
||||
(cat (cpp-else) (cadr o) endif)))
|
||||
(else endif))))
|
||||
(lambda (st)
|
||||
(let ((indent (c-current-indent-string st)))
|
||||
((cat fl "#" name " " (cpp-expr check) fl
|
||||
(if pass (cat indent pass) "") fl
|
||||
tail fl)
|
||||
st)))))
|
||||
|
||||
(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)
|
||||
(cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl))
|
||||
(define (cpp-endif . o)
|
||||
(cat 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)
|
||||
(cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl))
|
||||
|
||||
(define (cpp-generic name . ls)
|
||||
(cat fl "#" name (apply-cat 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)
|
||||
(cat "#" x))
|
||||
|
||||
(define (cpp-sym-cat . args)
|
||||
(fmt-join dsp args " ## "))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; general indentation and brace rules
|
||||
|
||||
(define (c-current-indent-string st . o)
|
||||
(make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0)))))
|
||||
|
||||
(define (c-indent st . o)
|
||||
(dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4)
|
||||
(if (pair? o) (car o) 0))))))
|
||||
|
||||
(define (c-indent/switch st)
|
||||
(dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4)))))
|
||||
|
||||
(define (c-open-brace st)
|
||||
(if (fmt-newline-before-brace? st)
|
||||
(cat nl (c-current-indent-string st) "{" nl)
|
||||
(cat " {" nl)))
|
||||
|
||||
(define (c-close-brace st)
|
||||
(dsp "}"))
|
||||
|
||||
(define (c-wrap-stmt x)
|
||||
(fmt-if fmt-expression?
|
||||
(c-expr x)
|
||||
(cat (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)
|
||||
(lambda (st)
|
||||
(if (fmt-braceless-bodies? st)
|
||||
((cat header fl (c-indent st offset) inner fl) st)
|
||||
((c-braced-block/aux offset header inner) st))))))
|
||||
|
||||
(define (c-braced-block . args)
|
||||
(apply c-braced-block/aux 0 args))
|
||||
|
||||
(define (c-braced-block/aux offset header . body)
|
||||
(lambda (st)
|
||||
((cat header (c-open-brace st) (c-indent st offset)
|
||||
(apply c-begin body) fl
|
||||
(c-current-indent-string st offset) (c-close-brace st))
|
||||
st)))
|
||||
|
||||
(define (c-begin . args)
|
||||
(apply c-begin/aux #f args))
|
||||
|
||||
(define (c-begin/aux ret? body0 . body)
|
||||
(if (null? body)
|
||||
(c-expr body0)
|
||||
(lambda (st)
|
||||
(if (fmt-expression? st)
|
||||
((fmt-try-fit
|
||||
(fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", "))
|
||||
(lambda (st)
|
||||
(let ((indent (c-current-indent-string st)))
|
||||
((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st))))
|
||||
st)
|
||||
(let ((orig-ret? (fmt-return? st)))
|
||||
((fmt-join/last c-expr
|
||||
(lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
|
||||
(cons body0 body)
|
||||
(cat fl (c-current-indent-string st)))
|
||||
(fmt-set! st 'return? (and ret? orig-ret?))))))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; 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 (if (not (null? o)) (car o) '()) x))
|
||||
(o (if (null? o) o (cdr o))))
|
||||
(if (not (null? body))
|
||||
(c-wrap-stmt
|
||||
(cat
|
||||
(c-braced-block
|
||||
(cat type (if (and name (not (equal? name ""))) (cat " " name) ""))
|
||||
(cat
|
||||
(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) (cat " " (apply c-begin o)) (dsp ""))))
|
||||
(c-wrap-stmt
|
||||
(cat type (if (and name (not (equal? name ""))) (cat " " name) ""))))))
|
||||
|
||||
(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) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
|
||||
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
|
||||
(vals (if name (car o) x)))
|
||||
(c-wrap-stmt
|
||||
(cat
|
||||
(c-braced-block
|
||||
(if name (cat "enum " name) (dsp "enum"))
|
||||
(c-in-expr (apply c-begin (map c-enum-one vals))))))))
|
||||
|
||||
(define (c-attribute . args)
|
||||
(cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; basic control structures
|
||||
|
||||
(define (c-while check . body)
|
||||
(cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
|
||||
(c-in-stmt (apply c-begin body)))
|
||||
fl))
|
||||
|
||||
(define (c-for init check update . body)
|
||||
(cat
|
||||
(c-block
|
||||
(c-in-expr
|
||||
(cat "for (" (c-expr init) "; " (c-in-test (c-expr 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 (cat (lambda (st) ((c-type (fmt-default-type st)) st)) " " x))))
|
||||
|
||||
(define (c-param-list ls)
|
||||
(c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", ")))
|
||||
|
||||
(define (c-fun type name params . body)
|
||||
(cat (c-block (c-in-expr (c-prototype type name params))
|
||||
(c-in-stmt (apply c-begin body)))
|
||||
fl))
|
||||
|
||||
(define (c-prototype type name params . o)
|
||||
(c-wrap-stmt
|
||||
(cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
|
||||
(fmt-join/prefix c-expr o " "))))
|
||||
|
||||
(define (c-static x) (cat "static " (c-expr x)))
|
||||
(define (c-const x) (cat "const " (c-expr x)))
|
||||
(define (c-restrict x) (cat "restrict " (c-expr x)))
|
||||
(define (c-volatile x) (cat "volatile " (c-expr x)))
|
||||
(define (c-auto x) (cat "auto " (c-expr x)))
|
||||
(define (c-inline x) (cat "inline " (c-expr x)))
|
||||
(define (c-extern x) (cat "extern " (c-expr x)))
|
||||
(define (c-extern/C . body)
|
||||
(cat "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)
|
||||
(cat (c-type (cadr type) #f)
|
||||
" (*" (or name "") ")("
|
||||
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
|
||||
((%array)
|
||||
(let ((name (cat name "[" (if (pair? (cddr type))
|
||||
(c-expr (caddr type))
|
||||
"")
|
||||
"]")))
|
||||
(c-type (cadr type) name)))
|
||||
((%pointer *)
|
||||
(let ((name (cat "*" (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)
|
||||
(cat (apply c-struct/aux (car type) (cdr type)) " " name))
|
||||
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
|
||||
((not type)
|
||||
(lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
|
||||
(else
|
||||
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
|
||||
|
||||
(define (c-var type name . init)
|
||||
(c-wrap-stmt
|
||||
(if (pair? init)
|
||||
(cat (c-type type name) " = " (c-expr (car init)))
|
||||
(c-type type (if (pair? name)
|
||||
(fmt-join c-expr name ", ")
|
||||
(c-expr name))))))
|
||||
|
||||
(define (c-cast type expr)
|
||||
(cat "(" (c-type type) ")" (c-expr expr)))
|
||||
|
||||
(define (c-typedef type alias . o)
|
||||
(c-wrap-stmt
|
||||
(cat "typedef " (c-type type alias) (fmt-join/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)
|
||||
(lambda (st)
|
||||
(let ((indent (c-current-indent-string st)))
|
||||
((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)
|
||||
(cat (c-block/aux -1 " else" p) fl))
|
||||
(let ((tail (if (pair? ls)
|
||||
(if (pair? (cdr ls))
|
||||
(lp (car ls) (cadr ls) (cddr ls))
|
||||
(lp 'else (car ls) '()))
|
||||
fl)))
|
||||
(cat (c-block/aux
|
||||
(if (eq? ls rest) 0 -1)
|
||||
(cat (if (eq? ls rest) (lambda (x) x) " else ")
|
||||
"if (" (c-in-test (c-expr c)) ")") p)
|
||||
tail))))
|
||||
st))))
|
||||
|
||||
(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)
|
||||
(cat (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)
|
||||
(fmt-if fmt-expression?
|
||||
(apply c-if/expr args)
|
||||
(apply c-if/stmt args)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; switch statements, automatic break handling
|
||||
|
||||
(define (c-label name)
|
||||
(lambda (st)
|
||||
(let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
|
||||
((cat fl indent name ":" fl) st))))
|
||||
|
||||
(define c-break
|
||||
(c-wrap-stmt (dsp "break")))
|
||||
(define c-continue
|
||||
(c-wrap-stmt (dsp "continue")))
|
||||
(define (c-return . result)
|
||||
(if (pair? result)
|
||||
(c-wrap-stmt (cat "return " (c-expr (car result))))
|
||||
(c-wrap-stmt (dsp "return"))))
|
||||
(define (c-goto label)
|
||||
(c-wrap-stmt (cat "goto " (c-expr label))))
|
||||
|
||||
(define (c-switch val . clauses)
|
||||
(lambda (st)
|
||||
((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
|
||||
(c-indent/switch st)
|
||||
(c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
|
||||
(c-current-indent-string st) (c-close-brace st) fl)
|
||||
st)))
|
||||
|
||||
(define (c-switch-clause/breaks x)
|
||||
(lambda (st)
|
||||
(let* ((break?
|
||||
(and (car x)
|
||||
(not (member (cadr x) '(case/fallthrough
|
||||
default/fallthrough
|
||||
else/fallthrough)))))
|
||||
(explicit-case? (member (cadr x) '(case case/fallthrough)))
|
||||
(indent (c-current-indent-string st))
|
||||
(indent-body (c-indent st))
|
||||
(sep (string-append ":" nl-str indent)))
|
||||
((cat (c-in-expr
|
||||
(fmt-join/suffix
|
||||
dsp
|
||||
(cond
|
||||
((pair? (cadr x))
|
||||
(map (lambda (y) (cat (dsp "case ") (c-expr y)))
|
||||
(cadr x)))
|
||||
(explicit-case?
|
||||
(map (lambda (y) (cat (dsp "case ") (c-expr y)))
|
||||
(if (list? (caddr x))
|
||||
(caddr x)
|
||||
(list (caddr x)))))
|
||||
((member (cadr x)
|
||||
'(default else default/fallthrough else/fallthrough))
|
||||
(list (dsp "default")))
|
||||
(else
|
||||
(error
|
||||
"unknown switch clause, expected a list or default but got"
|
||||
(cadr x))))
|
||||
sep))
|
||||
(make-space (or (fmt-indent-space st) 4))
|
||||
(fmt-join c-expr
|
||||
(if explicit-case? (cdddr x) (cddr x))
|
||||
indent-body)
|
||||
(if (and break? (not (fmt-return? st)))
|
||||
(cat fl indent-body c-break)
|
||||
""))
|
||||
st))))
|
||||
|
||||
(define (c-switch-clause x)
|
||||
(if (procedure? x) x (c-switch-clause/breaks (cons #t x))))
|
||||
(define (c-switch-clause/no-break x)
|
||||
(if (procedure? x) x (c-switch-clause/breaks (cons #f x))))
|
||||
|
||||
(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 "->"))
|
||||
(fmt-join c-expr ls str)
|
||||
(let ((flat
|
||||
(fmt-let 'no-wrap? #t
|
||||
(lambda (st)
|
||||
((fmt-join c-expr
|
||||
ls
|
||||
(if (and (fmt-non-spaced-ops? st)
|
||||
(every lit-op? ls))
|
||||
str
|
||||
(string-append " " str " ")))
|
||||
st)))))
|
||||
(fmt-if
|
||||
fmt-no-wrap?
|
||||
flat
|
||||
(fmt-try-fit
|
||||
flat
|
||||
(lambda (st)
|
||||
((fmt-join c-expr
|
||||
ls
|
||||
(cat nl (make-space (+ 2 (fmt-col st))) str " "))
|
||||
st))))))))))
|
||||
|
||||
(define (c-unary-op op x)
|
||||
(c-wrap-stmt
|
||||
(cat (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)
|
||||
(cat (c-maybe-paren 'post-increment (c-expr x)) "++"))
|
||||
(define (c--/post x)
|
||||
(cat (c-maybe-paren 'post-decrement (c-expr x)) "--"))
|
||||
@@ -1,18 +0,0 @@
|
||||
(include stdio.h)
|
||||
|
||||
(chicken-define (foo)
|
||||
"Hello from Chicken code!\n")
|
||||
|
||||
(struct foo
|
||||
((int a)
|
||||
(float b)))
|
||||
|
||||
(pub fn int main ((int argc) (char **argv))
|
||||
(var int a 10)
|
||||
(puts "Hello from Sex!")
|
||||
(var (array char 512) name)
|
||||
(puts "What is your name?")
|
||||
(scanf "%s" &name)
|
||||
(printf "Hello, %s!\n" name)
|
||||
(printf ,(foo))
|
||||
0)
|
||||
86
modules.scm
Normal file
86
modules.scm
Normal file
@@ -0,0 +1,86 @@
|
||||
; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
|
||||
; things start to break.
|
||||
(declare (unit sex-modules)
|
||||
(uses utils))
|
||||
|
||||
(import brev-separate
|
||||
(chicken file)
|
||||
(chicken load)
|
||||
(chicken pathname)
|
||||
(chicken process-context)
|
||||
(chicken string)
|
||||
fmt
|
||||
srfi-1)
|
||||
|
||||
(define +persistent-module-paths+ (list))
|
||||
|
||||
(define (import-modules module-list)
|
||||
;; Module list is a list of symbols
|
||||
;; How Sex handles modules:
|
||||
;; For each module in a list, construct path, find module by path in
|
||||
;; module path directories, extract public definitions from the
|
||||
;; module, paste them in current one in emulation of C include
|
||||
;; directives.
|
||||
(fold-right append (list)
|
||||
(map (fn (import-module (symbol->string x)))
|
||||
module-list)))
|
||||
|
||||
(define (import-module name)
|
||||
(let ((module-path (locate-module name)))
|
||||
(assert module-path (fmt #f "Failed to find module " name " in "
|
||||
(get-module-paths)))
|
||||
(read-public-interface module-path)))
|
||||
|
||||
(define (get-module-paths)
|
||||
(cons (current-directory)
|
||||
+persistent-module-paths+))
|
||||
|
||||
(define (locate-module name)
|
||||
;; Module locations: relative to file being compiled, or in what was
|
||||
;; in SEX_MODULE_PATH env var at the start of the process (see
|
||||
;; load-persistent-module-paths function)
|
||||
|
||||
(let ((search-paths (get-module-paths)))
|
||||
(let loop ((paths search-paths))
|
||||
(if (null? paths)
|
||||
#f
|
||||
(or (module-exists? name (car paths))
|
||||
(loop (cdr paths)))))))
|
||||
|
||||
(define (module-exists? name module-dir)
|
||||
;; returns absolute path to module, if it exists
|
||||
(and (directory-exists? module-dir)
|
||||
(let ((module-path (make-absolute-pathname module-dir name "sex")))
|
||||
(and (file-exists? module-path)
|
||||
(file-readable? module-path)
|
||||
module-path))))
|
||||
|
||||
(define (read-public-interface module-path)
|
||||
;; pub fns are reduced to prototypes, other pub forms are just pasted
|
||||
(let ((raw-forms (read-from-file module-path)))
|
||||
(fold
|
||||
process-public-interface-form
|
||||
(list)
|
||||
raw-forms)))
|
||||
|
||||
(define (process-public-interface-form form acc)
|
||||
(case (car form)
|
||||
((pub)
|
||||
(case (cadr form)
|
||||
((fn) ; replace with prototype
|
||||
;; fn type name (arg-list) (body)
|
||||
;; 1 2 3 4 - we need first 4
|
||||
(cons (take (cdr form) 4) acc))
|
||||
((define import include struct template typedef union var)
|
||||
(cons (cdr form) acc))
|
||||
(else (error "Pub what? " (cadr form)))))
|
||||
(else acc)))
|
||||
|
||||
(define (load-persistent-module-paths)
|
||||
(let ((sex-module-path-env-var
|
||||
(get-env-var "SEX_MODULE_PATH")))
|
||||
(when sex-module-path-env-var
|
||||
(set! +persistent-module-paths+
|
||||
(map (lambda (p)
|
||||
(make-absolute-pathname p #f #f))
|
||||
(string-split sex-module-path-env-var ":"))))))
|
||||
@@ -34,6 +34,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
|
||||
"chicken-load"
|
||||
"define"
|
||||
"extern"
|
||||
"import"
|
||||
"include"
|
||||
"fn"
|
||||
"pub"
|
||||
@@ -80,6 +81,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
|
||||
(put 'template 'lisp-indent-function 'defun)
|
||||
(put 'struct 'lisp-indent-function 'defun)
|
||||
(put 'var 'lisp-indent-function 0)
|
||||
(put 'import 'lisp-indent-function 1)
|
||||
|
||||
;;;###autoload
|
||||
(define-derived-mode sex-mode lisp-data-mode "Sex"
|
||||
|
||||
183
sexc.scm
183
sexc.scm
@@ -1,21 +1,25 @@
|
||||
(declare (unit sexc)
|
||||
(uses templates))
|
||||
(uses sex-modules
|
||||
fmt-c
|
||||
templates))
|
||||
|
||||
(include "utils.macros.scm")
|
||||
|
||||
(import brev-separate
|
||||
(chicken file)
|
||||
(chicken pathname)
|
||||
(chicken plist)
|
||||
(chicken pretty-print)
|
||||
(chicken process)
|
||||
(chicken process-context)
|
||||
(chicken string)
|
||||
fmt
|
||||
fmt-c
|
||||
getopt-long
|
||||
regex
|
||||
srfi-1 ; list routines
|
||||
srfi-13 ; string routines
|
||||
tree)
|
||||
|
||||
(define +debug+ #f)
|
||||
|
||||
(define (unkebabify sym)
|
||||
(case sym
|
||||
((-) sym)
|
||||
@@ -44,12 +48,6 @@
|
||||
(unkebabify atom)
|
||||
atom))))
|
||||
|
||||
(define (tree-finder symbol)
|
||||
(lambda (node)
|
||||
(or (and (tree? node)
|
||||
(eq? (car node) symbol))
|
||||
#f)))
|
||||
|
||||
(define (make-field-access form)
|
||||
(assert (= 2 (length form)) "Wrong field access format")
|
||||
(unkebabify
|
||||
@@ -86,7 +84,7 @@
|
||||
|
||||
;; another special case - template
|
||||
((template? form)
|
||||
(append (fold
|
||||
(append (fold-right
|
||||
walk-generic
|
||||
(list)
|
||||
(eval form))
|
||||
@@ -95,11 +93,10 @@
|
||||
;; toplevel, or a start of a regular list form
|
||||
(else
|
||||
(let ((new-acc (list)))
|
||||
(cons (reverse
|
||||
(fold
|
||||
(cons (fold-right
|
||||
walk-generic
|
||||
new-acc
|
||||
form))
|
||||
form)
|
||||
acc)))))
|
||||
|
||||
(define (normalize-fn-form form)
|
||||
@@ -141,7 +138,10 @@
|
||||
(walk-function form #f acc))
|
||||
((var)
|
||||
(append (walk-generic (list 'static (cdr form)) (list)) acc))
|
||||
(else (error "Pub what?"))))
|
||||
((define import include struct template typedef union var)
|
||||
;; ignore here, used in generating public interface
|
||||
(process-form (cdr form) acc))
|
||||
(else (error "Pub what?" (cadr form)))))
|
||||
|
||||
(define (template? form)
|
||||
(and (list? form)
|
||||
@@ -151,7 +151,7 @@
|
||||
(define (walk-sex-tree form acc)
|
||||
(if (list? form)
|
||||
(if (template? form)
|
||||
(fold (fn (walk-sex-tree x y))
|
||||
(fold-right (fn (walk-sex-tree x y))
|
||||
acc
|
||||
(eval form))
|
||||
(case (car form)
|
||||
@@ -174,10 +174,14 @@
|
||||
(load (cadr form)) acc)
|
||||
((chicken-import)
|
||||
(eval (cons 'import (cdr form))) acc)
|
||||
((import)
|
||||
(append (process-raw-forms
|
||||
|
||||
(import-modules (cdr form)) (list))
|
||||
acc))
|
||||
(else
|
||||
(walk-sex-tree form acc))))
|
||||
|
||||
|
||||
(define (process-raw-forms raw-forms acc)
|
||||
(if (null? raw-forms)
|
||||
(reverse acc)
|
||||
@@ -191,31 +195,47 @@
|
||||
|
||||
(define (emit-c forms)
|
||||
(for-each (lambda (form)
|
||||
(fmt #t (c-expr form))
|
||||
(fmt #t "\n"))
|
||||
(fmt #t (c-expr form) nl))
|
||||
forms))
|
||||
|
||||
;;; Main function facilities
|
||||
|
||||
(define opts-grammar
|
||||
`((output "Write output to file"
|
||||
(let ((padding 26))
|
||||
`((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl
|
||||
(pad padding) "environment variable, or if it is empty, to cc")
|
||||
(required #f)
|
||||
(value #t)
|
||||
(single-char #\o))
|
||||
(value #t))
|
||||
(compile-object "Compile object file instead of executable program"
|
||||
(required #f)
|
||||
(value #f)
|
||||
(single-char #\c))
|
||||
(preprocess "Emit C code"
|
||||
(required #f)
|
||||
(value #f)
|
||||
(single-char #\E))
|
||||
(public-interface "Get module's public interface"
|
||||
(required #f)
|
||||
(value #f))
|
||||
(help "Show this help"
|
||||
(required #f)
|
||||
(value #f)
|
||||
(single-char #\h))
|
||||
(macro-expand "Emit macro-expanded Sex code instead of C"
|
||||
(macro-expand "Emit macro-expanded Sex code"
|
||||
(required #f)
|
||||
(value #f)
|
||||
(single-char #\m))))
|
||||
(single-char #\m))
|
||||
(output ,(fmt #f "Write output to file. Default file name is a.out." nl
|
||||
(pad padding) "If -E or -m options are provided, defaults to stdout")
|
||||
(required #f)
|
||||
(value #t)
|
||||
(single-char #\o)))))
|
||||
|
||||
(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"))
|
||||
(fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
|
||||
(fmt #t "Options:\n")
|
||||
(fmt #t (usage opts-grammar))
|
||||
(fmt #t ""))
|
||||
|
||||
(define (help-arg? args)
|
||||
(assoc 'help args))
|
||||
@@ -225,44 +245,99 @@
|
||||
(if arg (cdr arg)
|
||||
default)))
|
||||
|
||||
(define (get-rest-args args)
|
||||
(cdr (assoc '@ args)))
|
||||
|
||||
(define (get-c-compiler-args args)
|
||||
(filter (fn (string-prefix? "-" x)) (get-rest-args args)))
|
||||
|
||||
(define (get-input-file args)
|
||||
(let ((rest-args (assoc '@ args)))
|
||||
(if (= 1 (length rest-args))
|
||||
(let ((rest-args (get-rest-args args)))
|
||||
(if (null? rest-args)
|
||||
'stdin
|
||||
(cadr rest-args))))
|
||||
(car rest-args))))
|
||||
|
||||
(define (read-from-file file)
|
||||
(with-directory file
|
||||
(with-input-from-file (pathname-strip-directory file)
|
||||
(fn (read-forms (list)))))
|
||||
(fn (read-forms (list))))))
|
||||
|
||||
(define (set-working-directory file)
|
||||
(change-directory
|
||||
(normalize-pathname
|
||||
(make-absolute-pathname
|
||||
(current-directory)
|
||||
(pathname-directory file)))))
|
||||
(define (write-to-file-or-stdout output what)
|
||||
(if (eq? output 'default)
|
||||
(what)
|
||||
(with-output-to-file output
|
||||
(fn (what)))))
|
||||
|
||||
(define (preprocess-or-macroexpand sex-forms output args)
|
||||
(write-to-file-or-stdout
|
||||
output
|
||||
(lambda ()
|
||||
(if (get-arg args 'macro-expand #f)
|
||||
(map pp sex-forms)
|
||||
(emit-c sex-forms)))))
|
||||
|
||||
(define (compile-to-file sex-forms output args)
|
||||
(let ((compiler (or (get-arg args 'c-compiler #f)
|
||||
(get-env-var "SEX_CC")
|
||||
"cc"))
|
||||
(out-file (if (eq? output 'default)
|
||||
"a.out"
|
||||
output))
|
||||
(temp-c-out (create-temporary-file ".sex.c")))
|
||||
(with-output-to-file temp-c-out
|
||||
(lambda ()
|
||||
(emit-c sex-forms)))
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(process compiler (append (list temp-c-out "-o" out-file)
|
||||
(if (get-arg args 'compile-object #f)
|
||||
(list "-c")
|
||||
(list))
|
||||
(get-c-compiler-args args))))
|
||||
(lambda (out-port in-port pid)
|
||||
(process-wait pid)))))
|
||||
|
||||
(define (process-input input raw-forms)
|
||||
(let ((current-dir (current-directory)))
|
||||
(unless (eq? input 'stdin)
|
||||
(set-working-directory input))
|
||||
(prog1
|
||||
(process-raw-forms raw-forms (list))
|
||||
(change-directory current-dir))))
|
||||
|
||||
(define (main)
|
||||
(let* ((raw-args (command-line-arguments))
|
||||
(current-dir (current-directory))
|
||||
(args (getopt-long raw-args
|
||||
opts-grammar))
|
||||
(output (get-arg args 'output 'stdout))
|
||||
(output (get-arg args 'output 'default))
|
||||
(help (help-arg? args))
|
||||
(input (get-input-file args)))
|
||||
(if help (print-help)
|
||||
|
||||
(input (get-input-file args))
|
||||
(current-dir (current-directory)))
|
||||
(call/cc
|
||||
(lambda (return)
|
||||
(when help
|
||||
(print-help)
|
||||
(return #f))
|
||||
(when (get-arg args 'public-interface #f)
|
||||
(assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
|
||||
|
||||
(write-to-file-or-stdout
|
||||
output
|
||||
(fn
|
||||
(map pp (reverse
|
||||
(read-public-interface input)))))
|
||||
(return #f))
|
||||
(load-persistent-module-paths)
|
||||
|
||||
(let* ((raw-forms
|
||||
(if (eq? input 'stdin)
|
||||
(read-forms (list))
|
||||
(begin
|
||||
(set-working-directory input)
|
||||
(read-from-file input))))
|
||||
(sex-forms (process-raw-forms raw-forms (list))))
|
||||
(change-directory current-dir)
|
||||
(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)))))))
|
||||
(read-from-file input)))
|
||||
(sex-forms (process-input input raw-forms)))
|
||||
(if (or (get-arg args 'macro-expand #f)
|
||||
(get-arg args 'preprocess #f))
|
||||
;; Preprocess or macroexpand
|
||||
(preprocess-or-macroexpand sex-forms output args)
|
||||
;; Compile file!
|
||||
(compile-to-file sex-forms output args)))))))
|
||||
|
||||
@@ -1,8 +1,8 @@
|
||||
(declare (unit templates))
|
||||
|
||||
(import
|
||||
(chicken plist)
|
||||
brev-separate
|
||||
(chicken plist)
|
||||
fmt
|
||||
regex
|
||||
srfi-1 ; list routines
|
||||
|
||||
1
tests/Makefile
Normal file
1
tests/Makefile
Normal file
@@ -0,0 +1 @@
|
||||
|
||||
37
tests/run.scm
Normal file
37
tests/run.scm
Normal file
@@ -0,0 +1,37 @@
|
||||
(declare (uses sexc))
|
||||
|
||||
(import
|
||||
(chicken process)
|
||||
(chicken process-context)
|
||||
srfi-1
|
||||
test)
|
||||
|
||||
;;; unkebabify
|
||||
(test '- (unkebabify '-))
|
||||
(test '-- (unkebabify '--))
|
||||
(test '-> (unkebabify '->))
|
||||
(test '-= (unkebabify '-=))
|
||||
(test 'kebab_case (unkebabify 'kebab-case))
|
||||
(test '_what_ (unkebabify '-what-))
|
||||
(test 'this->member (unkebabify 'this->member))
|
||||
(test '_this_->_member_ (unkebabify '-this-->-member-))
|
||||
(test '__->>> (unkebabify '--->>>))
|
||||
|
||||
;;; atom-to-fmt-c
|
||||
(test '%fun (atom-to-fmt-c 'fn))
|
||||
(test '%prototype (atom-to-fmt-c 'prototype))
|
||||
(test '%var (atom-to-fmt-c 'var))
|
||||
(test '%begin (atom-to-fmt-c 'begin))
|
||||
(test '%define (atom-to-fmt-c 'define))
|
||||
(test '%pointer (atom-to-fmt-c 'pointer))
|
||||
(test '%array (atom-to-fmt-c 'array))
|
||||
(test 'vector-ref (atom-to-fmt-c '@))
|
||||
(test '%include (atom-to-fmt-c 'include))
|
||||
(test '%cast (atom-to-fmt-c 'cast))
|
||||
|
||||
;;; make-field-access
|
||||
(test 'a.b (make-field-access '(.b a)))
|
||||
(test 'a.b.c (make-field-access '(.c a.b)))
|
||||
|
||||
;;; Should be the last in the test suite
|
||||
(test-exit)
|
||||
15
utils.macros.scm
Normal file
15
utils.macros.scm
Normal file
@@ -0,0 +1,15 @@
|
||||
(define-syntax prog1
|
||||
(syntax-rules ()
|
||||
((prog1 form . forms)
|
||||
(let ((res form))
|
||||
(begin . forms)
|
||||
res))))
|
||||
|
||||
(define-syntax with-directory
|
||||
(syntax-rules ()
|
||||
((with-directory path form . forms)
|
||||
(let ((current-dir (current-directory)))
|
||||
(set-working-directory path)
|
||||
(prog1
|
||||
(begin form . forms)
|
||||
(change-directory current-dir))))))
|
||||
19
utils.scm
Normal file
19
utils.scm
Normal file
@@ -0,0 +1,19 @@
|
||||
(declare (unit utils))
|
||||
|
||||
(include "utils.macros.scm")
|
||||
|
||||
(import
|
||||
(chicken pathname)
|
||||
(chicken process-context))
|
||||
|
||||
(define (get-env-var name)
|
||||
(get-environment-variable name))
|
||||
|
||||
(define (set-working-directory file)
|
||||
(change-directory
|
||||
(normalize-pathname
|
||||
(if (absolute-pathname? file)
|
||||
(pathname-directory file)
|
||||
(make-absolute-pathname
|
||||
(current-directory)
|
||||
(pathname-directory file))))))
|
||||
Reference in New Issue
Block a user