alex-eg/sex
1
0
Fork 1
Code Issues 3 Pull Requests 1 Actions Packages Projects 1 Releases Wiki Activity

unshittify templates

Browse Source
This commit is contained in:
alex-eg
2025-06-11 20:23:54 +03:00
parent 241d605db4
commit 19cc3ad43a
4 changed files with 78 additions and 167 deletions
Download Patch File Download Diff File Expand all files Collapse all files

66
lib/list.hsex
View File

@@ -1,40 +1,36 @@
(template (T) (template (list-T (T))
struct list-T (struct list-T
((T value) ((T value)
((list-T *) next))) ((* list-T) next))))
(template (T) (template (make-list-T (T) is-public?)
pub fn (list-T *) make-list-T () (,@(if is-public? '(pub) '()) fn (* list-T) make-list-T ()
(var (list-T *) list (malloc (sizeof list-T))) (var (* list-T) list (cast (* list-T) (malloc (sizeof list-T))))
(= (-> list next) NULL) (= (-> list next) NULL)
list) list))
(template (T) (template (add-value-list-T (T) is-public?)
pub fn void add-value-list-T ((list-T *list) (T value)) (,@(if is-public? '(pub) '()) fn void add-value-list-T ((list-T *list) (T value))
(while (!= (-> list next) NULL) (while (!= (-> list next) NULL)
(= list (-> list next))) (= list (-> list next)))
(= (-> list next) (make-list-T)) (= (-> list next) (make-list-T))
(= (-> list value) value)) (= (-> list value) value)))
(template (T) (template (length-list-T (T) is-public?)
pub fn size-t length-list-T ((list-T *list)) (,@(if is-public? '(pub) '()) fn size-t length-list-T ((list-T *list))
(var size-t n 0) (var size-t n 0)
(while (!= (-> list next) NULL) (while (!= (-> list next) NULL)
(= list (-> list next)) (= list (-> list next))
(++ n)) (++ n))
n) n))
(template (T) (template (is-empty-list-T (T) is-public?)
pub fn bool is-empty-list-T ((list-T *list)) (,@(if is-public? '(pub) '()) fn bool is-empty-list-T ((list-T *list))
(== (-> list next) NULL)) (== (-> list next) NULL)))
(define-syntax list-for-each (template (list-for-each (what-do list-var elt-var))
(syntax-rules () (var int elt-var (-> list-var value))
((_ list-var elt-var what-do ...) (while (!= (-> list-var next) NULL)
'(begin what-do
;; todo: that int here is not good (= list-var (-> list-var next))
(var int elt-var (-> list-var value)) (= elt-var (-> list-var value))))
(while (!= (-> list-var next) NULL)
what-do ...
(= list-var (-> list-var next))
(= elt-var (-> list-var value)))))))

18
lib/test-list.sex
View File

@@ -5,11 +5,17 @@
(load "list.hsex") (load "list.hsex")
(instance list-int list-T (int)) (struct foo
(instance make-list-int make-list-T (int)) ((float a)
(instance add-value-list-int add-value-list-T (int)) (int b)))
(instance length-list-int length-list-T (int))
(instance is-empty-list-int is-empty-list-T (int)) ,(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 () (pub fn int main ()
(var (* list-int) l (make-list-int)) (var (* list-int) l (make-list-int))
@@ -17,6 +23,6 @@
(add-value-list-int l 3) (add-value-list-int l 3)
(add-value-list-int l 4) (add-value-list-int l 4)
(printf "Size of the list: %zu\n" (length-list-int l)) (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") (printf "\n")
0) 0)

51
sexc.scm
View File

@@ -45,37 +45,44 @@
(eq? (car node) symbol)) (eq? (car node) symbol))
#f))) #f)))
(define (walk-generic form) (define (walk-generic form acc)
(tree-map (if (eq? (car form) 'unquote)
atom-to-fmt-c ;; special case - replace top-level unquote with it's expansion
(let ((ret-form form)) (append
(let loop ((unquote-form (tree-find (tree-finder 'unquote) form #f))) (fold append (list)
(if unquote-form (map (fn (walk-sex-tree x (list)))
(begin (eval (cadr form))))
(set! ret-form (tree-replace (invert-tree form) acc)
unquote-form (let loop ((unquote-form (tree-find (tree-finder 'unquote) form #f)))
(eval (cadr unquote-form)))) (if unquote-form
(loop (tree-find (tree-finder 'unquote) (begin
ret-form (let* ((inv (invert-tree form))
#f))) (pos (tree-local-position inv unquote-form)))
ret-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 (if static
(list 'static (walk-generic form)) (walk-generic (list 'static form) acc)
(walk-generic (cdr form)))) (walk-generic (cdr form) acc)))
(define (walk-struct form acc) (define (walk-struct form acc)
(let ((name (unkebabify (cadr form)))) (let ((name (unkebabify (cadr form))))
(cons (walk-generic form) (walk-generic form (cons `(typedef struct ,name ,name) acc))))
(cons `(typedef struct ,name ,name) acc))))
(define (walk-sex-tree form acc) (define (walk-sex-tree form acc)
(case (car form) (case (car form)
((fn) (cons (walk-function form #t) acc)) ((fn) (walk-function form #t acc))
((pub) (cons (walk-function form #f) acc)) ((pub) (walk-function form #f acc))
((struct) (walk-struct form acc)) ((struct) (walk-struct form acc))
(else (cons (walk-generic form) acc)))) (else (walk-generic form acc))))
(define (process-form form acc) (define (process-form form acc)
(case (car form) (case (car form)

110
templates.scm
View File

@@ -6,74 +6,14 @@
srfi-1 ; list routines srfi-1 ; list routines
tree) 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 (define-syntax template
(syntax-rules (pub fn struct) (syntax-rules ()
((_ (T ...) pub fn ret-type name args body ...) ((_ (name subst-list args ...) body ...)
(register-template-fn (list 'T ...) #t 'ret-type 'name 'args (list 'body ...))) (define (name subst-list-arg args ...)
((_ (T ...) fn ret-type name args body ...) (let* ((subst-alist (map cons 'subst-list subst-list-arg))
(register-template-fn (list 'T ...) #f 'ret-type 'name 'args (list 'body ...))) (replaced-body (apply-substitution `(body ...) subst-alist)))
((_ (T ...) struct name fields) replaced-body)))))
(register-template-struct (list 'T ...) 'name 'fields))))
(define (apply-symbol-substitution sym subst-alist) (define (apply-symbol-substitution sym subst-alist)
;; All non-symbol substitutions will be filtered. ;; All non-symbol substitutions will be filtered.
@@ -114,41 +54,3 @@
st)) st))
x)) x))
target)) 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))))