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
39 changed files with 1527 additions and 1175 deletions
Expand all files Collapse all files

2
.gitignore vendored
View File

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

63
Makefile
View File

@@ -1,21 +1,60 @@
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.
MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
# Order matters, since module check correctness on compilation
MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
OBJ = $(MODULES:%=%.o)
sexc: main.o $(OBJ)
$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
sexc: $(OBJ) main.scm
$(CHICKEN_C) $(CSC_FLAGS) main.scm -o sexc-tmp -link sexc
# 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 $@
#------------------------------------------------------------------
%.o: %.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@
utils.o: utils.module.scm utils.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
sex-tests: $(OBJ) tests/*.scm
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
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
sex-tests:
$(MAKE) -C tests sex-tests
cp ./tests/sex-tests ./
clean:
rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o
rm -f $(OBJ) main.o
rm -f *.import.scm
rm -f *.link
rm -f sexc sex-tests

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")

30
fmt-c-writer.scm
View File

@@ -1,20 +1,20 @@
;;; Sex fmt-c output writer
(declare (unit fmt-c-writer)
(uses fmt-c
semen
utils))
(import (chicken string)
(chicken syntax)
brev-separate
fmt
matchable
regex
srfi-1 ; lists
srfi-13 ; strings
srfi-39 ; parameters
tree)
(import
scheme
(chicken base)
(chicken string)
(chicken syntax)
brev-separate
fmt
sex-fmt-c
matchable
regex
srfi-1 ; lists
srfi-13 ; strings
srfi-39 ; parameters
tree
utils)
(define (unkebabify sym)
(case sym

959
fmt-c.scm
View File

@@ -1,959 +0,0 @@
;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
;;
;; Copyright (c) 2007 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; additional state information
(declare (unit fmt-c))
(import fmt
srfi-1
srfi-13)
(define (fmt-in-macro? st) (fmt-ref st 'in-macro?))
(define (fmt-macro-params st) (fmt-ref st 'macro-params))
(define (fmt-expression? st) (fmt-ref st 'expression?))
(define (fmt-return? st) (fmt-ref st 'return?))
(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?))
(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?))
(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?))
(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?))
(define (fmt-indent-space st) (fmt-ref st 'indent-space))
(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space))
(define (fmt-op st) (fmt-ref st 'op 'stmt))
(define (fmt-gen st) (fmt-ref st 'gen))
(define (c-in-expr proc) (fmt-let 'expression? #t proc))
(define (c-in-stmt proc) (fmt-let 'expression? #f proc))
(define (c-reset-newline proc) (fmt-let 'newline-before-brace? #f proc))
(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc)))
(define (c-with-op op proc) (fmt-let 'op op proc))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; be smart about operator precedence
(define (c-op-precedence x)
(if (string? x)
(cond
((or (string=? x ".") (string=? x "->")) 10)
((or (string=? x "++") (string=? x "--")) 20)
((string=? x "&") 55)
((string=? x "|") 65)
((string=? x "&&") 70)
((string=? x "||") 75)
((string=? x "|=") 85)
((or (string=? x "+=") (string=? x "-=")) 85)
(else 95))
(case x
;;((|::|) 5) ; C++
((dot arrow post-decrement post-increment) 10)
((**) 15) ; Perl
((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ --
((=~ !~) 25) ; Perl
((* / %) 30)
((+ -) 35)
((<< >>) 40)
((< > <= >=) 45)
((lt gt le ge) 45) ; Perl
((== !=) 50)
((eq ne cmp) 50) ; Perl
((&) 55)
((^) 60)
;;((|\||) 65)
((&& %and) 70)
((%or) 75)
;;((|\|\||) 75)
;;((.. ...) 77) ; Perl
((?) 80)
((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ; += -=
((comma) 90)
((=>) 90) ; Perl
((not) 92) ; Perl
((and) 93) ; Perl
((or xor) 94) ; Perl
((paren bracket) 100)
(else 95))))
(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-maybe-paren op x)
(lambda (st)
((fmt-let 'op op
(if (and (c-op<= (fmt-op st) op)
(not (vector? st)))
(c-paren x)
x))
st)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; default literals writer
(define (c-control-operator? x)
(memq x '(if while switch repeat do for fun begin)))
(define (c-literal? x)
(or (number? x) (string? x) (char? x) (boolean? x)))
(define (char->c-char c)
(string-append "'" (c-escape-char c #\') "'"))
(define (c-escape-char c quote-char)
(let ((n (char->integer c)))
(if (<= 32 n 126)
(if (or (eqv? c quote-char) (eqv? c #\\))
(string #\\ c)
(string c))
(case n
((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
((11) "\\v") ((12) "\\f") ((13) "\\r")
(else (string-append "\\x" (number->string (char->integer c) 16)))))))
(define (c-format-number x)
(if (and (integer? x) (exact? x))
(lambda (st)
((case (fmt-radix st)
((16) (cat "0x" (string-upcase (number->string x 16))))
((8) (cat "0" (number->string x 8)))
(else (dsp (number->string x))))
st))
(dsp (number->string x))))
(define (c-format-string x)
(lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st)))
(define (c-string-escaped x)
(let loop ((parts '()) (idx (string-length x)))
(cond ((string-index-right x c-needs-string-escape? 0 idx)
=> (lambda (special-idx)
(loop (cons (c-escape-char (string-ref x special-idx) #\")
(cons (substring/shared x (+ special-idx 1) idx)
parts))
special-idx)))
(else
(cons (substring/shared x 0 idx) parts)))))
(define (c-needs-string-escape? c)
(if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t))
(define (c-simple-literal x)
(c-wrap-stmt
(cond ((char? x) (dsp (char->c-char x)))
((boolean? x) (dsp (if x "1" "0")))
((number? x) (c-format-number x))
((string? x) (c-format-string x))
((null? x) (dsp "NULL"))
((eof-object? x) (dsp "EOF"))
(else (dsp (write-to-string x))))))
(define (c-literal x)
(lambda (st)
((if (and (symbol? x) (memq x (or (fmt-macro-params st) '())))
(c-paren (c-simple-literal x))
(c-simple-literal x))
st)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; default expression generator
(define (c-expr/sexp x)
(if (procedure? x)
x
(lambda (st)
(cond
((pair? x)
(case (car x)
((if) ((apply c-if (cdr x)) st))
((for) ((apply c-for (cdr x)) st))
((while) ((apply c-while (cdr x)) st))
((switch) ((apply c-switch (cdr x)) st))
((case) ((apply c-case (cdr x)) st))
((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st))
((default) ((apply c-default (cdr x)) st))
((break) (c-break st))
((continue) (c-continue st))
((return) ((apply c-return (cdr x)) st))
((goto) ((apply c-goto (cdr x)) st))
((typedef) ((apply c-typedef (cdr x)) st))
((struct union class) ((apply c-struct/aux x) st))
((enum) ((apply c-enum (cdr x)) st))
((inline auto restrict register volatile extern static)
((cat (car x) " " (apply c-begin (cdr x))) st))
;; non C-keywords must have some character invalid in a C
;; identifier to avoid conflicts - by default we prefix %
((vector-ref)
((c-wrap-stmt
(cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
st))
((vector-set!)
((c= (c-in-expr
(cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
(c-expr (cadddr x)))
st))
((extern/C) ((apply c-extern/C (cdr x)) st))
((%apply) ((apply c-apply (cdr x)) st))
((%define) ((apply cpp-define (cdr x)) st))
((%include) ((apply cpp-include (cdr x)) st))
((%fun) ((apply c-fun (cdr x)) st))
((%cond)
(let lp ((ls (cdr x)) (res '()))
(if (null? ls)
((apply c-if (reverse res)) st)
(lp (cdr ls)
(cons (if (pair? (cddar ls))
(apply c-begin (cdar ls))
(cadar ls))
(cons (caar ls) res))))))
((%prototype) ((apply c-prototype (cdr x)) st))
((%var) ((apply c-var (cdr x)) st))
((%begin) ((apply c-begin (cdr x)) st))
((%attribute) ((apply c-attribute (cdr x)) st))
((%line) ((apply cpp-line (cdr x)) st))
((%pragma %error %warning)
((apply cpp-generic (substring/shared (symbol->string (car x)) 1)
(cdr x)) st))
((%if %ifdef %ifndef %elif)
((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1)
(cdr x)) st))
((%endif) ((apply cpp-endif (cdr x)) st))
((%block-begin) ((apply c-braced-block #f (cdr x)) st))
((%block) ((apply c-braced-block (cdr x)) st))
((%comment) ((apply c-comment (cdr x)) st))
((:) ((apply c-label (cdr x)) st))
((%cast) ((apply c-cast (cdr x)) st))
((+ - & * / % ! ~ ^ && < > <= >= == != << >>
= *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
((apply c-op x) st))
((bitwise-and bit-and) ((apply c-op '& (cdr x)) st))
((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st))
((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st))
((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st))
((arithmetic-shift) ((apply c-op '<< (cdr x)) st))
((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st))
((%and) ((apply c-op "&&" (cdr x)) st))
((%or) ((apply c-op "||" (cdr x)) st))
((%. %field) ((apply c-op "." (cdr x)) st))
((%->) ((apply c-op "->" (cdr x)) st))
(else
(cond
((eq? (car x) (string->symbol "."))
((apply c-op "." (cdr x)) st))
((eq? (car x) (string->symbol "->"))
((apply c-op "->" (cdr x)) st))
((eq? (car x) (string->symbol "++"))
((apply c-op "++" (cdr x)) st))
((eq? (car x) (string->symbol "--"))
((apply c-op "--" (cdr x)) st))
((eq? (car x) (string->symbol "+="))
((apply c-op "+=" (cdr x)) st))
((eq? (car x) (string->symbol "-="))
((apply c-op "-=" (cdr x)) st))
(else ((c-apply x) st))))))
((vector? x)
((c-wrap-stmt
(fmt-try-fit
(fmt-let 'no-wrap? #t
(cat "{" (fmt-join c-expr (vector->list x) ", ") "}"))
(lambda (st)
(let* ((col (fmt-col st))
(sep (string-append "," (make-nl-space col))))
((cat "{" (fmt-join c-expr (vector->list x) sep)
"}" nl)
st)))))
st))
(else
((c-literal x) st))))))
(define (c-apply ls)
(c-wrap-stmt
(c-with-op
'paren
(cat (c-expr (car ls))
(let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", "))))
(fmt-if
fmt-no-wrap?
(c-paren flat)
(c-paren
(fmt-try-fit
flat
(lambda (st)
(let* ((col (fmt-col st))
(sep (string-append "," (make-nl-space col))))
((fmt-join c-expr (cdr ls) sep) st)))))))))))
(define (c-expr x)
(lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; comments, with Emacs-friendly escaping of nested comments
(define (make-comment-writer st)
(let ((output (fmt-ref st 'writer)))
(lambda (str st)
(let ((lim (- (string-length str) 1)))
(let lp ((i 0) (st st))
(let ((j (string-index str #\/ i)))
(if j
(let ((st (if (and (> j 0)
(eqv? #\* (string-ref str (- j 1))))
(output
"\\/"
(output (substring/shared str i j) st))
(output (substring/shared str i (+ j 1)) st))))
(lp (+ j 1)
(if (and (< j lim) (eqv? #\* (string-ref str (+ j 1))))
(output "\\" st)
st)))
(output (substring/shared str i) st))))))))
(define (c-comment . args)
(lambda (st)
((cat "/*" (fmt-let 'writer (make-comment-writer st)
(apply-cat args))
"*/")
st)))
(define (make-block-comment-writer st)
(let ((output (make-comment-writer st))
(indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* ")))
(lambda (str st)
(let ((lim (string-length str)))
(let lp ((i 0) (st st))
(let ((j (string-index str #\newline i)))
(if j
(lp (+ j 1)
(output indent (output (substring/shared str i j) st)))
(output (substring/shared str i) st))))))))
(define (c-block-comment . args)
(lambda (st)
(let ((col (fmt-col st))
(row (fmt-row st))
(indent (c-current-indent-string st)))
((cat "/* "
(fmt-let 'writer (make-block-comment-writer st) (apply-cat args))
(lambda (st)
(cond
((= row (fmt-row st)) ((dsp " */") st))
;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st))
(else ((cat fl indent " */") st)))))
st))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; preprocessor
(define (make-cpp-writer st)
(let ((output (fmt-ref st 'writer)))
(lambda (str st)
(let lp ((i 0) (st st))
(let ((j (string-index str #\newline i)))
(if j
(lp (+ j 1)
(output
nl-str
(output " \\" (output (substring/shared str i j) st))))
(output (substring/shared str i) st)))))))
(define (cpp-include file)
(if (string? file)
(cat fl "#include " (wrt file) fl)
(cat fl "#include <" file ">" fl)))
(define (list-dot x)
(cond ((pair? x) (list-dot (cdr x)))
((null? x) #f)
(else x)))
(define (flatten-list ls)
(let lp ((ls ls) (res '()))
(cond ((pair? ls) (lp (cdr ls) (cons (car ls) res)))
((null? ls) (reverse res))
(else (reverse (cons ls res))))))
(define (replace-tree from to x)
(let replace ((x x))
(cond ((eq? x from) to)
((pair? x) (cons (replace (car x)) (replace (cdr x))))
(else x))))
(define (cpp-define x . body)
(define (name-of x) (c-expr (if (pair? x) (cadr x) x)))
(lambda (st)
(let* ((body (cond
((and (pair? x) (list-dot x))
=> (lambda (dot)
(if (eq? dot '...)
body
(replace-tree dot '__VA_ARGS__ body))))
(else body)))
(params (map (lambda (x) (if (pair? x) (cadr x) x))
(flatten-list (if (pair? x) (cdr x) '()))))
(tail
(if (pair? body)
(cat " "
(fmt-let 'writer (make-cpp-writer st)
(fmt-let 'macro-params params
((if (or (not (pair? x))
(and (null? (cdr body))
(c-literal? (car body))))
(lambda (x) x)
c-paren)
(c-in-expr (apply c-begin body))))))
(lambda (x) x))))
((c-in-expr
(if (pair? x)
(cat fl "#define " (name-of (car x))
(c-paren
(fmt-join/dot name-of
(lambda (dot) (dsp "..."))
(cdr x)
", "))
tail fl)
(cat fl "#define " (c-expr x) tail fl)))
st))))
(define (cpp-expr x)
(if (or (symbol? x) (string? x)) (dsp x) (c-expr x)))
(define (cpp-if/aux name check . o)
(let* ((pass (and (pair? o) (car o)))
(comment (if (member name '("ifdef" "ifndef"))
(cat " "
(c-comment
" " (if (equal? name "ifndef") "! " "")
check " "))
""))
(endif (if pass (cat fl "#endif" comment) ""))
(tail (cond
((and (pair? o) (pair? (cdr o)))
(if (pair? (cddr o))
(apply cpp-elif (cdr o))
(cat (cpp-else) (cadr o) endif)))
(else endif))))
(lambda (st)
(let ((indent (c-current-indent-string st)))
((cat fl "#" name " " (cpp-expr check) fl
(if pass (cat indent pass) "") fl
tail fl)
st)))))
(define (cpp-if check . o)
(apply cpp-if/aux "if" check o))
(define (cpp-ifdef check . o)
(apply cpp-if/aux "ifdef" check o))
(define (cpp-ifndef check . o)
(apply cpp-if/aux "ifndef" check o))
(define (cpp-elif check . o)
(apply cpp-if/aux "elif" check o))
(define (cpp-else . o)
(cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl))
(define (cpp-endif . o)
(cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl))
(define (cpp-wrap-header name . body)
(let ((name name)) ; consider auto-mangling
(cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl))))
(define (cpp-line num . o)
(cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl))
(define (cpp-generic name . ls)
(cat fl "#" name (apply-cat ls) fl))
(define (cpp-undef . args) (apply cpp-generic "undef" args))
(define (cpp-pragma . args) (apply cpp-generic "pragma" args))
(define (cpp-error . args) (apply cpp-generic "error" args))
(define (cpp-warning . args) (apply cpp-generic "warning" args))
(define (cpp-stringify x)
(cat "#" x))
(define (cpp-sym-cat . args)
(fmt-join dsp args " ## "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general indentation and brace rules
(define (c-current-indent-string st . o)
(make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0)))))
(define (c-indent st . o)
(dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4)
(if (pair? o) (car o) 0))))))
(define (c-indent/switch st)
(dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4)))))
(define (c-open-brace st)
(if (fmt-newline-before-brace? st)
(begin
(fmt-set! st 'newline-before-brace? #t)
(cat "{" nl))
(begin
(fmt-set! st 'newline-before-brace? #t)
(cat " {" nl))))
(define (c-close-brace st)
(dsp "}"))
(define (c-wrap-stmt x)
(fmt-if fmt-expression?
(c-expr x)
(cat (c-in-expr (c-expr x)) ";" nl)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; code blocks
(define (c-block . args)
(apply c-block/aux 0 args))
(define (c-block/aux offset header body0 . body)
(let ((inner (apply c-begin body0 body)))
(if (or (pair? body)
(not (or (c-literal? body0)
(and (pair? body0)
(not (c-control-operator? (car body0)))))))
(c-braced-block/aux offset header inner)
(lambda (st)
(if (fmt-braceless-bodies? st)
((cat header fl (c-indent st offset) inner fl) st)
((c-braced-block/aux offset header inner) st))))))
(define (c-braced-block . args)
(apply c-braced-block/aux 0 args))
(define (c-braced-block/aux offset header . body)
(lambda (st)
((cat (if header header "") (c-open-brace st) (c-indent st offset)
(apply c-begin body) fl
(c-current-indent-string st offset) (c-close-brace st))
st)))
(define (c-begin . args)
(apply c-begin/aux #f args))
(define (c-begin/aux ret? body0 . body)
(if (null? body)
(c-expr body0)
(lambda (st)
(if (fmt-expression? st)
((fmt-try-fit
(fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", "))
(lambda (st)
(let ((indent (c-current-indent-string st)))
((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st))))
st)
(let ((orig-ret? (fmt-return? st)))
((fmt-join/last c-expr
(lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
(cons body0 body)
(cat fl (c-current-indent-string st)))
(fmt-set! st 'return? (and ret? orig-ret?))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; data structures
(define (c-struct/aux type x . o)
;; can be just pointer to SUC, need to support such case:
;; struct whatever * - body is just '*'
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
(body (if name (if (not (null? o)) (car o) '()) x))
(o (if (null? o) o (cdr o))))
(if (and (not (null? body))
(not (eq? '* body)))
(c-wrap-stmt
(cat
(c-braced-block
(cat type (if (and name (not (equal? name ""))) (cat " " name) ""))
(cat
(c-in-stmt
(if (list? body)
(apply c-begin (map c-wrap-stmt (map c-field body)))
(c-wrap-stmt (c-expr body))))))
(if (pair? o) (cat " " (apply c-begin o)) (dsp ""))))
(c-wrap-stmt
(cat type
(if (and name (not (equal? name "")))
(cat " " name)
"")
(if (not (null? body))
(cat body)
""))))))
(define (c-struct . args) (apply c-struct/aux "struct" args))
(define (c-union . args) (apply c-struct/aux "union" args))
(define (c-class . args) (apply c-struct/aux "class" args))
(define (c-enum x . o)
(define (c-enum-one x)
(if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
(vals (if name (car o) x)))
(c-wrap-stmt
(cat
(c-braced-block
(if name (cat "enum " name) (dsp "enum"))
(c-in-expr (apply c-begin (map c-enum-one vals))))))))
(define (c-attribute . args)
(cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic control structures
(define (c-while check . body)
(c-reset-newline
(if (null? body)
(cat "while (" (c-in-test (c-expr check)) ");")
(cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
(c-in-stmt (apply c-begin body)))
fl))))
(define (c-for init check update . body)
(c-reset-newline
(cat
(c-block
(c-in-expr
(cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; "
(c-expr update ) ")"))
(c-in-stmt (apply c-begin body)))
fl)))
(define (c-param x)
(cond
((procedure? x) x)
((pair? x) (c-param-type (car x) (cadr x)))
(else (error "missing type" x))))
(define (c-field x)
(cond
((procedure? x) x)
((pair? x)
(if (list? (car x))
(case (caar x)
((union struct class)
(if (> (length x) 1)
(c-type (car x)
(cadr x))
(c-type (car x))))
(else (c-type (car x) (cadr x))))
(c-type (car x)
(fmt-join c-expr (cdr x) ", "))))
(else (error "missing type" x))))
(define (c-param-list ls)
(if (null? ls)
(c-type 'void)
(c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", "))))
(define (c-fun type name params . body)
(cat (c-block (c-in-expr (c-prototype type name params))
(c-in-stmt (apply c-begin body)))
fl))
(define (c-prototype type name params . o)
(c-wrap-stmt
(cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
(fmt-join/prefix c-expr o " "))))
(define (c-static x) (cat "static " (c-expr x)))
(define (c-const x) (cat "const " (c-expr x)))
(define (c-restrict x) (cat "restrict " (c-expr x)))
(define (c-volatile x) (cat "volatile " (c-expr x)))
(define (c-auto x) (cat "auto " (c-expr x)))
(define (c-inline x) (cat "inline " (c-expr x)))
(define (c-extern x) (cat "extern " (c-expr x)))
(define (c-extern/C . body)
(cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl))
(define (c-type type . o)
(let ((name (and (pair? o) (car o))))
(cond
((pair? type)
(case (car type)
((%fun)
(cat (c-type (cadr type) #f)
" (*" (or name "") ")("
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
((%array)
(let ((name (cat name "[" (if (pair? (cddr type))
(c-expr (caddr type))
"")
"]")))
(c-type (cadr type) name)))
((%pointer *)
(let ((name (cat "*" (if name (c-expr name) ""))))
(c-type (cadr type)
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
(c-paren name)
name))))
((enum) (apply c-enum name (cdr type)))
((struct union class)
(cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) "")))
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
((not type)
(lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
(else
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
(define (c-param-type type . o)
(let ((name (and (pair? o) (car o))))
(cond
((pair? type)
(case (car type)
((%fun)
(cat (c-type (cadr type) #f)
" (*" (or name "") ")("
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
((%array)
(let ((name (cat name "[" (if (pair? (cddr type))
(c-expr (caddr type))
"")
"]")))
(c-type (cadr type) name)))
((%pointer *)
(let ((name (cat "*" (if name (c-expr name) ""))))
(c-type (cadr type)
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
(c-paren name)
name))))
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
((not type)
(lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
(else
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
(define (c-var type name . init)
(c-wrap-stmt
(if (pair? init)
(cat (c-type type name) " = " (c-expr (car init)))
(c-type type (if (pair? name)
(fmt-join c-expr name ", ")
(c-expr name))))))
(define (c-cast type expr)
(cat "(" (c-type type) ")" (c-expr expr)))
(define (c-typedef type alias . o)
(c-wrap-stmt
(cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generalized IF: allows multiple tail forms for if/else if/.../else
;; blocks. A final ELSE can be signified with a test of #t or 'else,
;; or by simply using an odd number of expressions (by which the
;; normal 2 or 3 clause IF forms are special cases).
(define (c-if/stmt c p . rest)
(lambda (st)
(let ((indent (c-current-indent-string st)))
((let lp ((c c) (p p) (ls rest))
(if (or (eq? c 'else) (eq? c #t))
(if (not (null? ls))
(error "forms after else clause in IF" c p ls)
(cat (c-block/aux -1 " else" p) fl))
(let ((tail (if (pair? ls)
(if (pair? (cdr ls))
(lp (car ls) (cadr ls) (cddr ls))
(lp 'else (car ls) '()))
fl)))
(cat (c-block/aux
(if (eq? ls rest) 0 -1)
(cat (if (eq? ls rest) (lambda (x) x) " else ")
"if (" (c-in-test (c-expr c)) ")") p)
tail))))
st))))
(define (c-if/expr c p . rest)
(let lp ((c c) (p p) (ls rest))
(cond
((or (eq? c 'else) (eq? c #t))
(if (not (null? ls))
(error "forms after else clause in IF" c p ls)
(c-expr p)))
((pair? ls)
(cat (c-in-test (c-expr c)) " ? " (c-expr p) " : "
(if (pair? (cdr ls))
(lp (car ls) (cadr ls) (cddr ls))
(lp 'else (car ls) '()))))
(else
(c-or (c-in-test (c-expr c)) (c-expr p))))))
(define (c-if . args)
(fmt-if fmt-expression?
(apply c-if/expr args)
(apply c-if/stmt args)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; switch statements, automatic break handling
(define (c-label name)
(lambda (st)
(let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
((cat fl indent name ":" fl) st))))
(define c-break
(c-wrap-stmt (dsp "break")))
(define c-continue
(c-wrap-stmt (dsp "continue")))
(define (c-return . result)
(if (pair? result)
(c-wrap-stmt (cat "return " (c-expr (car result))))
(c-wrap-stmt (dsp "return"))))
(define (c-goto label)
(c-wrap-stmt (cat "goto " (c-expr label))))
(define (c-switch val . clauses)
(c-reset-newline
(lambda (st)
((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
(c-indent/switch st)
(c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
(c-current-indent-string st) (c-close-brace st) fl)
st))))
(define (c-switch-clause/breaks x)
(lambda (st)
(let* ((break?
(and (car x)
(not (member (cadr x) '(case/fallthrough
default/fallthrough
else/fallthrough)))))
(explicit-case? (member (cadr x) '(case case/fallthrough)))
(indent (c-current-indent-string st))
(indent-body (c-indent st))
(sep (string-append ":" nl-str indent)))
((cat (c-in-expr
(fmt-join/suffix
dsp
(cond
((pair? (cadr x))
(map (lambda (y) (cat (dsp "case ") (c-expr y)))
(cadr x)))
(explicit-case?
(map (lambda (y) (cat (dsp "case ") (c-expr y)))
(if (list? (caddr x))
(caddr x)
(list (caddr x)))))
((member (cadr x)
'(default else default/fallthrough else/fallthrough))
(list (dsp "default")))
(else
(error
"unknown switch clause, expected a list or default but got"
(cadr x))))
sep))
(make-space (or (fmt-indent-space st) 4))
(fmt-join c-expr
(if explicit-case? (cdddr x) (cddr x))
indent-body)
(if (and break? (not (fmt-return? st)))
(cat fl indent-body c-break)
""))
st))))
(define (c-switch-clause x)
(if (procedure? x) x (c-switch-clause/breaks (cons #t x))))
(define (c-switch-clause/no-break x)
(if (procedure? x) x (c-switch-clause/breaks (cons #f x))))
(define (c-case x . body)
(c-switch-clause (cons (if (pair? x) x (list x)) body)))
(define (c-case/fallthrough x . body)
(c-switch-clause/no-break (cons (if (pair? x) x (list x)) body)))
(define (c-default . body)
(c-switch-clause/breaks (cons #t (cons 'else body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; operators
(define (c-op op first . rest)
(if (null? rest)
(c-unary-op op first)
(apply c-binary-op op first rest)))
(define (c-binary-op op . ls)
(define (lit-op? x) (or (c-literal? x) (symbol? x)))
(let ((str (display-to-string op)))
(c-wrap-stmt
(c-maybe-paren
op
(if (or (equal? str ".") (equal? str "->"))
(fmt-join c-expr ls str)
(let ((flat
(fmt-let 'no-wrap? #t
(lambda (st)
((fmt-join c-expr
ls
(if (and (fmt-non-spaced-ops? st)
(every lit-op? ls))
str
(string-append " " str " ")))
st)))))
(fmt-if
fmt-no-wrap?
flat
(fmt-try-fit
flat
(lambda (st)
((fmt-join c-expr
ls
(cat nl (make-space (+ 2 (fmt-col st))) str " "))
st))))))))))
(define (c-unary-op op x)
(c-wrap-stmt
(cat (display-to-string op) (c-maybe-paren op (c-expr x)))))
;; some convenience definitions
(define (c++ . args) (apply c-op "++" args))
(define (c-- . args) (apply c-op "--" args))
(define (c+ . args) (apply c-op '+ args))
(define (c- . args) (apply c-op '- args))
(define (c* . args) (apply c-op '* args))
(define (c/ . args) (apply c-op '/ args))
(define (c% . args) (apply c-op '% args))
(define (c& . args) (apply c-op '& args))
;; (define (|c\|| . args) (apply c-op '|\|| args))
(define (c^ . args) (apply c-op '^ args))
(define (c~ . args) (apply c-op '~ args))
(define (c! . args) (apply c-op '! args))
(define (c&& . args) (apply c-op '&& args))
;; (define (|c\|\|| . args) (apply c-op '|\|\|| args))
(define (c<< . args) (apply c-op '<< args))
(define (c>> . args) (apply c-op '>> args))
(define (c== . args) (apply c-op '== args))
(define (c!= . args) (apply c-op '!= args))
(define (c< . args) (apply c-op '< args))
(define (c> . args) (apply c-op '> args))
(define (c<= . args) (apply c-op '<= args))
(define (c>= . args) (apply c-op '>= args))
(define (c= . args) (apply c-op '= args))
(define (c+= . args) (apply c-op "+=" args))
(define (c-= . args) (apply c-op "-=" args))
(define (c*= . args) (apply c-op '*= args))
(define (c/= . args) (apply c-op '/= args))
(define (c%= . args) (apply c-op '%= args))
(define (c&= . args) (apply c-op '&= args))
;; (define (|c\|=| . args) (apply c-op '|\|=| args))
(define (c^= . args) (apply c-op '^= args))
(define (c<<= . args) (apply c-op '<<= args))
(define (c>>= . args) (apply c-op '>>= args))
(define (c. . args) (apply c-op "." args))
(define (c-> . args) (apply c-op "->" args))
(define (c-bit-or . args) (apply c-op "|" args))
(define (c-or . args) (apply c-op "||" args))
(define (c-bit-or= . args) (apply c-op "|=" args))
(define (c++/post x)
(cat (c-maybe-paren 'post-increment (c-expr x)) "++"))
(define (c--/post x)
(cat (c-maybe-paren 'post-decrement (c-expr x)) "--"))

3
main.scm
View File

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

3
reader.module.scm Normal file
View File

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

49
reader.scm Normal file
View File

@@ -0,0 +1,49 @@
(import
scheme
(chicken base)
(chicken io)
(chicken pathname)
(chicken port)
(chicken read-syntax)
(chicken string)
(chicken syntax)
brev-separate
fmt)
(import-syntax utils)
(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 (read-from-file file)
(with-directory file
(with-input-from-file (pathname-strip-directory file)
(fn (read-forms (list))))))
(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)))))))
(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")

106
semen.scm
View File

@@ -1,18 +1,22 @@
;;; Sex semantic engine
(declare (unit semen)
(uses sex-macros
sex-modules
utils))
(import
scheme
(chicken base)
(chicken keyword)
(chicken string)
(chicken module)
fmt
matchable ; pattern matching
srfi-1 ; list routines
srfi-69 ; hash tables
sex-macros
sex-modules
matchable ; pattern matching
srfi-1 ; list routines
srfi-69 ; hash tables
utils
)
(export/rename (process semen-process))
;;; for lambda extraction, docstring processing, macro expansion,
;;; injection of module headers, i.e. all things that rearrange code
;;; structurally, add or remove forms
@@ -21,28 +25,28 @@
;;; append their return to the resulting list. Each handler can return
;;; multiple forms, e.g. lambdas collected from a function may result
;;; in auxiliary structures and functions.
(define (semen-process raw-sex-forms)
(semen-process-rec raw-sex-forms (list)))
(define (process raw-sex-forms)
(process-rec raw-sex-forms (list)))
(define (semen-process-rec forms acc)
(define (process-rec forms acc)
(cond
((null? forms) (reverse acc))
((sex-macro? (car forms))
(semen-process-rec
(semen-apply-macro (car forms) (cdr forms))
((macro? (car forms))
(process-rec
(macroexpand (car forms) (cdr forms))
acc))
(else
(semen-process-rec (cdr forms)
(match-sex-form (car forms) acc)))))
(process-rec (cdr forms)
(match-sex-form (car forms) acc)))))
(define (semen-apply-macro macro-form rest-forms)
;; We want to replace macro with its expansion. The problem is,
;; top-level macro can return either a single form, or a list of
;; forms, when it for example generates some aux
;; structures/functions/typedefs.
;;
;; Single form we just cons to the top of rest-forms, but multiple
;; forms have to be appended to the rest-forms.
(define (macroexpand macro-form rest-forms)
;; We want to replace macro with its expansion. The problem is,
;; top-level macro can return either a single form, or a list of
;; forms, when it for example generates some aux
;; structures/functions/typedefs.
;;
;; Single form we just cons to the top of rest-forms, but multiple
;; forms have to be appended to the rest-forms.
(let ((res (apply-macro macro-form)))
(if (list? (car res))
(append res rest-forms)
@@ -66,7 +70,7 @@
(('define . _) (cons sex-form acc))
(('import . modules)
(semen-process-imports (get-public-forms modules) acc))
(process-imports (get-modules-public-forms modules) acc))
((or ('defmacro . rest)
('pub 'defmacro . rest)) (defmacro rest) acc)
@@ -77,30 +81,30 @@
(else (assert #f (fmt #f "Unknown top level form " sex-form)))))
(define (semen-process-imports module-public-forms acc)
(define (process-imports module-public-forms acc)
;; Recursively process imports: register public macros, cons all
;; other public things to our acc
(if (null? module-public-forms) acc
(match (car module-public-forms)
(('defmacro . rest)
(defmacro rest)
(semen-process-imports (cdr module-public-forms) acc))
(process-imports (cdr module-public-forms) acc))
(else
(semen-process-imports (cdr module-public-forms)
(cons (car module-public-forms)
acc))))))
(process-imports (cdr module-public-forms)
(cons (car module-public-forms)
acc))))))
(define (semen-macro-expand form)
(define (macro-expand form)
"Walk the form recursively and expand all macros, until none is left."
(semen-walk-form
(walk-form
form
(lambda (subform env)
(if (sex-macro? subform)
(cons semen-walk-embed-result (semen-apply-macro subform (list)))
(if (macro? subform)
(cons walk-embed-result (macroexpand subform (list)))
subform))
#f))
;;; semen-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
;;; perform additional operations depending of what the walk function
;;; has requested.
@@ -108,21 +112,21 @@
;;; For inspiration, see SBCL's walk.lisp and their template
;;; system.
(define semen-walk-embed-result (gensym)
(define walk-embed-result (gensym)
;; For cases when result is a list which must be embedded in the
;; form, e.g. when it returned from a macro
)
(define (semen-walk-form form walk-fn env)
(define (walk-form form walk-fn env)
(if (atom? form) form
(let ((new-form (walk-fn form env)))
(cond ((not (eq? form new-form))
(semen-walk-form new-form walk-fn env))
(walk-form new-form walk-fn env))
(else
(let ((new-car (semen-walk-form (car new-form) walk-fn env))
(new-cdr (semen-walk-form (cdr 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)))
(cond ((and (pair? new-car)
(eq? (car new-car) semen-walk-embed-result))
(eq? (car new-car) walk-embed-result))
(append (cdr new-car) new-cdr))
(else
(recons new-form new-car new-cdr)))))))))
@@ -135,12 +139,12 @@
;;; Fn processing
(define (process-fn sex-fn acc)
(let* ((expanded (semen-macro-expand sex-fn))
(let* ((expanded (macro-expand sex-fn))
(env (make-hash-table))
(processed
(semen-walk-form
(walk-form
expanded
semen-fn-walker
fn-walker
(begin
(set! (hash-table-ref env :fn-name) (sex-fn-name expanded))
(set! (hash-table-ref env :lambda-counter) 0)
@@ -150,23 +154,23 @@
(cons processed
(append (hash-table-ref env :lambda-aux-code) acc))))
(define (semen-fn-walker form env)
(define (fn-walker form env)
(if (eq? 'lambda (car form))
(let ((lambda-name (semen-make-lambda-name (hash-table-ref env :fn-name)
(hash-table-ref env :lambda-counter))))
(let ((lambda-name (make-lambda-name (hash-table-ref env :fn-name)
(hash-table-ref env :lambda-counter))))
(set! (hash-table-ref env :lambda-aux-code)
(append (semen-make-aux-lambda-struct lambda-name form)
(append (make-aux-lambda-struct lambda-name form)
(hash-table-ref env :lambda-aux-code)))
(set! (hash-table-ref env :lambda-counter)
(+ (hash-table-ref env :lambda-counter) 1))
lambda-name)
form))
form))
(define (semen-make-lambda-name enclosing-fn-name counter)
(define (make-lambda-name enclosing-fn-name counter)
(string->symbol
(fmt #f "__lambda_" counter "_" enclosing-fn-name)))
(define (semen-make-aux-lambda-struct name form)
(define (make-aux-lambda-struct name form)
(match form
(('lambda ret-type arglist captures . body)
;; Captures are ignored for now, but

985
sex-fmt-c.scm Normal file
View File

@@ -0,0 +1,985 @@
;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
;;
;; Copyright (c) 2007 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; additional state information
(module sex-fmt-c
(
fmt-in-macro? fmt-expression? fmt-return?
fmt-newline-before-brace? fmt-braceless-bodies?
fmt-indent-space fmt-switch-indent-space fmt-op fmt-gen
c-in-expr c-in-stmt c-in-test
c-paren c-maybe-paren c-type c-literal? c-literal char->c-char
c-struct c-union c-class c-enum c-typedef c-cast
c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string
c-wrap-stmt c-open-brace c-close-brace
c-block c-braced-block c-begin
c-fun c-var c-prototype c-param c-param-list
c-while c-for c-if c-switch
c-case c-case/fallthrough c-default
c-break c-continue c-return c-goto c-label
c-static c-const c-extern c-volatile c-auto c-restrict c-inline
c++ c-- c+ c- c* c/ c% c& c^ c~ c! c&& c<< c>> c== c!= ; |c\|| |c\|\||
c< c> c<= c>= c= c+= c-= c*= c/= c%= c&= c^= c<<= c>>= ;++c --c ; |c\|=|
c++/post c--/post c. c->
c-bit-or c-or c-bit-or=
cpp-if cpp-ifdef cpp-ifndef cpp-elif cpp-endif cpp-else cpp-undef
cpp-include cpp-define cpp-wrap-header cpp-pragma cpp-line
cpp-error cpp-warning cpp-stringify cpp-sym-cat
c-comment c-block-comment c-attribute)
(import
scheme
(chicken base)
fmt
srfi-1
srfi-13)
(define (fmt-in-macro? st) (fmt-ref st 'in-macro?))
(define (fmt-macro-params st) (fmt-ref st 'macro-params))
(define (fmt-expression? st) (fmt-ref st 'expression?))
(define (fmt-return? st) (fmt-ref st 'return?))
(define (fmt-newline-before-brace? st) (fmt-ref st 'newline-before-brace?))
(define (fmt-braceless-bodies? st) (fmt-ref st 'braceless-bodies?))
(define (fmt-non-spaced-ops? st) (fmt-ref st 'non-spaced-ops?))
(define (fmt-no-wrap? st) (fmt-ref st 'no-wrap?))
(define (fmt-indent-space st) (fmt-ref st 'indent-space))
(define (fmt-switch-indent-space st) (fmt-ref st 'switch-indent-space))
(define (fmt-op st) (fmt-ref st 'op 'stmt))
(define (fmt-gen st) (fmt-ref st 'gen))
(define (c-in-expr proc) (fmt-let 'expression? #t proc))
(define (c-in-stmt proc) (fmt-let 'expression? #f proc))
(define (c-reset-newline proc) (fmt-let 'newline-before-brace? #f proc))
(define (c-in-test proc) (fmt-let 'in-cond? #t (c-in-expr proc)))
(define (c-with-op op proc) (fmt-let 'op op proc))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; be smart about operator precedence
(define (c-op-precedence x)
(if (string? x)
(cond
((or (string=? x ".") (string=? x "->")) 10)
((or (string=? x "++") (string=? x "--")) 20)
((string=? x "&") 55)
((string=? x "|") 65)
((string=? x "&&") 70)
((string=? x "||") 75)
((string=? x "|=") 85)
((or (string=? x "+=") (string=? x "-=")) 85)
(else 95))
(case x
;;((|::|) 5) ; C++
((dot arrow post-decrement post-increment) 10)
((**) 15) ; Perl
((unary+ unary- ! ~ cast unary-* unary-& sizeof) 20) ; ++ --
((=~ !~) 25) ; Perl
((* / %) 30)
((+ -) 35)
((<< >>) 40)
((< > <= >=) 45)
((lt gt le ge) 45) ; Perl
((== !=) 50)
((eq ne cmp) 50) ; Perl
((&) 55)
((^) 60)
;;((|\||) 65)
((&& %and) 70)
((%or) 75)
;;((|\|\||) 75)
;;((.. ...) 77) ; Perl
((?) 80)
((= *= /= %= &= ^= <<= >>=) 85) ; |\|=| ; += -=
((comma) 90)
((=>) 90) ; Perl
((not) 92) ; Perl
((and) 93) ; Perl
((or xor) 94) ; Perl
((paren bracket) 100)
(else 95))))
(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-maybe-paren op x)
(lambda (st)
((fmt-let 'op op
(if (and (c-op<= (fmt-op st) op)
(not (vector? x)))
(c-paren x)
x))
st)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; default literals writer
(define (c-control-operator? x)
(memq x '(if while switch repeat do for fun begin)))
(define (c-literal? x)
(or (number? x) (string? x) (char? x) (boolean? x)))
(define (char->c-char c)
(string-append "'" (c-escape-char c #\') "'"))
(define (c-escape-char c quote-char)
(let ((n (char->integer c)))
(if (<= 32 n 126)
(if (or (eqv? c quote-char) (eqv? c #\\))
(string #\\ c)
(string c))
(case n
((7) "\\a") ((8) "\\b") ((9) "\\t") ((10) "\\n")
((11) "\\v") ((12) "\\f") ((13) "\\r")
(else (string-append "\\x" (number->string (char->integer c) 16)))))))
(define (c-format-number x)
(if (and (integer? x) (exact? x))
(lambda (st)
((case (fmt-radix st)
((16) (cat "0x" (string-upcase (number->string x 16))))
((8) (cat "0" (number->string x 8)))
(else (dsp (number->string x))))
st))
(dsp (number->string x))))
(define (c-format-string x)
(lambda (st) ((cat #\" (apply-cat (c-string-escaped x)) #\") st)))
(define (c-string-escaped x)
(let loop ((parts '()) (idx (string-length x)))
(cond ((string-index-right x c-needs-string-escape? 0 idx)
=> (lambda (special-idx)
(loop (cons (c-escape-char (string-ref x special-idx) #\")
(cons (substring/shared x (+ special-idx 1) idx)
parts))
special-idx)))
(else
(cons (substring/shared x 0 idx) parts)))))
(define (c-needs-string-escape? c)
(if (<= 32 (char->integer c) 127) (memv c '(#\" #\\)) #t))
(define (c-simple-literal x)
(c-wrap-stmt
(cond ((char? x) (dsp (char->c-char x)))
((boolean? x) (dsp (if x "1" "0")))
((number? x) (c-format-number x))
((string? x) (c-format-string x))
((null? x) (dsp "NULL"))
((eof-object? x) (dsp "EOF"))
(else (dsp (write-to-string x))))))
(define (c-literal x)
(lambda (st)
((if (and (symbol? x) (memq x (or (fmt-macro-params st) '())))
(c-paren (c-simple-literal x))
(c-simple-literal x))
st)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; default expression generator
(define (c-expr/sexp x)
(if (procedure? x)
x
(lambda (st)
(cond
((pair? x)
(case (car x)
((if) ((apply c-if (cdr x)) st))
((for) ((apply c-for (cdr x)) st))
((while) ((apply c-while (cdr x)) st))
((switch) ((apply c-switch (cdr x)) st))
((case) ((apply c-case (cdr x)) st))
((case/fallthrough) ((apply c-case/fallthrough (cdr x)) st))
((default) ((apply c-default (cdr x)) st))
((break) (c-break st))
((continue) (c-continue st))
((return) ((apply c-return (cdr x)) st))
((goto) ((apply c-goto (cdr x)) st))
((typedef) ((apply c-typedef (cdr x)) st))
((struct union class) ((apply c-struct/aux x) st))
((enum) ((apply c-enum (cdr x)) st))
((inline auto restrict register volatile extern static)
((cat (car x) " " (apply c-begin (cdr x))) st))
;; non C-keywords must have some character invalid in a C
;; identifier to avoid conflicts - by default we prefix %
((vector-ref)
((c-wrap-stmt
(cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
st))
((vector-set!)
((c= (c-in-expr
(cat (c-expr (cadr x)) "[" (c-expr (caddr x)) "]"))
(c-expr (cadddr x)))
st))
((extern/C) ((apply c-extern/C (cdr x)) st))
((%apply) ((apply c-apply (cdr x)) st))
((%define) ((apply cpp-define (cdr x)) st))
((%include) ((apply cpp-include (cdr x)) st))
((%fun) ((apply c-fun (cdr x)) st))
((%cond)
(let lp ((ls (cdr x)) (res '()))
(if (null? ls)
((apply c-if (reverse res)) st)
(lp (cdr ls)
(cons (if (pair? (cddar ls))
(apply c-begin (cdar ls))
(cadar ls))
(cons (caar ls) res))))))
((%prototype) ((apply c-prototype (cdr x)) st))
((%var) ((apply c-var (cdr x)) st))
((%begin) ((apply c-begin (cdr x)) st))
((%attribute) ((apply c-attribute (cdr x)) st))
((%line) ((apply cpp-line (cdr x)) st))
((%pragma %error %warning)
((apply cpp-generic (substring/shared (symbol->string (car x)) 1)
(cdr x)) st))
((%if %ifdef %ifndef %elif)
((apply cpp-if/aux (substring/shared (symbol->string (car x)) 1)
(cdr x)) st))
((%endif) ((apply cpp-endif (cdr x)) st))
((%block-begin) ((apply c-braced-block #f (cdr x)) st))
((%block) ((apply c-braced-block (cdr x)) st))
((%comment) ((apply c-comment (cdr x)) st))
((:) ((apply c-label (cdr x)) st))
((%cast) ((apply c-cast (cdr x)) st))
((+ - & * / % ! ~ ^ && < > <= >= == != << >>
= *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
((apply c-op x) st))
((bitwise-and bit-and) ((apply c-op '& (cdr x)) st))
((bitwise-ior bit-or) ((apply c-op "|" (cdr x)) st))
((bitwise-xor bit-xor) ((apply c-op '^ (cdr x)) st))
((bitwise-not bit-not) ((apply c-op '~ (cdr x)) st))
((arithmetic-shift) ((apply c-op '<< (cdr x)) st))
((bitwise-ior= bit-or=) ((apply c-op "|=" (cdr x)) st))
((%and) ((apply c-op "&&" (cdr x)) st))
((%or) ((apply c-op "||" (cdr x)) st))
((%. %field) ((apply c-op "." (cdr x)) st))
((%->) ((apply c-op "->" (cdr x)) st))
(else
(cond
((eq? (car x) (string->symbol "."))
((apply c-op "." (cdr x)) st))
((eq? (car x) (string->symbol "->"))
((apply c-op "->" (cdr x)) st))
((eq? (car x) (string->symbol "++"))
((apply c-op "++" (cdr x)) st))
((eq? (car x) (string->symbol "--"))
((apply c-op "--" (cdr x)) st))
((eq? (car x) (string->symbol "+="))
((apply c-op "+=" (cdr x)) st))
((eq? (car x) (string->symbol "-="))
((apply c-op "-=" (cdr x)) st))
(else ((c-apply x) st))))))
((vector? x)
((c-wrap-stmt
(fmt-try-fit
(fmt-let 'no-wrap? #t
(cat "{" (fmt-join c-expr (vector->list x) ", ") "}"))
(lambda (st)
(let* ((col (fmt-col st))
(sep (string-append "," (make-nl-space col))))
((cat "{" (fmt-join c-expr (vector->list x) sep)
"}" nl)
st)))))
st))
(else
((c-literal x) st))))))
(define (c-apply ls)
(c-wrap-stmt
(c-with-op
'paren
(cat (c-expr (car ls))
(let ((flat (fmt-let 'no-wrap? #t (fmt-join c-expr (cdr ls) ", "))))
(fmt-if
fmt-no-wrap?
(c-paren flat)
(c-paren
(fmt-try-fit
flat
(lambda (st)
(let* ((col (fmt-col st))
(sep (string-append "," (make-nl-space col))))
((fmt-join c-expr (cdr ls) sep) st)))))))))))
(define (c-expr x)
(lambda (st) (((or (fmt-gen st) c-expr/sexp) x) st)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; comments, with Emacs-friendly escaping of nested comments
(define (make-comment-writer st)
(let ((output (fmt-ref st 'writer)))
(lambda (str st)
(let ((lim (- (string-length str) 1)))
(let lp ((i 0) (st st))
(let ((j (string-index str #\/ i)))
(if j
(let ((st (if (and (> j 0)
(eqv? #\* (string-ref str (- j 1))))
(output
"\\/"
(output (substring/shared str i j) st))
(output (substring/shared str i (+ j 1)) st))))
(lp (+ j 1)
(if (and (< j lim) (eqv? #\* (string-ref str (+ j 1))))
(output "\\" st)
st)))
(output (substring/shared str i) st))))))))
(define (c-comment . args)
(lambda (st)
((cat "/*" (fmt-let 'writer (make-comment-writer st)
(apply-cat args))
"*/")
st)))
(define (make-block-comment-writer st)
(let ((output (make-comment-writer st))
(indent (string-append (make-nl-space (+ (fmt-col st) 1)) "* ")))
(lambda (str st)
(let ((lim (string-length str)))
(let lp ((i 0) (st st))
(let ((j (string-index str #\newline i)))
(if j
(lp (+ j 1)
(output indent (output (substring/shared str i j) st)))
(output (substring/shared str i) st))))))))
(define (c-block-comment . args)
(lambda (st)
(let ((col (fmt-col st))
(row (fmt-row st))
(indent (c-current-indent-string st)))
((cat "/* "
(fmt-let 'writer (make-block-comment-writer st) (apply-cat args))
(lambda (st)
(cond
((= row (fmt-row st)) ((dsp " */") st))
;;((= (+ 3 col) (fmt-col st)) ((dsp "*/") st))
(else ((cat fl indent " */") st)))))
st))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; preprocessor
(define (make-cpp-writer st)
(let ((output (fmt-ref st 'writer)))
(lambda (str st)
(let lp ((i 0) (st st))
(let ((j (string-index str #\newline i)))
(if j
(lp (+ j 1)
(output
nl-str
(output " \\" (output (substring/shared str i j) st))))
(output (substring/shared str i) st)))))))
(define (cpp-include file)
(if (string? file)
(cat fl "#include " (wrt file) fl)
(cat fl "#include <" file ">" fl)))
(define (list-dot x)
(cond ((pair? x) (list-dot (cdr x)))
((null? x) #f)
(else x)))
(define (flatten-list ls)
(let lp ((ls ls) (res '()))
(cond ((pair? ls) (lp (cdr ls) (cons (car ls) res)))
((null? ls) (reverse res))
(else (reverse (cons ls res))))))
(define (replace-tree from to x)
(let replace ((x x))
(cond ((eq? x from) to)
((pair? x) (cons (replace (car x)) (replace (cdr x))))
(else x))))
(define (cpp-define x . body)
(define (name-of x) (c-expr (if (pair? x) (cadr x) x)))
(lambda (st)
(let* ((body (cond
((and (pair? x) (list-dot x))
=> (lambda (dot)
(if (eq? dot '...)
body
(replace-tree dot '__VA_ARGS__ body))))
(else body)))
(params (map (lambda (x) (if (pair? x) (cadr x) x))
(flatten-list (if (pair? x) (cdr x) '()))))
(tail
(if (pair? body)
(cat " "
(fmt-let 'writer (make-cpp-writer st)
(fmt-let 'macro-params params
((if (or (not (pair? x))
(and (null? (cdr body))
(c-literal? (car body))))
(lambda (x) x)
c-paren)
(c-in-expr (apply c-begin body))))))
(lambda (x) x))))
((c-in-expr
(if (pair? x)
(cat fl "#define " (name-of (car x))
(c-paren
(fmt-join/dot name-of
(lambda (dot) (dsp "..."))
(cdr x)
", "))
tail fl)
(cat fl "#define " (c-expr x) tail fl)))
st))))
(define (cpp-expr x)
(if (or (symbol? x) (string? x)) (dsp x) (c-expr x)))
(define (cpp-if/aux name check . o)
(let* ((pass (and (pair? o) (car o)))
(comment (if (member name '("ifdef" "ifndef"))
(cat " "
(c-comment
" " (if (equal? name "ifndef") "! " "")
check " "))
""))
(endif (if pass (cat fl "#endif" comment) ""))
(tail (cond
((and (pair? o) (pair? (cdr o)))
(if (pair? (cddr o))
(apply cpp-elif (cdr o))
(cat (cpp-else) (cadr o) endif)))
(else endif))))
(lambda (st)
(let ((indent (c-current-indent-string st)))
((cat fl "#" name " " (cpp-expr check) fl
(if pass (cat indent pass) "") fl
tail fl)
st)))))
(define (cpp-if check . o)
(apply cpp-if/aux "if" check o))
(define (cpp-ifdef check . o)
(apply cpp-if/aux "ifdef" check o))
(define (cpp-ifndef check . o)
(apply cpp-if/aux "ifndef" check o))
(define (cpp-elif check . o)
(apply cpp-if/aux "elif" check o))
(define (cpp-else . o)
(cat fl "#else " (if (pair? o) (c-comment (car o)) "") fl))
(define (cpp-endif . o)
(cat fl "#endif " (if (pair? o) (c-comment (car o)) "") fl))
(define (cpp-wrap-header name . body)
(let ((name name)) ; consider auto-mangling
(cpp-ifndef name (c-begin (cpp-define name) nl (apply c-begin body) nl))))
(define (cpp-line num . o)
(cat fl "#line " num (if (pair? o) (cat " " (car o)) "") fl))
(define (cpp-generic name . ls)
(cat fl "#" name (apply-cat ls) fl))
(define (cpp-undef . args) (apply cpp-generic "undef" args))
(define (cpp-pragma . args) (apply cpp-generic "pragma" args))
(define (cpp-error . args) (apply cpp-generic "error" args))
(define (cpp-warning . args) (apply cpp-generic "warning" args))
(define (cpp-stringify x)
(cat "#" x))
(define (cpp-sym-cat . args)
(fmt-join dsp args " ## "))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; general indentation and brace rules
(define (c-current-indent-string st . o)
(make-space (max 0 (+ (fmt-col st) (if (pair? o) (car o) 0)))))
(define (c-indent st . o)
(dsp (make-space (max 0 (+ (fmt-col st) (or (fmt-indent-space st) 4)
(if (pair? o) (car o) 0))))))
(define (c-indent/switch st)
(dsp (make-space (+ (fmt-col st) (or (fmt-switch-indent-space st) 4)))))
(define (c-open-brace st)
(if (fmt-newline-before-brace? st)
(begin
(fmt-set! st 'newline-before-brace? #t)
(cat "{" nl))
(begin
(fmt-set! st 'newline-before-brace? #t)
(cat " {" nl))))
(define (c-close-brace st)
(dsp "}"))
(define (c-wrap-stmt x)
(fmt-if fmt-expression?
(c-expr x)
(cat (c-in-expr (c-expr x)) ";" nl)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; code blocks
(define (c-block . args)
(apply c-block/aux 0 args))
(define (c-block/aux offset header body0 . body)
(let ((inner (apply c-begin body0 body)))
(if (or (pair? body)
(not (or (c-literal? body0)
(and (pair? body0)
(not (c-control-operator? (car body0)))))))
(c-braced-block/aux offset header inner)
(lambda (st)
(if (fmt-braceless-bodies? st)
((cat header fl (c-indent st offset) inner fl) st)
((c-braced-block/aux offset header inner) st))))))
(define (c-braced-block . args)
(apply c-braced-block/aux 0 args))
(define (c-braced-block/aux offset header . body)
(lambda (st)
((cat (if header header "") (c-open-brace st) (c-indent st offset)
(apply c-begin body) fl
(c-current-indent-string st offset) (c-close-brace st))
st)))
(define (c-begin . args)
(apply c-begin/aux #f args))
(define (c-begin/aux ret? body0 . body)
(if (null? body)
(c-expr body0)
(lambda (st)
(if (fmt-expression? st)
((fmt-try-fit
(fmt-let 'no-wrap? #t (fmt-join c-expr (cons body0 body) ", "))
(lambda (st)
(let ((indent (c-current-indent-string st)))
((fmt-join c-expr (cons body0 body) (cat "," nl indent)) st))))
st)
(let ((orig-ret? (fmt-return? st)))
((fmt-join/last c-expr
(lambda (x) (fmt-let 'return? orig-ret? (c-expr x)))
(cons body0 body)
(cat fl (c-current-indent-string st)))
(fmt-set! st 'return? (and ret? orig-ret?))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; data structures
(define (c-struct/aux type x . o)
;; can be just pointer to SUC, need to support such case:
;; struct whatever * - body is just '*'
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
(body (if name (if (not (null? o)) (car o) '()) x))
(o (if (null? o) o (cdr o))))
(if (and (not (null? body))
(not (eq? '* body)))
(c-wrap-stmt
(cat
(c-braced-block
(cat type (if (and name (not (equal? name ""))) (cat " " name) ""))
(cat
(c-in-stmt
(if (list? body)
(apply c-begin (map c-wrap-stmt (map c-field body)))
(c-wrap-stmt (c-expr body))))))
(if (pair? o) (cat " " (apply c-begin o)) (dsp ""))))
(c-wrap-stmt
(cat type
(if (and name (not (equal? name "")))
(cat " " name)
"")
(if (not (null? body))
(cat body)
""))))))
(define (c-struct . args) (apply c-struct/aux "struct" args))
(define (c-union . args) (apply c-struct/aux "union" args))
(define (c-class . args) (apply c-struct/aux "class" args))
(define (c-enum x . o)
(define (c-enum-one x)
(if (pair? x) (cat (car x) " = " (c-expr (cadr x))) (dsp x)))
(let* ((name (if (null? o) (if (or (symbol? x) (string? x)) x #f) x))
(vals (if name (car o) x)))
(c-wrap-stmt
(cat
(c-braced-block
(if name (cat "enum " name) (dsp "enum"))
(c-in-expr (apply c-begin (map c-enum-one vals))))))))
(define (c-attribute . args)
(cat "__attribute__ ((" (fmt-join c-expr args ", ") "))"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; basic control structures
(define (c-while check . body)
(c-reset-newline
(if (null? body)
(cat "while (" (c-in-test (c-expr check)) ");")
(cat (c-block (cat "while (" (c-in-test (c-expr check)) ")")
(c-in-stmt (apply c-begin body)))
fl))))
(define (c-for init check update . body)
(c-reset-newline
(cat
(c-block
(c-in-expr
(cat "for (" (c-expr init) "; " (c-in-test (c-expr check)) "; "
(c-expr update ) ")"))
(c-in-stmt (apply c-begin body)))
fl)))
(define (c-param x)
(cond
((procedure? x) x)
((pair? x) (c-param-type (car x) (cadr x)))
(else (error "missing type" x))))
(define (c-field x)
(cond
((procedure? x) x)
((pair? x)
(if (list? (car x))
(case (caar x)
((union struct class)
(if (> (length x) 1)
(c-type (car x)
(cadr x))
(c-type (car x))))
(else (c-type (car x) (cadr x))))
(c-type (car x)
(fmt-join c-expr (cdr x) ", "))))
(else (error "missing type" x))))
(define (c-param-list ls)
(if (null? ls)
(c-type 'void)
(c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", "))))
(define (c-fun type name params . body)
(cat (c-block (c-in-expr (c-prototype type name params))
(c-in-stmt (apply c-begin body)))
fl))
(define (c-prototype type name params . o)
(c-wrap-stmt
(cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
(fmt-join/prefix c-expr o " "))))
(define (c-static x) (cat "static " (c-expr x)))
(define (c-const x) (cat "const " (c-expr x)))
(define (c-restrict x) (cat "restrict " (c-expr x)))
(define (c-volatile x) (cat "volatile " (c-expr x)))
(define (c-auto x) (cat "auto " (c-expr x)))
(define (c-inline x) (cat "inline " (c-expr x)))
(define (c-extern x) (cat "extern " (c-expr x)))
(define (c-extern/C . body)
(cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl))
(define (c-type type . o)
(let ((name (and (pair? o) (car o))))
(cond
((pair? type)
(case (car type)
((%fun)
(cat (c-type (cadr type) #f)
" (*" (or name "") ")("
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
((%array)
(let ((name (cat name "[" (if (pair? (cddr type))
(c-expr (caddr type))
"")
"]")))
(c-type (cadr type) name)))
((%pointer *)
(let ((name (cat "*" (if name (c-expr name) ""))))
(c-type (cadr type)
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
(c-paren name)
name))))
((enum) (apply c-enum name (cdr type)))
((struct union class)
(cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) "")))
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
((not type)
(lambda (st) ((c-type 'int name) st)))
(else
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
(define (c-param-type type . o)
(let ((name (and (pair? o) (car o))))
(cond
((pair? type)
(case (car type)
((%fun)
(cat (c-type (cadr type) #f)
" (*" (or name "") ")("
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
((%array)
(let ((name (cat name "[" (if (pair? (cddr type))
(c-expr (caddr type))
"")
"]")))
(c-type (cadr type) name)))
((%pointer *)
(let ((name (cat "*" (if name (c-expr name) ""))))
(c-type (cadr type)
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
(c-paren name)
name))))
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
((not type)
(lambda (st) ((c-type 'int name) st)))
(else
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
(define (c-var type name . init)
(c-wrap-stmt
(if (pair? init)
(cat (c-type type name) " = " (c-expr (car init)))
(c-type type (if (pair? name)
(fmt-join c-expr name ", ")
(c-expr name))))))
(define (c-cast type expr)
(cat "(" (c-type type) ")" (c-expr expr)))
(define (c-typedef type alias . o)
(c-wrap-stmt
(cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Generalized IF: allows multiple tail forms for if/else if/.../else
;; blocks. A final ELSE can be signified with a test of #t or 'else,
;; or by simply using an odd number of expressions (by which the
;; normal 2 or 3 clause IF forms are special cases).
(define (c-if/stmt c p . rest)
(lambda (st)
(let ((indent (c-current-indent-string st)))
((let lp ((c c) (p p) (ls rest))
(if (or (eq? c 'else) (eq? c #t))
(if (not (null? ls))
(error "forms after else clause in IF" c p ls)
(cat (c-block/aux -1 " else" p) fl))
(let ((tail (if (pair? ls)
(if (pair? (cdr ls))
(lp (car ls) (cadr ls) (cddr ls))
(lp 'else (car ls) '()))
fl)))
(cat (c-block/aux
(if (eq? ls rest) 0 -1)
(cat (if (eq? ls rest) (lambda (x) x) " else ")
"if (" (c-in-test (c-expr c)) ")") p)
tail))))
st))))
(define (c-if/expr c p . rest)
(let lp ((c c) (p p) (ls rest))
(cond
((or (eq? c 'else) (eq? c #t))
(if (not (null? ls))
(error "forms after else clause in IF" c p ls)
(c-expr p)))
((pair? ls)
(cat (c-in-test (c-expr c)) " ? " (c-expr p) " : "
(if (pair? (cdr ls))
(lp (car ls) (cadr ls) (cddr ls))
(lp 'else (car ls) '()))))
(else
(c-or (c-in-test (c-expr c)) (c-expr p))))))
(define (c-if . args)
(fmt-if fmt-expression?
(apply c-if/expr args)
(apply c-if/stmt args)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; switch statements, automatic break handling
(define (c-label name)
(lambda (st)
(let ((indent (make-space (max 0 (- (fmt-col st) 2)))))
((cat fl indent name ":" fl) st))))
(define c-break
(c-wrap-stmt (dsp "break")))
(define c-continue
(c-wrap-stmt (dsp "continue")))
(define (c-return . result)
(if (pair? result)
(c-wrap-stmt (cat "return " (c-expr (car result))))
(c-wrap-stmt (dsp "return"))))
(define (c-goto label)
(c-wrap-stmt (cat "goto " (c-expr label))))
(define (c-switch val . clauses)
(c-reset-newline
(lambda (st)
((cat "switch (" (c-in-expr val) ")" (c-open-brace st)
(c-indent/switch st)
(c-in-stmt (apply c-begin/aux #t (map c-switch-clause clauses))) fl
(c-current-indent-string st) (c-close-brace st) fl)
st))))
(define (c-switch-clause/breaks x)
(lambda (st)
(let* ((break?
(and (car x)
(not (member (cadr x) '(case/fallthrough
default/fallthrough
else/fallthrough)))))
(explicit-case? (member (cadr x) '(case case/fallthrough)))
(indent (c-current-indent-string st))
(indent-body (c-indent st))
(sep (string-append ":" nl-str indent)))
((cat (c-in-expr
(fmt-join/suffix
dsp
(cond
((pair? (cadr x))
(map (lambda (y) (cat (dsp "case ") (c-expr y)))
(cadr x)))
(explicit-case?
(map (lambda (y) (cat (dsp "case ") (c-expr y)))
(if (list? (caddr x))
(caddr x)
(list (caddr x)))))
((member (cadr x)
'(default else default/fallthrough else/fallthrough))
(list (dsp "default")))
(else
(error
"unknown switch clause, expected a list or default but got"
(cadr x))))
sep))
(make-space (or (fmt-indent-space st) 4))
(fmt-join c-expr
(if explicit-case? (cdddr x) (cddr x))
indent-body)
(if (and break? (not (fmt-return? st)))
(cat fl indent-body c-break)
""))
st))))
(define (c-switch-clause x)
(if (procedure? x) x (c-switch-clause/breaks (cons #t x))))
(define (c-switch-clause/no-break x)
(if (procedure? x) x (c-switch-clause/breaks (cons #f x))))
(define (c-case x . body)
(c-switch-clause (cons (if (pair? x) x (list x)) body)))
(define (c-case/fallthrough x . body)
(c-switch-clause/no-break (cons (if (pair? x) x (list x)) body)))
(define (c-default . body)
(c-switch-clause/breaks (cons #t (cons 'else body))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; operators
(define (c-op op first . rest)
(if (null? rest)
(c-unary-op op first)
(apply c-binary-op op first rest)))
(define (c-binary-op op . ls)
(define (lit-op? x) (or (c-literal? x) (symbol? x)))
(let ((str (display-to-string op)))
(c-wrap-stmt
(c-maybe-paren
op
(if (or (equal? str ".") (equal? str "->"))
(fmt-join c-expr ls str)
(let ((flat
(fmt-let 'no-wrap? #t
(lambda (st)
((fmt-join c-expr
ls
(if (and (fmt-non-spaced-ops? st)
(every lit-op? ls))
str
(string-append " " str " ")))
st)))))
(fmt-if
fmt-no-wrap?
flat
(fmt-try-fit
flat
(lambda (st)
((fmt-join c-expr
ls
(cat nl (make-space (+ 2 (fmt-col st))) str " "))
st))))))))))
(define (c-unary-op op x)
(c-wrap-stmt
(cat (display-to-string op) (c-maybe-paren op (c-expr x)))))
;; some convenience definitions
(define (c++ . args) (apply c-op "++" args))
(define (c-- . args) (apply c-op "--" args))
(define (c+ . args) (apply c-op '+ args))
(define (c- . args) (apply c-op '- args))
(define (c* . args) (apply c-op '* args))
(define (c/ . args) (apply c-op '/ args))
(define (c% . args) (apply c-op '% args))
(define (c& . args) (apply c-op '& args))
;; (define (|c\|| . args) (apply c-op '|\|| args))
(define (c^ . args) (apply c-op '^ args))
(define (c~ . args) (apply c-op '~ args))
(define (c! . args) (apply c-op '! args))
(define (c&& . args) (apply c-op '&& args))
;; (define (|c\|\|| . args) (apply c-op '|\|\|| args))
(define (c<< . args) (apply c-op '<< args))
(define (c>> . args) (apply c-op '>> args))
(define (c== . args) (apply c-op '== args))
(define (c!= . args) (apply c-op '!= args))
(define (c< . args) (apply c-op '< args))
(define (c> . args) (apply c-op '> args))
(define (c<= . args) (apply c-op '<= args))
(define (c>= . args) (apply c-op '>= args))
(define (c= . args) (apply c-op '= args))
(define (c+= . args) (apply c-op "+=" args))
(define (c-= . args) (apply c-op "-=" args))
(define (c*= . args) (apply c-op '*= args))
(define (c/= . args) (apply c-op '/= args))
(define (c%= . args) (apply c-op '%= args))
(define (c&= . args) (apply c-op '&= args))
;; (define (|c\|=| . args) (apply c-op '|\|=| args))
(define (c^= . args) (apply c-op '^= args))
(define (c<<= . args) (apply c-op '<<= args))
(define (c>>= . args) (apply c-op '>>= args))
(define (c. . args) (apply c-op "." args))
(define (c-> . args) (apply c-op "->" args))
(define (c-bit-or . args) (apply c-op "|" args))
(define (c-or . args) (apply c-op "||" args))
(define (c-bit-or= . args) (apply c-op "|=" args))
(define (c++/post x)
(cat (c-maybe-paren 'post-increment (c-expr x)) "++"))
(define (c--/post x)
(cat (c-maybe-paren 'post-decrement (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")

12
sex-macros.scm
View File

@@ -1,11 +1,11 @@
(declare (unit sex-macros))
(import
scheme
(only fmt fmt)
(chicken base)
(chicken plist)
(chicken string))
(define (cat-syms s-1 s-2)
(import fmt)
(fmt #f s-1 s-2))
(define (cat sym-1 sym-2)
@@ -14,18 +14,20 @@
(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 (sex-macro? form)
(define (macro? form)
(and (list? form)
(symbol? (car form))
(get (car form) 'sex-macro)))
(define (apply-macro form)
(assert (sex-macro? form)
(assert (macro? form)
(fmt #f (car form) " is not a macro"))
(apply (get-macro (car form))
(cdr form)))

4
sex-mode.el
View File

@@ -51,7 +51,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
;; Keywords
(list (concat "("
(regexp-opt '(
"begin"
"case"
"default"
"do"
"if"
"for"
@@ -83,6 +85,8 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(put 'union 'lisp-indent-function 'defun)
(put 'var 'lisp-indent-function 0)
(put 'import 'lisp-indent-function 1)
(put 'switch 'lisp-indent-function 1)
(put 'case 'lisp-indent-function 1)
;;;###autoload
(define-derived-mode sex-mode lisp-data-mode "Sex"

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")

31
sex-modules.scm
View File

@@ -1,21 +1,20 @@
; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
; things start to break.
(declare (unit sex-modules)
(uses sex-reader
utils))
(import brev-separate
(chicken file)
(chicken load)
(chicken pathname)
(chicken process-context)
(chicken string)
fmt
srfi-1)
(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-public-forms module-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
@@ -69,7 +68,7 @@
(case (car form)
((pub)
(case (cadr form)
((fn) ; replace with prototype
((fn) ; replace with prototype
;; fn type name (arg-list) (body)
;; 1 2 3 4 - we need first 4
(cons (take (cdr form) 4) acc))

63
sex-reader.scm
View File

@@ -1,63 +0,0 @@
(declare (unit sex-reader))
(include "utils.macros.scm")
(import
(chicken base)
(chicken io)
(chicken pathname)
(chicken port)
(chicken read-syntax)
(chicken string)
(chicken syntax)
brev-separate
fmt)
(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 (read-from-file file)
(with-directory file
(with-input-from-file (pathname-strip-directory file)
(fn (read-forms (list))))))
(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 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)))))))
(if (eq? input-source 'stdin)
(read-forms (list))
(read-from-file input-source)))

1
sexc.module.scm Normal file
View File

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

40
sexc.scm
View File

@@ -1,12 +1,6 @@
(declare (unit sexc)
(uses fmt-c-writer
sex-reader
utils
semen))
(include "utils.macros.scm")
(import brev-separate
(import scheme
brev-separate
(chicken base)
(chicken file)
(chicken plist)
(chicken pretty-print)
@@ -14,10 +8,16 @@
(chicken process-context)
(chicken port)
fmt
fmt-c-writer
getopt-long
sex-macros
sex-modules
reader
semen
srfi-1 ; list routines
srfi-13
tree)
tree
utils)
;;; Main function facilities
@@ -32,9 +32,9 @@
(value #f)
(single-char #\c))
(emit-c "Emit C code"
(required #f)
(value #f)
(single-char #\C))
(required #f)
(value #f)
(single-char #\C))
(public-interface "Get module's public interface"
(required #f)
(value #f))
@@ -86,10 +86,10 @@
(define (emit-c-or-sex sex-forms output args)
(write-to-file-or-stdout output
(lambda ()
(if (get-arg args 'macro-expand #f)
(map pp sex-forms)
(emit-c sex-forms)))))
(lambda ()
(if (get-arg args 'macro-expand #f)
(map pp sex-forms)
(emit-c sex-forms)))))
(define (compile-to-file sex-forms output args)
(let ((compiler (or (get-arg args 'c-compiler #f)
@@ -116,7 +116,7 @@
(if (eq? input-source 'stdin)
(semen-process raw-forms)
(with-directory input-source
(semen-process raw-forms))))
(semen-process raw-forms))))
(define prelude
'((include inttypes.h)
@@ -155,7 +155,9 @@
(return #f))
(load-persistent-module-paths)
(sex-fmt-current-file (to-absolute-pathname input))
(if (eq? input 'stdin)
(sex-fmt-current-file "stdin")
(sex-fmt-current-file (to-absolute-pathname input)))
(let* ((raw-forms (append prelude (read-raw-forms input)))
(sex-forms (semantic-process-forms raw-forms input)))
(if (or (get-arg args 'macro-expand #f)

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"
;; 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
(syntax-rules ()

6
tests/run.scm
View File

@@ -1,10 +1,4 @@
(declare (uses fmt-c-writer
semen))
(import
(chicken process)
(chicken process-context)
srfi-1
test)
(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
'(fn void print-str ((string s))
@@ -38,11 +39,11 @@
(define (form-identity form env)
form)
(test 'a (semen-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 (walk-form 'a 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 b c) (semen-macro-expand '(a b c)))
(test 'a (macro-expand 'a))
(test '(a b c) (macro-expand '(a b c)))
(let ((sex-code-macro
'((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

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

26
tools/sextest/README.org Normal file
View File

@@ -0,0 +1,26 @@
* Sextest
A tool for testing Sex compiler by using test programs.
The tools compiles test programs, then runs with provided
input, checking the output and return code.
* Test format
The test program is just a regular Sex program, which may contain
additional toplevel forms, to define compilation parameters, input to
the program, and expected output and return code. Default value for
compilation, input and output is an empty strings. For the return code
it is 0.
* Example
some-test.sex:
#+begin_src
(compilation "-- -O2")
(input "")
(output "Hello world!")
(return 123)
(include stdio.h)
(pub fn main () int
(puts "Hello World!")
(return 123))
#+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)

17
utils.macros.scm
View File

@@ -1,17 +0,0 @@
(import (chicken process-context))
(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))))))

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")

22
utils.scm
View File

@@ -1,12 +1,26 @@
(declare (unit utils))
(include "utils.macros.scm")
(import
scheme
(chicken base)
(chicken pathname)
(chicken process-context)
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 (get-env-var name)
(get-environment-variable name))