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:a80b8d9acf62d27cd7580f8252e7c0435419b3a1
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:a64caec5f8aa968f0194289771a4d83bb94a2866
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

5 Commits
a80b8d9acf ... a64caec5f8

Author SHA1 Message Date
alex-eg
a64caec5f8 WIP 2026-05-14 15:56:58 +03:00
alex-eg
b157315e3d fix paren placing in fmt
Some checks failed
Sex CI / build-linux (pull_request) Has been cancelled
Details
Sex CI / build-macos (pull_request) Has been cancelled
Details
Sex CI / build-linux (push) Has been cancelled
Details
Sex CI / build-macos (push) Has been cancelled
Details 
Prior to the fix, the Sex code
`(while (!= EOF (= c (getc f))) ...)` expanded wrongly to
`while (EOF != c = getc(f)) { ...`, instead of
`while (EOF != (c = getc(f))) { ...`
 2026-04-29 22:48:55 +03:00
alex-eg
24b3e71969 update sex-mode.el 
- add switch and case indents
- add begin and default highlighting as keywords
 2026-04-29 22:48:55 +03:00
alex-eg
a951fd81b6 remove utils.macros.scm as it is no longer needed 2026-04-29 22:48:55 +03:00
alex-eg
196694f18e modularize sex 
Also rename macros to sex-macros, module-system to sex-modules for
clarity, uniformity, and to avoid name clashes with Chicken's
units/modules named "macros" and "modules"
 2026-04-29 22:48:55 +03:00
40 changed files with 1138 additions and 1020 deletions
Expand all files Collapse all files

1
.gitignore vendored
View File

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

75
Makefile
View File

@@ -1,53 +1,60 @@
CHICKEN_C = csc CHICKEN_C = csc
CSC_FLAGS += -K prefix CSC_FLAGS += -K prefix -static
# 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 macros reader module-system semen sex-fmt-c fmt-c-writer sexc MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
OBJ = $(MODULES:%=%.o) OBJ = $(MODULES:%=%.o)
IMPORTS = $(MODULES:%=%.import.scm)
LINK = $(MODULES:%=%.link)
sexc: $(OBJ) main.o sexc: $(OBJ) main.scm
$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@ $(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
# otherwise csc hangs, probably because it tries to compile to sexc.o first
main.o: main.scm mv sexc-tmp sexc
$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@ -link sexc
#------------------------------------------------------------------ #------------------------------------------------------------------
utils.o: utils.scm utils.o: utils.module.scm utils.scm
$(CHICKEN_C) $(CSC_FLAGS) utils.scm -e -c -J -o utils.o -unit utils $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
macros.o: macros.scm sex-macros.o: sex-macros.module.scm sex-macros.scm
$(CHICKEN_C) $(CSC_FLAGS) macros.scm -e -c -J -o macros.o -unit macros $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-macros.module.scm -o sex-macros.o -unit sex-macros
reader.o: reader.o: reader.module.scm reader.scm
$(CHICKEN_C) $(CSC_FLAGS) reader.scm -e -c -J -o reader.o -unit reader $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader
module-system.o: module-system.scm reader.import.scm utils.import.scm sex-modules.o: sex-modules.module.scm sex-modules.scm reader.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) module-system.scm -e -c -J -o module-system.o -unit module-system -link reader,utils $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-modules.module.scm -o sex-modules.o -unit sex-modules -link reader,utils
semen.o: semen.scm macros.import.scm module-system.import.scm utils.import.scm semen.o: semen.module.scm semen.scm sex-macros.o sex-modules.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) semen.scm -e -c -J -o semen.o -unit semen -link macros,module-system,utils $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,utils
fmt-c-writer.o: fmt-c-writer.scm sex-fmt-c.import.scm utils.import.scm sex-fmt-c.o: sex-fmt-c.scm
$(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 $(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) sex-fmt-c.scm -o sex-fmt-c.o -unit sex-fmt-c
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 fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) sexc.scm -e -c -J -o sexc.o -unit sexc -link fmt-c-writer,macros,module-system,reader,semen,utils $(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
%.link: %.o sexc.o: sexc.module.scm sexc.scm fmt-c-writer.o sex-macros.o sex-modules.o reader.o semen.o utils.o
%.import.scm: %.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
%.o: %.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -J -o $@ -unit $(@:%.o=%)
sex-tests:
sex-tests: $(OBJ) tests/*.scm $(MAKE) -C tests sex-tests
cd ./tests && $(CHICKEN_C) $(CSC_FLAGS) run.scm -c -o sex-tests.o cp ./tests/sex-tests ./
$(CHICKEN_C) $(CSC_FLAGS) $(OBJ) ./tests/sex-tests.o -o sex-tests
clean: clean:
rm -f $(OBJ) main.o ./tests/sex-tests.o rm -f $(OBJ) main.o
rm -f $(IMPORTS) rm -f *.import.scm
rm -f $(LINK) main.link rm -f *.link
rm -f sexc sex-tests rm -f sexc sex-tests

2
example/mini-test.sex
View File

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

25
example/our-reader.sex
View File

@@ -1,25 +0,0 @@
(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
View File

@@ -1,6 +0,0 @@
(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 Normal file
View File

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

502
fmt-c-writer.scm
View File

@@ -1,285 +1,283 @@
;;; Sex fmt-c output writer ;;; Sex fmt-c output writer
(module fmt-c-writer (emit-c (import
sex-fmt-current-file) scheme
(import (chicken base)
scheme (chicken string)
(chicken base) (chicken syntax)
(chicken string) brev-separate
(chicken syntax) fmt
brev-separate sex-fmt-c
fmt matchable
sex-fmt-c regex
matchable srfi-1 ; lists
regex srfi-13 ; strings
srfi-1 ; lists srfi-39 ; parameters
srfi-13 ; strings tree
srfi-39 ; parameters utils)
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
(fmt #f (cadr form) (car form))))) (string-substitute "-(?!>)" "_"
(symbol->string sym) #t)))))
(define (walk-generic-toplevel form) (define (atom-to-fmt-c atom)
(cond ((atom? form) (atom-to-fmt-c form)) (case atom
((list? form) (map walk-generic-toplevel form)) ((fn) '%fun)
(else (error "Malformed form " form)))) ((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 (field-access-form? form) (define (maybe-unwrap-type type)
(and (symbol? (car form)) (if (and (list? type)
(char=? #\. (string-ref (symbol->string (car form)) 0)))) (= 1 (length type)))
(car type)
type))
(define (walk-expr form) (define (make-field-access form)
(match form (assert
((? vector?) (= 2 (length form)) "Wrong field access format")
(list->vector (unkebabify
(walk-expr (vector->list form)))) (string->symbol
((? atom?) (fmt #f (cadr form) (car form)))))
(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) (define (walk-generic-toplevel form)
;; (var a int) -> (%var int a) (cond ((atom? form) (atom-to-fmt-c form))
;; (var a (const int) 32) -> (%var (const int) a 32) ((list? form) (map walk-generic-toplevel form))
;; (var b [const char 512]) -> (%var (%array (const char) 512) b) (else (error "Malformed form " form))))
;; 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 (field-access-form? form)
;; int -> int (and (symbol? (car form))
;; (const int) -> const int (char=? #\. (string-ref (symbol->string (car form)) 0))))
;; [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"))
;; Special case: nested structs/unions (define (walk-expr form)
((or ('struct . _) (match form
('union . _)) (walk-struct form)) ((? vector?)
(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))))
(('enum . _) (walk-enum form)) (define (walk-var form)
(else ;; (var a int) -> (%var int a)
(type-convert-to-c form)))) ;; (var a (const int) 32) -> (%var (const int) a 32)
;; (var b [const char 512]) -> (%var (%array (const char) 512) b)
;; note: [...] is actually (¤ ...) after reading
;; (var c (fn ((int) (float)) void)) -> (%var (%fun void ((int) (float))) c)
`(%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 (type-convert-to-c type) (define (walk-type form)
;; Our pointers to C pointers ;; int -> int
;; int -> int ;; (const int) -> const int
;; * const char -> const char * ;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512)
;; const * const char -> const char * const ;; [float 8] -> (%array float 8)
(if (atom? type) (atom-to-fmt-c type) ;; (* const char) -> (const char *)
(flatten ;; (const * const * const char) -> (const char * const * const)
(tree-map atom-to-fmt-c ;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
(flatten (match form
(list-join (reverse (list-split type '*)) (('¤ . 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-fn-def form) ;; Special case: nested structs/unions
(match form ((or ('struct . _)
(('fn name args ret-type . maybe-body) ('union . _)) (walk-struct form))
`(%fun
,(walk-type ret-type) (('enum . _) (walk-enum form))
,(atom-to-fmt-c name) (else
,(walk-arglist args) (type-convert-to-c form))))
.
,(walk-expr maybe-body))))) (define (type-convert-to-c type)
;; Our pointers to C pointers
;; int -> int
;; * const char -> const char *
;; const * const char -> const char * const
(if (atom? type) (atom-to-fmt-c type)
(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
View File

@@ -1,45 +0,0 @@
(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
View File

@@ -1,92 +0,0 @@
(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 Normal file
View File

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

101
reader.scm
View File

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

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

370
semen.scm
View File

@@ -1,22 +1,21 @@
;;; Sex semantic engine ;;; Sex semantic engine
(module semen () (import
(import scheme
scheme (chicken base)
(chicken base) (chicken keyword)
(chicken keyword) (chicken string)
(chicken string) (chicken module)
(chicken module) fmt
fmt sex-macros
macros sex-modules
matchable ; pattern matching matchable ; pattern matching
module-system srfi-1 ; list routines
srfi-1 ; list routines srfi-69 ; hash tables
srfi-69 ; hash tables utils
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
@@ -26,84 +25,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
@@ -113,129 +112,128 @@
;;; 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,7 +105,6 @@
(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 Normal file
View File

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

38
sex-macros.scm Normal file
View File

@@ -0,0 +1,38 @@
(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 Normal file
View File

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

87
sex-modules.scm Normal file
View File

@@ -0,0 +1,87 @@
(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 Normal file
View File

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

293
sexc.scm
View File

@@ -1,167 +1,168 @@
(module sexc (main) (import scheme
(import scheme brev-separate
brev-separate (chicken base)
(chicken base) (chicken file)
(chicken file) (chicken plist)
(chicken plist) (chicken pretty-print)
(chicken pretty-print) (chicken process)
(chicken process) (chicken process-context)
(chicken process-context) (chicken port)
(chicken port) fmt
fmt fmt-c-writer
fmt-c-writer getopt-long
getopt-long sex-macros
macros sex-modules
module-system reader
reader semen
semen srfi-1 ; list routines
srfi-1 ; list routines srfi-13
srfi-13 tree
tree utils)
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)
(value #f)
(single-char #\c))
(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)
(value #f)
(single-char #\h))
(macro-expand "Emit macro-expanded semantically processed Sex code"
(required #f) (required #f)
(value #f) (value #f)
(single-char #\m)) (single-char #\c))
(output ,(fmt #f "Write output to file. Default file name is a.out." nl (emit-c "Emit C code"
(pad padding) "If -E or -m options are provided, defaults to stdout") (required #f)
(required #f) (value #f)
(value #t) (single-char #\C))
(single-char #\o))))) (public-interface "Get module's public interface"
(required #f)
(value #f))
(help "Show this help"
(required #f)
(value #f)
(single-char #\h))
(macro-expand "Emit macro-expanded semantically processed Sex code"
(required #f)
(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)
(sex-fmt-current-file (to-absolute-pathname input)) (if (eq? input 'stdin)
(let* ((raw-forms (append prelude (read-raw-forms input))) (sex-fmt-current-file "stdin")
(sex-forms (semantic-process-forms raw-forms input))) (sex-fmt-current-file (to-absolute-pathname input)))
(if (or (get-arg args 'macro-expand #f) (let* ((raw-forms (append prelude (read-raw-forms input)))
(get-arg args 'emit-c #f)) (sex-forms (semantic-process-forms raw-forms input)))
;; Emit processed and macro-expanded sex code, or emit C code (if (or (get-arg args 'macro-expand #f)
(emit-c-or-sex sex-forms output args) (get-arg args 'emit-c #f))
;; Compile file! ;; Emit processed and macro-expanded sex code, or emit C code
(compile-to-file sex-forms output args)))))))) (emit-c-or-sex sex-forms output args)
;; Compile file!
(compile-to-file sex-forms output args)))))))

44
tests/Makefile
View File

@@ -1 +1,45 @@
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,3 +1,5 @@
(import fmt-c-writer)
(test-group "basic" (test-group "basic"
;; unkebabify ;; unkebabify

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

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

3
tests/reader.module.scm Normal file
View File

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

3
tests/reader.scm
View File

@@ -1,4 +1,5 @@
(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,10 +1,4 @@
(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 Normal file
View File

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

11
tests/semen.scm
View File

@@ -1,4 +1,5 @@
(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))
@@ -38,11 +39,11 @@
(define (form-identity form env) (define (form-identity form env)
form) form)
(test 'a (semen-walk-form 'a form-identity (make-hash-table))) (test 'a (walk-form 'a form-identity (make-hash-table)))
(test '(a b c) (semen-walk-form '(a b c) form-identity (make-hash-table))) (test '(a b c) (walk-form '(a b c) form-identity (make-hash-table)))
(test 'a (semen-macro-expand 'a)) (test 'a (macro-expand 'a))
(test '(a b c) (semen-macro-expand '(a b c))) (test '(a b c) (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 Normal file
View File

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

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

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

1
tests/sexc.module.scm Normal file
View File

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

3
tests/utils.module.scm Normal file
View File

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

2
tests/utils.scm
View File

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

5
tools/sextest/Makefile Normal file
View File

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

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

@@ -0,0 +1,13 @@
(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 Normal file
View File

@@ -0,0 +1,154 @@
(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
View File

@@ -1,73 +0,0 @@
(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 Normal file
View File

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