diff --git a/Readme.org b/Readme.org index 180770d..fc041b4 100644 --- a/Readme.org +++ b/Readme.org @@ -54,13 +54,13 @@ An example of Sex source: #+begin_src scheme (include stdio.h) -(pub fn int main ((int argc) (char **argv)) +(pub fn main ((argc int) (argv [* const char])) int (puts "Hello from Sex!") - (var (array char 512) name) + (var name [char 512]) (puts "What is your name?") - (scanf "%s" (cast char* &name)) + (scanf "%s" (cast (& name) (* char))) (printf "Hello, %s!\n" name) - 0) + (return 0)) #+end_src Compile and run: @@ -106,16 +106,16 @@ return Sex code. (pub defmacro (list-T type) (let ((list-type (cat 'list- type))) `(struct ,list-type - ((,type value) - ((* ,list-type) next))))) + ((value ,type) + (next (* ,list-type)))))) (list-T int) #+end_src -> #+begin_src scheme (struct list_int - ((int value) - ((* list_int) next))) + ((value int) + (next (* list_int)))) #+end_src **** Wrapper for checking return codes @@ -126,18 +126,17 @@ return Sex code. (puts ,message) (return ,ret-code)))) -(pub fn int init () +(pub fn init () int (check-sdl-return (SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1) ...) #+end_src -> -#+begin_src c -(%fun int init () +#+begin_src scheme +(pub fn init () int (if (< 0 (SDL_Init SDL_INIT_VIDEO)) - (%begin (puts "Failed to initialize SDL") (return 1))) + (begin (puts "Failed to initialize SDL") (return 1))) ...) -} #+end_src ** Use an established environment for development diff --git a/example/fns.sex b/example/fns.sex index 73aa0b2..da45fa2 100644 --- a/example/fns.sex +++ b/example/fns.sex @@ -1,10 +1,10 @@ ;;; Prototypes -(fn void puk ()) +(fn puk () void) -(pub fn void plak ()) +(pub fn plak () void) ;;; Functions -(fn int foo () (return 1)) +(fn foo () int (return 1)) -(pub fn void bar ((int a) (int b)) +(pub fn bar ((a int) (b int)) void (printf "%d\n" (+ a b))) diff --git a/example/hello-world.sex b/example/hello-world.sex index f5da6e2..42bc32d 100644 --- a/example/hello-world.sex +++ b/example/hello-world.sex @@ -1,9 +1,9 @@ (include stdio.h) -(pub fn int main ((int argc) (char **argv)) +(pub fn main ((argc int) (argv [* const char])) int (puts "Hello from Sex!") - (var (array char 512) name) + (var name [char 512]) (puts "What is your name?") - (scanf "%s" (cast char* &name)) + (scanf "%s" (cast (& name) (* char))) (printf "Hello, %s!\n" name) (return 0)) diff --git a/example/lambdas.sex b/example/lambdas.sex index 6a0bdcf..4ffaec3 100644 --- a/example/lambdas.sex +++ b/example/lambdas.sex @@ -1,21 +1,21 @@ (include stdio.h) -(fn int sum ((int a) (int b)) +(fn sum ((a int) (b int)) int (return (+ a b))) -(pub fn int main () - (var int a 10) - (var int b 20) - (var (fn int ((int) (int))) sum-fn sum) +(pub fn main () int + (var a int 10) + (var b int 20) + (var (fn ((int) (int)) int) sum-fn sum) - (var (fn int ((int) (int))) sum-lambda + (var (fn ((int) (int)) int) sum-lambda - (lambda int ((int a) (int b)) () + (lambda ((a int) (b int)) int () (return (+ a b)))) - (var (fn int ((int))) sum-lambda-2 + (var (fn ((int)) int) sum-lambda-2 - (lambda int ((int a)) () + (lambda ((a int)) int () (return (+ a 20)))) (printf "Hello from main fn!\n") @@ -24,15 +24,28 @@ (printf "Calling fn ptr: %d\n" (sum-fn a b)) (printf "Calling lambda: %d\n" (sum-lambda a b)) (printf "Calling other lambda: %d\n" (sum-lambda-2 a)) - (printf "Calling lambda inplace: %d\n" ((lambda int ((int a) (int b)) () + (printf "Calling lambda inplace: %d\n" ((lambda ((a int) (b int)) int () (return (+ a b 100))) a b)) - (var (fn int ((int))) l-1 - (lambda int ((int a)) () - (var (fn int ((int))) l-2 - (lambda int ((int a)) () + (var (fn ((int)) int) l-1 + (lambda ((a int)) int () + (var (fn ((int)) int) l-2 + (lambda ((a int)) int () (return (+ 60 a)))) (return (+ 600 (l-2 a))))) (printf "Calling nested lambdas: %d\n" (l-1 6)) + + ;; Not supported yet + ;; Closure + ;; (var (fn (fn ((int)) int) ((int))) make-adder + ;; (lambda (fn int ((int a))) () + ;; (return (lambda int ((int b)) (a) + ;; (return (+ a b)))))) + ;; + ;; (var (fn int ((int))) add-10 + ;; (make-adder 10)) + ;; (var (fn int ((int))) add-20 + ;; (make-adder 20)) + ;; (printf "Calling closures: %d\n" (add-10 24)) (return 0)) diff --git a/example/list.sex b/example/list.sex index bac0941..8355f73 100644 --- a/example/list.sex +++ b/example/list.sex @@ -1,21 +1,21 @@ (pub defmacro (list-T type) (let ((list-type (cat 'list- type))) `(struct ,list-type - ((,type value) - ((* (struct ,list-type)) next))))) + ((value ,type) + (next (* struct ,list-type)))))) (pub defmacro (make-list-T type is-public?) (let ((list-type (list 'struct (cat 'list- type))) (fn-name (cat 'make-list- type))) - `(,@(if is-public? '(pub) '()) fn (* ,list-type) ,fn-name () - (var (* ,list-type) list (cast (* ,list-type) (malloc (sizeof ,list-type)))) + `(,@(if is-public? '(pub) '()) fn ,fn-name () (* ,list-type) + (var list (* ,list-type) (cast (malloc (sizeof ,list-type)) (* ,list-type))) (= (-> list next) NULL) (return list)))) (pub defmacro (add-value-list-T type is-public?) (let ((list-type (list 'struct (cat 'list- type))) (fn-name (cat 'add-value-list- type))) - `(,@(if is-public? '(pub) '()) fn void ,fn-name ((,list-type *list) (,type value)) + `(,@(if is-public? '(pub) '()) fn ,fn-name ((list * ,list-type) (value ,type)) void (while (!= (-> list next) NULL) (= list (-> list next))) (= (-> list next) (,(cat 'make-list- type))) @@ -24,23 +24,24 @@ (pub defmacro (length-list-T type is-public?) (let ((fn-name (cat 'length-list- type)) (list-type (list 'struct (cat 'list- type)))) - `(,@(if is-public? '(pub) '()) fn size-t ,fn-name ((,list-type *list)) - (var size-t n 0) + `(,@(if is-public? '(pub) '()) fn ,fn-name ((list ,(cons '* list-type))) size-t + (var n size-t 0) (while (!= (-> list next) NULL) (= list (-> list next)) (++ n)) (return n)))) (pub defmacro (is-empty-list-T type is-public?) - `(,@(if is-public? '(pub) '()) fn bool ,(cat 'is-empty-list- type) - ((,(list 'struct (cat 'list- type)) *list)) + `(,@(if is-public? '(pub) '()) fn ,(cat 'is-empty-list- type) + ((list ,(list '* 'struct (cat 'list- type)))) + bool (return (== (-> list next) NULL)))) (pub defmacro (list-for-each list-type list-var elt-type elt-var what-do) (let ((list-var-2 (cat list-var '-2))) `(begin - (var (pointer ,list-type) ,list-var-2 ,list-var) - (var ,elt-type ,elt-var (-> ,list-var-2 value)) + (var ,list-var-2 (* ,list-type) ,list-var) + (var ,elt-var ,elt-type (-> ,list-var-2 value)) (while (!= (-> ,list-var-2 next) NULL) ,what-do (= ,list-var-2 (-> ,list-var-2 next)) diff --git a/example/test-list.sex b/example/test-list.sex index 3685c17..9f627dc 100644 --- a/example/test-list.sex +++ b/example/test-list.sex @@ -5,12 +5,12 @@ (import list) (struct foo - ((float a-field) - (int b) - ((const char *) c) - ((fn bool ((bool val))) not))) + ((a-field float) + (b int) + (c (* const char)) + (not (fn ((val bool)) bool)))) -(var (struct foo) f) +(var f (struct foo)) (list-T int) (make-list-T int #f) @@ -18,15 +18,16 @@ (length-list-T int #f) (is-empty-list-T int #f) -(extern fn void puk ((int a) (float b))) -(pub fn bool baz () (return true)) +(extern fn puk ((a int) (b float)) void) +(pub fn baz () bool + (return true)) -(extern var int i) -(var int j) -(pub var int k) +(extern var i int) +(var j int) +(pub var k int) -(pub fn int main () - (var (struct list-int) *l (make-list-int)) +(pub fn main () int + (var l (* struct list-int) (make-list-int)) (printf "Size of the list: %lu\n" (length-list-int l)) (add-value-list-int l 3) (add-value-list-int l 4) @@ -35,9 +36,9 @@ (printf "%d " v)) (printf "\n") (printf "Size of the list: %lu\n" (length-list-int l)) - (printf "%p\n" (cast void* l->next)) + (printf "%p\n" (cast l->next (* void))) (return 0)) -(pub fn void print-list (((const struct list-int) *l)) +(pub fn print-list ((l (* const struct list-int))) void (list-for-each (const struct list-int) l int v (printf "%d " v)) (printf "\n")) diff --git a/fmt-c-writer.scm b/fmt-c-writer.scm index 3682e5b..a9abd9b 100644 --- a/fmt-c-writer.scm +++ b/fmt-c-writer.scm @@ -2,14 +2,17 @@ (declare (unit fmt-c-writer) (uses fmt-c - semen)) + semen + utils)) (import (chicken string) brev-separate fmt + matchable regex srfi-1 ; lists srfi-13 ; strings + tree ) (define (unkebabify sym) @@ -27,15 +30,13 @@ (case atom ((fn) '%fun) ((prototype) '%prototype) - ((var) '%var) ((begin) '%block-begin) ((define) '%define) ((pointer) '%pointer) ((array) '%array) ((attribute) '%attribute) - ((@) 'vector-ref) + ((¤) 'vector-ref) ((include) '%include) - ((cast) '%cast) ;; uh things we do for c89 compatibility ((bool) 'int) ((true) 1) @@ -45,6 +46,12 @@ (unkebabify atom) atom)))) +(define (maybe-unwrap-type type) + (if (and (list? type) + (= 1 (length type))) + (car type) + type)) + (define (make-field-access form) (assert (= 2 (length form)) "Wrong field access format") @@ -52,77 +59,208 @@ (string->symbol (fmt #f (cadr form) (car form))))) -(define (walk-generic form acc) - (cond - ((null? form) (cons '() acc)) +(define (walk-generic-toplevel form) + (cond ((atom? form) (atom-to-fmt-c form)) + ((list? form) (map walk-generic-toplevel form)) + (else (error "Malformed form " form)))) - ;; vector, e.g. {}-initializer - ((vector? form) - (cons +(define (field-access-form? form) + (and (symbol? (car form)) + (char=? #\. (string-ref (symbol->string (car form)) 0)))) + +(define (walk-expr form) + (match form + ((? vector?) (list->vector - (car (walk-generic (vector->list form) (list)))) - acc)) + (walk-expr (vector->list form)))) + ((? atom?) + (atom-to-fmt-c form)) + ((? field-access-form?) + (make-field-access form)) + (('var . _) (walk-var form)) + (('cast expr type) (list '%cast + (walk-type type) + (walk-expr expr))) + (('enum . _) (walk-enum form)) + ;; | is problematic... And c-or/bit-or/etc are actually + ;; procedures, so we have to call the procedure itself + (('c-or . rest) (apply c-or (map walk-expr rest))) + (('c-bit-or . rest) (apply c-bit-or (map walk-expr rest))) + (('c-bit-or= . rest) (apply c-bit-or= (map walk-expr rest))) + (else (map walk-expr form)))) - ;; atom (hopefully) - ((not (list? form)) (cons (atom-to-fmt-c form) acc)) +(define (walk-var form) + ;; (var a int) -> (%var int a) + ;; (var a (const int) 32) -> (%var (const int) a 32) + ;; (var b [const char 512]) -> (%var (%array (const char) 512) b) + ;; note: [...] is actually (¤ ...) after reading + ;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c) + `(%var + ,(walk-type (third form)) + ,(atom-to-fmt-c (second form)) + . + ,(if (null? (drop form 3)) + (list) + (walk-expr (drop form 3))) ; optional init expression + )) - ;; another special case - field access - ((and (symbol? (car form)) - (char=? #\. (string-ref (symbol->string (car form)) 0))) - (cons (make-field-access form) acc)) +(define (walk-type form) + ;; int -> int + ;; (const int) -> const int + ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512) + ;; [float 8] -> (%array float 8) + ;; (* const char) -> (const char *) + ;; (const * const * const char) -> (const char * const * const) + ;; (fn ((int) (float)) void) -> (%fun void ((int) (float))) + (match form + (('¤ . array-type) + (if (integer? (last array-type)) + ;; sized array + (let* ((type-list (drop-right array-type 1)) + (type (maybe-unwrap-type type-list)) + (size (last array-type))) + `(%array ,(walk-type type) + ,size)) + ;; sugar for pointer... Do we really need it? Guess why not, + ;; it's a strong semantic cue + `(%array ,(walk-type (maybe-unwrap-type array-type))))) + (('fn arglist ret-type) + `(%fun ,(walk-type ret-type) ,(walk-arglist arglist))) + (('fn . _) + (assert #f "Malformed function type form")) - ;; toplevel, or a start of a regular list form - (else - (let ((new-acc (list))) - (cons (fold-right - walk-generic - new-acc - form) - acc))))) + ;; Special case: nested structs/unions + ((or ('struct . _) + ('union . _)) (walk-struct form)) -(define (normalize-fn-form form) + (('enum . _) (walk-enum form)) + (else + (type-convert-to-c form)))) + +(define (type-convert-to-c type) + ;; Our pointers to C pointers + ;; int -> int + ;; * const char -> const char * + ;; const * const char -> const char * const + (if (atom? type) (atom-to-fmt-c type) + (flatten + (tree-map atom-to-fmt-c + (flatten + (list-join (reverse (list-split type '*)) + '(*))))))) + +(define (walk-fn-def form) + (match form + (('fn name args ret-type . maybe-body) + `(%fun + ,(walk-type ret-type) + ,(atom-to-fmt-c name) + ,(walk-arglist args) + . + ,(walk-expr maybe-body))))) + +;;; TODO: isn't there a better way? +(define (is-probably-type form) + (case (car form) + ((¤ * const volatile struct union) #t) + (else #f))) + +(define (walk-arglist form) + ;; E.g.: + ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32)) + ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4))) + (map (fn + (match x + (('¤ . _) (walk-type x)) + + ;; yeah shitty, but I don't know yet how to determine if the + ;; first entry is part of the type and not an argument name + ;; :( + ((? is-probably-type) (walk-type x)) + + ;; 1 element args are always type + ((_) (walk-type x)) + + ((var . type) (append (list (walk-type (maybe-unwrap-type type))) + (list (walk-type var)))))) + form)) + +(define (walk-function form) ;; (fn ret-type name arglist body) -> normal function ;; (fn ret-type name arglist) -> prototype (if (>= (length form) 5) - form - (cons 'prototype (cdr form)))) + (walk-fn-def form) + (cons '%prototype (cdr (walk-fn-def form))))) -(define (walk-function form static) - (if static - (walk-generic (list 'static (normalize-fn-form form)) - (list)) - (walk-generic (normalize-fn-form (cdr form)) - (list)))) +(define (process-struct-fields fields) + (map (fn + (let ((type (walk-type (last x)))) + (cons type (map atom-to-fmt-c (drop-right x 1))))) + fields)) + +(define (walk-struct form) + (match form + ((type (fields ...) . attrs) ; anonymous struct + `(,type ,(process-struct-fields fields) + . ,(tree-map atom-to-fmt-c attrs))) + ((type name) ; simple 'struct whatever', like in variable def + `(,type ,(atom-to-fmt-c name))) + ((type name (fields ...) . attrs) + `(,type ,(atom-to-fmt-c name) + ,(process-struct-fields fields) + . ,(tree-map atom-to-fmt-c attrs))) + (else (error "Malformed aggregate definition " form)))) + +(define (walk-enum form) + (match form + (('enum (values ...)) + `(enum ,(map atom-to-fmt-c values))) + (('enum name (values ...)) + `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values))))) (define (walk-extern form) - (case (cadr form) - ((fn) - (list (cons 'extern (walk-function form #f)))) - ((var) - (list (cons 'extern (walk-generic (cdr form) (list))))) + (match form + (('fn . _) + ;; extern function?.. What + (list 'extern (walk-function form))) + (('var . _) + (list 'extern (walk-var form))) (else (error "Extern what?")))) (define (walk-public form) - (case (cadr form) - ((fn) - (walk-function form #f)) - ((var) - (walk-generic (list 'static (cdr form)) (list))) - ((define defmacro import include struct typedef union var) + (match form + (('fn . _) + (walk-function form)) + (('var . _) + (walk-var form)) + ((or ('define . _) + ('defmacro . _) + + ('import . _) + ('include . _) + + ('struct . _) + ('union . _) + + ('typedef . _)) ;; ignore here, used in generating public interface - (process-toplevel-form (cdr form))) + (process-toplevel-form form)) (else (error "Pub what?" (cadr form))))) (define (process-toplevel-form form) - ;; todo: rewrite to match - (case (car form) - ((fn) (walk-function form #t)) - ((extern) (walk-extern form)) - ((pub) (walk-public form)) - (else (walk-generic form (list))))) + (match form + (('fn . _) (list 'static (walk-function form))) + (('var . _) (list 'static (walk-var form))) + (('extern . rest) (walk-extern rest)) + (('pub . rest) (walk-public rest)) + ((or ('struct . _) + ('union . _)) (walk-struct form)) + (('enum . _) (walk-enum form)) + (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest)) + (else (walk-expr form)))) (define (emit-c sex-forms) (for-each (lambda (form) - (fmt #t (c-expr (car (process-toplevel-form form))) nl)) + (fmt #t (c-expr (process-toplevel-form form)) nl)) sex-forms)) diff --git a/fmt-c.scm b/fmt-c.scm index 71602f4..7828762 100644 --- a/fmt-c.scm +++ b/fmt-c.scm @@ -9,6 +9,7 @@ (declare (unit fmt-c)) (import fmt + srfi-1 srfi-13) (define (fmt-in-macro? st) (fmt-ref st 'in-macro?)) @@ -84,7 +85,8 @@ (define (c-maybe-paren op x) (lambda (st) ((fmt-let 'op op - (if (c-op<= (fmt-op st) op) + (if (and (c-op<= (fmt-op st) op) + (not (vector? st))) (c-paren x) x)) st))) @@ -557,10 +559,13 @@ ;; data structures (define (c-struct/aux type x . o) + ;; can be just pointer to SUC, need to support such case: + ;; struct whatever * - body is just '*' (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)) + (if (and (not (null? body)) + (not (eq? '* body))) (c-wrap-stmt (cat (c-braced-block @@ -572,7 +577,13 @@ (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) "")))))) + (cat type + (if (and name (not (equal? name ""))) + (cat " " name) + "") + (if (not (null? body)) + (cat body) + "")))))) (define (c-struct . args) (apply c-struct/aux "struct" args)) (define (c-union . args) (apply c-struct/aux "union" args)) @@ -597,9 +608,11 @@ (define (c-while check . body) (c-reset-newline - (cat (c-block (cat "while (" (c-in-test (c-expr check)) ")") - (c-in-stmt (apply c-begin body))) - fl))) + (if (null? body) + (cat "while (" (c-in-test (c-expr check)) ");") + (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) (c-reset-newline @@ -614,7 +627,7 @@ (define (c-param x) (cond ((procedure? x) x) - ((pair? x) (c-type (car x) (cadr x))) + ((pair? x) (c-param-type (car x) (cadr x))) (else (error "missing type" x)))) (define (c-field x) @@ -688,6 +701,33 @@ (else (cat (if (eq? '%pointer type) '* type) (if name (cat " " name) "")))))) +(define (c-param-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)))) + (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) diff --git a/semen.scm b/semen.scm index 8d7d4a3..8912dc1 100644 --- a/semen.scm +++ b/semen.scm @@ -2,7 +2,8 @@ (declare (unit semen) (uses sex-macros - sex-modules)) + sex-modules + utils)) (import (chicken string) @@ -56,10 +57,13 @@ ('pub 'struct . _)) (process-struct sex-form acc)) ((or ('union . _) ('pub 'union . _)) (process-struct sex-form acc)) + ((or ('enum . _) + ('pub 'enum . _)) (process-struct sex-form acc)) ((or ('var . _) ('pub 'var . _) ('extern 'var . _)) (process-global-var sex-form acc)) (('include _) (cons sex-form acc)) + (('define . _) (cons sex-form acc)) (('import . modules) (semen-process-imports (get-public-forms modules) acc)) @@ -67,6 +71,10 @@ ((or ('defmacro . rest) ('pub 'defmacro . rest)) (defmacro rest) acc) + ((or ('typedef new-type target) + ('pub 'typedef new-type target)) + (process-typedef new-type target acc)) + (else (assert #f (fmt #f "Unknown top level form " sex-form))))) (define (semen-process-imports module-public-forms acc) @@ -88,28 +96,41 @@ form (lambda (subform env) (if (sex-macro? subform) - (apply-macro subform) + (cons semen-walk-embed-result (semen-apply-macro subform (list))) subform)) #f)) -;;; TODO: for greater inspiration, see SBCL's walk.lisp and their -;;; template system. Maybe it is worth it to implement something -;;; similar here +;;; semen-walk-form and friends: form walker with various abilities. +;;; By default, replaces walked form with walk-fn result But may +;;; perform additional operations depending of what the walk function +;;; has requested. + +;;; For inspiration, see SBCL's walk.lisp and their template +;;; system. + +(define semen-walk-embed-result (gensym) + ;; For cases when result is a list which must be embedded in the + ;; form, e.g. when it returned from a macro + ) + (define (semen-walk-form form walk-fn env) (if (atom? form) form (let ((new-form (walk-fn form env))) (cond ((not (eq? form new-form)) (semen-walk-form new-form walk-fn env)) - (else (recons - new-form - (semen-walk-form (car new-form) walk-fn env) - (semen-walk-form (cdr new-form) walk-fn env))))))) + (else + (let ((new-car (semen-walk-form (car new-form) walk-fn env)) + (new-cdr (semen-walk-form (cdr new-form) walk-fn env))) + (cond ((and (pair? new-car) + (eq? (car new-car) semen-walk-embed-result)) + (append (cdr new-car) new-cdr)) + (else + (recons new-form new-car new-cdr))))))))) -(define (recons old-cons new-car new-cdr) - (if (and (eq? new-car (car old-cons)) - (eq? new-cdr (cdr old-cons))) - old-cons - (cons new-car new-cdr))) +;;; Typdef + +(define (process-typedef new-type target acc) + (cons `(typedef ,target ,new-type) acc)) ;;; Fn processing @@ -153,7 +174,7 @@ (process-fn `(fn ,ret-type ,name ,arglist ,@body) (list))) (else (assert #f (fmt #f "Malformed lambda " form))))) -;;; Struct +;;; Structs (define (process-struct sex-struct acc) (cons sex-struct acc)) diff --git a/sex-reader.scm b/sex-reader.scm index 2f3f07b..05f192f 100644 --- a/sex-reader.scm +++ b/sex-reader.scm @@ -2,9 +2,15 @@ (include "utils.macros.scm") -(import (chicken pathname) - brev-separate - fmt) +(import + (chicken base) + (chicken io) + (chicken pathname) + (chicken port) + (chicken read-syntax) + (chicken string) + brev-separate + fmt) (define (read-forms acc) (let ((r (read))) @@ -16,7 +22,41 @@ (with-input-from-file (pathname-strip-directory file) (fn (read-forms (list)))))) +(define (read-bracket port) + (let loop ((c (read-char port)) + (str (string))) + (cond ((char=? c #\]) + (cons '¤ + (with-input-from-string str + (fn (port-map identity read))))) + ((char=? c #\[) + (loop port (conc ))) + (else + (loop (read-char port) + (conc str c)))))) + +(define open-bracket-counter (make-parameter 0)) + (define (read-raw-forms input-source) + (let ((bracket-end (gensym))) + (set-read-syntax! + #\] + (lambda (port) + (when (= 0 (open-bracket-counter)) + (error "Unmatched closing bracket")) + (open-bracket-counter (- (open-bracket-counter) 1)) + bracket-end)) + + (set-read-syntax! + #\[ + (lambda (port) + (open-bracket-counter (+ (open-bracket-counter) 1)) + (let loop ((r (read port)) + (acc (list))) + (if (eq? r bracket-end) + (cons '¤ (reverse acc)) + (loop (read port) + (cons r acc))))))) (if (eq? input-source 'stdin) (read-forms (list)) (read-from-file input-source))) diff --git a/sexc.scm b/sexc.scm index 9fc4e2f..f8d0414 100644 --- a/sexc.scm +++ b/sexc.scm @@ -117,6 +117,18 @@ (with-directory input-source (semen-process raw-forms)))) +(define prelude + '((include inttypes.h) + + (typedef u8 uint8-t) + (typedef i8 int8-t) + (typedef u16 uint16-t) + (typedef i16 int16-t) + (typedef u32 uint32-t) + (typedef i32 int32-t) + (typedef u64 uint64-t) + (typedef i64 int64-t))) + (define (main) (let* ((raw-args (command-line-arguments)) (args (getopt-long raw-args @@ -142,7 +154,7 @@ (return #f)) (load-persistent-module-paths) - (let* ((raw-forms (read-raw-forms input)) + (let* ((raw-forms (append prelude (read-raw-forms input))) (sex-forms (semantic-process-forms raw-forms input))) (if (or (get-arg args 'macro-expand #f) (get-arg args 'emit-c #f)) diff --git a/tests/basic.scm b/tests/basic.scm index 847a7bd..8b0dfe9 100644 --- a/tests/basic.scm +++ b/tests/basic.scm @@ -1,35 +1,31 @@ -(test-begin "basic") +(test-group "basic" -;;; 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 '--->>>)) + ;; 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)) + ;; atom-to-fmt-c + (test '%fun (atom-to-fmt-c 'fn)) + (test '%prototype (atom-to-fmt-c 'prototype)) + (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)) -;;; c89 stuff -(test 'int (atom-to-fmt-c 'bool)) -(test 1 (atom-to-fmt-c 'true)) -(test 0 (atom-to-fmt-c 'false)) + ;; 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))) - -(test-end) + ;; make-field-access + (test 'a.b (make-field-access '(.b a))) + (test 'a.b.c (make-field-access '(.c a.b)))) diff --git a/tests/fmt-c-writer.scm b/tests/fmt-c-writer.scm new file mode 100644 index 0000000..ba103c1 --- /dev/null +++ b/tests/fmt-c-writer.scm @@ -0,0 +1,159 @@ +;;; Types +(test-group "fmt-writer" + + (test + '(const int) + (walk-type '(const int))) + + (test + '(%array (const char) 512) + (walk-type '(¤ const char 512))) + + (test + '(%array (float) 512) + (walk-type '(¤ (float) 512))) + + (test + '(%array (const char) 512) + (walk-type '(¤ (const char) 512))) + + (test + '(%array (const char)) + (walk-type '(¤ const char))) + + (test + '(%array (const char)) + (walk-type '(¤ (const char)))) + + (test + '(%array float 8) + (walk-type '(¤ float 8))) + + (test + "Pointer to const char" + '(const char *) + (walk-type '(* const char))) + + (test + "Const pointer to const char" + '(const char * const) + (walk-type '(const * const char))) + + (test + '(%fun void ((int) (float) (%array (struct what * const)))) + (walk-type '(fn ((int) (float) (¤ (const * struct what))) void))) + + (test + '(%fun void ((int) (%array float) (%array (struct what * const)))) + (walk-type '(fn ((int) (¤ float) (¤ (const * struct what))) void))) + + (test + '(%array (%fun void ((int) (%array float) (%array (struct what * const))))) + (walk-type '(¤ (fn ((int) (¤ float) (¤ (const * struct what))) void)))) + + ;; Type convert to C + (test + '(int) + (type-convert-to-c '(int))) + + (test + '(* int) + (type-convert-to-c '(int *))) + + (test + '(* const int) + (type-convert-to-c '(const int *))) + + (test + '(const * const char) + (type-convert-to-c '(const char * const))) + +;;; Variable defs + (test + '(%var (%array float 8) a) + (walk-var '(var a (¤ float 8)))) + + (test + '(%var (int *) a (& n)) + (walk-var '(var a (* int) (& n)))) + + (test + '(%var (const int *) a (& n)) + (walk-var '(var a (* const int) (& n)))) + + (test + '(%var (struct suc) s) + (walk-var '(var s (struct suc)))) + + (test + '(%var (const struct suc *) s s1) + (walk-var '(var s (* const struct suc) s1))) + + (test + '(%var (const struct suc *) s s1) + (walk-var '(var s (* (const struct suc)) s1))) + + (test + '(%var (struct suc) s (hoge piyo)) + (walk-var '(var s (struct suc) (hoge piyo)))) + + (test + '(%var (struct suc *) s (hoge piyo)) + (walk-var '(var s (* struct suc) (hoge piyo)))) + +;;; Fn defs + (test + '(%fun void puk ((int) (%array float 8))) + (walk-fn-def '(fn puk ((int) (¤ float 8)) void))) + + (test + '(%fun int main ((int argc) ((%array (const char)) argv)) + (return 0)) + (walk-fn-def + '(fn main ((argc int) (argv (¤ const char))) int + (return 0)))) + (test + '(%fun int quxu (((struct piq *) bar)) + (return 0)) + (walk-fn-def + '(fn quxu ((bar (* struct piq))) int + (return 0)))) + + (test + '(%fun int quxu (((struct piq *) bar) ((%array (struct tt *)) ploop)) + (return 0)) + (walk-fn-def + '(fn quxu ((bar (* struct piq)) (ploop (¤ * struct tt))) int + (return 0)))) + + ;; Structs + (test + '(struct no_kebab ((int a) (float f))) + (walk-struct '(struct no-kebab ((a int) (f float))))) + + (test + '(struct settings ((u32 x y w h) + ((%array (struct ((float r g b a))) 4) colors))) + (walk-struct + '(struct settings + ((x y w h u32) + (colors [¤ struct ((r g b a float)) 4]))))) + + (test + '(struct settings ((u32 x y w h) + ((%array (struct color ((float r g b a))) 4) colors))) + (walk-struct + '(struct settings + ((x y w h u32) + (colors [¤ struct color ((r g b a float)) 4]))))) + + (test + '(struct mega_kebab ((int a) + ((struct ((int year) (int month) (int day))) dob) + ((%fun int ((int) (%array int))) min))) + (walk-struct '(struct mega-kebab + ((a int) + (dob (struct ((year int) + (month int) + (day int)))) + (min (fn ((int) (¤ int)) bool))))))) diff --git a/tests/reader.scm b/tests/reader.scm new file mode 100644 index 0000000..8edb836 --- /dev/null +++ b/tests/reader.scm @@ -0,0 +1,17 @@ +(import (chicken port)) + +(define-syntax reader-test + (syntax-rules () + ((reader-test result string) + (test result + (with-input-from-string string + (lambda () (read-raw-forms 'stdin))))))) + +(test-group "reader" + ;; []-syntax. For array types and array access expressions + (reader-test '((¤ * char)) "[* char]") + (reader-test '((¤ * * char const 512)) "[* * char const 512]") + (reader-test '((¤)) "[]") + (reader-test '((¤ (¤))) "[[]]") + (reader-test '((¤ (¤ const char))) "[[const char]]") +) diff --git a/tests/run.scm b/tests/run.scm index 00d6c8a..2e09267 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -9,6 +9,9 @@ (include "basic.scm") (include "semen.scm") +(include "reader.scm") +(include "fmt-c-writer.scm") +(include "utils.scm") ;;; Should be the last in the test suite (test-exit) diff --git a/tests/semen.scm b/tests/semen.scm index cb85a4d..722776f 100644 --- a/tests/semen.scm +++ b/tests/semen.scm @@ -8,51 +8,49 @@ '(pub fn float sum ((int a) (int b)) (return (cast float (+ a b))))) -(test-begin "semen") -(test-assert (sex-fn? print-str-fn)) -(test #f (sex-fn-public? print-str-fn)) -(test 'void (sex-fn-return-type print-str-fn)) -(test 'print-str (sex-fn-name print-str-fn)) -(test '((string s)) (sex-fn-arglist print-str-fn)) -(test '(fn void print-str ((string s))) (sex-fn-prototype print-str-fn)) -(test '((printf "%s" s)) (sex-fn-body print-str-fn)) +(test-group "semen" + (test-assert (sex-fn? print-str-fn)) + (test #f (sex-fn-public? print-str-fn)) + (test 'void (sex-fn-return-type print-str-fn)) + (test 'print-str (sex-fn-name print-str-fn)) + (test '((string s)) (sex-fn-arglist print-str-fn)) + (test '(fn void print-str ((string s))) (sex-fn-prototype print-str-fn)) + (test '((printf "%s" s)) (sex-fn-body print-str-fn)) -(test-assert (sex-fn? sum-fn)) -(test #t (sex-fn-public? sum-fn)) -(test 'float (sex-fn-return-type sum-fn)) -(test 'sum (sex-fn-name sum-fn)) -(test '((int a) (int b)) (sex-fn-arglist sum-fn)) -(test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn)) -(test '((return (cast float (+ a b)))) (sex-fn-body sum-fn)) + (test-assert (sex-fn? sum-fn)) + (test #t (sex-fn-public? sum-fn)) + (test 'float (sex-fn-return-type sum-fn)) + (test 'sum (sex-fn-name sum-fn)) + (test '((int a) (int b)) (sex-fn-arglist sum-fn)) + (test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn)) + (test '((return (cast float (+ a b)))) (sex-fn-body sum-fn)) -(let ((sex-code - '((defmacro (sum-var name a b c) - `(var ,name ,(+ a b c))) + (let ((sex-code + '((defmacro (sum-var name a b c) + `(var ,name ,(+ a b c))) - (sum-var v 1 2 3)))) + (sum-var v 1 2 3)))) - (test '((var v 6)) (semen-process sex-code))) + (test '((var v 6)) (semen-process sex-code))) ;;; Macro expansion -(define (form-identity form env) - form) + (define (form-identity form env) + form) -(test 'a (semen-walk-form 'a form-identity (make-hash-table))) -(test '(a b c) (semen-walk-form '(a b c) form-identity (make-hash-table))) + (test 'a (semen-walk-form 'a form-identity (make-hash-table))) + (test '(a b c) (semen-walk-form '(a b c) form-identity (make-hash-table))) -(test 'a (semen-macro-expand 'a)) -(test '(a b c) (semen-macro-expand '(a b c))) + (test 'a (semen-macro-expand 'a)) + (test '(a b c) (semen-macro-expand '(a b c))) -(let ((sex-code-macro - '((defmacro (x10 a) - `(* 10 ,a)) + (let ((sex-code-macro + '((defmacro (x10 a) + `(* 10 ,a)) - (fn void foo ((int a) (int b)) - (return (+ a (x10 b))))))) + (fn void foo ((int a) (int b)) + (return (+ a (x10 b))))))) - (test '((fn void foo ((int a) (int b)) - (return (+ a (* 10 b))))) - (semen-process sex-code-macro))) - -(test-end) + (test '((fn void foo ((int a) (int b)) + (return (+ a (* 10 b))))) + (semen-process sex-code-macro)))) diff --git a/tests/utils.scm b/tests/utils.scm new file mode 100644 index 0000000..6f9013f --- /dev/null +++ b/tests/utils.scm @@ -0,0 +1,22 @@ +(test-group "utils" + + (test + '((1) (2) (3)) + (list-split '(1 * 2 * 3) '*)) + + (test + '((1 2 3)) + (list-split '(1 2 3) '*)) + + (test + '(() (1) (2) (3) ()) + (list-split '(* 1 * 2 * 3 *) '*)) + + (test + '((const) (const struct something)) + (list-split '(const * const struct something) '*)) + + (test + '(1 * 2 * 3) + (list-join '(1 2 3) '*)) +) diff --git a/utils.scm b/utils.scm index dd0506e..c4fb8e8 100644 --- a/utils.scm +++ b/utils.scm @@ -4,7 +4,8 @@ (import (chicken pathname) - (chicken process-context)) + (chicken process-context) + srfi-1) (define (get-env-var name) (get-environment-variable name)) @@ -17,3 +18,28 @@ (make-absolute-pathname (current-directory) (pathname-directory file)))))) + +(define (list-split src-list split-elt) + ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6)) + (fold (lambda (elt acc) + (if (eq? elt split-elt) + (append acc (list (list))) + (append (drop-right acc 1) + (list (append (last acc) (list elt)))))) + (list (list)) + src-list)) + +(define (list-join lists join-by) + (drop-right + (fold (lambda (elt acc) + (append acc (list elt) (list join-by))) + (list) + lists) + 1)) + +;;; Reconstruct form +(define (recons old-cons new-car new-cdr) + (if (and (eq? new-car (car old-cons)) + (eq? new-cdr (cdr old-cons))) + old-cons + (cons new-car new-cdr)))