diff --git a/lib/list.hsex b/lib/list.hsex index 119dece..22960b7 100644 --- a/lib/list.hsex +++ b/lib/list.hsex @@ -1,40 +1,36 @@ -(template (T) - struct list-T - ((T value) - ((list-T *) next))) +(template (list-T (T)) + (struct list-T + ((T value) + ((* list-T) next)))) -(template (T) - pub fn (list-T *) make-list-T () - (var (list-T *) list (malloc (sizeof list-T))) - (= (-> list next) NULL) - list) +(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 (T) - 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 (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 (T) - 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 (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 (T) - pub fn bool is-empty-list-T ((list-T *list)) - (== (-> list next) NULL)) +(template (is-empty-list-T (T) is-public?) + (,@(if is-public? '(pub) '()) fn bool is-empty-list-T ((list-T *list)) + (== (-> list next) NULL))) -(define-syntax list-for-each - (syntax-rules () - ((_ list-var elt-var what-do ...) - '(begin - ;; todo: that int here is not good - (var int elt-var (-> list-var value)) - (while (!= (-> list-var next) NULL) - what-do ... - (= list-var (-> list-var next)) - (= elt-var (-> list-var value))))))) +(template (list-for-each (what-do list-var elt-var)) + (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/lib/test-list.sex b/lib/test-list.sex index 7657bd1..4664329 100644 --- a/lib/test-list.sex +++ b/lib/test-list.sex @@ -5,11 +5,17 @@ (load "list.hsex") -(instance list-int list-T (int)) -(instance make-list-int make-list-T (int)) -(instance add-value-list-int add-value-list-T (int)) -(instance length-list-int length-list-T (int)) -(instance is-empty-list-int is-empty-list-T (int)) +(struct foo + ((float a) + (int b))) + +,(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) + +(fn bool bar () false) (pub fn int main () (var (* list-int) l (make-list-int)) @@ -17,6 +23,6 @@ (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 (printf "%d " v)) + ,(list-for-each '((printf "%d " v) l v)) (printf "\n") 0) diff --git a/sexc.scm b/sexc.scm index a36625f..8a51b40 100644 --- a/sexc.scm +++ b/sexc.scm @@ -45,37 +45,44 @@ (eq? (car node) symbol)) #f))) -(define (walk-generic form) - (tree-map - atom-to-fmt-c - (let ((ret-form form)) - (let loop ((unquote-form (tree-find (tree-finder 'unquote) form #f))) - (if unquote-form - (begin - (set! ret-form (tree-replace (invert-tree form) - unquote-form - (eval (cadr unquote-form)))) - (loop (tree-find (tree-finder 'unquote) - ret-form - #f))) - ret-form))))) +(define (walk-generic form acc) + (if (eq? (car form) 'unquote) + ;; special case - replace top-level unquote with it's expansion + (append + (fold append (list) + (map (fn (walk-sex-tree x (list))) + (eval (cadr form)))) + acc) + (let loop ((unquote-form (tree-find (tree-finder 'unquote) form #f))) + (if unquote-form + (begin + (let* ((inv (invert-tree form)) + (pos (tree-local-position inv unquote-form))) + (for-each (fn + (set! form (tree-insert inv (tree-parent inv unquote-form) pos x)) + (set! inv (invert-tree form))) + (reverse (eval (cadr unquote-form)))) + (set! form (tree-prune inv unquote-form))) + (loop (tree-find (tree-finder 'unquote) + form + #f))) + (cons (tree-map atom-to-fmt-c form) acc))))) -(define (walk-function form static) +(define (walk-function form static acc) (if static - (list 'static (walk-generic form)) - (walk-generic (cdr form)))) + (walk-generic (list 'static form) acc) + (walk-generic (cdr form) acc))) (define (walk-struct form acc) (let ((name (unkebabify (cadr form)))) - (cons (walk-generic form) - (cons `(typedef struct ,name ,name) acc)))) + (walk-generic form (cons `(typedef struct ,name ,name) acc)))) (define (walk-sex-tree form acc) (case (car form) - ((fn) (cons (walk-function form #t) acc)) - ((pub) (cons (walk-function form #f) acc)) + ((fn) (walk-function form #t acc)) + ((pub) (walk-function form #f acc)) ((struct) (walk-struct form acc)) - (else (cons (walk-generic form) acc)))) + (else (walk-generic form acc)))) (define (process-form form acc) (case (car form) diff --git a/templates.scm b/templates.scm index 9407e56..871c803 100644 --- a/templates.scm +++ b/templates.scm @@ -6,74 +6,14 @@ srfi-1 ; list routines tree) -;;; template structure storage example: -;;; (name (T U) ((T field-1) (U field-2)))) -;;; -;;; template function storage example: -;;; (name (T U) public? T-ret ((T arg-1) (U arg-2)) body) - -(define template-functions (list)) -(define template-structures (list)) - -(define (template-name template) - (first template)) - -(define (template-subst-list template) - (second template)) - -(define (template-struct-fields template) - (third template)) - -(define (template-fn-public? template) - (third template)) - -(define (template-fn-return-type template) - (fourth template)) - -(define (template-fn-arglist template) - (fifth template)) - -(define (template-fn-body template) - (sixth template)) - -(define (find-template name subst-list template-storage) - (find (fn (and (eq? name (template-name x)) - (= (length subst-list) - (length (template-subst-list x))))) - template-storage)) - -(define (check-template-doesnt-exist name subst-list) - (when (find-template - name subst-list - template-functions) - (error "Template function with this name and number of parameters already exists")) - (when (find-template - name subst-list - template-structures) - (error "Template structure with this name and number of parameters already exists"))) - -(define (register-template-fn subst-list public? return-type name arg-list body) - (check-template-doesnt-exist name subst-list) - (when +debug+ - (fmt #t (fmt-join dsp (list "Adding template fn" public? return-type name subst-list) " ") nl)) - (set! template-functions - (cons (list name subst-list public? return-type arg-list body) template-functions))) - -(define (register-template-struct subst-list name fields) - (check-template-doesnt-exist name subst-list) - (when +debug+ - (fmt #t (fmt-join dsp (list "Adding template structure" name subst-list fields) " ") nl)) - (set! template-structures - (cons (list name subst-list fields) template-structures))) (define-syntax template - (syntax-rules (pub fn struct) - ((_ (T ...) pub fn ret-type name args body ...) - (register-template-fn (list 'T ...) #t 'ret-type 'name 'args (list 'body ...))) - ((_ (T ...) fn ret-type name args body ...) - (register-template-fn (list 'T ...) #f 'ret-type 'name 'args (list 'body ...))) - ((_ (T ...) struct name fields) - (register-template-struct (list 'T ...) 'name 'fields)))) + (syntax-rules () + ((_ (name subst-list args ...) body ...) + (define (name subst-list-arg args ...) + (let* ((subst-alist (map cons 'subst-list subst-list-arg)) + (replaced-body (apply-substitution `(body ...) subst-alist))) + replaced-body))))) (define (apply-symbol-substitution sym subst-alist) ;; All non-symbol substitutions will be filtered. @@ -114,41 +54,3 @@ st)) x)) target)) - -(define (instantiate-template-fn instance-name fun subst-alist) - `(,@((fn (if (template-fn-public? fun) '(pub) '()))) - fn - ,(apply-substitution (template-fn-return-type fun) subst-alist) - ,instance-name - ,(apply-substitution (template-fn-arglist fun) subst-alist) - ,@(apply-substitution (template-fn-body fun) subst-alist))) - -(define (instantiate-template-struct instance-name struct subst-alist) - (list 'struct instance-name - (apply-substitution (template-struct-fields struct) - subst-alist))) - -(define (instantiate-template instance-name template subst-list) - (let ((struct (find-template template subst-list template-structures)) - (fn (find-template template subst-list template-functions))) - (when (and struct fn) - (error (fmt #f "Both template structure and function are defined. Shouldn't have happened\n" - "Struct: " struct nl - "Fn: " fn nl))) - (unless (or struct fn) - (error (fmt #f "Template with name " template " was not found." nl - "Known template fns: " (fmt-join dsp (map template-name template-functions) - "\n ") - nl - "Known template structs: " (fmt-join dsp (map template-name template-structures) - "\n ")))) - (let ((subst-alist - (map cons (template-subst-list (or struct fn)) subst-list))) - (if struct - (instantiate-template-struct instance-name struct subst-alist) - (instantiate-template-fn instance-name fn subst-alist))))) - -(define-syntax instance - (syntax-rules () - ((_ instance-name template subst-list) - (instantiate-template 'instance-name 'template 'subst-list))))