42 Commits

Author SHA1 Message Date
37a252f2b1 Make Sex templates more pleasant syntactically
No more unquotes to instantiate templates.
Also no need to pass quoted substitution lists, just use them as
regular lisp macros.
2025-07-11 18:27:50 +03:00
162d4f5322 add info about Emacs sex-mode to Readme.org 2025-06-19 12:31:43 +03:00
7115f61538 update Readme.org
a bit of spellchecking, add some examples for templates
2025-06-16 15:18:21 +03:00
alex-eg
a1e0fbc4f9 support unkebabification in #()-forms
which are vectors in Chicken, {}-initializers in C
2025-06-14 19:02:45 +03:00
alex-eg
e1c386ebcd support cpp define 2025-06-14 18:49:01 +03:00
alex-eg
27822cee2a prefix define and define-syntax with chicken-
as we have define in cpp
2025-06-14 18:09:50 +03:00
alex-eg
af6b7a37ee don't unkebabify -> in symbols (it's -> from C) 2025-06-14 17:48:41 +03:00
alex-eg
1229f89153 fix pub function prototypes 2025-06-14 17:21:40 +03:00
alex-eg
bb3d7c1d3e fix non-symbolic template replacements causing error on expansion
symbol->string doesn't work for anything besides synmols. And not
any (not (list? ...)) is a symbol. String are not, for example.
2025-06-14 17:08:18 +03:00
alex-eg
df9c62ffa4 add define and define-syntax syntax coloring in sex-mode.el 2025-06-14 14:10:19 +03:00
alex-eg
3da85c3e2e change load to chicken-load in sex sources
to explicitly denote that it is chiken
2025-06-14 14:09:39 +03:00
alex-eg
8b1ade4f24 add chicken-import support to sex
also fix unquoting to single atom processing wrongly in walk-sex-tree
2025-06-14 14:07:41 +03:00
alex-eg
750d8f8256 rename dir lib -> example
because it is not quite lib yet, but an example dump definitely
2025-06-14 12:40:15 +03:00
alex-eg
db8ff39171 hanlde pub for global vars correctly 2025-06-14 12:39:13 +03:00
alex-eg
0ebdef2792 add union support to sex-mode.el 2025-06-13 18:21:06 +03:00
alex-eg
2295b5ad17 add extern support 2025-06-13 18:20:51 +03:00
alex-eg
4efa730b21 sex headers are now seh, not hsex 2025-06-13 14:47:55 +03:00
alex-eg
7f2463823a update Readme.org 2025-06-13 14:31:10 +03:00
alex-eg
e9c0323e6e add field access support (also unfuck tree walker a bit) 2025-06-12 23:40:35 +03:00
alex-eg
497603c111 remove useless empty line 2025-06-12 23:40:15 +03:00
alex-eg
35c7539d1e fix indent 2025-06-12 23:40:08 +03:00
alex-eg
88b441b58c sex-mode inherits scheme mode 2025-06-11 20:24:12 +03:00
alex-eg
ad983a0d9c unshittify templates 2025-06-11 20:23:54 +03:00
2ba9ad37b7 implement templates (kinda)
uh oh
2025-06-09 00:30:14 +03:00
fea7e58dd1 make some exceptions for unkebabification 2025-06-09 00:29:43 +03:00
dead339e8c add clean target 2025-06-09 00:28:50 +03:00
f46e087958 [] isn't gonna work with Sheme reader 2025-06-09 00:27:36 +03:00
e195ba8553 don't need map here, for-each is enough 2025-06-09 00:27:21 +03:00
9a1757dda8 fix reading from files not in current dir 2025-06-09 00:27:03 +03:00
2641e9f4fb add auto typedefs for structs 2025-06-09 00:23:49 +03:00
3d080b2bb0 typo 2025-06-05 17:17:58 +03:00
3224e8cf6a rewrite tree walk with tree module
also add pub support
2025-06-05 17:12:16 +03:00
0452f442b1 filter out '()s from the tree 2025-06-05 12:15:06 +03:00
4389392123 add cmdline options
-h help
-o write to file
-m expand macros in Sex code and print result
2025-06-05 07:32:05 +03:00
alex-eg
555bd836a9 add sex-mode.el 2025-05-30 12:38:18 +03:00
alex-eg
c4dd5786a8 maybe rewrite map-filter-tree with tree.scm's tree inversions?
They don't seem intuitive, need to mess around a bit to understand
them.
2025-05-30 12:37:28 +03:00
alex-eg
24bcd93a36 add template list class and test 2025-05-30 12:37:07 +03:00
alex-eg
80b69cc8ad add link to Chicken web site 2025-05-29 22:19:23 +03:00
alex-eg
794e97c473 fix format in Readme 2025-05-29 22:15:12 +03:00
alex-eg
61ddabf85f implement comma in Sex sources 2025-05-29 22:08:14 +03:00
alex-eg
861b862a13 add info about Chicken deps to Readme.org 2025-05-27 14:50:10 +03:00
alex-eg
7007623e94 update Readme 2025-05-27 12:02:54 +03:00
45 changed files with 586 additions and 2652 deletions

View File

@@ -1,55 +0,0 @@
name: Sex CI
on:
push:
branches: [ main ]
pull_request:
branches: [ main ]
jobs:
build-linux:
runs-on: ubuntu-latest
steps:
- uses: actions/checkout@v3
- name: Install chicken
run: |
wget -N https://code.call-cc.org/releases/5.4.0/chicken-5.4.0.tar.gz
tar zxf chicken-5.4.0.tar.gz
sudo apt install -y make
make -C chicken-5.4.0 PLATFORM=linux
sudo make -C chicken-5.4.0 PLATFORM=linux install
- name: Install dependencies
# FIXME: [project-local deps]: use venv or something
# run: make deps
run: sudo chicken-install $(cat dependencies.txt)
- name: Make sure that sexc builds
# FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
# Without it there will be `Error: cannot load extension: fmt`.
run: make sexc && ./sexc --help
- name: Run tests
# FIXME: [project-local deps]: use local deps or build with -static
# run: make run-tests
run: make sex-tests && ./sex-tests
build-macos:
runs-on: macos-15
steps:
- uses: actions/checkout@v3
- name: Install chicken
run: brew install chicken make
- name: Install dependencies
# FIXME: [project-local deps]: use venv or something
# run: make deps
run: chicken-install $(cat dependencies.txt)
- name: Make sure that sexc builds
# FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
# Without it there will be `Error: cannot load extension: fmt`.
run: make sexc && ./sexc --help
- name: Run tests
# FIXME: [project-local deps]: use local deps or build with -static
# run: make run-tests
run: make sex-tests && ./sex-tests

5
.gitignore vendored
View File

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

View File

@@ -1,60 +1,19 @@
CHICKEN_C = csc
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
MODULES = utils sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
MODULES = sexc templates main
OBJ = $(MODULES:%=%.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
# chicken flags
CFLAGS = -compile-syntax
#------------------------------------------------------------------
sexc: $(OBJ)
$(CHICKEN_C) $^ -o $@
utils.o: utils.module.scm utils.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
main.o: main.scm
$(CHICKEN_C) $< -c -o $@
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 ./
%.o: %.scm
$(CHICKEN_C) $< -e -c -o $@ $(CFLAGS)
clean:
rm -f $(OBJ) main.o
rm -f *.import.scm
rm -f *.link
rm -f sexc sex-tests
rm -f $(OBJ) sexc

View File

@@ -1,76 +1,66 @@
* The Sex language
Sex is a S-expressions language, which transpiles to C.
#+NAME: the Sex logo
#+ATTR_HTML: :width 300px
[[sex.png][file:./sex.png]]
Sex is also Chicken, since all source processing and compile-time
computations are written in Chicken.
Sex is a S-expressions language. Sex is written in Chicken, which is a
[[https://call-cc.org][R5RS Scheme]].
Sex is statically typed, compiled general purpose language.
And Chicken is [[https://call-cc.org][R5RS Scheme]].
* Compilation
First, get yourself a Chicken, then, some Chicken deps. You also will
need a C compiler.
* Compilation and usage
First, get yourself a Chicken. Second, some Chicken deps.
** Install Chicken Eggs
Tip: there's a way to make Chicken install eggs non-globally. You need
to export ~CHICKEN_INSTALL_REPOSITORY~ and ~CHICKEN_REPOSITORY_PATH~
environment variables. Refer to the documentation for more info:
By the way, there's a way to make Chicken install eggs non-globally. Refer to
the documentation for more info:
https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
~chicken-install `cat dependencies.txt`~
~chicken-install fmt getopt-long brev-separate~
** Compilation
~make~
* Usage
** Summary
** Usage
You'll also need a C compiler, so pick any.
#+begin_src
Usage: sexc [options] filename [-- options-for-c-compiler]
Options:
--c-compiler=ARG Select C compiler. Defaults to value of SEX_CC
environment variable, or if it is empty, to cc
-c, --compile-object Compile object file instead of executable program
-C, --preprocess Emit C code
--public-interface Get module's public interface
-h, --help Show this help
-m, --macro-expand Emit macro-expanded semantically processed Sex code
(sort of IR). May be useful for debugging
-o, --output=ARG Write output to file. Default file name is a.out.
If -E or -m options are provided, defaults to stdout
#+end_src
** Compiling Hello World
#+begin_src shell
sexc ./examples/hello-world.sex -o hello
cat hello-world.sex | sexc > hello_world.c
cc hello_world.c -o hello_world
#+end_src
That's it. Now you should have executable named ~hello~ in your
directory. Sex uses C under the hood, the default C compiler is ~cc~,
but you can pass any using ~--c-compiler~ option, or by setting
~SEX_CC~ environment variable.
* Example
Here is an example, demonstrating what Sex source looks like, and what
it compiles too. An avid reader also shall notice how we call Chicken
procedures in Sex source.
** Example
An example of Sex source:
#+begin_src scheme
The Sex source:
#+begin_src
(include stdio.h)
(pub fn main ((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 0))
(define (foo)
"Hello from Chicken code!\n")
(pub fn int main ((int argc) (char **argv))
(puts "Hello from Sex!")
(var (array char 512) name)
(puts "What is your name?")
(scanf "%s" &name)
(printf "Hello, %s!\n" name)
(printf ,(foo))
0)
#+end_src
Compile and run:
#+begin_src shell
~/dev/sex $ ./sexc ./example/hello-world.sex -o hello-world
~/dev/sex $ ./hello-world
Hello from Sex!
What is your name?
Alex
Hello, Alex!
The resulting C source:
#+begin_src
#include <stdio.h>
int main (int argc, char **argv) {
puts("Hello from Sex!");
char name[512];
puts("What is your name?");
scanf("%s", &name);
printf("Hello, %s!\n", name);
printf("Hello from Chicken code!\n");
return 0;
}
#+end_src
* Features
@@ -78,65 +68,144 @@ Hello, Alex!
Just ~(include "Your/Favourite/Library.h")~ and use it as you would
have is C.
*** Auto kebabification
For hardcore fans of traditional Lisp naming convention,
Sex offers automatic kebabification of all symbols, i.e. no more
Sex offers automatic unkebabification of all symbols, i.e. no more
ugly ~GL_ARRAY_BUFFER~ s in your code, they may be written in their
proper form: ~GL-ARRAY-BUFFER~.
** Modules
Each source file is a module. Module can provide public interface and
be imported by using ~(import path/to/module)~ expression. Module
search path consists of two parts: first is relative to the source
being compiled location, and the second is ~SEX_MODULE_PATH~
environment variable.
** Auto typedef for structs
Probably harmless idk. Example:
#+begin_src
(struct foo
((float a)
(int b)))
#+end_src
expands to
#+begin_src
typedef struct foo foo;
Module's public interface consists of everything declared
~pub~. Structures, function, macros, types, variables can be
public.
struct foo {
float a;
int b;
};
#+end_src
** Syntactic macros
Sex has support for syntactic macros. Macro definitions look like
functions: they have a name, an argument list and a body. Macro should
return Sex code.
** Syntactic templates
Sex has support for template substitutions. Any piece of code can be
templated. Template declarations look like functions: they have a
name, an argument list and a body. When declared template is
encountered during reading of Sex code, its body will udergo syntactic
rewriting using the provided values by the following rules:
1. If the value is a symbol, all arguments in a body are replaced with
the value, and also all /parts/ of any other symbol equal to the
value also get replaced.
2. If the value is a non-symbolic form, all arguments in a body are
replaced with it, but no symbolic substitution is performed.
Formally, template declaration has the following syntax:
#+begin_src
(template (name . substitute-args) . body)
#+end_src
*** Examples:
**** Structure with templated value type
#+begin_src scheme
(pub defmacro (list-T type)
(let ((list-type (cat 'list- type)))
`(struct ,list-type
((value ,type)
(next (* ,list-type))))))
#+begin_src
(template (foo ?T)
(struct foo-?T
((?T value))))
(list-T int)
(foo float)
#+end_src
->
#+begin_src scheme
(struct list_int
((value int)
(next (* list_int))))
#+begin_src
typedef struct foo_float foo_float;
struct foo_float {
float value;
};
#+end_src
**** Wrapper for checking return codes
#+begin_src scheme
(pub defmacro (check-sdl-return call message ret-code)
`(if (< 0 ,call)
(begin
(puts ,message)
(return ,ret-code))))
Note that ~?~ at the start of template argument is not syntax, just
convention.
(pub fn init () int
**** Wrapper for checking return codes
#+begin_src
(template (check-sdl-return call message ret-code)
(if (< 0 call)
(begin
(puts message)
(return ret-code))))
(fn int init ()
(check-sdl-return
(SDL-Init SDL-INIT-VIDEO) "Failed to initialize SDL" 1)
...)
#+end_src
->
#+begin_src scheme
(pub fn init () int
(if (< 0 (SDL_Init SDL_INIT_VIDEO))
(begin (puts "Failed to initialize SDL") (return 1)))
...)
#+begin_src
static int init () {
if (0 < SDL_Init(SDL_INIT_VIDEO)) {
puts("Failed to initialize SDL");
return 1;
}
return 0;
}
#+end_src
**** A bit of everything
#+begin_src
(template (list-T ?T)
(struct list-?T
((?T value)
((* list-?T) next))))
(template (list-for-each type list-var elt-var body)
(var type elt-var (-> list-var value))
(while (!= (-> list-var next) NULL)
body
(= list-var (-> list-var next))
(= elt-var (-> list-var value))))
; ... somewhere later
(list-T int)
(pub fn void print-list (((const list-int) *l))
(list-for-each int l v (printf "%d " v))
(printf "\n"))
#+end_src
Then will be expanded in the following code:
#+begin_src
(typedef struct list_int list_int)
(struct list_int ((int value) ((* list_int) next)))
(%fun void
print_list
(((const list_int) *l))
(%var int v (-> l value))
(while (!= (-> l next) NULL)
(printf "%d " v)
(= l (-> l next))
(= v (-> l value)))
(printf "\n"))
#+end_src
And then translated to:
#+begin_src
typedef struct list_int list_int;
struct list_int {
int value;
list_int *next;
};
void print_list (const list_int *l) {
int v = l->value;
while (l->next != NULL) {
printf("%d ", v);
l = l->next;
v = l->value;
}
printf("\n");
}
#+end_src
** Use an established environment for development
@@ -146,8 +215,10 @@ best option.
*** sex-mode.el
To harness the power of sex-mode, add the following lines to your
~$HOME/.config/emacs/init.el~:
#+begin_src emacs-lisp
#+begin_src
(use-package sex-mode
:load-path "/path/to/sex"
:mode ("\\.sex\\'"))
:mode ("\\.sex\\'" "\\.seh\\'"))
#+end_src
** COMING SOON?: Polymorphism

View File

@@ -1 +0,0 @@
fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69 matchable

View File

@@ -1,10 +0,0 @@
;;; Prototypes
(fn puk () void)
(pub fn plak () void)
;;; Functions
(fn foo () int (return 1))
(pub fn bar ((a int) (b int)) void
(printf "%d\n" (+ a b)))

View File

@@ -1,9 +0,0 @@
(include stdio.h)
(pub fn main ((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 0))

View File

@@ -1,51 +0,0 @@
(include stdio.h)
(fn sum ((a int) (b int)) int
(return (+ a b)))
(pub fn main () int
(var a int 10)
(var b int 20)
(var (fn ((int) (int)) int) sum-fn sum)
(var (fn ((int) (int)) int) sum-lambda
(lambda ((a int) (b int)) int ()
(return (+ a b))))
(var (fn ((int)) int) sum-lambda-2
(lambda ((a int)) int ()
(return (+ a 20))))
(printf "Hello from main fn!\n")
(printf "We will now perform some function calling.\n")
(printf "Calling fn ptr: %d\n" (sum-fn a b))
(printf "Calling lambda: %d\n" (sum-lambda a b))
(printf "Calling other lambda: %d\n" (sum-lambda-2 a))
(printf "Calling lambda inplace: %d\n" ((lambda ((a int) (b int)) int ()
(return (+ a b 100)))
a b))
(var (fn ((int)) int) l-1
(lambda ((a int)) int ()
(var (fn ((int)) int) l-2
(lambda ((a int)) int ()
(return (+ 60 a))))
(return (+ 600 (l-2 a)))))
(printf "Calling nested lambdas: %d\n" (l-1 6))
;; Not supported yet
;; Closure
;; (var (fn (fn ((int)) int) ((int))) make-adder
;; (lambda (fn int ((int a))) ()
;; (return (lambda int ((int b)) (a)
;; (return (+ a b))))))
;;
;; (var (fn int ((int))) add-10
;; (make-adder 10))
;; (var (fn int ((int))) add-20
;; (make-adder 20))
;; (printf "Calling closures: %d\n" (add-10 24))
(return 0))

36
example/list.seh Normal file
View File

@@ -0,0 +1,36 @@
(template (list-T ?T)
(struct list-?T
((?T value)
((* list-?T) next))))
(template (make-list-T ?T is-public?)
(,@(if 'is-public? '(pub) '()) fn (* list-?T) make-list-?T ()
(var (* list-?T) list (cast (* list-?T) (malloc (sizeof list-?T))))
(= (-> list next) NULL)
list))
(template (add-value-list-?T ?T is-public?)
(,@(if 'is-public? '(pub) '()) fn void add-value-list-?T ((list-?T *list) (T value))
(while (!= (-> list next) NULL)
(= list (-> list next)))
(= (-> list next) (make-list-?T))
(= (-> list value) value)))
(template (length-list-?T ?T is-public?)
(,@(if 'is-public? '(pub) '()) fn size-t length-list-?T ((list-?T *list))
(var size-t n 0)
(while (!= (-> list next) NULL)
(= list (-> list next))
(++ n))
n))
(template (is-empty-list-?T ?T is-public?)
(,@(if 'is-public? '(pub) '()) fn bool is-empty-list-?T ((list-?T *list))
(== (-> list next) NULL)))
(template (list-for-each list-var elt-var what-do)
(var int elt-var (-> list-var value))
(while (!= (-> list-var next) NULL)
what-do
(= list-var (-> list-var next))
(= elt-var (-> list-var value))))

View File

@@ -1,48 +0,0 @@
(pub defmacro (list-T type)
(let ((list-type (cat 'list- type)))
`(struct ,list-type
((value ,type)
(next (* struct ,list-type))))))
(pub defmacro (make-list-T type is-public?)
(let ((list-type (list 'struct (cat 'list- type)))
(fn-name (cat 'make-list- type)))
`(,@(if is-public? '(pub) '()) fn ,fn-name () (* ,list-type)
(var list (* ,list-type) (cast (malloc (sizeof ,list-type)) (* ,list-type)))
(= (-> list next) NULL)
(return list))))
(pub defmacro (add-value-list-T type is-public?)
(let ((list-type (list 'struct (cat 'list- type)))
(fn-name (cat 'add-value-list- type)))
`(,@(if is-public? '(pub) '()) fn ,fn-name ((list * ,list-type) (value ,type)) void
(while (!= (-> list next) NULL)
(= list (-> list next)))
(= (-> list next) (,(cat 'make-list- type)))
(= (-> list value) value))))
(pub defmacro (length-list-T type is-public?)
(let ((fn-name (cat 'length-list- type))
(list-type (list 'struct (cat 'list- type))))
`(,@(if is-public? '(pub) '()) fn ,fn-name ((list ,(cons '* list-type))) size-t
(var n size-t 0)
(while (!= (-> list next) NULL)
(= list (-> list next))
(++ n))
(return n))))
(pub defmacro (is-empty-list-T type is-public?)
`(,@(if is-public? '(pub) '()) fn ,(cat 'is-empty-list- type)
((list ,(list '* 'struct (cat 'list- type))))
bool
(return (== (-> list next) NULL))))
(pub defmacro (list-for-each list-type list-var elt-type elt-var what-do)
(let ((list-var-2 (cat list-var '-2)))
`(begin
(var ,list-var-2 (* ,list-type) ,list-var)
(var ,elt-var ,elt-type (-> ,list-var-2 value))
(while (!= (-> ,list-var-2 next) NULL)
,what-do
(= ,list-var-2 (-> ,list-var-2 next))
(= ,elt-var (-> ,list-var-2 value))))))

View File

@@ -1,44 +1,69 @@
(include stdlib.h)
(include stddef.h)
(include stdbool.h)
(include stdio.h)
(import list)
(chicken-import srfi-1 brev-separate) ; list routines, e.g. fold
(chicken-load "list.seh")
(chicken-define (imports-test a b c)
(fold + 0 (list 1 2 3 a b c)))
(struct foo
((a-field float)
(b int)
(c (* const char))
(not (fn ((val bool)) bool))))
((float a-field)
(int b)
((const char *) c)
((fn bool ((bool val))) not)))
(var f (struct foo))
(var foo f #((= .a-field 1.2)))
(list-T int)
(make-list-T int #f)
(add-value-list-T int #f)
(length-list-T int #f)
(is-empty-list-T int #f)
(make-list-T int)
(add-value-list-T int)
(length-list-T int)
(is-empty-list-T int)
(extern fn puk ((a int) (b float)) void)
(pub fn baz () bool
(return true))
(extern fn void puk ((int a) (float b)))
(fn int bar () ,(imports-test 10 20 30))
(pub fn void baz () true)
(extern var i int)
(var j int)
(pub var k int)
(extern var int i)
(var int j)
(pub var int k)
(pub fn main () int
(var l (* struct list-int) (make-list-int))
(printf "Size of the list: %lu\n" (length-list-int l))
(pub fn int main ()
(var (* list-int) l (make-list-int))
(printf "Size of the list: %zu\n" (length-list-int l))
(add-value-list-int l 3)
(add-value-list-int l 4)
(printf "Size of the list: %lu\n" (length-list-int l))
(list-for-each (struct list-int) l int v
(printf "Size of the list: %zu\n" (length-list-int l))
(list-for-each l v
(printf "%d " v))
(printf "\n")
(printf "Size of the list: %lu\n" (length-list-int l))
(printf "%p\n" (cast l->next (* void)))
(return 0))
(printf "%zu\n" l->next)
0)
(pub fn print-list ((l (* const struct list-int))) void
(list-for-each (const struct list-int) l int v (printf "%d " v))
(pub fn segs-renderer* create-renderer ())
(pub fn void clear-command-buffer ((segs-renderer *r)))
(pub fn void add-render-command ((segs-renderer *r) ((fn void ()) command)))
(pub fn void commit-command-buffer ((segs-renderer *r)))
(template (list-T ?T)
(struct list-?T
((?T value)
((* list-?T) next))))
(template (list-for-each type list-var elt-var body)
(var type elt-var (-> list-var value))
(while (!= (-> list-var next) NULL)
body
(= list-var (-> list-var next))
(= elt-var (-> list-var value))))
; ... somewhere later
(list-T int)
(pub fn void print-list (((const list-int) *l))
(list-for-each int l v (printf "%d " v))
(printf "\n"))

View File

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

View File

@@ -1,283 +0,0 @@
;;; Sex fmt-c output writer
(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
((-) sym)
((--) sym)
((->) sym)
((-=) sym)
(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
(fmt #f (cadr form) (car form)))))
(define (walk-generic-toplevel form)
(cond ((atom? form) (atom-to-fmt-c form))
((list? form) (map walk-generic-toplevel form))
(else (error "Malformed form " form))))
(define (field-access-form? form)
(and (symbol? (car form))
(char=? #\. (string-ref (symbol->string (car form)) 0))))
(define (walk-expr form)
(match 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))))
(define (walk-var form)
;; (var a int) -> (%var int a)
;; (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 (walk-type form)
;; int -> int
;; (const int) -> const int
;; [const char 512] ->(¤ (const char) 512) -> (%array (const char) 512)
;; [float 8] -> (%array float 8)
;; (* const char) -> (const char *)
;; (const * const * const char) -> (const char * const * const)
;; (fn ((int) (float)) void) -> (%fun void ((int) (float)))
(match form
(('¤ . array-type)
(if (integer? (last array-type))
;; sized array
(let* ((type-list (drop-right array-type 1))
(type (maybe-unwrap-type type-list))
(size (last array-type)))
`(%array ,(walk-type type)
,size))
;; sugar for pointer... Do we really need it? Guess why not,
;; it's a strong semantic cue
`(%array ,(walk-type (maybe-unwrap-type array-type)))))
(('fn arglist ret-type)
`(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
(('fn . _)
(assert #f "Malformed function type form"))
;; Special case: nested structs/unions
((or ('struct . _)
('union . _)) (walk-struct form))
(('enum . _) (walk-enum form))
(else
(type-convert-to-c form))))
(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?
(define (is-probably-type form)
(case (car form)
((¤ * const volatile struct union) #t)
(else #f)))
(define (walk-arglist form)
;; E.g.:
;; ((float) (int) (const char) (* const char) (¤ (* const struct res) 32))
;; ((f1 float) (f2 float) (f3 float) (res (¤ float 4)))
(map (fn
(match x
(('¤ . _) (walk-type x))
;; 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
;; :(
((? is-probably-type) (walk-type x))
;; 1 element args are always type
((_) (walk-type x))
((var . type) (append (list (walk-type (maybe-unwrap-type type)))
(list (walk-type var))))))
form))
(define (walk-function form)
;; (fn ret-type name arglist body) -> normal function
;; (fn ret-type name arglist) -> prototype
(if (>= (length form) 5)
(walk-fn-def form)
(cons '%prototype (cdr (walk-fn-def form)))))
(define (process-struct-fields fields)
(map (fn
(let ((type (walk-type (last x))))
(cons type (map atom-to-fmt-c (drop-right x 1)))))
fields))
(define (walk-struct form)
(match form
((type (fields ...) . attrs) ; anonymous struct
`(,type ,(process-struct-fields fields)
. ,(tree-map atom-to-fmt-c attrs)))
((type name) ; simple 'struct whatever', like in variable def
`(,type ,(atom-to-fmt-c name)))
((type name (fields ...) . attrs)
`(,type ,(atom-to-fmt-c name)
,(process-struct-fields fields)
. ,(tree-map atom-to-fmt-c attrs)))
(else (error "Malformed aggregate definition " form))))
(define (walk-enum form)
(match form
(('enum (values ...))
`(enum ,(map atom-to-fmt-c values)))
(('enum name (values ...))
`(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
(define (walk-extern form)
(match form
(('fn . _)
;; extern function?.. What
(list 'extern (walk-function form)))
(('var . _)
(list 'extern (walk-var form)))
(else (error "Extern what?"))))
(define (walk-public form)
(match form
(('fn . _)
(walk-function form))
(('var . _)
(walk-var form))
((or ('define . _)
('defmacro . _)
('import . _)
('include . _)
('struct . _)
('union . _)
('typedef . _))
;; ignore here, used in generating public interface
(process-toplevel-form form))
(else
(error "Pub what?" (cadr form)))))
(define (process-toplevel-form form)
(match form
(('fn . _) (list 'static (walk-function form)))
(('var . _) (list 'static (walk-var form)))
(('extern . rest) (walk-extern rest))
(('pub . rest) (walk-public rest))
((or ('struct . _)
('union . _)) (walk-struct form))
(('enum . _) (walk-enum form))
(('define name . rest) `(%define ,(atom-to-fmt-c name) ,@rest))
(else (walk-expr form))))
(define (get-line-num form)
(let ((num (get-line-number form)))
(if (string? num)
(last (string-split num ":"))
#f)))
(define sex-fmt-current-file (make-parameter "/dev/null"))
(define sex-fmt-line-num (make-parameter 0))
(define (line-directive-string)
(fmt #f #\# "line " (sex-fmt-line-num) " " #\" (sex-fmt-current-file) #\"))
(define (emit-c sex-forms)
(for-each (lambda (form)
(let ((start-line (get-line-num form)))
(when start-line
(sex-fmt-line-num start-line)
(fmt #t (line-directive-string) nl)))
(fmt #t (c-expr (process-toplevel-form form)) nl))
sex-forms))

18
hello-world.sex Normal file
View File

@@ -0,0 +1,18 @@
(include stdio.h)
(define (foo)
"Hello from Chicken code!\n")
(struct foo
((int a)
(float b)))
(pub fn int main ((int argc) (char **argv))
(var int a 10)
(puts "Hello from Sex!")
(var (array char 512) name)
(puts "What is your name?")
(scanf "%s" &name)
(printf "Hello, %s!\n" name)
(printf ,(foo))
0)

View File

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

View File

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

View File

@@ -1,62 +0,0 @@
(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 (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)))

View File

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

239
semen.scm
View File

@@ -1,239 +0,0 @@
;;; Sex semantic engine
(import
scheme
(chicken base)
(chicken keyword)
(chicken string)
(chicken module)
fmt
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
;;;
;;; The algorithm: feed toplevel forms to appropriate handlers, then
;;; 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 (process raw-sex-forms)
(process-rec raw-sex-forms (list)))
(define (process-rec forms acc)
(cond
((null? forms) (reverse acc))
((macro? (car forms))
(process-rec
(macroexpand (car forms) (cdr forms))
acc))
(else
(process-rec (cdr forms)
(match-sex-form (car forms) acc)))))
(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)
(cons res rest-forms))))
(define (match-sex-form sex-form acc)
(match sex-form
((or ('fn . _)
('pub 'fn . _)
('extern 'fn . _)) (process-fn sex-form acc))
((or ('struct . _)
('pub 'struct . _)) (process-struct sex-form acc))
((or ('union . _)
('pub 'union . _)) (process-struct sex-form acc))
((or ('enum . _)
('pub 'enum . _)) (process-struct sex-form acc))
((or ('var . _)
('pub 'var . _)
('extern 'var . _)) (process-global-var sex-form acc))
(('include _) (cons sex-form acc))
(('define . _) (cons sex-form acc))
(('import . modules)
(process-imports (get-modules-public-forms modules) acc))
((or ('defmacro . rest)
('pub 'defmacro . rest)) (defmacro rest) acc)
((or ('typedef new-type target)
('pub 'typedef new-type target))
(process-typedef new-type target acc))
(else (assert #f (fmt #f "Unknown top level form " sex-form)))))
(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)
(process-imports (cdr module-public-forms) acc))
(else
(process-imports (cdr module-public-forms)
(cons (car module-public-forms)
acc))))))
(define (macro-expand form)
"Walk the form recursively and expand all macros, until none is left."
(walk-form
form
(lambda (subform env)
(if (macro? subform)
(cons walk-embed-result (macroexpand subform (list)))
subform))
#f))
;;; 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.
;;; For inspiration, see SBCL's walk.lisp and their template
;;; system.
(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 (walk-form form walk-fn env)
(if (atom? form) form
(let ((new-form (walk-fn form env)))
(cond ((not (eq? form new-form))
(walk-form new-form walk-fn env))
(else
(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) walk-embed-result))
(append (cdr new-car) new-cdr))
(else
(recons new-form new-car new-cdr)))))))))
;;; Typdef
(define (process-typedef new-type target acc)
(cons `(typedef ,target ,new-type) acc))
;;; Fn processing
(define (process-fn sex-fn acc)
(let* ((expanded (macro-expand sex-fn))
(env (make-hash-table))
(processed
(walk-form
expanded
fn-walker
(begin
(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-aux-code) (list))
env))))
(cons processed
(append (hash-table-ref env :lambda-aux-code) acc))))
(define (fn-walker form env)
(if (eq? 'lambda (car form))
(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 (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))
(define (make-lambda-name enclosing-fn-name counter)
(string->symbol
(fmt #f "__lambda_" counter "_" enclosing-fn-name)))
(define (make-aux-lambda-struct name form)
(match form
(('lambda ret-type arglist captures . body)
;; Captures are ignored for now, but
;; we'll need them for TODO: closures support
(process-fn `(fn ,ret-type ,name ,arglist ,@body) (list)))
(else (assert #f (fmt #f "Malformed lambda " form)))))
;;; Structs
(define (process-struct sex-struct acc)
(cons sex-struct acc))
(define (process-global-var sex-var acc)
(cons sex-var acc))
;;; Utils
(define (non-empty-list? form)
(and (list? form)
(not (null? form))))
(define (sex-fn? form)
"The `form` must be toplevel.
Returns #f if the form is not a function, returns the form otherwise"
(match form
((fn . _) form)
((pub fn . _) form)
(else #f)))
(define (sex-fn-public? fn-form)
(eq? (car fn-form) 'pub))
(define (sex-fn-return-type fn-form)
(assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form)
(third fn-form)
(second fn-form)))
(define (sex-fn-name fn-form)
(assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form)
(fourth fn-form)
(third fn-form)))
(define (sex-fn-arglist fn-form)
(assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form)
(fifth fn-form)
(fourth fn-form)))
(define (sex-fn-prototype fn-form)
"Returns all except body"
(assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form)
(take fn-form 5)
(take fn-form 4)))
(define (sex-fn-body fn-form)
(assert (sex-fn? fn-form)
(fmt #f "Form " fn-form " is not a function"))
(if (sex-fn-public? fn-form)
(drop fn-form 5)
(drop fn-form 4)))

View File

@@ -1,985 +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
(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)) "--")))

View File

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

View File

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

View File

@@ -33,13 +33,12 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
"chicken-import"
"chicken-load"
"define"
"defmacro"
"extern"
"import"
"include"
"fn"
"pub"
"struct"
"template"
"var"
"union")
'word)
@@ -51,9 +50,7 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
;; Keywords
(list (concat "("
(regexp-opt '(
"begin"
"case"
"default"
"do"
"if"
"for"
@@ -79,14 +76,9 @@ All commands in `lisp-mode-shared-map' are inherited by this map.")
(setq-local prettify-symbols-alist lisp-prettify-symbols-alist))
(put 'fn 'lisp-indent-function 'defun)
(put 'pub 'lisp-indent-function 'defun)
(put 'defmacro 'lisp-indent-function 'defun)
(put 'template 'lisp-indent-function 'defun)
(put 'struct 'lisp-indent-function 'defun)
(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"

View File

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

View File

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

BIN
sex.png

Binary file not shown.

Before

Width:  |  Height:  |  Size: 600 KiB

View File

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

370
sexc.scm
View File

@@ -1,62 +1,221 @@
(import scheme
brev-separate
(chicken base)
(chicken file)
(declare (unit sexc)
(uses templates))
(import brev-separate
(chicken pathname)
(chicken plist)
(chicken pretty-print)
(chicken process)
(chicken process-context)
(chicken port)
(chicken string)
fmt
fmt-c-writer
fmt-c
getopt-long
sex-macros
sex-modules
reader
semen
regex
srfi-1 ; list routines
srfi-13
tree
utils)
tree)
(define +debug+ #f)
(define (unkebabify sym)
(case sym
((-) sym)
((--) sym)
((->) sym)
((-=) sym)
(else
(string->symbol
(string-substitute "-(?!>)" "_"
(symbol->string sym) #t)))))
(define (atom-to-fmt-c atom)
(case atom
((fn) '%fun)
((prototype) '%prototype)
((var) '%var)
((begin) '%begin)
((define) '%define)
((pointer) '%pointer)
((array) '%array)
((@) 'vector-ref)
((include) '%include)
((cast) '%cast)
(else
(if (symbol? atom)
(unkebabify atom)
atom))))
(define (tree-finder symbol)
(lambda (node)
(or (and (tree? node)
(eq? (car node) symbol))
#f)))
(define (make-field-access form)
(assert (= 2 (length form)) "Wrong field access format")
(unkebabify
(string->symbol
(fmt #f (cadr form) (car form)))))
(define (walk-generic form acc)
(cond
((null? form) (cons '() acc))
;; vector, e.g. {}-initializer
((vector? form)
(cons
(list->vector
(car (walk-sex-tree (vector->list form) (list))))
acc))
;; atom (hopefully)
((not (list? form)) (cons (atom-to-fmt-c form) acc))
;; special case - replace unquote with its expansion
((eq? (car form) 'unquote)
(fold
cons
acc
(car ; bc walk-sex-tree always
; wraps its result
(walk-sex-tree (eval (cadr form)) (list)))))
;; another special case - field access
((and (symbol? (car form))
(char=? #\. (string-ref (symbol->string (car form)) 0)))
(cons (make-field-access form) acc))
;; another special case - template
((template? form)
(append (fold
walk-generic
(list)
(eval form))
acc))
;; toplevel, or a start of a regular list form
(else
(let ((new-acc (list)))
(cons (reverse
(fold
walk-generic
new-acc
form))
acc)))))
(define (normalize-fn-form form)
;; (fn ret-type name arglist body) -> normal function
;; (fn ret-type name arglist) -> prototype
(if (>= (length form) 5)
form
(cons 'prototype (cdr form))))
(define (walk-function form static acc)
(if static
(append (walk-generic (list 'static (normalize-fn-form form))
(list))
acc)
(append (walk-generic (normalize-fn-form (cdr form))
(list))
acc)))
(define (walk-struct form acc)
(let ((name (unkebabify (cadr form))))
(append (walk-generic form (list))
(cons `(typedef struct ,name ,name) acc))))
(define (walk-extern form acc)
(case (cadr form)
((fn)
(append
(list (cons 'extern (walk-function form #f (list))))
acc))
((var)
(append
(list (cons 'extern (walk-generic (cdr form) (list))))
acc))
(else (error "Extern what?"))))
(define (walk-public form acc)
(case (cadr form)
((fn)
(walk-function form #f acc))
((var)
(append (walk-generic (list 'static (cdr form)) (list)) acc))
(else (error "Pub what?"))))
(define (template? form)
(and (list? form)
(symbol? (car form))
(get (car form) 'sex-template)))
(define (walk-sex-tree form acc)
(if (list? form)
(if (template? form)
(fold (fn (walk-sex-tree x y))
acc
(eval form))
(case (car form)
((fn) (walk-function form #t acc))
((extern) (walk-extern form acc))
((pub) (walk-public form acc))
((struct union) (walk-struct form acc))
((unquote) (fold (fn (walk-sex-tree x y))
acc
(eval (cadr form))))
(else (append (walk-generic form (list)) acc))))
;; only for unquote support
(list (list (atom-to-fmt-c form)))))
(define (process-form form acc)
(case (car form)
((chicken-define) (eval (cons 'define (cdr form))) acc)
((template) (eval form) acc)
((chicken-load)
(load (cadr form)) acc)
((chicken-import)
(eval (cons 'import (cdr form))) acc)
(else
(walk-sex-tree form acc))))
(define (process-raw-forms raw-forms acc)
(if (null? raw-forms)
(reverse acc)
(process-raw-forms (cdr raw-forms)
(process-form (car raw-forms) acc))))
(define (read-forms acc)
(let ((r (read)))
(if (eof-object? r) (reverse acc)
(read-forms (cons r acc)))))
(define (emit-c forms)
(for-each (lambda (form)
(fmt #t (c-expr form))
(fmt #t "\n"))
forms))
;;; Main function facilities
(define opts-grammar
(let ((padding 26))
`((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")
(required #f)
(value #t))
(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"
`((output "Write output to file"
(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)))))
(value #t)
(single-char #\o))
(help "Show this help"
(required #f)
(value #f)
(single-char #\h))
(macro-expand "Emit macro-expanded Sex code instead of C"
(required #f)
(value #f)
(single-char #\m))))
(define (print-help)
(fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
(fmt #t "Options:\n")
(fmt #t (usage opts-grammar))
(fmt #t ""))
(fmt #t "Usage: sexc [OPTIONS] [FILE]\n")
(fmt #t "Options: -o, --output <file> Write output to file. If omitted, write to stdout\n")
(fmt #t " -h, --help Show this help\n")
(fmt #t " -m, --macro-expand Emit macro-expanded Sex code instead of C\n"))
(define (help-arg? args)
(assoc 'help args))
@@ -66,101 +225,44 @@
(if arg (cdr arg)
default)))
(define (get-rest-args args)
(cdr (assoc '@ args)))
(define (get-c-compiler-args args)
(filter (fn (string-prefix? "-" x)) (get-rest-args args)))
(define (get-input-file args)
(let ((rest-args (get-rest-args args)))
(if (null? rest-args)
(let ((rest-args (assoc '@ args)))
(if (= 1 (length rest-args))
'stdin
(car rest-args))))
(cadr rest-args))))
(define (write-to-file-or-stdout output what)
(if (eq? output 'default)
(what)
(with-output-to-file output
(fn (what)))))
(define (read-from-file file)
(with-input-from-file (pathname-strip-directory file)
(fn (read-forms (list)))))
(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)))))
(define (compile-to-file sex-forms output args)
(let ((compiler (or (get-arg args 'c-compiler #f)
(get-env-var "SEX_CC")
"cc"))
(out-file (if (eq? output 'default)
"a.out"
output)))
(call-with-values
(lambda ()
(process compiler (append (list "-o" out-file "-x" "c")
(if (get-arg args 'compile-object #f)
(list "-c")
(list))
(list "-") ; read stdin
(get-c-compiler-args args))))
(lambda (out-port in-port pid)
(with-output-to-port in-port
(lambda () (emit-c sex-forms)))
(close-output-port in-port)
(process-wait pid)))))
(define (semantic-process-forms raw-forms input-source)
(if (eq? input-source 'stdin)
(semen-process raw-forms)
(with-directory input-source
(semen-process raw-forms))))
(define prelude
'((include inttypes.h)
(typedef u8 uint8-t)
(typedef i8 int8-t)
(typedef u16 uint16-t)
(typedef i16 int16-t)
(typedef u32 uint32-t)
(typedef i32 int32-t)
(typedef u64 uint64-t)
(typedef i64 int64-t)))
(define (set-working-directory file)
(change-directory
(normalize-pathname
(make-absolute-pathname
(current-directory)
(pathname-directory file)))))
(define (main)
(let* ((raw-args (command-line-arguments))
(current-dir (current-directory))
(args (getopt-long raw-args
opts-grammar))
(output (get-arg args 'output 'default))
(output (get-arg args 'output 'stdout))
(help (help-arg? args))
(input (get-input-file args))
(current-dir (current-directory)))
(call/cc
(lambda (return)
(when help
(print-help)
(return #f))
(when (get-arg args 'public-interface #f)
(assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
(write-to-file-or-stdout
output
(fn
(map pp (reverse
(read-public-interface input)))))
(return #f))
(load-persistent-module-paths)
(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)
(get-arg args 'emit-c #f))
;; Emit processed and macro-expanded sex code, or emit C code
(emit-c-or-sex sex-forms output args)
;; Compile file!
(compile-to-file sex-forms output args)))))))
(input (get-input-file args)))
(if help (print-help)
(let* ((raw-forms
(if (eq? input 'stdin)
(read-forms (list))
(begin
(set-working-directory input)
(read-from-file input))))
(sex-forms (process-raw-forms raw-forms (list))))
(change-directory current-dir)
(if (get-arg args 'macro-expand #f)
(map pp sex-forms)
(if (not (eq? output 'stdout))
(with-output-to-file output
(lambda ()
(emit-c sex-forms)))
(emit-c sex-forms)))))))

66
templates.scm Normal file
View File

@@ -0,0 +1,66 @@
(declare (unit templates))
(import
(chicken plist)
brev-separate
fmt
regex
srfi-1 ; list routines
tree)
(define (register-template name)
(put! name 'sex-template #t))
(define-syntax template
(syntax-rules ()
((template (name . args) . body)
(begin
(register-template 'name)
(define-syntax name
(syntax-rules ()
((name . applied-args)
(let* ((subst-alist (map cons 'args 'applied-args))
(replaced-body (apply-substitution `body subst-alist)))
replaced-body))))))))
(define (apply-symbol-substitution sym subst-alist)
;; All non-symbol substitutions will be filtered.
;; E.g. if the subst-alist is ((T + 1 2) (U . w) (W . e)),
;; only ((U . w) (W . e)) will be applied to symbols.
(let ((str (symbol->string sym))
(subst-map (map (fn
(if (symbol? (car x))
(cons
(fmt #f "([^\\-]?)"
(regexp-escape (symbol->string (car x)))
"([\\-$]?)")
(fmt #f "\\1" (symbol->string (cdr x)) "\\2"))
x))
(filter (fn (symbol? (cdr x))) subst-alist))))
(string->symbol
(string-substitute* str subst-map))))
(define (maybe-replace-symbol sym subst-alist)
(call/cc
(lambda (return)
(for-each (fn (when (eq? (car x) sym)
(return (cdr x))))
subst-alist)
(return sym))))
(define (apply-substitution target subst-alist)
;; Subsitute free symbols and -/$/^ separated parts
;; of symbols with provided forms.
;; E.g. with substitution (T int):
;; list-T -> list-int ; by apply-symbol-substitution
;; (var T data) -> (var int data) ; by maybe-replace-symbol
;; see respective functions for further details.
(tree-map
(fn
(if (symbol? x)
(let ((st (maybe-replace-symbol x subst-alist)))
(if (eq? st x)
(apply-symbol-substitution x subst-alist)
st))
x))
target))

View File

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

View File

@@ -1,33 +0,0 @@
(import fmt-c-writer)
(test-group "basic"
;; unkebabify
(test '- (unkebabify '-))
(test '-- (unkebabify '--))
(test '-> (unkebabify '->))
(test '-= (unkebabify '-=))
(test 'kebab_case (unkebabify 'kebab-case))
(test '_what_ (unkebabify '-what-))
(test 'this->member (unkebabify 'this->member))
(test '_this_->_member_ (unkebabify '-this-->-member-))
(test '__->>> (unkebabify '--->>>))
;; atom-to-fmt-c
(test '%fun (atom-to-fmt-c 'fn))
(test '%prototype (atom-to-fmt-c 'prototype))
(test '%block-begin (atom-to-fmt-c 'begin))
(test '%define (atom-to-fmt-c 'define))
(test '%pointer (atom-to-fmt-c 'pointer))
(test '%array (atom-to-fmt-c 'array))
(test 'vector-ref (atom-to-fmt-c '¤))
(test '%include (atom-to-fmt-c 'include))
;; c89 stuff
(test 'int (atom-to-fmt-c 'bool))
(test 1 (atom-to-fmt-c 'true))
(test 0 (atom-to-fmt-c 'false))
;; make-field-access
(test 'a.b (make-field-access '(.b a)))
(test 'a.b.c (make-field-access '(.c a.b))))

View File

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

View File

@@ -1,159 +0,0 @@
;;; Types
(test-group "fmt-writer"
(test
'(const int)
(walk-type '(const int)))
(test
'(%array (const char) 512)
(walk-type '(¤ const char 512)))
(test
'(%array (float) 512)
(walk-type '(¤ (float) 512)))
(test
'(%array (const char) 512)
(walk-type '(¤ (const char) 512)))
(test
'(%array (const char))
(walk-type '(¤ const char)))
(test
'(%array (const char))
(walk-type '(¤ (const char))))
(test
'(%array float 8)
(walk-type '(¤ float 8)))
(test
"Pointer to const char"
'(const char *)
(walk-type '(* const char)))
(test
"Const pointer to const char"
'(const char * const)
(walk-type '(const * const char)))
(test
'(%fun void ((int) (float) (%array (struct what * const))))
(walk-type '(fn ((int) (float) (¤ (const * struct what))) void)))
(test
'(%fun void ((int) (%array float) (%array (struct what * const))))
(walk-type '(fn ((int) (¤ float) (¤ (const * struct what))) void)))
(test
'(%array (%fun void ((int) (%array float) (%array (struct what * const)))))
(walk-type '(¤ (fn ((int) (¤ float) (¤ (const * struct what))) void))))
;; Type convert to C
(test
'(int)
(type-convert-to-c '(int)))
(test
'(* int)
(type-convert-to-c '(int *)))
(test
'(* const int)
(type-convert-to-c '(const int *)))
(test
'(const * const char)
(type-convert-to-c '(const char * const)))
;;; Variable defs
(test
'(%var (%array float 8) a)
(walk-var '(var a (¤ float 8))))
(test
'(%var (int *) a (& n))
(walk-var '(var a (* int) (& n))))
(test
'(%var (const int *) a (& n))
(walk-var '(var a (* const int) (& n))))
(test
'(%var (struct suc) s)
(walk-var '(var s (struct suc))))
(test
'(%var (const struct suc *) s s1)
(walk-var '(var s (* const struct suc) s1)))
(test
'(%var (const struct suc *) s s1)
(walk-var '(var s (* (const struct suc)) s1)))
(test
'(%var (struct suc) s (hoge piyo))
(walk-var '(var s (struct suc) (hoge piyo))))
(test
'(%var (struct suc *) s (hoge piyo))
(walk-var '(var s (* struct suc) (hoge piyo))))
;;; Fn defs
(test
'(%fun void puk ((int) (%array float 8)))
(walk-fn-def '(fn puk ((int) (¤ float 8)) void)))
(test
'(%fun int main ((int argc) ((%array (const char)) argv))
(return 0))
(walk-fn-def
'(fn main ((argc int) (argv (¤ const char))) int
(return 0))))
(test
'(%fun int quxu (((struct piq *) bar))
(return 0))
(walk-fn-def
'(fn quxu ((bar (* struct piq))) int
(return 0))))
(test
'(%fun int quxu (((struct piq *) bar) ((%array (struct tt *)) ploop))
(return 0))
(walk-fn-def
'(fn quxu ((bar (* struct piq)) (ploop (¤ * struct tt))) int
(return 0))))
;; Structs
(test
'(struct no_kebab ((int a) (float f)))
(walk-struct '(struct no-kebab ((a int) (f float)))))
(test
'(struct settings ((u32 x y w h)
((%array (struct ((float r g b a))) 4) colors)))
(walk-struct
'(struct settings
((x y w h u32)
(colors [¤ struct ((r g b a float)) 4])))))
(test
'(struct settings ((u32 x y w h)
((%array (struct color ((float r g b a))) 4) colors)))
(walk-struct
'(struct settings
((x y w h u32)
(colors [¤ struct color ((r g b a float)) 4])))))
(test
'(struct mega_kebab ((int a)
((struct ((int year) (int month) (int day))) dob)
((%fun int ((int) (%array int))) min)))
(walk-struct '(struct mega-kebab
((a int)
(dob (struct ((year int)
(month int)
(day int))))
(min (fn ((int) (¤ int)) bool)))))))

View File

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

View File

@@ -1,18 +0,0 @@
(import (chicken port)
reader)
(define-syntax reader-test
(syntax-rules ()
((reader-test result string)
(test result
(with-input-from-string string
(lambda () (read-raw-forms 'stdin)))))))
(test-group "reader"
;; []-syntax. For array types and array access expressions
(reader-test '((¤ * char)) "[* char]")
(reader-test '((¤ * * char const 512)) "[* * char const 512]")
(reader-test '((¤)) "[]")
(reader-test '((¤ (¤))) "[[]]")
(reader-test '((¤ (¤ const char))) "[[const char]]")
)

View File

@@ -1,11 +0,0 @@
(import
test)
(include "basic.scm")
(include "semen.scm")
(include "reader.scm")
(include "fmt-c-writer.scm")
(include "utils.scm")
;;; Should be the last in the test suite
(test-exit)

View File

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

View File

@@ -1,57 +0,0 @@
(import srfi-69
semen)
(define print-str-fn
'(fn void print-str ((string s))
(printf "%s" s)))
(define sum-fn
'(pub fn float sum ((int a) (int b))
(return (cast float (+ a b)))))
(test-group "semen"
(test-assert (sex-fn? print-str-fn))
(test #f (sex-fn-public? print-str-fn))
(test 'void (sex-fn-return-type print-str-fn))
(test 'print-str (sex-fn-name print-str-fn))
(test '((string s)) (sex-fn-arglist print-str-fn))
(test '(fn void print-str ((string s))) (sex-fn-prototype print-str-fn))
(test '((printf "%s" s)) (sex-fn-body print-str-fn))
(test-assert (sex-fn? sum-fn))
(test #t (sex-fn-public? sum-fn))
(test 'float (sex-fn-return-type sum-fn))
(test 'sum (sex-fn-name sum-fn))
(test '((int a) (int b)) (sex-fn-arglist sum-fn))
(test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn))
(test '((return (cast float (+ a b)))) (sex-fn-body sum-fn))
(let ((sex-code
'((defmacro (sum-var name a b c)
`(var ,name ,(+ a b c)))
(sum-var v 1 2 3))))
(test '((var v 6)) (semen-process sex-code)))
;;; Macro expansion
(define (form-identity form env)
form)
(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 (macro-expand 'a))
(test '(a b c) (macro-expand '(a b c)))
(let ((sex-code-macro
'((defmacro (x10 a)
`(* 10 ,a))
(fn void foo ((int a) (int b))
(return (+ a (x10 b)))))))
(test '((fn void foo ((int a) (int b))
(return (+ a (* 10 b)))))
(semen-process sex-code-macro))))

View File

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

View File

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

View File

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

View File

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

View File

@@ -1,24 +0,0 @@
(import utils)
(test-group "utils"
(test
'((1) (2) (3))
(list-split '(1 * 2 * 3) '*))
(test
'((1 2 3))
(list-split '(1 2 3) '*))
(test
'(() (1) (2) (3) ())
(list-split '(* 1 * 2 * 3 *) '*))
(test
'((const) (const struct something))
(list-split '(const * const struct something) '*))
(test
'(1 * 2 * 3)
(list-join '(1 2 3) '*))
)

View File

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

View File

@@ -1,66 +0,0 @@
(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))
(define (set-working-directory file)
(change-directory
(normalize-pathname
(if (absolute-pathname? file)
(pathname-directory file)
(make-absolute-pathname
(current-directory)
(pathname-directory file))))))
(define (to-absolute-pathname pathname)
(if (absolute-pathname? pathname)
pathname
(make-absolute-pathname
(current-directory)
pathname)))
(define (list-split src-list split-elt)
;; split '(1 2 / 3 4 / 5 6) by '/ -> '((1 2) (3 4) (5 6))
(fold (lambda (elt acc)
(if (eq? elt split-elt)
(append acc (list (list)))
(append (drop-right acc 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
(define (recons old-cons new-car new-cdr)
(if (and (eq? new-car (car old-cons))
(eq? new-cdr (cdr old-cons)))
old-cons
(cons new-car new-cdr)))