diff --git a/Makefile b/Makefile index ce57a7b..c6014fd 100644 --- a/Makefile +++ b/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 diff --git a/Readme.org b/Readme.org index 7f47040..e9cdc21 100644 --- a/Readme.org +++ b/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) - (printf "Hello, %s!\n" name) - (printf ,(foo)) - 0) + (puts "Hello from Sex!") + (var (array char 512) name) + (puts "What is your name?") + (scanf "%s" (cast char* &name)) + (printf "Hello, %s!\n" name) + 0) #+end_src -The resulting C source: +Compile and run: #+begin_src -#include - -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 diff --git a/example/hello-world.sex b/example/hello-world.sex new file mode 100644 index 0000000..f5da6e2 --- /dev/null +++ b/example/hello-world.sex @@ -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)) diff --git a/example/list.seh b/example/list.seh deleted file mode 100644 index 8b445c0..0000000 --- a/example/list.seh +++ /dev/null @@ -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)))) diff --git a/example/list.sex b/example/list.sex new file mode 100644 index 0000000..62b2e9c --- /dev/null +++ b/example/list.sex @@ -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)))) diff --git a/example/test-list.sex b/example/test-list.sex index 73bfdfc..912e341 100644 --- a/example/test-list.sex +++ b/example/test-list.sex @@ -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")) diff --git a/fmt-c.scm b/fmt-c.scm new file mode 100644 index 0000000..2f8b92e --- /dev/null +++ b/fmt-c.scm @@ -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)) "--")) diff --git a/hello-world.sex b/hello-world.sex deleted file mode 100644 index 33a9410..0000000 --- a/hello-world.sex +++ /dev/null @@ -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) diff --git a/modules.scm b/modules.scm new file mode 100644 index 0000000..348e53c --- /dev/null +++ b/modules.scm @@ -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 ":")))))) diff --git a/sex-mode.el b/sex-mode.el index 23e47d1..c4f9c90 100644 --- a/sex-mode.el +++ b/sex-mode.el @@ -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" diff --git a/sexc.scm b/sexc.scm index d867f57..7f51748 100644 --- a/sexc.scm +++ b/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 - walk-generic - new-acc - form)) + (cons (fold-right + walk-generic + new-acc + 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,9 +151,9 @@ (define (walk-sex-tree form acc) (if (list? form) (if (template? form) - (fold (fn (walk-sex-tree x y)) - acc - (eval form)) + (fold-right (fn (walk-sex-tree x y)) + acc + (eval form)) (case (car form) ((fn) (walk-function form #t acc)) ((extern) (walk-extern form acc)) @@ -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" - (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" + (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)) + (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 #\m)))) + (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" + (required #f) + (value #f) + (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 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-input-from-file (pathname-strip-directory file) - (fn (read-forms (list))))) + (with-directory file + (with-input-from-file (pathname-strip-directory file) + (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) - (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))))))) + + (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)) + (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))))))) diff --git a/templates.scm b/templates.scm index 4510a12..c967e20 100644 --- a/templates.scm +++ b/templates.scm @@ -1,8 +1,8 @@ (declare (unit templates)) (import - (chicken plist) brev-separate + (chicken plist) fmt regex srfi-1 ; list routines diff --git a/tests/Makefile b/tests/Makefile new file mode 100644 index 0000000..8b13789 --- /dev/null +++ b/tests/Makefile @@ -0,0 +1 @@ + diff --git a/tests/run.scm b/tests/run.scm new file mode 100644 index 0000000..e786828 --- /dev/null +++ b/tests/run.scm @@ -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) diff --git a/utils.macros.scm b/utils.macros.scm new file mode 100644 index 0000000..190209c --- /dev/null +++ b/utils.macros.scm @@ -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)))))) diff --git a/utils.scm b/utils.scm new file mode 100644 index 0000000..dd0506e --- /dev/null +++ b/utils.scm @@ -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))))))