Makefile

@@ -12,9 +12,9 @@ main.o: main.scm
 %.o: %.scm
 	$(CHICKEN_C) $< -e -c -o $@
 
-sex-tests: $(OBJ) tests/run.scm
+sex-tests: $(OBJ) tests/*.scm
-	$(CHICKEN_C) tests/run.scm -c -o sex-tests.o
+	cd ./tests && $(CHICKEN_C) run.scm -c -o sex-tests.o
-	$(CHICKEN_C) $(OBJ) sex-tests.o -o sex-tests
+	$(CHICKEN_C) $(OBJ) ./tests/sex-tests.o -o sex-tests
 
 clean:
-	rm -f $(OBJ) sexc sex-tests main.o sex-test.o
+	rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o

example/list.sex

@@ -38,9 +38,10 @@
 
 (pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
   (let ((list-var-2 (cat list-var '-2)))
-    `((var (pointer ,list-type) ,list-var-2 ,list-var)
+    `((begin
-      (var ,elt-type ,elt-var (-> ,list-var-2 value))
+       (var (pointer ,list-type) ,list-var-2 ,list-var)
-      (while (!= (-> ,list-var-2 next) NULL)
+       (var ,elt-type ,elt-var (-> ,list-var-2 value))
-        ,what-do
+       (while (!= (-> ,list-var-2 next) NULL)
-        (= ,list-var-2 (-> ,list-var-2 next))
+         ,what-do
-        (= ,elt-var (-> ,list-var-2 value))))))
+         (= ,list-var-2 (-> ,list-var-2 next))
+         (= ,elt-var (-> ,list-var-2 value)))))))

example/test-list.sex

@@ -1,6 +1,5 @@
 (include stdlib.h)
 (include stddef.h)
-(include stdbool.h)
 (include stdio.h)
 
 (chicken-import srfi-1 brev-separate)                 ; list routines, e.g. fold
@@ -16,7 +15,7 @@
    ((const char *) c)
    ((fn bool ((bool val))) not)))
 
-(var foo f #((= .a-field 1.2)))
+(var foo f)
 
 (list-T int)
 (make-list-T int #f)
@@ -26,7 +25,7 @@
 
 (extern fn void puk ((int a) (float b)))
 (fn int bar () (return ,(imports-test 10 20 30)))
-(pub fn void baz () true)
+(pub fn bool baz () (return true))
 
 (extern var int i)
 (var int j)
@@ -34,15 +33,15 @@
 
 (pub fn int main ()
      (var (* list-int) l (make-list-int))
-     (printf "Size of the list: %zu\n" (length-list-int l))
+     (printf "Size of the list: %lu\n" (length-list-int l))
      (add-value-list-int l 3)
      (add-value-list-int l 4)
-     (printf "Size of the list: %zu\n" (length-list-int l))
+     (printf "Size of the list: %lu\n" (length-list-int l))
      (list-for-each list-int l int v
        (printf "%d " v))
      (printf "\n")
-     (printf "Size of the list: %zu\n" (length-list-int l))
+     (printf "Size of the list: %lu\n" (length-list-int l))
-     (printf "%p\n" l->next)
+     (printf "%p\n" (cast void* l->next))
      (return 0))
 
 (pub fn void print-list (((const list-int) *l))

fmt-c.scm

@@ -15,7 +15,6 @@
 (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?))
@@ -27,6 +26,8 @@
 
 (define (c-in-expr proc) (fmt-let 'expression? #t proc))
 (define (c-in-stmt proc) (fmt-let 'expression? #f proc))
+(define (c-reset-newline proc) (fmt-let 'newline-before-brace? #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))
 
@@ -218,6 +219,7 @@
              ((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1)
                      (cdr x)) st))
             ((%endif) ((apply cpp-endif (cdr x)) st))
+            ((%block-begin) ((apply c-braced-block #f (cdr x)) st))
             ((%block) ((apply c-braced-block (cdr x)) st))
             ((%comment) ((apply c-comment (cdr x)) st))
             ((:) ((apply c-label (cdr x)) st))
@@ -487,8 +489,12 @@
 
 (define (c-open-brace st)
   (if (fmt-newline-before-brace? st)
-      (cat nl (c-current-indent-string st) "{" nl)
+      (begin
-      (cat " {" nl)))
+        (fmt-set! st 'newline-before-brace? #t)
+        (cat "{" nl))
+      (begin
+        (fmt-set! st 'newline-before-brace? #t)
+        (cat " {" nl))))
 
 (define (c-close-brace st)
   (dsp "}"))
@@ -521,7 +527,7 @@
 
 (define (c-braced-block/aux offset header . body)
    (lambda (st)
-     ((cat header (c-open-brace st) (c-indent st offset)
+     ((cat (if header 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)))
@@ -590,24 +596,26 @@
 ;; basic control structures
 
 (define (c-while check . body)
-  (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
+  (c-reset-newline
-                (c-in-stmt (apply c-begin body)))
+   (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
-       fl))
+                 (c-in-stmt (apply c-begin body)))
+        fl)))
 
 (define (c-for init check update . body)
-  (cat
+  (c-reset-newline
-   (c-block
+   (cat
-    (c-in-expr
+    (c-block
-     (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; "
+     (c-in-expr
-          (c-expr update ) ")"))
+      (cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; "
-    (c-in-stmt (apply c-begin body)))
+           (c-expr update ) ")"))
-   fl))
+     (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))))
+    (else (error "missing type" x))))
 
 (define (c-field x)
   (cond
@@ -623,10 +631,12 @@
            (else (c-type (car x) (cadr x))))
          (c-type (car x)
                  (fmt-join c-expr (cdr x) ", "))))
-    (else (cat (lambda (st) ((c-type (fmt-default-type st)) st)) " " x))))
+    (else (error "missing type" x))))
 
 (define (c-param-list ls)
-  (c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", ")))
+  (if (null? ls)
+      (c-type 'void)
+      (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))
@@ -759,12 +769,13 @@
   (c-wrap-stmt (cat "goto " (c-expr label))))
 
 (define (c-switch val . clauses)
-  (lambda (st)
+  (c-reset-newline
-    ((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
+   (lambda (st)
-          (c-indent/switch st)
+     ((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
-          (c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
+           (c-indent/switch st)
-          (c-current-indent-string st) (c-close-brace st) fl)
+           (c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
-     st)))
+           (c-current-indent-string st) (c-close-brace st) fl)
+      st))))
 
 (define (c-switch-clause/breaks x)
   (lambda (st)

sex-mode.el

@@ -80,6 +80,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
 (put 'pub 'lisp-indent-function 'defun)
 (put 'defmacro 'lisp-indent-function 'defun)
 (put 'struct 'lisp-indent-function 'defun)
+(put 'union 'lisp-indent-function 'defun)
 (put 'var 'lisp-indent-function 0)
 (put 'import 'lisp-indent-function 1)
 

sexc.scm

@@ -1,7 +1,8 @@
 (declare (unit sexc)
          (uses fmt-c
                sex-macros
-               sex-modules))
+               sex-modules
+               sex-types))
 
 (include "utils.macros.scm")
 
@@ -12,6 +13,7 @@
         (chicken pretty-print)
         (chicken process)
         (chicken process-context)
+        (chicken port)
         (chicken string)
         fmt
         getopt-long
@@ -36,7 +38,7 @@
     ((fn) '%fun)
     ((prototype) '%prototype)
     ((var) '%var)
-    ((begin) '%begin)
+    ((begin) '%block-begin)
     ((define) '%define)
     ((pointer) '%pointer)
     ((array) '%array)
@@ -44,6 +46,10 @@
     ((@) 'vector-ref)
     ((include) '%include)
     ((cast) '%cast)
+    ;; uh things we do for c89 compatibility
+    ((bool) 'int)
+    ((true) 1)
+    ((false) 0)
     (else
      (if (symbol? atom)
          (unkebabify atom)
@@ -281,19 +287,19 @@
                       "cc"))
         (out-file (if (eq? output 'default)
                       "a.out"
-                      output))
+                      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)
+          (process compiler (append (list "-o" out-file "-std=c89" "-pedantic" "-x" "c")
                                     (if (get-arg args 'compile-object #f)
                                         (list "-c")
                                         (list))
+                                    (list "-")  ; read stdin
                                     (get-c-compiler-args args))))
       (lambda (out-port in-port pid)
+        (with-output-to-port in-port
+          (lambda () (emit-c sex-forms)))
+        (close-output-port in-port)
         (process-wait pid)))))
 
 (define (process-input input raw-forms)

tests/basic.scm

@@ -0,0 +1,31 @@
+;;; 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 '%block-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))
+
+;;; c89 stuff
+(test 'int (atom-to-fmt-c 'bool))
+(test 1 (atom-to-fmt-c 'true))
+(test 0 (atom-to-fmt-c 'false))
+
+;;; make-field-access
+(test 'a.b (make-field-access '(.b a)))
+(test 'a.b.c (make-field-access '(.c a.b)))

tests/run.scm

@@ -6,32 +6,8 @@
   srfi-1
   test)
 
-;;; unkebabify
+(include "basic.scm")
-(test '- (unkebabify '-))
+(include "types.scm")
-(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)

tests/types.scm

@@ -0,0 +1 @@
+(test "char *" (to-c-type '(%pointer char)))