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

Compare commits

base: alex-eg:a64caec5f8aa968f0194289771a4d83bb94a2866
Branches Tags
alex-eg:main alex-eg:type-inference alex-eg:minor-language-improvements alex-eg:make-include-take-multiple-args alex-eg:review-fixes alex-eg:refactor-to-modules alex-eg:initial-lambdas-support alex-eg:types-and-poly alex-eg:templates-enhancing alex-eg:rework-templates
..
compare: alex-eg:a80b8d9acf62d27cd7580f8252e7c0435419b3a1
Branches Tags
alex-eg:type-inference alex-eg:main alex-eg:minor-language-improvements alex-eg:make-include-take-multiple-args alex-eg:review-fixes alex-eg:refactor-to-modules alex-eg:initial-lambdas-support alex-eg:types-and-poly alex-eg:templates-enhancing alex-eg:rework-templates

3 Commits
a64caec5f8 ... a80b8d9acf

Author SHA1 Message Date
alex-eg
a80b8d9acf dump 2026-03-24 21:19:03 +03:00
alex-eg
d039fa0cb9 remove utils.macros.scm as it is no longer needed
Some checks failed
Sex CI / build-linux (pull_request) Has been cancelled
Details
Sex CI / build-macos (pull_request) Has been cancelled
Details
2026-03-12 12:41:14 +03:00
alex-eg
559ed9c7fa modularize sex 2026-03-12 12:41:14 +03:00
40 changed files with 1020 additions and 1138 deletions
Expand all files Collapse all files

1
.gitignore vendored
View File

@@ -1,5 +1,4 @@
*.o *.o
*.import.scm *.import.scm
*.link
sexc sexc
sex-tests sex-tests

75
Makefile
View File

@@ -1,60 +1,53 @@
CHICKEN_C = csc CHICKEN_C = csc
CSC_FLAGS += -K prefix -static CSC_FLAGS += -K prefix
# What and why:
# -emit-all-import-libraries: Emit import-libraries for all defined modules.
# Used to generate .import.scm files so compiler would know how to use the modules.
# Without it, csc fails with "cannot import from undefined module" error.
# -module-registration: Always generate module registration code, even when
# import libraries are emitted. Enables us to import from our modules at run time.
# Used in macros, where we inject `(import (only sex-macros cat))' before the macro body.
# Without it, sexc compiles scuccessfully, but is unable to process macros, failing with
# "during expansion of (import ...) - cannot import from undefined module: sex-macros"
# error.
# -c: Stop after compilation to object files. This one is obvious.
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
# Order matters, since module check correctness on compilation # Order matters, since module check correctness on compilation
MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc MODULES = utils macros reader module-system semen sex-fmt-c fmt-c-writer sexc
OBJ = $(MODULES:%=%.o) OBJ = $(MODULES:%=%.o)
IMPORTS = $(MODULES:%=%.import.scm)
LINK = $(MODULES:%=%.link)
sexc: $(OBJ) main.scm sexc: $(OBJ) main.o
$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc $(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
# otherwise csc hangs, probably because it tries to compile to sexc.o first
mv sexc-tmp sexc main.o: main.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@ -link sexc
#------------------------------------------------------------------ #------------------------------------------------------------------
utils.o: utils.module.scm utils.scm utils.o: utils.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils $(CHICKEN_C) $(CSC_FLAGS) utils.scm -e -c -J -o utils.o -unit utils
sex-macros.o: sex-macros.module.scm sex-macros.scm macros.o: macros.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros $(CHICKEN_C) $(CSC_FLAGS) macros.scm -e -c -J -o macros.o -unit macros
reader.o: reader.module.scm reader.scm reader.o:
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader $(CHICKEN_C) $(CSC_FLAGS) reader.scm -e -c -J -o reader.o -unit reader
sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o module-system.o: module-system.scm reader.import.scm utils.import.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils $(CHICKEN_C) $(CSC_FLAGS) module-system.scm -e -c -J -o module-system.o -unit module-system -link reader,utils
semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o utils.o semen.o: semen.scm macros.import.scm module-system.import.scm utils.import.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils $(CHICKEN_C) $(CSC_FLAGS) semen.scm -e -c -J -o semen.o -unit semen -link macros,module-system,utils
sex-fmt-c.o: sex-fmt-c.scm fmt-c-writer.o: fmt-c-writer.scm sex-fmt-c.import.scm utils.import.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c $(CHICKEN_C) $(CSC_FLAGS) fmt-c-writer.scm -e -c -J -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o sexc.o: sexc.scm fmt-c-writer.import.scm macros.import.scm module-system.import.scm reader.import.scm semen.import.scm utils.import.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils $(CHICKEN_C) $(CSC_FLAGS) sexc.scm -e -c -J -o sexc.o -unit sexc -link fmt-c-writer,macros,module-system,reader,semen,utils
sexc.o: sexc.module.scm sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o %.link: %.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils %.import.scm: %.o
%.o: %.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -J -o $@ -unit $(@:%.o=%)
sex-tests:
$(MAKE) -C tests sex-tests sex-tests: $(OBJ) tests/*.scm
cp ./tests/sex-tests ./ cd ./tests && $(CHICKEN_C) $(CSC_FLAGS) run.scm -c -o sex-tests.o
$(CHICKEN_C) $(CSC_FLAGS) $(OBJ) ./tests/sex-tests.o -o sex-tests
clean: clean:
rm -f $(OBJ) main.o rm -f $(OBJ) main.o ./tests/sex-tests.o
rm -f *.import.scm rm -f $(IMPORTS)
rm -f *.link rm -f $(LINK) main.link
rm -f sexc sex-tests rm -f sexc sex-tests

2
example/mini-test.sex Normal file
View File

@@ -0,0 +1,2 @@
(pub fn main () int
(var l (* (struct list-int)) (make-list-int)))

25
example/our-reader.sex Normal file
View File

@@ -0,0 +1,25 @@
(include stdio.h)
(defmacro (plus . rest)
`(+ ,@rest))
(struct vertex
((pos (struct ((x u32) (y u32))))
(color (struct ((r float) (g float) (b float))))
(mask u32)))
(enum
(B A R))
;;; Main entry point
;;; Multi line comments should be packed
(pub fn main () int
;; the vertex
(var a (struct vertex) #(#(10 20)
#(0.3 0.5 0.7)
(c-bit-or B A R)))
(printf "%d %f %d\n" ; the printf
(plus a.pos.x a.pos.y)
(plus a.color.r a.color.g a.color.b)
a.mask)
(return 0))

6
example/structs.sex Normal file
View File

@@ -0,0 +1,6 @@
(struct settings
((b-x u32)
(l r t b x y w h u32)
(color (struct
((r g b a float))))
(colors [struct color ((r g b a float))])))

3
fmt-c-writer.module.scm
View File

@@ -1,3 +0,0 @@
(module fmt-c-writer (emit-c
sex-fmt-current-file)
"fmt-c-writer.scm")

502
fmt-c-writer.scm
View File

@@ -1,283 +1,285 @@
;;; Sex fmt-c output writer ;;; Sex fmt-c output writer
(import (module fmt-c-writer (emit-c
scheme sex-fmt-current-file)
(chicken base) (import
(chicken string) scheme
(chicken syntax) (chicken base)
brev-separate (chicken string)
fmt (chicken syntax)
sex-fmt-c brev-separate
matchable fmt
regex sex-fmt-c
srfi-1 ; lists matchable
srfi-13 ; strings regex
srfi-39 ; parameters srfi-1 ; lists
tree srfi-13 ; strings
utils) srfi-39 ; parameters
tree
utils)
(define (unkebabify sym) (define (unkebabify sym)
(case sym (case sym
((-) sym) ((-) sym)
((--) sym) ((--) sym)
((->) sym) ((->) sym)
((-=) sym) ((-=) sym)
(else (else
(string->symbol
(string-substitute "-(?!>)" "_"
(symbol->string sym) #t)))))
(define (atom-to-fmt-c atom)
(case atom
((fn) '%fun)
((prototype) '%prototype)
((begin) '%block-begin)
((define) '%define)
((pointer) '%pointer)
((array) '%array)
((attribute) '%attribute)
((¤) 'vector-ref)
((include) '%include)
;; uh things we do for c89 compatibility
((bool) 'int)
((true) 1)
((false) 0)
(else
(if (symbol? atom)
(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")
(unkebabify
(string->symbol (string->symbol
(string-substitute "-(?!>)" "_" (fmt #f (cadr form) (car form)))))
(symbol->string sym) #t)))))
(define (atom-to-fmt-c atom) (define (walk-generic-toplevel form)
(case atom (cond ((atom? form) (atom-to-fmt-c form))
((fn) '%fun) ((list? form) (map walk-generic-toplevel form))
((prototype) '%prototype) (else (error "Malformed form " form))))
((begin) '%block-begin)
((define) '%define)
((pointer) '%pointer)
((array) '%array)
((attribute) '%attribute)
((¤) 'vector-ref)
((include) '%include)
;; uh things we do for c89 compatibility
((bool) 'int)
((true) 1)
((false) 0)
(else
(if (symbol? atom)
(unkebabify atom)
atom))))
(define (maybe-unwrap-type type) (define (field-access-form? form)
(if (and (list? type) (and (symbol? (car form))
(= 1 (length type))) (char=? #\. (string-ref (symbol->string (car form)) 0))))
(car type)
type))
(define (make-field-access form) (define (walk-expr form)
(assert (match form
(= 2 (length form)) "Wrong field access format") ((? vector?)
(unkebabify (list->vector
(string->symbol (walk-expr (vector->list form))))
(fmt #f (cadr form) (car 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))))
(define (walk-generic-toplevel form) (define (walk-var form)
(cond ((atom? form) (atom-to-fmt-c form)) ;; (var a int) -> (%var int a)
((list? form) (map walk-generic-toplevel form)) ;; (var a (const int) 32) -> (%var (const int) a 32)
(else (error "Malformed form " form)))) ;; (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
))
(define (field-access-form? form) (define (walk-type form)
(and (symbol? (car form)) ;; int -> int
(char=? #\. (string-ref (symbol->string (car form)) 0)))) ;; (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"))
(define (walk-expr form) ;; Special case: nested structs/unions
(match form ((or ('struct . _)
((? vector?) ('union . _)) (walk-struct form))
(list->vector
(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))))
(define (walk-var form) (('enum . _) (walk-enum form))
;; (var a int) -> (%var int a) (else
;; (var a (const int) 32) -> (%var (const int) a 32) (type-convert-to-c form))))
;; (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
))
(define (walk-type form) (define (type-convert-to-c type)
;; int -> int ;; Our pointers to C pointers
;; (const int) -> const int ;; int -> int
;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512) ;; * const char -> const char *
;; [float 8] -> (%array float 8) ;; const * const char -> const char * const
;; (* const char) -> (const char *) (if (atom? type) (atom-to-fmt-c type)
;; (const * const * const char) -> (const char * const * const) (flatten
;; (fn ((int) (float)) void) -> (%fun void ((int) (float))) (tree-map atom-to-fmt-c
(match form (flatten
(('¤ . array-type) (list-join (reverse (list-split 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"))
;; Special case: nested structs/unions (define (walk-fn-def form)
((or ('struct . _) (match form
('union . _)) (walk-struct form)) (('fn name args ret-type . maybe-body)
`(%fun
(('enum . _) (walk-enum form)) ,(walk-type ret-type)
(else ,(atom-to-fmt-c name)
(type-convert-to-c form)))) ,(walk-arglist args)
.
(define (type-convert-to-c type) ,(walk-expr maybe-body)))))
;; 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? ;;; TODO: isn't there a better way?
(define (is-probably-type form) (define (is-probably-type form)
(case (car form) (case (car form)
((¤ * const volatile struct union) #t) ((¤ * const volatile struct union) #t)
(else #f))) (else #f)))
(define (walk-arglist form) (define (walk-arglist form)
;; E.g.: ;; E.g.:
;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32)) ;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4))) ;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
(map (fn (map (fn
(match x (match x
(('¤ . _) (walk-type x)) (('¤ . _) (walk-type x))
;; yeah shitty, but I don't know yet how to determine if the ;; 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 ;; first entry is part of the type and not an argument name
;; :( ;; :(
((? is-probably-type) (walk-type x)) ((? is-probably-type) (walk-type x))
;; 1 element args are always type ;; 1 element args are always type
((_) (walk-type x)) ((_) (walk-type x))
((var . type) (append (list (walk-type (maybe-unwrap-type type))) ((var . type) (append (list (walk-type (maybe-unwrap-type type)))
(list (walk-type var)))))) (list (walk-type var))))))
form)) form))
(define (walk-function form) (define (walk-function form)
;; (fn ret-type name arglist body) -> normal function ;; (fn ret-type name arglist body) -> normal function
;; (fn ret-type name arglist) -> prototype ;; (fn ret-type name arglist) -> prototype
(if (>= (length form) 5) (if (>= (length form) 5)
(walk-fn-def form) (walk-fn-def form)
(cons '%prototype (cdr (walk-fn-def form))))) (cons '%prototype (cdr (walk-fn-def form)))))
(define (process-struct-fields fields) (define (process-struct-fields fields)
(map (fn (map (fn
(let ((type (walk-type (last x)))) (let ((type (walk-type (last x))))
(cons type (map atom-to-fmt-c (drop-right x 1))))) (cons type (map atom-to-fmt-c (drop-right x 1)))))
fields)) fields))
(define (walk-struct form) (define (walk-struct form)
(match form (match form
((type (fields ...) . attrs) ; anonymous struct ((type (fields ...) . attrs) ; anonymous struct
`(,type ,(process-struct-fields fields) `(,type ,(process-struct-fields fields)
. ,(tree-map atom-to-fmt-c attrs))) . ,(tree-map atom-to-fmt-c attrs)))
((type name) ; simple 'struct whatever', like in variable def ((type name) ; simple 'struct whatever', like in variable def
`(,type ,(atom-to-fmt-c name))) `(,type ,(atom-to-fmt-c name)))
((type name (fields ...) . attrs) ((type name (fields ...) . attrs)
`(,type ,(atom-to-fmt-c name) `(,type ,(atom-to-fmt-c name)
,(process-struct-fields fields) ,(process-struct-fields fields)
. ,(tree-map atom-to-fmt-c attrs))) . ,(tree-map atom-to-fmt-c attrs)))
(else (error "Malformed aggregate definition " form)))) (else (error "Malformed aggregate definition " form))))
(define (walk-enum form) (define (walk-enum form)
(match form (match form
(('enum (values ...)) (('enum (values ...))
`(enum ,(map atom-to-fmt-c values))) `(enum ,(map atom-to-fmt-c values)))
(('enum name (values ...)) (('enum name (values ...))
`(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values))))) `(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
(define (walk-extern form) (define (walk-extern form)
(match form (match form
(('fn . _) (('fn . _)
;; extern function?.. What ;; extern function?.. What
(list 'extern (walk-function form))) (list 'extern (walk-function form)))
(('var . _) (('var . _)
(list 'extern (walk-var form))) (list 'extern (walk-var form)))
(else (error "Extern what?")))) (else (error "Extern what?"))))
(define (walk-public form) (define (walk-public form)
(match form (match form
(('fn . _) (('fn . _)
(walk-function form)) (walk-function form))
(('var . _) (('var . _)
(walk-var form)) (walk-var form))
((or ('define . _) ((or ('define . _)
('defmacro . _) ('defmacro . _)
('import . _) ('import . _)
('include . _) ('include . _)
('struct . _) ('struct . _)
('union . _) ('union . _)
('typedef . _)) ('typedef . _))
;; ignore here, used in generating public interface ;; ignore here, used in generating public interface
(process-toplevel-form form)) (process-toplevel-form form))
(else (else
(error "Pub what?" (cadr form))))) (error "Pub what?" (cadr form)))))
(define (process-toplevel-form form) (define (process-toplevel-form form)
(match form (match form
(('fn . _) (list 'static (walk-function form))) (('fn . _) (list 'static (walk-function form)))
(('var . _) (list 'static (walk-var form))) (('var . _) (list 'static (walk-var form)))
(('extern . rest) (walk-extern rest)) (('extern . rest) (walk-extern rest))
(('pub . rest) (walk-public rest)) (('pub . rest) (walk-public rest))
((or ('struct . _) ((or ('struct . _)
('union . _)) (walk-struct form)) ('union . _)) (walk-struct form))
(('enum . _) (walk-enum form)) (('enum . _) (walk-enum form))
(('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest)) (('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
(else (walk-expr form)))) (else (walk-expr form))))
(define (get-line-num form) (define (get-line-num form)
(let ((num (get-line-number form))) (let ((num (get-line-number form)))
(if (string? num) (if (string? num)
(last (string-split num ":")) (last (string-split num ":"))
#f))) #f)))
(define sex-fmt-current-file (make-parameter "/dev/null")) (define sex-fmt-current-file (make-parameter "/dev/null"))
(define sex-fmt-line-num (make-parameter 0)) (define sex-fmt-line-num (make-parameter 0))
(define (line-directive-string) (define (line-directive-string)
(fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\")) (fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
(define (emit-c sex-forms) (define (emit-c sex-forms)
(for-each (lambda (form) (for-each (lambda (form)
(let ((start-line (get-line-num form))) (let ((start-line (get-line-num form)))
(when start-line (when start-line
(sex-fmt-line-num start-line) (sex-fmt-line-num start-line)
(fmt #t (line-directive-string) nl))) (fmt #t (line-directive-string) nl)))
(fmt #t (c-expr (process-toplevel-form form)) nl)) (fmt #t (c-expr (process-toplevel-form form)) nl))
sex-forms)) sex-forms)))

45
macros.scm Normal file
View File

@@ -0,0 +1,45 @@
(module macros
(register-macro
cat
get-macro
macro?
apply-macro
defmacro)
(import
scheme
(only fmt fmt)
(chicken base)
(chicken plist)
(chicken string))
(define (cat-syms s-1 s-2)
(fmt #f s-1 s-2))
(define (cat sym-1 sym-2)
(string->symbol (cat-syms sym-1 sym-2)))
(define (register-macro name arglist body)
(put! name 'sex-macro
`(lambda ,arglist
(import scheme
(only macros cat))
,@body)))
(define (get-macro name)
(eval (get name 'sex-macro)))
(define (macro? form)
(and (list? form)
(symbol? (car form))
(get (car form) 'sex-macro)))
(define (apply-macro form)
(assert (macro? form)
(fmt #f (car form) " is not a macro"))
(apply (get-macro (car form))
(cdr form)))
(define (defmacro form)
(let ((arglist (car form))
(body (cdr form)))
(register-macro (car arglist) (cdr arglist) body))))

92
module-system.scm Normal file
View File

@@ -0,0 +1,92 @@
(module module-system
(get-modules-public-forms
load-persistent-module-paths
read-public-interface)
(import
scheme
brev-separate
(chicken base)
(chicken file)
(chicken load)
(chicken pathname)
(chicken process-context)
(chicken string)
fmt
reader
srfi-1
utils)
(define +persistent-module-paths+ (list))
(define (get-modules-public-forms module-list)
;; Module list is a list of symbols
;; How Sex handles modules:
;; For each module in a list, construct path, find module by path in
;; module path directories, extract public definitions from the
;; module, paste them in current one in emulation of C include
;; directives.
(fold-right append (list)
(map (fn (import-module (symbol->string x)))
module-list)))
(define (import-module name)
(let ((module-path (locate-module name)))
(assert module-path (fmt #f "Failed to find module " name " in "
(get-module-paths)))
(read-public-interface module-path)))
(define (get-module-paths)
(cons (current-directory)
+persistent-module-paths+))
(define (locate-module name)
;; Module locations: relative to file being compiled, or in what was
;; in SEX_MODULE_PATH env var at the start of the process (see
;; load-persistent-module-paths function)
(let ((search-paths (get-module-paths)))
(let loop ((paths search-paths))
(if (null? paths)
#f
(or (module-exists? name (car paths))
(loop (cdr paths)))))))
(define (module-exists? name module-dir)
;; returns absolute path to module, if it exists
(and (directory-exists? module-dir)
(let ((module-path (make-absolute-pathname module-dir name "sex")))
(and (file-exists? module-path)
(file-readable? module-path)
module-path))))
(define (read-public-interface module-path)
;; pub fns are reduced to prototypes, other pub forms are just pasted
(let ((raw-forms (read-from-file module-path)))
(fold
process-public-interface-form
(list)
raw-forms)))
;;; TODO: use semen facilities to analyze modules
(define (process-public-interface-form form acc)
(case (car form)
((pub)
(case (cadr form)
((fn) ; replace with prototype
;; fn type name (arg-list) (body)
;; 1 2 3 4 - we need first 4
(cons (take (cdr form) 4) acc))
((define defmacro import include struct typedef union var)
(cons (cdr form) acc))
(else (error "Pub what? " (cadr form)))))
(else acc)))
(define (load-persistent-module-paths)
(let ((sex-module-path-env-var
(get-env-var "SEX_MODULE_PATH")))
(when sex-module-path-env-var
(set! +persistent-module-paths+
(map (lambda (p)
(make-absolute-pathname p #f #f))
(string-split sex-module-path-env-var ":")))))))

3
reader.module.scm
View File

@@ -1,3 +0,0 @@
(module reader (read-from-file
read-raw-forms)
"reader.scm")

101
reader.scm
View File

@@ -1,49 +1,64 @@
(import (module reader (read-from-file
scheme read-raw-forms)
(chicken base) (import
(chicken io) scheme
(chicken pathname) (chicken base)
(chicken port) (chicken io)
(chicken read-syntax) (chicken pathname)
(chicken string) (chicken port)
(chicken syntax) (chicken read-syntax)
brev-separate (chicken string)
fmt) (chicken syntax)
brev-separate
fmt)
(import-syntax utils) (import-syntax utils)
(define (read-forms acc) (define (read-forms acc)
(let ((r (read-with-source-info (current-input-port)))) (let ((r (read-with-source-info (current-input-port))))
(if (eof-object? r) (reverse acc) (if (eof-object? r) (reverse acc)
(read-forms (cons r acc))))) (read-forms (cons r acc)))))
(define (read-from-file file) (define (read-from-file file)
(with-directory file (with-directory file
(with-input-from-file (pathname-strip-directory file) (with-input-from-file (pathname-strip-directory file)
(fn (read-forms (list)))))) (fn (read-forms (list))))))
(define open-bracket-counter (make-parameter 0)) (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 (read-raw-forms input-source) (define open-bracket-counter (make-parameter 0))
(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! (define (read-raw-forms input-source)
#\[ (let ((bracket-end (gensym)))
(lambda (port) (set-read-syntax!
(open-bracket-counter (+ (open-bracket-counter) 1)) #\]
(let loop ((r (read port)) (lambda (port)
(acc (list))) (when (= 0 (open-bracket-counter))
(if (eq? r bracket-end) (error "Unmatched closing bracket"))
(cons '¤ (reverse acc)) (open-bracket-counter (- (open-bracket-counter) 1))
(loop (read port) bracket-end))
(cons r acc)))))))
(if (eq? input-source 'stdin) (set-read-syntax!
(read-forms (list)) #\[
(read-from-file input-source))) (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))))

2
semen.module.scm
View File

@@ -1,2 +0,0 @@
(module semen ()
"semen.scm")

370
semen.scm
View File

@@ -1,21 +1,22 @@
;;; Sex semantic engine ;;; Sex semantic engine
(import (module semen ()
scheme (import
(chicken base) scheme
(chicken keyword) (chicken base)
(chicken string) (chicken keyword)
(chicken module) (chicken string)
fmt (chicken module)
sex-macros fmt
sex-modules macros
matchable ; pattern matching matchable ; pattern matching
srfi-1 ; list routines module-system
srfi-69 ; hash tables srfi-1 ; list routines
utils srfi-69 ; hash tables
) utils
)
(export/rename (process semen-process)) (export/rename (process semen-process))
;;; for lambda extraction, docstring processing, macro expansion, ;;; for lambda extraction, docstring processing, macro expansion,
;;; injection of module headers, i.e. all things that rearrange code ;;; injection of module headers, i.e. all things that rearrange code
@@ -25,84 +26,84 @@
;;; append their return to the resulting list. Each handler can return ;;; append their return to the resulting list. Each handler can return
;;; multiple forms, e.g. lambdas collected from a function may result ;;; multiple forms, e.g. lambdas collected from a function may result
;;; in auxiliary structures and functions. ;;; in auxiliary structures and functions.
(define (process raw-sex-forms) (define (process raw-sex-forms)
(process-rec raw-sex-forms (list))) (process-rec raw-sex-forms (list)))
(define (process-rec forms acc) (define (process-rec forms acc)
(cond (cond
((null? forms) (reverse acc)) ((null? forms) (reverse acc))
((macro? (car forms)) ((macro? (car forms))
(process-rec (process-rec
(macroexpand (car forms) (cdr forms)) (macroexpand (car forms) (cdr forms))
acc)) acc))
(else (else
(process-rec (cdr forms) (process-rec (cdr forms)
(match-sex-form (car forms) acc))))) (match-sex-form (car forms) acc)))))
(define (macroexpand macro-form rest-forms) (define (macroexpand macro-form rest-forms)
;; We want to replace macro with its expansion. The problem is, ;; We want to replace macro with its expansion. The problem is,
;; top-level macro can return either a single form, or a list of ;; top-level macro can return either a single form, or a list of
;; forms, when it for example generates some aux ;; forms, when it for example generates some aux
;; structures/functions/typedefs. ;; structures/functions/typedefs.
;; ;;
;; Single form we just cons to the top of rest-forms, but multiple ;; Single form we just cons to the top of rest-forms, but multiple
;; forms have to be appended to the rest-forms. ;; forms have to be appended to the rest-forms.
(let ((res (apply-macro macro-form))) (let ((res (apply-macro macro-form)))
(if (list? (car res)) (if (list? (car res))
(append res rest-forms) (append res rest-forms)
(cons res rest-forms)))) (cons res rest-forms))))
(define (match-sex-form sex-form acc) (define (match-sex-form sex-form acc)
(match sex-form (match sex-form
((or ('fn . _) ((or ('fn . _)
('pub 'fn . _) ('pub 'fn . _)
('extern 'fn . _)) (process-fn sex-form acc)) ('extern 'fn . _)) (process-fn sex-form acc))
((or ('struct . _) ((or ('struct . _)
('pub 'struct . _)) (process-struct sex-form acc)) ('pub 'struct . _)) (process-struct sex-form acc))
((or ('union . _) ((or ('union . _)
('pub 'union . _)) (process-struct sex-form acc)) ('pub 'union . _)) (process-struct sex-form acc))
((or ('enum . _) ((or ('enum . _)
('pub 'enum . _)) (process-struct sex-form acc)) ('pub 'enum . _)) (process-struct sex-form acc))
((or ('var . _) ((or ('var . _)
('pub 'var . _) ('pub 'var . _)
('extern 'var . _)) (process-global-var sex-form acc)) ('extern 'var . _)) (process-global-var sex-form acc))
(('include _) (cons sex-form acc)) (('include _) (cons sex-form acc))
(('define . _) (cons sex-form acc)) (('define . _) (cons sex-form acc))
(('import . modules) (('import . modules)
(process-imports (get-modules-public-forms modules) acc)) (process-imports (get-modules-public-forms modules) acc))
((or ('defmacro . rest) ((or ('defmacro . rest)
('pub 'defmacro . rest)) (defmacro rest) acc) ('pub 'defmacro . rest)) (defmacro rest) acc)
((or ('typedef new-type target) ((or ('typedef new-type target)
('pub 'typedef new-type target)) ('pub 'typedef new-type target))
(process-typedef new-type target acc)) (process-typedef new-type target acc))
(else (assert #f (fmt #f "Unknown top level form " sex-form))))) (else (assert #f (fmt #f "Unknown top level form " sex-form)))))
(define (process-imports module-public-forms acc) (define (process-imports module-public-forms acc)
;; Recursively process imports: register public macros, cons all ;; Recursively process imports: register public macros, cons all
;; other public things to our acc ;; other public things to our acc
(if (null? module-public-forms) acc (if (null? module-public-forms) acc
(match (car module-public-forms) (match (car module-public-forms)
(('defmacro . rest) (('defmacro . rest)
(defmacro rest) (defmacro rest)
(process-imports (cdr module-public-forms) acc)) (process-imports (cdr module-public-forms) acc))
(else (else
(process-imports (cdr module-public-forms) (process-imports (cdr module-public-forms)
(cons (car module-public-forms) (cons (car module-public-forms)
acc)))))) acc))))))
(define (macro-expand form) (define (macro-expand form)
"Walk the form recursively and expand all macros, until none is left." "Walk the form recursively and expand all macros, until none is left."
(walk-form (walk-form
form form
(lambda (subform env) (lambda (subform env)
(if (macro? subform) (if (macro? subform)
(cons walk-embed-result (macroexpand subform (list))) (cons walk-embed-result (macroexpand subform (list)))
subform)) subform))
#f)) #f))
;;; walk-form and friends: form walker with various abilities. ;;; walk-form and friends: form walker with various abilities.
;;; By default, replaces walked form with walk-fn result But may ;;; By default, replaces walked form with walk-fn result But may
@@ -112,128 +113,129 @@
;;; For inspiration, see SBCL's walk.lisp and their template ;;; For inspiration, see SBCL's walk.lisp and their template
;;; system. ;;; system.
(define walk-embed-result (gensym) (define walk-embed-result (gensym)
;; For cases when result is a list which must be embedded in the ;; For cases when result is a list which must be embedded in the
;; form, e.g. when it returned from a macro ;; form, e.g. when it returned from a macro
) )
(define (walk-form form walk-fn env) (define (walk-form form walk-fn env)
(if (atom? form) form (if (atom? form) form
(let ((new-form (walk-fn form env))) (let ((new-form (walk-fn form env)))
(cond ((not (eq? form new-form)) (cond ((not (eq? form new-form))
(walk-form new-form walk-fn env)) (walk-form new-form walk-fn env))
(else (else
(let ((new-car (walk-form (car new-form) walk-fn env)) (let ((new-car (walk-form (car new-form) walk-fn env))
(new-cdr (walk-form (cdr new-form) walk-fn env))) (new-cdr (walk-form (cdr new-form) walk-fn env)))
(cond ((and (pair? new-car) (cond ((and (pair? new-car)
(eq? (car new-car) walk-embed-result)) (eq? (car new-car) walk-embed-result))
(append (cdr new-car) new-cdr)) (append (cdr new-car) new-cdr))
(else (else
(recons new-form new-car new-cdr))))))))) (recons new-form new-car new-cdr)))))))))
;;; Typdef ;;; Typdef
(define (process-typedef new-type target acc) (define (process-typedef new-type target acc)
(cons `(typedef ,target ,new-type) acc)) (cons `(typedef ,target ,new-type) acc))
;;; Fn processing ;;; Fn processing
(define (process-fn sex-fn acc) (define (process-fn sex-fn acc)
(let* ((expanded (macro-expand sex-fn)) (let* ((expanded (macro-expand sex-fn))
(env (make-hash-table)) (env (make-hash-table))
(processed (processed
(walk-form (walk-form
expanded expanded
fn-walker fn-walker
(begin (begin
(set! (hash-table-ref env :fn-name) (sex-fn-name expanded)) (set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
(set! (hash-table-ref env :lambda-counter) 0) (set! (hash-table-ref env :lambda-counter) 0)
(set! (hash-table-ref env :lambda-aux-code) (list)) (set! (hash-table-ref env :lambda-aux-code) (list))
env)))) env))))
(cons processed (cons processed
(append (hash-table-ref env :lambda-aux-code) acc)))) (append (hash-table-ref env :lambda-aux-code) acc))))
(define (fn-walker form env) (define (fn-walker form env)
(if (eq? 'lambda (car form)) (if (eq? 'lambda (car form))
(let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name) (let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name)
(hash-table-ref env :lambda-counter)))) (hash-table-ref env :lambda-counter))))
(set! (hash-table-ref env :lambda-aux-code) (set! (hash-table-ref env :lambda-aux-code)
(append (make-aux-lambda-struct lambda-name form) (append (make-aux-lambda-struct lambda-name form)
(hash-table-ref env :lambda-aux-code))) (hash-table-ref env :lambda-aux-code)))
(set! (hash-table-ref env :lambda-counter) (set! (hash-table-ref env :lambda-counter)
(+ (hash-table-ref env :lambda-counter) 1)) (+ (hash-table-ref env :lambda-counter) 1))
lambda-name) lambda-name)
form)) form))
(define (make-lambda-name enclosing-fn-name counter) (define (make-lambda-name enclosing-fn-name counter)
(string->symbol (string->symbol
(fmt #f "__lambda_" counter "_" enclosing-fn-name))) (fmt #f "__lambda_" counter "_" enclosing-fn-name)))
(define (make-aux-lambda-struct name form) (define (make-aux-lambda-struct name form)
(match form (match form
(('lambda ret-type arglist captures . body) (('lambda ret-type arglist captures . body)
;; Captures are ignored for now, but ;; Captures are ignored for now, but
;; we'll need them for TODO: closures support ;; we'll need them for TODO: closures support
(process-fn `(fn ,ret-type ,name ,arglist ,@body) (list))) (process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
(else (assert #f (fmt #f "Malformed lambda " form))))) (else (assert #f (fmt #f "Malformed lambda " form)))))
;;; Structs ;;; Structs
(define (process-struct sex-struct acc) (define (process-struct sex-struct acc)
(cons sex-struct acc)) (cons sex-struct acc))
(define (process-global-var sex-var acc) (define (process-global-var sex-var acc)
(cons sex-var acc)) (cons sex-var acc))
;;; Utils ;;; Utils
(define (non-empty-list? form) (define (non-empty-list? form)
(and (list? form) (and (list? form)
(not (null? form)))) (not (null? form))))
(define (sex-fn? form) (define (sex-fn? form)
"The `form` must be toplevel. "The `form` must be toplevel.
Returns #f if the form is not a function, returns the form otherwise" Returns #f if the form is not a function, returns the form otherwise"
(match form (match form
((fn . _) form) ((fn . _) form)
((pub fn . _) form) ((pub fn . _) form)
(else #f))) (else #f)))
(define (sex-fn-public? fn-form) (define (sex-fn-public? fn-form)
(eq? (car fn-form) 'pub)) (eq? (car fn-form) 'pub))
(define (sex-fn-return-type fn-form) (define (sex-fn-return-type fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(third fn-form) (third fn-form)
(second fn-form))) (second fn-form)))
(define (sex-fn-name fn-form) (define (sex-fn-name fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(fourth fn-form) (fourth fn-form)
(third fn-form))) (third fn-form)))
(define (sex-fn-arglist fn-form) (define (sex-fn-arglist fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(fifth fn-form) (fifth fn-form)
(fourth fn-form))) (fourth fn-form)))
(define (sex-fn-prototype fn-form) (define (sex-fn-prototype fn-form)
"Returns all except body" "Returns all except body"
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(take fn-form 5) (take fn-form 5)
(take fn-form 4))) (take fn-form 4)))
(define (sex-fn-body fn-form) (define (sex-fn-body fn-form)
(assert (sex-fn? fn-form) (assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function")) (fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form) (if (sex-fn-public? fn-form)
(drop fn-form 5) (drop fn-form 5)
(drop fn-form 4))) (drop fn-form 4)))
)

1
sex-fmt-c.scm
View File

@@ -105,6 +105,7 @@
(define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y))) (define (c-op< x y) (< (c-op-precedence x) (c-op-precedence y)))
(define (c-op<= x y) (<= (c-op-precedence x) (c-op-precedence y))) (define (c-op<= x y) (<= (c-op-precedence x) (c-op-precedence y)))
(define (c-op>= x y) (>= (c-op-precedence x) (c-op-precedence y)))
(define (c-paren x) (cat "(" (c-expr x) ")")) (define (c-paren x) (cat "(" (c-expr x) ")"))

8
sex-macros.module.scm
View File

@@ -1,8 +0,0 @@
(module sex-macros
(register-macro
cat
get-macro
macro?
apply-macro
defmacro)
"sex-macros.scm")

38
sex-macros.scm
View File

@@ -1,38 +0,0 @@
(import
scheme
(only fmt fmt)
(chicken base)
(chicken plist)
(chicken string))
(define (cat-syms s-1 s-2)
(fmt #f s-1 s-2))
(define (cat sym-1 sym-2)
(string->symbol (cat-syms sym-1 sym-2)))
(define (register-macro name arglist body)
(put! name 'sex-macro
`(lambda ,arglist
(import scheme
(only sex-macros cat))
,@body)))
(define (get-macro name)
(eval (get name 'sex-macro)))
(define (macro? form)
(and (list? form)
(symbol? (car form))
(get (car form) 'sex-macro)))
(define (apply-macro form)
(assert (macro? form)
(fmt #f (car form) " is not a macro"))
(apply (get-macro (car form))
(cdr form)))
(define (defmacro form)
(let ((arglist (car form))
(body (cdr form)))
(register-macro (car arglist) (cdr arglist) body)))

5
sex-modules.module.scm
View File

@@ -1,5 +0,0 @@
(module sex-modules
(get-modules-public-forms
load-persistent-module-paths
read-public-interface)
"sex-modules.scm")

87
sex-modules.scm
View File

@@ -1,87 +0,0 @@
(import
scheme
brev-separate
(chicken base)
(chicken file)
(chicken load)
(chicken pathname)
(chicken process-context)
(chicken string)
fmt
reader
srfi-1
utils)
(define +persistent-module-paths+ (list))
(define (get-modules-public-forms module-list)
;; Module list is a list of symbols
;; How Sex handles modules:
;; For each module in a list, construct path, find module by path in
;; module path directories, extract public definitions from the
;; module, paste them in current one in emulation of C include
;; directives.
(fold-right append (list)
(map (fn (import-module (symbol->string x)))
module-list)))
(define (import-module name)
(let ((module-path (locate-module name)))
(assert module-path (fmt #f "Failed to find module " name " in "
(get-module-paths)))
(read-public-interface module-path)))
(define (get-module-paths)
(cons (current-directory)
+persistent-module-paths+))
(define (locate-module name)
;; Module locations: relative to file being compiled, or in what was
;; in SEX_MODULE_PATH env var at the start of the process (see
;; load-persistent-module-paths function)
(let ((search-paths (get-module-paths)))
(let loop ((paths search-paths))
(if (null? paths)
#f
(or (module-exists? name (car paths))
(loop (cdr paths)))))))
(define (module-exists? name module-dir)
;; returns absolute path to module, if it exists
(and (directory-exists? module-dir)
(let ((module-path (make-absolute-pathname module-dir name "sex")))
(and (file-exists? module-path)
(file-readable? module-path)
module-path))))
(define (read-public-interface module-path)
;; pub fns are reduced to prototypes, other pub forms are just pasted
(let ((raw-forms (read-from-file module-path)))
(fold
process-public-interface-form
(list)
raw-forms)))
;;; TODO: use semen facilities to analyze modules
(define (process-public-interface-form form acc)
(case (car form)
((pub)
(case (cadr form)
((fn) ; replace with prototype
;; fn type name (arg-list) (body)
;; 1 2 3 4 - we need first 4
(cons (take (cdr form) 4) acc))
((define defmacro import include struct typedef union var)
(cons (cdr form) acc))
(else (error "Pub what? " (cadr form)))))
(else acc)))
(define (load-persistent-module-paths)
(let ((sex-module-path-env-var
(get-env-var "SEX_MODULE_PATH")))
(when sex-module-path-env-var
(set! +persistent-module-paths+
(map (lambda (p)
(make-absolute-pathname p #f #f))
(string-split sex-module-path-env-var ":"))))))

1
sexc.module.scm
View File

@@ -1 +0,0 @@
(module sexc (main) "sexc.scm")

293
sexc.scm
View File

@@ -1,168 +1,167 @@
(import scheme (module sexc (main)
brev-separate (import scheme
(chicken base) brev-separate
(chicken file) (chicken base)
(chicken plist) (chicken file)
(chicken pretty-print) (chicken plist)
(chicken process) (chicken pretty-print)
(chicken process-context) (chicken process)
(chicken port) (chicken process-context)
fmt (chicken port)
fmt-c-writer fmt
getopt-long fmt-c-writer
sex-macros getopt-long
sex-modules macros
reader module-system
semen reader
srfi-1 ; list routines semen
srfi-13 srfi-1 ; list routines
tree srfi-13
utils) tree
utils)
;;; Main function facilities ;;; Main function facilities
(define opts-grammar (define opts-grammar
(let ((padding 26)) (let ((padding 26))
`((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl `((c-compiler ,(fmt #f "Select C compiler. Defaults to value of SEX_CC" nl
(pad padding) "environment variable, or if it is empty, to cc") (pad padding) "environment variable, or if it is empty, to cc")
(required #f) (required #f)
(value #t)) (value #t))
(compile-object "Compile object file instead of executable program" (compile-object "Compile object file instead of executable program"
(required #f) (required #f)
(value #f) (value #f)
(single-char #\c)) (single-char #\c))
(emit-c "Emit C code" (emit-c "Emit C code"
(required #f)
(value #f)
(single-char #\C))
(public-interface "Get module's public interface"
(required #f)
(value #f))
(help "Show this help"
(required #f) (required #f)
(value #f) (value #f)
(single-char #\C)) (single-char #\h))
(public-interface "Get module's public interface" (macro-expand "Emit macro-expanded semantically processed Sex code"
(required #f) (required #f)
(value #f)) (value #f)
(help "Show this help" (single-char #\m))
(required #f) (output ,(fmt #f "Write output to file. Default file name is a.out." nl
(value #f) (pad padding) "If -E or -m options are provided, defaults to stdout")
(single-char #\h)) (required #f)
(macro-expand "Emit macro-expanded semantically processed Sex code" (value #t)
(required #f) (single-char #\o)))))
(value #f)
(single-char #\m))
(output ,(fmt #f "Write output to file. Default file name is a.out." nl
(pad padding) "If -E or -m options are provided, defaults to stdout")
(required #f)
(value #t)
(single-char #\o)))))
(define (print-help) (define (print-help)
(fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n") (fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
(fmt #t "Options:\n") (fmt #t "Options:\n")
(fmt #t (usage opts-grammar)) (fmt #t (usage opts-grammar))
(fmt #t "")) (fmt #t ""))
(define (help-arg? args) (define (help-arg? args)
(assoc 'help args)) (assoc 'help args))
(define (get-arg args arg-name default) (define (get-arg args arg-name default)
(let ((arg (assoc arg-name args))) (let ((arg (assoc arg-name args)))
(if arg (cdr arg) (if arg (cdr arg)
default))) default)))
(define (get-rest-args args) (define (get-rest-args args)
(cdr (assoc '@ args))) (cdr (assoc '@ args)))
(define (get-c-compiler-args args) (define (get-c-compiler-args args)
(filter (fn (string-prefix? "-" x)) (get-rest-args args))) (filter (fn (string-prefix? "-" x)) (get-rest-args args)))
(define (get-input-file args) (define (get-input-file args)
(let ((rest-args (get-rest-args args))) (let ((rest-args (get-rest-args args)))
(if (null? rest-args) (if (null? rest-args)
'stdin 'stdin
(car rest-args)))) (car rest-args))))
(define (write-to-file-or-stdout output what) (define (write-to-file-or-stdout output what)
(if (eq? output 'default) (if (eq? output 'default)
(what) (what)
(with-output-to-file output (with-output-to-file output
(fn (what))))) (fn (what)))))
(define (emit-c-or-sex sex-forms output args) (define (emit-c-or-sex sex-forms output args)
(write-to-file-or-stdout output (write-to-file-or-stdout output
(lambda () (lambda ()
(if (get-arg args 'macro-expand #f) (if (get-arg args 'macro-expand #f)
(map pp sex-forms) (map pp sex-forms)
(emit-c sex-forms))))) (emit-c sex-forms)))))
(define (compile-to-file sex-forms output args) (define (compile-to-file sex-forms output args)
(let ((compiler (or (get-arg args 'c-compiler #f) (let ((compiler (or (get-arg args 'c-compiler #f)
(get-env-var "SEX_CC") (get-env-var "SEX_CC")
"cc")) "cc"))
(out-file (if (eq? output 'default) (out-file (if (eq? output 'default)
"a.out" "a.out"
output))) output)))
(call-with-values (call-with-values
(lambda () (lambda ()
(process compiler (append (list "-o" out-file "-x" "c") (process compiler (append (list "-o" out-file "-x" "c")
(if (get-arg args 'compile-object #f) (if (get-arg args 'compile-object #f)
(list "-c") (list "-c")
(list)) (list))
(list "-") ; read stdin (list "-") ; read stdin
(get-c-compiler-args args)))) (get-c-compiler-args args))))
(lambda (out-port in-port pid) (lambda (out-port in-port pid)
(with-output-to-port in-port (with-output-to-port in-port
(lambda () (emit-c sex-forms))) (lambda () (emit-c sex-forms)))
(close-output-port in-port) (close-output-port in-port)
(process-wait pid))))) (process-wait pid)))))
(define (semantic-process-forms raw-forms input-source) (define (semantic-process-forms raw-forms input-source)
(if (eq? input-source 'stdin) (if (eq? input-source 'stdin)
(semen-process raw-forms) (semen-process raw-forms)
(with-directory input-source (with-directory input-source
(semen-process raw-forms)))) (semen-process raw-forms))))
(define prelude (define prelude
'((include inttypes.h) '((include inttypes.h)
(typedef u8 uint8-t) (typedef u8 uint8-t)
(typedef i8 int8-t) (typedef i8 int8-t)
(typedef u16 uint16-t) (typedef u16 uint16-t)
(typedef i16 int16-t) (typedef i16 int16-t)
(typedef u32 uint32-t) (typedef u32 uint32-t)
(typedef i32 int32-t) (typedef i32 int32-t)
(typedef u64 uint64-t) (typedef u64 uint64-t)
(typedef i64 int64-t))) (typedef i64 int64-t)))
(define (main) (define (main)
(let* ((raw-args (command-line-arguments)) (let* ((raw-args (command-line-arguments))
(args (getopt-long raw-args (args (getopt-long raw-args
opts-grammar)) opts-grammar))
(output (get-arg args 'output 'default)) (output (get-arg args 'output 'default))
(help (help-arg? args)) (help (help-arg? args))
(input (get-input-file args)) (input (get-input-file args))
(current-dir (current-directory))) (current-dir (current-directory)))
(call/cc (call/cc
(lambda (return) (lambda (return)
(when help (when help
(print-help) (print-help)
(return #f)) (return #f))
(when (get-arg args 'public-interface #f) (when (get-arg args 'public-interface #f)
(assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument") (assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
(write-to-file-or-stdout (write-to-file-or-stdout
output output
(fn (fn
(map pp (reverse (map pp (reverse
(read-public-interface input))))) (read-public-interface input)))))
(return #f)) (return #f))
(load-persistent-module-paths) (load-persistent-module-paths)
(if (eq? input 'stdin) (sex-fmt-current-file (to-absolute-pathname input))
(sex-fmt-current-file "stdin") (let* ((raw-forms (append prelude (read-raw-forms input)))
(sex-fmt-current-file (to-absolute-pathname input))) (sex-forms (semantic-process-forms raw-forms input)))
(let* ((raw-forms (append prelude (read-raw-forms input))) (if (or (get-arg args 'macro-expand #f)
(sex-forms (semantic-process-forms raw-forms input))) (get-arg args 'emit-c #f))
(if (or (get-arg args 'macro-expand #f) ;; Emit processed and macro-expanded sex code, or emit C code
(get-arg args 'emit-c #f)) (emit-c-or-sex sex-forms output args)
;; Emit processed and macro-expanded sex code, or emit C code ;; Compile file!
(emit-c-or-sex sex-forms output args) (compile-to-file sex-forms output args))))))))
;; Compile file!
(compile-to-file sex-forms output args)))))))

44
tests/Makefile
View File

@@ -1,45 +1 @@
CHICKEN_C = csc
CSC_FLAGS += -K prefix -static
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
SEX_OBJ = $(MODULES:%=%.o)
TESTS = basic semen reader fmt-c-writer utils
TEST_SRCS = $(TESTS:%=%.scm)
sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
$(CHICKEN_C) $(CSC_FLAGS) run.scm -o sex-tests -link sexc
#------------------------------------------------------------------
utils.o: utils.module.scm ../utils.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
sex-macros.o: sex-macros.module.scm ../sex-macros.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
reader.o: reader.module.scm ../reader.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader
sex-modules.o: sex-modules.module.scm ../sex-modules.scm reader.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
semen.o: semen.module.scm ../semen.scm sex-macros.o sex-modules.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils
sex-fmt-c.o: ../sex-fmt-c.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) ../sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
sexc.o: sexc.module.scm ../sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sexc.module.scm -o sexc.o -unit sexc -link fmt-c-writer,sex-macros,sex-modules,reader,semen,utils
clean:
rm -f $(OBJ)
rm -f *.import.scm
rm -f *.link
rm -f sex-tests

2
tests/basic.scm
View File

@@ -1,5 +1,3 @@
(import fmt-c-writer)
(test-group "basic" (test-group "basic"
;; unkebabify ;; unkebabify

3
tests/fmt-c-writer.module.scm
View File

@@ -1,3 +0,0 @@
(module fmt-c-writer
*
"../fmt-c-writer.scm")

3
tests/reader.module.scm
View File

@@ -1,3 +0,0 @@
(module reader
*
"../reader.scm")

3
tests/reader.scm
View File

@@ -1,5 +1,4 @@
(import (chicken port) (import (chicken port))
reader)
(define-syntax reader-test (define-syntax reader-test
(syntax-rules () (syntax-rules ()

6
tests/run.scm
View File

@@ -1,4 +1,10 @@
(declare (uses fmt-c-writer
semen))
(import (import
(chicken process)
(chicken process-context)
srfi-1
test) test)
(include "basic.scm") (include "basic.scm")

2
tests/semen.module.scm
View File

@@ -1,2 +0,0 @@
(module semen *
"../semen.scm")

11
tests/semen.scm
View File

@@ -1,5 +1,4 @@
(import srfi-69 (import srfi-69)
semen)
(define print-str-fn (define print-str-fn
'(fn void print-str ((string s)) '(fn void print-str ((string s))
@@ -39,11 +38,11 @@
(define (form-identity form env) (define (form-identity form env)
form) form)
(test 'a (walk-form 'a form-identity (make-hash-table))) (test 'a (semen-walk-form 'a form-identity (make-hash-table)))
(test '(a b c) (walk-form '(a b c) form-identity (make-hash-table))) (test '(a b c) (semen-walk-form '(a b c) form-identity (make-hash-table)))
(test 'a (macro-expand 'a)) (test 'a (semen-macro-expand 'a))
(test '(a b c) (macro-expand '(a b c))) (test '(a b c) (semen-macro-expand '(a b c)))
(let ((sex-code-macro (let ((sex-code-macro
'((defmacro (x10 a) '((defmacro (x10 a)

3
tests/sex-macros.module.scm
View File

@@ -1,3 +0,0 @@
(module sex-macros
*
"../sex-macros.scm")

3
tests/sex-modules.module.scm
View File

@@ -1,3 +0,0 @@
(module sex-modules
*
"../sex-modules.scm")

1
tests/sexc.module.scm
View File

@@ -1 +0,0 @@
(module sexc (main) "../sexc.scm")

3
tests/utils.module.scm
View File

@@ -1,3 +0,0 @@
(module utils
*
"../utils.scm")

2
tests/utils.scm
View File

@@ -1,5 +1,3 @@
(import utils)
(test-group "utils" (test-group "utils"
(test (test

5
tools/sextest/Makefile
View File

@@ -1,5 +0,0 @@
CHICKEN_C = csc
CSC_FLAGS += -K prefix -static
sextest: sextest.scm
$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest

34
tools/sextest/README.org
View File

@@ -1,26 +1,34 @@
* Sextest * Sextest
A tool for testing Sex compiler by using test programs.
The tools compiles test programs, then runs with provided A tool for testing sex compilator by using test programs.
input, checking the output and return code. The tools compiles them using the compiler, then runs with provided
input, then checks that the output and return code matches the test
specification.
* Test format * Test format
The test program is just a regular Sex program, which may contain The test program consists of two sections: prelude and the test
additional toplevel forms, to define compilation parameters, input to program itself. Prelude contains four sections: compilation
the program, and expected output and return code. Default value for parameters, such as flags to compiler; string to be
compilation, input and output is an empty strings. For the return code passed to program's stdin; output to match against
it is 0. program's stdout; return code to match against what
program returns.
All sections start with respective name: :compilation, :stdout,
:stdin, :return.
Section names must be present, but all can be empty. Return code
defaults to 0 in such case.
* Example * Example
some-test.sex: some-test.sex:
#+begin_src #+begin_src
(compilation "-- -O2") ; :compilation
(input "") ; :stdin
(output "Hello world!") ; :stdout Hello world!
(return 123) ; :return
(include stdio.h) (include stdio.h)
(pub fn main () int (pub fn main () int
(puts "Hello World!") (puts "Hello World!")
(return 123)) (printf "Hello, %s!\n" name)
(return 0))
#+end_src #+end_src

13
tools/sextest/hello-sextest.sex
View File

@@ -1,13 +0,0 @@
(input "Sextest")
(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
(return 0)
(include stdio.h)
(pub fn main s ((argc int) (argv [* const char])) int
(puts "Hello from Sex!")
(var name [char 512])
(puts "What is your name?")
(scanf "%s" (cast (& name) (* char)))
(printf "Hello, %s!\n" name)
(return 255))

154
tools/sextest/sextest.scm
View File

@@ -1,154 +0,0 @@
(import scheme
brev-separate
(chicken base)
(chicken file)
(chicken io)
(chicken pathname)
(chicken port)
(chicken process)
(chicken process-context)
(chicken read-syntax)
(chicken syntax)
fmt
srfi-1)
(define-syntax prog1
(syntax-rules ()
((prog1 form . forms)
(let ((res form))
(begin . forms)
res))))
(define-syntax with-directory
(syntax-rules ()
((with-directory path form . forms)
(let ((current-dir (current-directory)))
(set-working-directory path)
(prog1
(begin form . forms)
(change-directory current-dir))))))
(define (set-working-directory file)
(change-directory
(normalize-pathname
(if (absolute-pathname? file)
(pathname-directory file)
(make-absolute-pathname
(current-directory)
(pathname-directory file))))))
;;; TODO: use sexc reader code i.e. link with sex reader
(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)))))))
(read-from-file input-source))
(define (read-from-file file)
(with-directory file
(with-input-from-file (pathname-strip-directory file)
(fn (read-forms (list))))))
(define (read-forms acc)
(let ((r (read-with-source-info (current-input-port))))
(if (eof-object? r) (reverse acc)
(read-forms (cons r acc)))))
(define (print-help)
(fmt #t "Usage: sextest ./path/to/test-file.sex\n"))
(define (process-file target-path)
(let ((contents (read-raw-forms target-path)))
(foldl (lambda (acc elt)
(case (car elt)
((compilation input output return)
(cons
(append (car acc) (list elt))
(cdr acc)))
(else
(cons
(car acc)
(append (cdr acc) (list elt))))))
(cons (list) (list))
contents)))
(define (compile src flags)
(let ((compiler (or (get-environment-variable "SEXC")
;; TODO: pass compiler in args
;; (get-arg args 'sex-compiler #f)
"sexc"))
(compiled-file (create-temporary-file)))
(call-with-values
(fn
(process compiler
(append (list "-o" compiled-file)
flags)))
(lambda (out-port in-port pid)
(with-output-to-port in-port
(fn (map print src)))
(close-output-port in-port)
(call-with-values
(fn (process-wait pid))
(lambda (pid exited retcode)
(if (= 0 retcode)
compiled-file
#f)))))))
(define (run-and-check file in out ret)
(call-with-values
(fn (process file))
(lambda (out-port in-port pid)
(when in
(with-output-to-port in-port
(fn (map print (cdr in))))
(close-output-port in-port))
(with-input-from-port out-port
(fn
(let loop ((line (read-line))
(lines (list)))
(if (eof-object? line)
(reverse lines)
(loop (read-line)
(cons line lines))))))
(call-with-values
(fn (process-wait pid))
(lambda (pid exited retcode)
(fmt #t "Ret code: " retcode nl))))))
(define (main)
(let ((args (command-line-arguments)))
(if (not (= 1 (length args)))
(print-help)
(let ((settings-and-src
(process-file (first args))))
(let ((settings (car settings-and-src))
(src (cdr settings-and-src)))
(let ((compiled-file (compile src (assoc 'compile settings))))
(unless compiled-file
(fmt #t "Compilation failed." nl)
(exit 1))
(run-and-check
compiled-file
(assoc 'input settings)
(assoc 'output settings)
(assoc 'return settings))))))))
(main)

73
tools/sextest/sextest.sex Normal file
View File

@@ -0,0 +1,73 @@
(include stdio.h)
(include unistd.h)
(include string.h)
(var COMP (* const char) ":compilation")
(var STDIN (* const char) ":stdin")
(var STDOUT (* const char) ":stdout")
(var RET (* const char) ":return")
(var test-file-path (* const char) NULL)
(var prelude-comp [const char 1024])
(var prelude-stdin [const char 1024])
(var prelude-stdout [const char 1024])
(var prelude-ret [const char 1024])
(fn print-usage () void
(printf "Usage: sextest ./path/to/test-file.sex\n"))
(fn read-file ((file-path (* const char))) void
(var f (* FILE) (fopen file-path "r"))
(if (== f NULL)
(begin
(printf "Failed to read file %s\n" file-path)
(return)))
;; should be more than enough
(var buffer [const char 1024])
(var i int 0)
(var c char)
(var section (* const char))
(while (!= EOF (= c (getc f)))
(switch c
(case (#\space #\newline #\tab #\return)
(= [buffer i] #\null)
(if (!= NULL section)
(begin
(memcpy i section buffer)))
(if (== 0 (strncmp buffer COMP 8ul)))
(= i 0))
(default
(if (== i (sizeof buffer))
(printf "Blast! The section is longer than %d, not going to work with this" (++/post i)))
(if (< i (sizeof buffer))
(= [buffer (++/post i)] c))))))
(fn get-section ((section-name (* const char))) (* const char)
;; Get section from test file by name.
;; Name must be one of: :compilation, :stdin, :stdout, :return
(if (== 0 (strncmp section-name COMP 8ul))
(return prelude-comp))
(if (== 0 (strncmp section-name STDIN 6ul))
(return prelude-stdin))
(if (== 0 (strncmp section-name STDOUT 7ul))
(return prelude-stdout))
(if (== 0 (strncmp section-name RET 7ul))
(return prelude-ret))
(printf "Expected section name, got %s\n" section-name)
(return NULL))
(pub fn main ((argc int) (argv [* const char])) int
(if (!= argc 2)
(begin
(print-usage)
(return 1)))
(var test-file-path (* const char) [argv 1])
(read-file test-file-path)
(return 0))

10
utils.module.scm
View File

@@ -1,10 +0,0 @@
(module utils
(get-env-var
set-working-directory
to-absolute-pathname
list-split
list-join
recons
with-directory
)
"utils.scm")

123
utils.scm
View File

@@ -1,66 +1,77 @@
(import (module utils
scheme (get-env-var
(chicken base) set-working-directory
(chicken pathname) to-absolute-pathname
(chicken process-context) list-split
srfi-1) list-join
recons
with-directory
)
(define-syntax prog1 (import
(syntax-rules () scheme
((prog1 form . forms) (chicken base)
(let ((res form)) (chicken pathname)
(begin . forms) (chicken process-context)
res)))) srfi-1)
(define-syntax with-directory (define-syntax prog1
(syntax-rules () (syntax-rules ()
((with-directory path form . forms) ((prog1 form . forms)
(let ((current-dir (current-directory))) (let ((res form))
(set-working-directory path) (begin . forms)
(prog1 res))))
(begin form . forms)
(change-directory current-dir))))))
(define (get-env-var name) (define-syntax with-directory
(get-environment-variable name)) (syntax-rules ()
((with-directory path form . forms)
(let ((current-dir (current-directory)))
(set-working-directory path)
(prog1
(begin form . forms)
(change-directory current-dir))))))
(define (set-working-directory file) (define (get-env-var name)
(change-directory (get-environment-variable name))
(normalize-pathname
(if (absolute-pathname? file) (define (set-working-directory file)
(pathname-directory file) (change-directory
(normalize-pathname
(if (absolute-pathname? file)
(pathname-directory file)
(make-absolute-pathname
(current-directory)
(pathname-directory file))))))
(define (to-absolute-pathname pathname)
(if (absolute-pathname? pathname)
pathname
(make-absolute-pathname (make-absolute-pathname
(current-directory) (current-directory)
(pathname-directory file)))))) pathname)))
(define (to-absolute-pathname pathname) (define (list-split src-list split-elt)
(if (absolute-pathname? pathname) ;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6))
pathname (fold (lambda (elt acc)
(make-absolute-pathname (if (eq? elt split-elt)
(current-directory) (append acc (list (list)))
pathname))) (append (drop-right acc 1)
(list (append (last acc) (list elt))))))
(list (list))
src-list))
(define (list-split src-list split-elt) (define (list-join lists join-by)
;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6)) (drop-right
(fold (lambda (elt acc) (fold (lambda (elt acc)
(if (eq? elt split-elt) (append acc (list elt) (list join-by)))
(append acc (list (list))) (list)
(append (drop-right acc 1) lists)
(list (append (last acc) (list elt)))))) 1))
(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 ;;; Reconstruct form
(define (recons old-cons new-car new-cdr) (define (recons old-cons new-car new-cdr)
(if (and (eq? new-car (car old-cons)) (if (and (eq? new-car (car old-cons))
(eq? new-cdr (cdr old-cons))) (eq? new-cdr (cdr old-cons)))
old-cons old-cons
(cons new-car new-cdr))) (cons new-car new-cdr)))
)