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

implement templates (kinda)

Browse Source 
uh oh
This commit is contained in:
alex-eg
2025-06-09 00:30:14 +03:00
parent fea7e58dd1
commit 2ba9ad37b7
6 changed files with 243 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files

16
Makefile
View File

@@ -1,7 +1,19 @@
CHICKEN_C = csc
sexc: sexc.scm
$(CHICKEN_C) $< -o $@
MODULES = sexc templates main
OBJ = $(MODULES:%=%.o)
# chicken flags
CFLAGS = -compile-syntax
sexc: $(OBJ)
$(CHICKEN_C) $^ -o $@
main.o: main.scm
$(CHICKEN_C) $< -c -o $@
%.o: %.scm
$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
clean:
rm -f $(OBJ) sexc

43
lib/list.hsex
View File

@@ -1,3 +1,40 @@
(template (T) struct list
(var T value)
())
(template (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 (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 (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 (T)
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)))))))

22
lib/test-list.sex
View File

@@ -0,0 +1,22 @@
(include stdlib.h)
(include stddef.h)
(include stdbool.h)
(include stdio.h)
(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))
(pub fn int main ()
(var (* list-int) l (make-list-int))
(printf "Size of the list: %zu\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))
,(list-for-each l v (printf "%d " v))
(printf "\n")
0)

6
main.scm Normal file
View File

@@ -0,0 +1,6 @@
;;; The purpose of this file is to compile it to the only
;;; .o that has main entry point.
(declare (uses sexc))
(main)

9
sexc.scm
View File

@@ -1,3 +1,6 @@
(declare (unit sexc)
(uses templates))
(import brev-separate
(chicken pathname)
(chicken pretty-print)
@@ -9,6 +12,8 @@
srfi-1 ; list routines
tree)
(define +debug+ #f)
(define (unkebabify sym)
(case sym
((-) sym)
@@ -75,7 +80,9 @@
(define (process-form form acc)
(case (car form)
((define) (eval form) acc)
((template) (eval form) acc)
((load) (eval form) acc)
((instance) (walk-sex-tree (eval form) acc))
(else
(walk-sex-tree form acc))))
@@ -167,5 +174,3 @@
(lambda ()
(emit-c sex-forms)))
(emit-c sex-forms)))))))
(main)

154
templates.scm Normal file
View File

@@ -0,0 +1,154 @@
(declare (unit templates))
(import brev-separate
fmt
regex
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))))
(define (apply-symbol-substitution sym subst-alist)
;; All non-symbol substitutions will be filtered.
;; E.g. if the subst-alist is ((T + 1 2) (U . w) (W . e)),
;; only ((U . w) (W . e)) will be applied to symbols.
(let ((str (symbol->string sym))
(subst-map (map (fn
(if (symbol? (car x))
(cons
(fmt #f "([^\\-]?)" (symbol->string (car x)) "([\\-$]?)")
(fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
x))
(filter (fn (not (list? (cdr x)))) subst-alist))))
(string->symbol
(string-substitute* str subst-map))))
(define (maybe-replace-symbol sym subst-alist)
(call/cc
(lambda (return)
(for-each (fn (when (eq? (car x) sym)
(return (cdr x))))
subst-alist)
(return sym))))
(define (apply-substitution target subst-alist)
;; Subsitute free symbols and -/$/^ separated parts
;; of symbols with provided forms.
;; E.g. with substitution (T int):
;; list-T -> list-int ; by apply-symbol-substitution
;; (var T data) -> (var int data) ; by maybe-replace-symbol
;; see respective functions for further details.
(tree-map
(fn
(if (symbol? x)
(let ((st (maybe-replace-symbol x subst-alist)))
(if (eq? st x)
(apply-symbol-substitution x subst-alist)
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))))