From 48a3d06925c0d269e12184e7823aaad16af849b3 Mon Sep 17 00:00:00 2001 From: alex-eg Date: Tue, 21 Oct 2025 21:38:41 +0300 Subject: [PATCH] move Sex to better types Types, fns and vars are now written in another, better, more intuitive and readable way. Types: "pointer to const char" is "* const char" "array of pointers to volatile int" is "[* volatile int]" Read left to right Vars (as well as fn args, struct fields): (var name type) (struct vec3 ((x float) (y float) (z float)) (fn vec3-add ((v1 vec3) (v2 vec3)) vec3 ...) Also fns are now have return types after arg list. * is now must not be attached to any type name (or variable for that matter) --- example/fns.sex | 8 +-- example/hello-world.sex | 6 +- example/lambdas.sex | 41 +++++++---- example/list.sex | 23 +++--- example/test-list.sex | 29 ++++---- fmt-c-writer.scm | 155 ++++++++++++++++++++++++++++++++++++---- tests/fmt-c-writer.scm | 114 +++++++++++++++++++++++++++++ tests/run.scm | 1 + 8 files changed, 318 insertions(+), 59 deletions(-) create mode 100644 tests/fmt-c-writer.scm 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..388fc87 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) @@ -71,21 +72,133 @@ (char=? #\. (string-ref (symbol->string (car form)) 0))) (cons (make-field-access form) acc)) + ;; variable declaration inside function + ((eq? (car form) 'var) + (cons (walk-var form) acc)) + + ;; (cast expr type) -> (%cast type expr) + ((eq? (car form) 'cast) + (cons (list '%cast + (walk-type (drop form 2)) + (car (walk-generic (second form) (list)))) + acc)) + ;; toplevel, or a start of a regular list form (else - (let ((new-acc (list))) - (cons (fold-right - walk-generic - new-acc - form) - acc))))) + (cons (fold-right + walk-generic + (list) + 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) + (append + (list '%var) + (list (walk-type (flatten (third form)))) + (list (atom-to-fmt-c (second form))) + + (if (null? (drop form 3)) + (list) + (car (walk-generic (drop form 3) (list)))) ; optional init expression + )) + +(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 (drop-right array-type 1)) + (size (last array-type))) + `(%array ,(walk-type (flatten type)) + ,size)) + ;; sugar for pointer... Do we really need it? Guess why not, + ;; it's a strong semantic cue + `(%array ,(walk-type (flatten array-type))))) + (('fn arglist ret-type) + `(%fun ,(walk-type ret-type) ,(walk-arglist arglist))) + + ;; Special case: nested structs/unions + (('struct ((field-names field-types) ...) . attrs) + (append `(struct ,(process-struct-fields field-names field-types)) + (if (null? attrs) + (list) + (list (map atom-to-fmt-c attrs))))) + (('union ((field-names field-types) ...) . attrs) + (append `(union ,(process-struct-fields field-names field-types)) + (if (null? attrs) + (list) + (list (map atom-to-fmt-c attrs))))) + + (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) + (tree-map atom-to-fmt-c + (fold-right append (list) + (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) + ,(car (walk-generic name (list))) + ,(walk-arglist args) + . + ,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 (if (= 1 (length type)) + (car type) + type))) + (list (walk-type var)))))) + form)) (define (normalize-fn-form 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 @@ -94,6 +207,19 @@ (walk-generic (normalize-fn-form (cdr form)) (list)))) +(define (process-struct-fields names types) + (zip (map walk-type types) (map atom-to-fmt-c names))) + +(define (walk-struct form) + (match form + ((type name ((field-names field-types) ...) . attrs) + (list (append `(,type ,(atom-to-fmt-c name) + ,(process-struct-fields field-names field-types)) + (if (null? attrs) + (list) + (list (map atom-to-fmt-c attrs)))))) + (else (error "Malformed aggregate definition " form)))) + (define (walk-extern form) (case (cadr form) ((fn) @@ -107,7 +233,7 @@ ((fn) (walk-function form #f)) ((var) - (walk-generic (list 'static (cdr form)) (list))) + (walk-generic (walk-var (cdr form)) (list))) ((define defmacro import include struct typedef union var) ;; ignore here, used in generating public interface (process-toplevel-form (cdr form))) @@ -116,10 +242,13 @@ (define (process-toplevel-form form) ;; todo: rewrite to match + ;; for some reason should return list in a list; TODO: rewrite (case (car form) ((fn) (walk-function form #t)) + ((var) (walk-generic (list 'static (walk-var form)) (list))) ((extern) (walk-extern form)) ((pub) (walk-public form)) + ((struct union) (walk-struct form)) (else (walk-generic form (list))))) (define (emit-c sex-forms) diff --git a/tests/fmt-c-writer.scm b/tests/fmt-c-writer.scm new file mode 100644 index 0000000..2c898e3 --- /dev/null +++ b/tests/fmt-c-writer.scm @@ -0,0 +1,114 @@ +;;; 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) (struct what *))) + (walk-type '(fn ((int) (float) (* struct what)) void))) + + (test + '(%fun void ((int) (%array (float)) (struct what *))) + (walk-type '(fn ((int) (¤ float) (* struct what)) void))) + +;;; 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 (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 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/run.scm b/tests/run.scm index 6411d71..2e09267 100644 --- a/tests/run.scm +++ b/tests/run.scm @@ -10,6 +10,7 @@ (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