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

Compare commits

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

10 Commits
type-infer ... initial-la

Author SHA1 Message Date
alex-eg
18b9e20fee add support for nested lambdas 2025-10-01 12:37:59 +03:00
alex-eg
e888ed1281 add initial lambda support 
No closures for now, but solid groundwork is laid.
 2025-09-26 16:53:38 +03:00
alex-eg
21293c421f enable prefix form for keywords 
I like writing :keyword more than #:keyword. That hash sign seems
redundant
 2025-09-26 16:52:34 +03:00
alex-eg
d5bbe853aa don't force c89 after all 2025-09-26 14:51:44 +03:00
alex-eg
a7cd720057 update Readme.org 2025-09-26 14:51:44 +03:00
alex-eg
b314dfd58e re-implement macro-expansion using new semantic walker 2025-09-26 14:33:47 +03:00
alex-eg
d0005a6622 implement semantic code walking framework 2025-09-26 14:33:23 +03:00
alex-eg
13984ccc78 add binaries to .gitignore 2025-09-26 11:53:10 +03:00
alex-eg
d8d6f4f5a4 add .gitignore 2025-09-24 20:14:21 +03:00
alex-eg
42d58d3359 split semantic processing and fmt-c code generation 
Introducing Sex SEMantic ENgine: the semen.
Also split reader to other file (it can be replaced in the future).
Macro expansion inside Sex code doesn't work yet, and it must be done
in semen, not during fmt-c generation as before.
 2025-09-24 20:12:08 +03:00
90 changed files with 1405 additions and 8877 deletions
Expand all files Collapse all files

67
.gitea/workflows/build.yaml
View File

@@ -1,67 +0,0 @@
name: Sex CI
on:
push:
branches: [main]
pull_request:
branches: [main]
workflow_dispatch:
jobs:
build-linux:
runs-on: ubuntu-latest
steps:
- name: Fetch repository
env:
GITEA_TOKEN: ${{ secrets.GITEA_TOKEN }}
run: |
set -eu
git config --global --add safe.directory "$PWD"
git init
git remote add origin "${GITHUB_SERVER_URL%/}/${GITHUB_REPOSITORY}.git"
git -c http.extraHeader="Authorization: token ${GITEA_TOKEN}" \
fetch --depth 1 origin "${GITHUB_SHA}"
git checkout --force FETCH_HEAD
- name: Install toolchain
run: |
set -eu
if [ "$(id -u)" -eq 0 ]; then
apt-get update
apt-get install -y --no-install-recommends build-essential git wget ca-certificates
else
sudo apt-get update
sudo apt-get install -y --no-install-recommends build-essential git wget ca-certificates
fi
- name: Install Chicken
env:
CHICKEN_VERSION: "6.0.0"
CHICKEN_SHA256: 92835552b1b687ad26737e429b5aba36510bf429f8816ec0f6d336c8cb41f443
run: |
set -eu
tarball="chicken-${CHICKEN_VERSION}.tar.gz"
wget -N "https://code.call-cc.org/releases/${CHICKEN_VERSION}/${tarball}"
echo "${CHICKEN_SHA256} ${tarball}" | sha256sum -c
tar zxf "${tarball}"
(
cd "chicken-${CHICKEN_VERSION}"
./configure --prefix=/usr/local
make -j"$(nproc)"
if [ "$(id -u)" -eq 0 ]; then
make install
else
sudo make install
fi
)
hash -r
csc -version
- name: Install dependencies
run: make deps
- name: Build sexc
run: make && ./sexc --help
- name: Run tests
run: make check

11
.gitignore vendored
View File

@@ -1,14 +1,3 @@
# Project-local Chicken egg repository
/.eggs
# Compilation artifacts
*.o
*.import.scm
*.link
sexc
sex-tests
sextest
tools/sextest/sextest
# Scrapped design docs, kept for reference
/attic

180
Makefile
View File

@@ -1,175 +1,21 @@
CHICKEN_C ?= csc
CHICKEN_INSTALL ?= chicken-install
CHICKEN_STATUS ?= chicken-status
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.
CHICKEN_C = csc
CSC_FLAGS = -K prefix
# GNU directory variables. Command line overrides, e.g.
# make prefix=$(HOME)/.local install
# make DESTDIR=/tmp/stage prefix=/usr install
prefix = /usr/local
exec_prefix = $(prefix)
bindir = $(exec_prefix)/bin
INSTALL = install
INSTALL_PROGRAM = $(INSTALL)
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
# Order matters, since module check correctness on compilation
MODULES = utils types infer sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
MODULES = sexc fmt-c fmt-c-writer semen sex-macros sex-modules sex-reader utils
OBJ = $(MODULES:%=%.o)
DEPSFILE = dependencies.txt
DEPSLOCK = eggs.lock
EGGS_DIR := $(abspath .eggs)
sexc: main.o $(OBJ)
$(CHICKEN_C) $(CSC_FLAGS) $^ -o $@
# Compiler's own repository (types.db, chicken.*), ignoring ambient venv vars.
SYSTEM_CHICKEN_REPO := $(shell env \
-u CHICKEN_INSTALL_REPOSITORY -u CHICKEN_REPOSITORY_PATH \
-u CHICKEN_EGG_CACHE -u CHICKEN_INSTALL_PREFIX \
$(CHICKEN_INSTALL) -repository 2>/dev/null)
CHICKEN_ABI := $(notdir $(SYSTEM_CHICKEN_REPO))
EGGS_STAMP := $(EGGS_DIR)/.installed-$(CHICKEN_ABI)
main.o: main.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -c -o $@
# Try project-local chicken repository first. In case it doesn't exist (packaging for distros),
# system-wide repository will be used.
unexport CHICKEN_INSTALL_REPOSITORY
unexport CHICKEN_EGG_CACHE
unexport CHICKEN_INSTALL_PREFIX
export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
%.o: %.scm
$(CHICKEN_C) $(CSC_FLAGS) $< -e -c -o $@
all: sexc
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
#------------------------------------------------------------------
utils.o: utils.module.scm utils.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
types.o: types.module.scm types.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
infer.o: infer.module.scm infer.scm types.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) infer.module.scm -o infer.o -unit infer -link types,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 utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
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 infer.o sex-macros.o sex-modules.o types.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,infer,types,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 types.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,types,utils
sexc.o: sexc.module.scm infer.o types.o 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,infer,types,utils
# Unit testing
sex-tests:
$(MAKE) -C ./tests sex-tests
cp ./tests/sex-tests ./
sextest:
$(MAKE) -C ./tools/sextest sextest
cp ./tools/sextest/sextest .
SEX_TEST_PROGRAMS = c99 \
closure-signatures \
closures \
comments \
compound-literals \
feature-flags \
features \
fixpoint \
hello-world \
inference \
lambdas \
lists \
operators \
serialize \
type-shapes \
unicode \
unnamed-params \
wildcards
# Multi-module linking is checked end to end; see tests/modules/Makefile.
check-modules: sexc
@$(MAKE) --no-print-directory -C ./tests/modules check SEXC=../../sexc
# The failure paths are checked end to end; see tests/exit-code/Makefile.
check-exit-code: sexc
@$(MAKE) --no-print-directory -C ./tests/exit-code check SEXC=../../sexc
check run-tests: sexc sex-tests sextest
./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules && $(MAKE) check-exit-code
install: all installdirs
$(INSTALL_PROGRAM) sexc $(DESTDIR)$(bindir)/sexc
install-strip:
$(MAKE) INSTALL_PROGRAM='$(INSTALL_PROGRAM) -s' install
installdirs:
$(INSTALL) -d $(DESTDIR)$(bindir)
uninstall:
rm -f $(DESTDIR)$(bindir)/sexc
$(EGGS_STAMP) deps-update: export CHICKEN_EGG_CACHE := $(EGGS_DIR)/cache
$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_REPOSITORY := $(EGGS_DIR)
$(EGGS_STAMP) deps-update: export CHICKEN_INSTALL_PREFIX := $(EGGS_DIR)
$(EGGS_STAMP) deps-update: export CHICKEN_REPOSITORY_PATH := $(EGGS_DIR):$(SYSTEM_CHICKEN_REPO)
$(EGGS_STAMP): $(DEPSLOCK)
mkdir -p $(CHICKEN_EGG_CACHE)
$(CHICKEN_INSTALL) -force -from-list $(DEPSLOCK)
touch $@
deps: $(EGGS_STAMP)
deps-update: $(DEPSFILE) deps-clean
mkdir -p $(CHICKEN_EGG_CACHE)
$(CHICKEN_INSTALL) -force $$(cat $(DEPSFILE))
# Local repo only: a system path here would leak distro eggs into the lock.
CHICKEN_REPOSITORY_PATH=$(EGGS_DIR) $(CHICKEN_STATUS) -list | sort > $(DEPSLOCK).tmp
mv $(DEPSLOCK).tmp $(DEPSLOCK)
touch $(EGGS_STAMP)
sex-tests: $(OBJ) tests/*.scm
cd ./tests && $(CHICKEN_C) $(CSC_FLAGS) run.scm -c -o sex-tests.o
$(CHICKEN_C) $(CSC_FLAGS) $(OBJ) ./tests/sex-tests.o -o sex-tests
clean:
rm -f $(OBJ) main.o
rm -f *.import.scm
rm -f *.link
rm -f sexc sex-tests sextest
$(MAKE) -C ./tests clean
$(MAKE) -C ./tests/modules clean
$(MAKE) -C ./tools/sextest clean
deps-clean:
rm -rf $(EGGS_DIR)
.PHONY: all check run-tests check-modules check-exit-code \
install install-strip installdirs uninstall \
deps deps-update deps-clean clean sex-tests sextest
rm -f $(OBJ) sexc sex-tests main.o ./tests/sex-tests.o

190
Readme.org
View File

@@ -1,60 +1,22 @@
* The Sex language
#+NAME: the Sex logo
#+ATTR_HTML: :width 300px
[[sex.png][file:./sex.png]]
Sex is a S-expressions language. Sex is written in Chicken, which is an
[[https://call-cc.org][R7RS Scheme]].
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.
* Compilation
First, get yourself a Chicken, then, some Chicken deps. You also will
need a C compiler.
** Development
#+begin_src sh
make deps
make
#+end_src
** 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:
https://wiki.call-cc.org/man/5/Extension%20tools#changing-the-repository-location
~make deps~ installs pinned eggs from ~eggs.lock~ into a project-local
~.eggs/~ repository. ~dependencies.txt~ is the unpinned request list.
To refresh ~eggs.lock~ after changing it:
~chicken-install fmt getopt-long brev-separate test tree srfi-1 srfi-13 srfi-69 matchable~
#+begin_src sh
make deps-update
#+end_src
** Packaging for system package managers
- Depend ~sex~ package on Chicken-6 (with ~libchicken.a~) and all eggs from ~dependencies.txt~.
- Compile and install with ~make~ (usually no other arguments required).
- Move resulting ~sexc~ binary to the appropriate place.
** Static compilation
The default ~CSC_FLAGS~ include ~-static~, so ~sexc~ does not need
~.eggs~ at runtime and ~make install~ stays relocatable. Chicken must
provide ~libchicken.a~ (E.g. for gentoo: ~dev-scheme/chicken~ with
~static-libs~ use flag).
To link dynamically instead (the binary will look for eggs under this
tree's ~.eggs~ path):
#+begin_src sh
make CSC_FLAGS='-K prefix'
#+end_src
** Installation
GNU directory variables: ~prefix~, ~exec_prefix~, ~bindir~, ~DESTDIR~.
#+begin_src sh
# default installation (/usr/local/bin/)
make install
# customize the prefix (installs to ~/.local/bin)
make prefix=$(HOME)/.local install
# staged install for packaging
make DESTDIR=/tmp/stage prefix=/usr install
#+end_src
** Compilation
~make~
* Usage
** Summary
@@ -64,21 +26,13 @@ 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
-f, --features=ARG Comma-separated feature names, added to the host's own
for #+ and #- feature expressions. May be given
more than once
--no-platform-features Leave out the host's own features. With --features,
this reads a file the way another platform would
-C, --emit-c Emit C code
-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
--line-directives=ARG How much #line information to emit: statement (default),
toplevel, or none. `statement' is what makes a debugger
land on the right source line; `none' is for reading -C
output by eye
#+end_src
** Compiling Hello World
#+begin_src shell
@@ -90,24 +44,18 @@ 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.
Everything after ~--~ is handed to the C compiler exactly as written:
#+begin_src shell
sexc example/sdl3-triangle.sex -o triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL
#+end_src
** Example
An example of Sex source:
#+begin_src scheme
(include stdio.h)
(pub fn main ((argc int) (argv [* const char])) int
(pub fn int main ((int argc) (char **argv))
(puts "Hello from Sex!")
(var name [char 512])
(var (array char 512) name)
(puts "What is your name?")
(scanf "%s" (cast (& name) (* char)))
(scanf "%s" (cast char* &name))
(printf "Hello, %s!\n" name)
(return 0))
0)
#+end_src
Compile and run:
@@ -142,135 +90,51 @@ Module's public interface consists of everything declared
~pub~. Structures, function, macros, types, variables can be
public.
** Read-time feature expressions
Sex is able to use ~#+~ and ~#-~ for conditional compilation: the form that
follows is kept only when the feature expression is true, and otherwise
is read and thrown away.
#+begin_src scheme
#+macosx (include OpenGL/gl3.h)
#-macosx (include GL/gl.h)
#+(and unix (not macosx)) (define HAVE-EPOLL 1)
#+end_src
An expression is a feature name, or ~and~, ~or~ and ~not~ of them.
This is read time, not compile time. What does not apply never reaches macro
expansion, the type database or the generated C.
The features are the host's ~(software-version)~, ~(software-type)~
and ~(machine-type)~, e.g. ~macosx unix arm64~ or ~linux unix
x86-64~. ~--features~ adds to them:
#+begin_src shell
sexc prog.sex -f debug,with-sdl
sexc prog.sex --features=debug --features=with-sdl
#+end_src
A feature is never taken away. The host's features can be disabled,
e.g. for checking output for other platform:
#+begin_src shell
sexc example/sdl3-triangle.sex -C --no-platform-features --features=linux,unix,x86-64
#+end_src
** Aggregate initializers and compound literals
~#(...)~ is a brace initializer. On its own it has no type and takes one
from where it is written:
#+begin_src scheme
(var p (struct point) #(1 2))
#+end_src
A ~:~ inside one ends a type and makes the whole thing a compound
literal --- an unnamed object of that type, usable anywhere an
expression is:
#+begin_src scheme
(var q (struct point) #(struct point : 3 4))
(var a (* int) #([int 3] : 10 20 30))
(draw-line ui #(struct point : 0 0) end)
(var p (* struct point) (& #(struct point : 9 9))) ; an lvalue, so `&' works
#+end_src
The type is written as bare words, the way it is everywhere else in the
language; ~:~ is what ends it.
A leading ~.~ names a field, so initializers may be designated, given in
any order, and mixed with positional ones:
#+begin_src scheme
(var r (struct named) #(struct named : .n 7 .first-name "zoe"))
#+end_src
A compound literal written inside a block lives until the end of that
block and no longer, so returning its address is a dangling pointer.
** 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.
A macro returns *one* form. To return several --- a function beside the
struct it works on, say --- return them under =$=, which splices them in
where the macro was written:
#+begin_src scheme
(defmacro (pair-of-fns a b)
`($ (fn ,a () int (return 1))
(fn ,b () int (return 2))))
#+end_src
=($)= expands to nothing. Everything else is a single form, including
one whose head is itself a form: =`((make-adder 10) 5)= calls what
=make-adder= returned, and is not two forms.
*** 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))))))
((,type value)
((* ,list-type) next)))))
(list-T int)
#+end_src
->
#+begin_src scheme
(struct list_int
((value int)
(next (* list_int))))
((int value)
((* list_int) next)))
#+end_src
**** Wrapper for checking return codes
#+begin_src scheme
(pub defmacro (check-sdl-return call message ret-code)
`(if (< 0 ,call)
(do
(begin
(puts ,message)
(return ,ret-code))))
(return ,ret-code)))))
(pub fn init () int
(pub 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
#+begin_src c
(%fun int init ()
(if (< 0 (SDL_Init SDL_INIT_VIDEO))
(do (puts "Failed to initialize SDL") (return 1)))
(%begin (puts "Failed to initialize SDL") (return 1)))
...)
}
#+end_src
** Compile-time type information
Sex has a number of type reflection features, aiming to help with
macro writing. During the compilation, all type info is collected, and
is accessible during macro expansion. This allows us to write things
like providing auto serialization, adding meta information, and so on.
** Use an established environment for development
As Sex is S-expressions, you always have Emacs with paredit as your
best option.

1
dependencies.txt
View File

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

8
eggs.lock
View File

@@ -1,8 +0,0 @@
(brev-separate "1.100")
(fmt "0.8.14")
(getopt-long "4.0")
(matchable "1.2")
(srfi-1 "0.5.1")
(srfi-13 "0.3.8")
(srfi-69 "0.5.3")
(test "1.3")

8
example/fns.sex
View File

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

6
example/hello-world.sex
View File

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

38
example/lambdas.sex
View File

@@ -1,27 +1,21 @@
(include stdio.h)
(fn sum ((a int) (b int)) int
(fn int sum ((int a) (int b))
(return (+ a b)))
;;; A lambda captures nothing and is a bare function pointer; a closure
;;; captures and is a value carrying its own environment
(fn make-adder ((a int)) (closure ((int)) int)
(return (closure ((b int)) int (a)
(return (+ a b)))))
(pub fn int main ()
(var int a 10)
(var int b 20)
(var (fn int ((int) (int))) sum-fn sum)
(pub fn main () int
(var a int 10)
(var b int 20)
(var sum-fn (fn ((int) (int)) int) sum)
(var (fn int ((int) (int))) sum-lambda
(var sum-lambda (fn ((int) (int)) int)
(lambda ((a int) (b int)) int
(lambda int ((int a) (int b)) ()
(return (+ a b))))
(var sum-lambda-2 (fn ((int)) int)
(var (fn int ((int))) sum-lambda-2
(lambda ((a int)) int
(lambda int ((int a)) ()
(return (+ a 20))))
(printf "Hello from main fn!\n")
@@ -30,19 +24,15 @@
(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
(printf "Calling lambda inplace: %d\n" ((lambda int ((int a) (int b)) ()
(return (+ a b 100)))
a b))
(var l-1 (fn ((int)) int)
(lambda ((a int)) int
(var l-2 (fn ((int)) int)
(lambda ((a int)) int
(var (fn int ((int))) l-1
(lambda int ((int a)) ()
(var (fn int ((int))) l-2
(lambda int ((int a)) ()
(return (+ 60 a))))
(return (+ 600 (l-2 a)))))
(printf "Calling nested lambdas: %d\n" (l-1 6))
(var add-10 (closure ((int)) int) (make-adder 10))
(var add-20 (closure ((int)) int) (make-adder 20))
(printf "Calling closures: %d %d\n" (add-10 24) (add-20 24))
(return 0))

25
example/list.sex
View File

@@ -1,21 +1,21 @@
(pub defmacro (list-T type)
(let ((list-type (cat 'list- type)))
`(struct ,list-type
((value ,type)
(next (* struct ,list-type))))))
((,type value)
((* (struct ,list-type)) next)))))
(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)))
`(,@(if is-public? '(pub) '()) fn (* ,list-type) ,fn-name ()
(var (* ,list-type) list (cast (* ,list-type) (malloc (sizeof ,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
`(,@(if is-public? '(pub) '()) fn void ,fn-name ((,list-type *list) (,type value))
(while (!= (-> list next) NULL)
(= list (-> list next)))
(= (-> list next) (,(cat 'make-list- type)))
@@ -24,24 +24,23 @@
(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)
`(,@(if is-public? '(pub) '()) fn size-t ,fn-name ((,list-type *list))
(var size-t n 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
`(,@(if is-public? '(pub) '()) fn bool ,(cat 'is-empty-list- type)
((,(list 'struct (cat 'list- type)) *list))
(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)))
`(do
(var ,list-var-2 (* ,list-type) ,list-var)
(var ,elt-var ,elt-type (-> ,list-var-2 value))
`(begin
(var (pointer ,list-type) ,list-var-2 ,list-var)
(var ,elt-type ,elt-var (-> ,list-var-2 value))
(while (!= (-> ,list-var-2 next) NULL)
,what-do
(= ,list-var-2 (-> ,list-var-2 next))

262
example/sdl3-triangle.sex
View File

@@ -1,262 +0,0 @@
;;; A triangle that follows the mouse pointer, spins while the left
;;; mouse button is held down, and quits on Escape (or on closing the
;;; window).
;;;
;;; SDL3 supplies the window, the GL context and the events. Everything
;;; drawn goes through an OpenGL 3.3 core-profile pipeline: a vertex and
;;; fragment shader, and one VAO/VBO holding a unit triangle. Where the
;;; triangle is and how far it has spun are passed in as uniforms, so
;;; the geometry itself is uploaded once and never touched again.
;;;
;;; Build, macOS:
;;; ./sexc example/sdl3-triangle.sex -o sdl3-triangle -- `pkg-config --cflags --libs sdl3` -framework OpenGL
;;;
;;; Build, Linux:
;;; ./sexc example/sdl3-triangle.sex -o sdl3-triangle -- `pkg-config --cflags --libs sdl3 gl`
;;;
;;; The GL header is the one platform difference, and #+ / #- picks it.
;;; Apple keeps the core-profile entry points in <OpenGL/gl3.h> and
;;; links them through -framework OpenGL, which no pkg-config file
;;; describes; everywhere else the prototypes come from <GL/glext.h>
;;; with GL_GLEXT_PROTOTYPES defined, and -lGL -- `pkg-config --libs
;;; gl' -- resolves them. SDL3/SDL_opengl.h is not the shortcut it
;;; looks like: on Apple it resolves to the 2.1 header, which has no
;;; glGenVertexArrays and so cannot bind the VAO this program needs.
#+macosx (define GL-SILENCE-DEPRECATION 1) ; OpenGL is deprecated on macOS
(include SDL3/SDL.h)
#+macosx (include OpenGL/gl3.h)
#-macosx (define GL-GLEXT-PROTOTYPES 1)
#-macosx (include GL/gl.h)
#-macosx (include GL/glext.h)
(define WINDOW-WIDTH 800)
(define WINDOW-HEIGHT 600)
(define TRIANGLE-RADIUS 70.0) ; in window units
(define SPIN-SPEED 3.0) ; radians per second
;;; The vertex shader does the whole transform: spin the unit triangle
;;; by u_angle, scale it to u_radius, move it to u_center, then convert
;;; from window coordinates to clip space. That way a frame only has to
;;; push four uniforms rather than rebuild any geometry.
(var vertex-shader-src (* const char) "
#version 330 core
layout (location = 0) in vec2 a_pos;
layout (location = 1) in vec3 a_color;
uniform vec2 u_center; // triangle centre, in window units
uniform vec2 u_viewport; // window size, same units as u_center
uniform float u_angle; // current spin, in radians
uniform float u_radius; // triangle size, in window units
out vec3 v_color;
void main()
{
float s = sin(u_angle);
float c = cos(u_angle);
vec2 spun = vec2(a_pos.x * c - a_pos.y * s,
a_pos.x * s + a_pos.y * c);
vec2 p = spun * u_radius + u_center;
// Window coordinates have their origin top-left with y growing
// downwards; clip space is centred with y growing upwards.
gl_Position = vec4(p.x / u_viewport.x * 2.0 - 1.0,
1.0 - p.y / u_viewport.y * 2.0,
0.0,
1.0);
v_color = a_color;
}
")
(var fragment-shader-src (* const char) "
#version 330 core
in vec3 v_color;
out vec4 frag_color;
void main()
{
frag_color = vec4(v_color, 1.0);
}
")
(fn compile-shader ((kind GLenum) (src (* const char))) GLuint
(var shader GLuint (glCreateShader kind))
(glShaderSource shader 1 (& src) NULL)
(glCompileShader shader)
(var ok GLint 0)
(glGetShaderiv shader GL-COMPILE-STATUS (& ok))
(if (== ok 0)
(do
(var info [char 1024])
(glGetShaderInfoLog shader 1024 NULL info)
(SDL-Log "shader compilation failed: %s" info)
(glDeleteShader shader)
(return 0)))
(return shader))
(fn make-program () GLuint
(var vertex-shader GLuint (compile-shader GL-VERTEX-SHADER vertex-shader-src))
(var fragment-shader GLuint (compile-shader GL-FRAGMENT-SHADER fragment-shader-src))
(if (c-or (== vertex-shader 0) (== fragment-shader 0))
(do
(glDeleteShader vertex-shader)
(glDeleteShader fragment-shader)
(return 0)))
(var program GLuint (glCreateProgram))
(glAttachShader program vertex-shader)
(glAttachShader program fragment-shader)
(glLinkProgram program)
;; The shaders are only needed until the program is linked; the
;; program holds its own reference until then.
(glDeleteShader vertex-shader)
(glDeleteShader fragment-shader)
(var ok GLint 0)
(glGetProgramiv program GL-LINK-STATUS (& ok))
(if (== ok 0)
(do
(var info [char 1024])
(glGetProgramInfoLog program 1024 NULL info)
(SDL-Log "program linking failed: %s" info)
(glDeleteProgram program)
(return 0)))
(return program))
(pub fn main () int
(if (! (SDL-Init SDL-INIT-VIDEO))
(do
(SDL-Log "SDL_Init failed: %s" (SDL-GetError))
(return 1)))
;; Ask for core profile 3.3 before the window exists: these attributes
;; are read when the context is created.
(SDL-GL-SetAttribute SDL-GL-CONTEXT-MAJOR-VERSION 3)
(SDL-GL-SetAttribute SDL-GL-CONTEXT-MINOR-VERSION 3)
(SDL-GL-SetAttribute SDL-GL-CONTEXT-PROFILE-MASK SDL-GL-CONTEXT-PROFILE-CORE)
(SDL-GL-SetAttribute SDL-GL-DOUBLEBUFFER 1)
(var window (* SDL-Window)
(SDL-CreateWindow "Sex + SDL3 + OpenGL"
WINDOW-WIDTH WINDOW-HEIGHT
SDL-WINDOW-OPENGL))
(if (== window NULL)
(do
(SDL-Log "SDL_CreateWindow failed: %s" (SDL-GetError))
(SDL-Quit)
(return 1)))
(var gl-context SDL-GLContext (SDL-GL-CreateContext window))
(if (== gl-context NULL)
(do
(SDL-Log "SDL_GL_CreateContext failed: %s" (SDL-GetError))
(SDL-DestroyWindow window)
(SDL-Quit)
(return 1)))
(SDL-GL-MakeCurrent window gl-context)
(SDL-GL-SetSwapInterval 1)
(var program GLuint (make-program))
(if (== program 0)
(do
(SDL-GL-DestroyContext gl-context)
(SDL-DestroyWindow window)
(SDL-Quit)
(return 1)))
;; A unit triangle, two position components then three colour
;; components per vertex. The vertices sit on the unit circle at 90,
;; 210 and 330 degrees; the shader spins, scales and moves it.
(var verts [GLfloat 15]
#( 0.000 1.000 1.00 0.35 0.35
-0.866 -0.500 0.35 1.00 0.45
0.866 -0.500 0.40 0.50 1.00))
(var vao GLuint 0)
(var vbo GLuint 0)
(glGenVertexArrays 1 (& vao))
(glBindVertexArray vao)
(glGenBuffers 1 (& vbo))
(glBindBuffer GL-ARRAY-BUFFER vbo)
(glBufferData GL-ARRAY-BUFFER (sizeof verts) verts GL-STATIC-DRAW)
(var stride GLsizei (cast (* 5 (sizeof GLfloat)) GLsizei))
(glVertexAttribPointer 0 2 GL-FLOAT GL-FALSE stride (cast 0 (* void)))
(glEnableVertexAttribArray 0)
(glVertexAttribPointer 1 3 GL-FLOAT GL-FALSE stride
(cast (* 2 (sizeof GLfloat)) (* void)))
(glEnableVertexAttribArray 1)
(var u-center GLint (glGetUniformLocation program "u_center"))
(var u-viewport GLint (glGetUniformLocation program "u_viewport"))
(var u-angle GLint (glGetUniformLocation program "u_angle"))
(var u-radius GLint (glGetUniformLocation program "u_radius"))
(var running bool true)
(var angle float 0.0)
(var last-ticks Uint64 (SDL-GetTicks))
(var event SDL-Event)
(while running
(while (SDL-PollEvent (& event))
(switch (. event type)
(case SDL-EVENT-QUIT
(= running false))
(case SDL-EVENT-KEY-DOWN
(if (== (. event key key) SDLK-ESCAPE)
(= running false)))))
;; Seconds since the previous frame, so the spin rate does not
;; depend on how fast we happen to be rendering.
(var now Uint64 (SDL-GetTicks))
(var dt float (/ (cast (- now last-ticks) float) 1000.0))
(= last-ticks now)
(var mouse-x float 0.0)
(var mouse-y float 0.0)
(var buttons SDL-MouseButtonFlags (SDL-GetMouseState (& mouse-x) (& mouse-y)))
(if (!= 0 (& buttons SDL-BUTTON-LMASK))
(= angle (+ angle (* SPIN-SPEED dt))))
;; The viewport is in pixels, which is not the same as window units
;; on a HiDPI display; the mouse position is in window units, so the
;; shader needs that size rather than the pixel one.
(var pixel-width int 0)
(var pixel-height int 0)
(SDL-GetWindowSizeInPixels window (& pixel-width) (& pixel-height))
(glViewport 0 0 pixel-width pixel-height)
(var window-width int 0)
(var window-height int 0)
(SDL-GetWindowSize window (& window-width) (& window-height))
(glClearColor 0.06 0.06 0.09 1.0)
(glClear GL-COLOR-BUFFER-BIT)
(glUseProgram program)
(glUniform2f u-center mouse-x mouse-y)
(glUniform2f u-viewport (cast window-width float) (cast window-height float))
(glUniform1f u-angle angle)
(glUniform1f u-radius TRIANGLE-RADIUS)
(glBindVertexArray vao)
(glDrawArrays GL-TRIANGLES 0 3)
(SDL-GL-SwapWindow window))
(glDeleteVertexArrays 1 (& vao))
(glDeleteBuffers 1 (& vbo))
(glDeleteProgram program)
(SDL-GL-DestroyContext gl-context)
(SDL-DestroyWindow window)
(SDL-Quit)
(return 0))

64
example/serialize.sex
View File

@@ -1,64 +0,0 @@
;;; Generating code from a type's own definition.
;;;
;;; `serialize-struct' is handed nothing but a struct's name. It asks
;;; the compiler's type database what fields that struct has and what
;;; type each one is, and writes a printer to match. Add a field to the
;;; struct and the printer grows with it, with no other edit.
;;;
;;; The database is filled in as toplevel forms are processed, in order,
;;; so a struct has to be declared before the macro call that asks about
;;; it -- the same rule C has.
(include stdio.h)
(defmacro (serialize-struct type-name)
;; map-fields walks the declaration; type-match picks a printf
;; conversion per field. Both come from the compiler's type database,
;; so the macro never takes a type apart itself.
(let ((printers
(map-fields type-name
(lambda (name type)
`(fprintf out
,(string-append
" " (symbol->string name) "="
(type-match type
(int "%d")
(char "%c")
(long "%ld")
(unsigned "%u")
(float "%g")
(double "%g")
((* const char) "%s")
((* char) "%s")
(else (error "serialize-struct: unsupported field type"
type-name name type))))
(-> v ,name))))))
(if (not printers)
(error "serialize-struct: no such struct" type-name)
`(pub fn ,(cat 'serialize- type-name)
((v (* const struct ,type-name)) (out (* FILE)))
void
(fprintf out ,(string-append (symbol->string type-name) " {"))
,@printers
(fprintf out " }\n")))))
(struct point ((x int) (y int)))
(struct person
((name (* const char))
(age int)
(height float)))
;;; Two printers, written by the compiler from the declarations above.
(serialize-struct point)
(serialize-struct person)
(pub fn main () int
(var origin (struct point) #(0 0))
(var corner (struct point) #(640 -480))
(var alex (struct person) #("Alex" 34 1.82))
(serialize-point (& origin) stdout)
(serialize-point (& corner) stdout)
(serialize-person (& alex) stdout)
(return 0))

29
example/test-list.sex
View File

@@ -5,12 +5,12 @@
(import list)
(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 (struct foo) f)
(list-T int)
(make-list-T int #f)
@@ -18,16 +18,15 @@
(length-list-T int #f)
(is-empty-list-T int #f)
(extern fn puk ((a int) (b float)) void)
(pub fn baz () bool
(return true))
(extern fn void puk ((int a) (float b)))
(pub fn bool baz () (return 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))
(pub fn int main ()
(var (struct list-int) *l (make-list-int))
(printf "Size of the list: %lu\n" (length-list-int l))
(add-value-list-int l 3)
(add-value-list-int l 4)
@@ -36,9 +35,9 @@
(printf "%d " v))
(printf "\n")
(printf "Size of the list: %lu\n" (length-list-int l))
(printf "%p\n" (cast l->next (* void)))
(printf "%p\n" (cast void* l->next))
(return 0))
(pub fn print-list ((l (* const struct list-int))) void
(pub fn void print-list (((const struct list-int) *l))
(list-for-each (const struct list-int) l int v (printf "%d " v))
(printf "\n"))

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

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

536
fmt-c-writer.scm
View File

@@ -1,98 +1,16 @@
;;; Sex fmt-c output writer
(import
scheme
(scheme base) ; make-parameter
(chicken base)
(chicken string)
(chicken syntax)
brev-separate ; fn, flatten
fmt
sex-fmt-c
matchable
(chicken irregex) ; unkebabify
srfi-1 ; lists
srfi-13 ; strings
types ; array-bound?, named-arg?
utils)
(declare (unit fmt-c-writer)
(uses fmt-c
semen))
;;; egg `tree' not ported to CHICKEN 6 yet
(define (tree-map f tree)
(cond ((null? tree) (list))
((pair? tree) (cons (tree-map f (car tree))
(tree-map f (cdr tree))))
(else (f tree))))
;;; How much #line information to emit:
;;;
;;; statement -- before every statement.
;;; toplevel -- one directive per toplevel form.
;;; none -- none at all, for reading -C output by eye.
(define sex-line-directives (make-parameter 'statement))
(define (anchor-statements?)
(eq? (sex-line-directives) 'statement))
(define (line-directive src)
;; `%line' is fmt-c's #line directive. cpp-line concatenates its
;; second argument verbatim, so the file name arrives already quoted.
`(%line ,(cdr src) ,(fmt #f #\" (car src) #\")))
(define (walk-body stmts)
"Walk a statement list, re-anchoring each statement that has a known
source location. Only statement positions may be walked this way: a
#line inside an expression is a C syntax error."
(if (anchor-statements?)
(append-map (lambda (s)
(let ((src (form-source s)))
(if src
(list (line-directive src) (walk-expr s))
(list (walk-expr s)))))
(pack-comments stmts))
(map walk-expr (pack-comments stmts))))
(define (walk-stmt s)
"A statement in a slot that holds exactly one form -- an `if' arm.
Splicing is not possible there, since c-if reads anything past the arm
as an `else if' chain, so the anchor and the statement are wrapped in
`%begin': a statement sequence that emits no braces of its own (the
surrounding c-block supplies them)."
(let ((src (and (pair? s) (anchor-statements?) (form-source s))))
(if src
`(%begin ,(line-directive src) ,(walk-expr s))
(walk-expr s))))
;;; A `;' comment reads as a form, so one written inside a construct
;;; with positional slots lands in a slot and shifts everything after
;;; it. So take the positional slots by skipping comments, and hand
;;; the comments back to be emitted just before the statement
(define (take-slots forms n)
"Three values: the comment forms skipped over, the next N non-comment
forms, and what remains."
(let loop ((fs forms) (n n) (comments (list)) (slots (list)))
(cond ((or (= n 0) (null? fs))
(values (reverse comments) (reverse slots) fs))
((comment-form? (car fs))
(loop (cdr fs) n (cons (car fs) comments) slots))
(else
(loop (cdr fs) (- n 1) comments (cons (car fs) slots))))))
;;; `%begin' is a statement sequence that emits no braces of its own, so
;;; the comments simply precede the statement.
(define (with-comments comments form)
(if (null? comments)
form
`(%begin ,@(map walk-expr comments) ,form)))
(define (walk-if-clauses clauses)
"(test stmt test stmt ... [else-stmt]) -- tests stay expressions."
(let loop ((cs clauses) (acc (list)))
(cond ((null? cs) (reverse acc))
((null? (cdr cs)) ; trailing else statement
(reverse (cons (walk-stmt (car cs)) acc)))
(else (loop (cddr cs)
(cons (walk-stmt (cadr cs))
(cons (walk-expr (car cs)) acc)))))))
(import (chicken string)
brev-separate
fmt
regex
srfi-1 ; lists
srfi-13 ; strings
)
(define (unkebabify sym)
(case sym
@@ -102,399 +20,109 @@ forms, and what remains."
((-=) sym)
(else
(string->symbol
(irregex-replace/all "-(?!>)" (symbol->string sym) "_")))))
(string-substitute "-(?!>)" "_"
(symbol->string sym) #t)))))
(define (atom-to-fmt-c atom)
(case atom
((fn) '%fun)
((prototype) '%prototype)
((do) '%block-begin)
((var) '%var)
((begin) '%block-begin)
((define) '%define)
((pointer) '%pointer)
((array) '%array)
((attribute) '%attribute)
((¤) 'vector-ref)
((@) 'vector-ref)
((include) '%include)
((static-assert) '_Static_assert)
;; a `|' inside a symbol has to be escaped to be written in
;; a Scheme source, so we just rename it in fmt-c compatible
;; way
((|\||) 'bit-or)
((|\|\||) '%or)
((|\|=|) 'bit-or=)
((cast) '%cast)
;; 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)))))
;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
(define (strip-comment-marker text)
(string-trim-both (string-trim text #\;)))
(define (walk-generic form acc)
(cond
((null? form) (cons '() acc))
(define (walk-comment texts)
(list '%comment
(string-append " "
(string-intersperse (map strip-comment-marker texts)
"\n ")
" ")))
;; vector, e.g. {}-initializer
((vector? form)
(cons
(list->vector
(car (walk-generic (vector->list form) (list))))
acc))
;;; Merge multiple lines of /* */ into single block
(define (pack-comments forms)
(let loop ((fs forms) (acc (list)))
(cond
((null? fs) (reverse acc))
((comment-form? (car fs))
(let ((first (car fs)))
(let gather ((rest (cdr fs)) (texts (cdr first)) (line (form-line first)))
(if (and (pair? rest)
(comment-form? (car rest))
line
(equal? (form-file first) (form-file (car rest)))
(eqv? (form-line (car rest)) (+ line 1)))
(gather (cdr rest)
(append texts (cdr (car rest)))
(form-line (car rest)))
(loop rest
(cons (if (eq? texts (cdr first))
first ; a run of one, left alone
(copy-form-source! first (cons 'comment texts)))
acc))))))
(else (loop (cdr fs) (cons (car fs) acc))))))
;; atom (hopefully)
((not (list? form)) (cons (atom-to-fmt-c form) acc))
(define (walk-generic-toplevel form)
(cond ((atom? form) (atom-to-fmt-c form))
((list? form) (map walk-generic-toplevel form))
(else (sex-error form "malformed form" form))))
;; another special case - field access
((and (symbol? (car form))
(char=? #\. (string-ref (symbol->string (car form)) 0)))
(cons (make-field-access form) acc))
(define (walk-expr form)
(match form
((? vector?) (walk-initializer (vector->list form)))
((? atom?)
(atom-to-fmt-c form))
;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
(('comment . text) (walk-comment text))
;; (dot-access obj field ...) -> obj.field... member access. `%.'
;; is the fmt-c directive for the `.' operator (see sex-fmt-c).
(('dot-access . rest) (cons '%. (map walk-expr rest)))
(('var . _) (walk-var form))
;; An expression has no room for a statement, so a comment in a
;; cast is dropped rather than relocated.
(('cast . rest)
(let-values (((comments slots _) (take-slots rest 2)))
(list '%cast (walk-type (cadr slots)) (walk-expr (car slots)))))
(('enum . _) (walk-enum form))
(('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)))
;; toplevel, or a start of a regular list form
(else
(let ((new-acc (list)))
(cons (fold-right
walk-generic
new-acc
form)
acc)))))
;; Statement positions. These are the only places a #line may go,
;; and each is spliced or wrapped according to what the
;; corresponding fmt-c procedure accepts.
(('do . stmts) (cons '%block-begin (walk-body stmts)))
(('if . clauses)
(with-comments (filter comment-form? clauses)
(cons 'if (walk-if-clauses (remove comment-form? clauses)))))
(('while . rest)
(let-values (((comments slots body) (take-slots rest 1)))
(with-comments comments
(cons* 'while (walk-expr (car slots)) (walk-body body)))))
(('for . rest)
(let-values (((comments slots body) (take-slots rest 3)))
(with-comments comments
(cons* 'for (walk-expr (car slots)) (walk-expr (cadr slots))
(walk-expr (caddr slots))
(walk-body body)))))
;; No anchor *between* switch clauses: c-switch requires every clause
;; to be a case/default form and errors on anything else. The clause
;; bodies are anchored from inside, which is what a debugger steps
;; onto -- a `case' label is not a statement.
;; A comment between clauses has to go too: c-switch requires every
;; clause to be a case/default form and errors on anything else.
(('switch . rest)
(let-values (((comments slots clauses) (take-slots rest 1)))
(with-comments (append comments (filter comment-form? clauses))
(cons* 'switch (walk-expr (car slots))
(map walk-expr (remove comment-form? clauses))))))
(('case . rest)
(let-values (((comments slots body) (take-slots rest 1)))
(with-comments comments
(cons* 'case (walk-expr (car slots)) (walk-body body)))))
(('case/fallthrough . rest)
(let-values (((comments slots body) (take-slots rest 1)))
(with-comments comments
(cons* 'case/fallthrough (walk-expr (car slots)) (walk-body body)))))
(('default . body) (cons 'default (walk-body body)))
;; Drop comments so they will not generate additional comma
(else (map walk-expr (remove comment-form? form)))))
;;; #(a b c) is a brace initializer. A `:' inside one ends a type and
;;; turns the whole thing into a C99 compound literal:
;;; #(struct point : 1 2) is (struct point){1, 2}, and the type is
;;; written as bare words, the way it is everywhere else in the
;;; language. `:' is the separator because it is the one thing that can
;;; be neither a type word nor an expression -- a named form would be a
;;; C identifier, and so shadowable (see issue #36).
(define (walk-initializer elements)
(let ((parts (list-split (remove comment-form? elements) ':)))
(if (null? (cdr parts))
(list->vector (walk-designators (car parts)))
(cons* '%compound
(walk-type (maybe-unwrap-type (car parts)))
(walk-designators (cadr parts))))))
;;; `.field value' is a designated initializer; anything else is
;;; positional. C lets the two be mixed, and nothing here stops it. A
;;; leading `.' cannot begin a C identifier, so a field name needs no
;;; keyword to introduce it and cannot collide with one.
(define (walk-designators elements)
(let loop ((es elements) (acc (list)))
(match es
(() (reverse acc))
(((? designator? d))
(sex-error elements "designated initializer without a value" d))
(((? designator? d) value . rest)
(loop rest
(cons (list '%designate
(atom-to-fmt-c (designator-field d))
(walk-expr value))
acc)))
((e . rest) (loop rest (cons (walk-expr e) acc))))))
(define (designator? x)
(and (symbol? x)
(let ((s (symbol->string x)))
(and (> (string-length s) 1)
(char=? #\. (string-ref s 0))))))
(define (designator-field d)
(string->symbol (substring (symbol->string d) 1)))
(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)
;; Likewise a declaration: drop any comment rather than shift the
;; name and type apart.
(let ((form (cons (car form) (remove comment-form? (cdr form)))))
`(%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 (array-bound? form)
`(%array ,(walk-type (array-element-type form)) ,(last array-type))
;; sugar for pointer... Do we really need it? Guess why not,
;; it's a strong semantic cue
`(%array ,(walk-type (array-element-type form)))))
(('fn arglist ret-type)
`(%fun ,(walk-type ret-type) ,(walk-arg-types arglist)))
(('fn . _)
(sex-error form "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))))
;;; An array or a function type
(define (structured-type? form)
(and (pair? form) (memq (car form) '(¤ fn))))
(define (has-pointer-star? form)
(and (pair? form)
(not (structured-type? form))
(or (memq '* form)
(any has-pointer-star? (filter pair? form)))))
;;; A `*' inside a sublist. Pointer chains are written flat -- (* * T),
;;; never (* (* T))
;;; Sublists that merely group, like (* (const struct suc)), contain
;;; no `*' and are fine.
(define (nested-pointer? type)
(and (pair? type)
(any has-pointer-star? (filter pair? type))))
(define (nested-structured-type type)
(and (pair? type)
(find structured-type? (filter pair? type))))
(define (type-convert-to-c type)
;; Our pointers to C pointers
;; int -> int
;; * const char -> const char *
;; const * const char -> const char * const
(when (nested-pointer? type)
(sex-error type "pointer chains are written flat, as (* * T), not nested" type))
(let ((inner (nested-structured-type type)))
(when inner
(if (eq? (car inner) 'fn)
;; (fn ...) is spelled as the pointer it already is in C
(sex-error type "a fn type is a function pointer already: write (fn ...), not (* (fn ...))" type)
(sex-error type "a pointer to an array is not supported" type))))
(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-body maybe-body)))))
;;; The type of one parameter
(define (arg-type arg)
(if (named-arg? arg)
(walk-type (maybe-unwrap-type (cdr arg)))
;; A lone type may arrive wrapped in parens of its own, and those
;; are not part of it: ((* const char)), (int)
(walk-type (maybe-unwrap-type arg))))
;;; fmt-c reads a parameter as `(type name)', taking the name with
;;; `cadr'. A nameless one is the type and an explicit #f:
;;;
;;; (* const char) -> const char the star read as the name
;;; ((* const char) #f) -> const char *
;;; (int) -> (cadr) error
;;; (int #f) -> int
(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 (lambda (arg)
(list (arg-type arg)
(and (named-arg? arg) (walk-type (car arg)))))
(remove comment-form? form)))
(define (walk-arg-types form)
(map arg-type (remove comment-form? form)))
(define (walk-function form)
;; (fn name arglist ret-type body) -> normal function
;; (fn name arglist ret-type) -> prototype
(define (normalize-fn-form 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)))))
form
(cons 'prototype (cdr 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)))))
(remove comment-form? 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 (sex-error form "malformed aggregate definition" form))))
(define (walk-enum form)
(match form
;; Naming one without defining it: `(var m (enum mood))', the same
;; shape walk-struct accepts for `(struct foo)'. Guarded, and
;; before the anonymous case, since `(enum (red green))' is also a
;; two-element form
(('enum (? symbol? name))
`(enum ,(atom-to-fmt-c name)))
(('enum (values ...))
`(enum ,(map atom-to-fmt-c values)))
(('enum name (values ...))
`(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))
(else (sex-error form "malformed enum" form))))
(define (walk-function form static)
(if static
(walk-generic (list 'static (normalize-fn-form form))
(list))
(walk-generic (normalize-fn-form (cdr form))
(list))))
(define (walk-extern form)
(match form
(('fn . _)
;; extern function?.. What
(list 'extern (walk-function form)))
(('var . _)
(list 'extern (walk-var form)))
(else (sex-error form "extern must be followed by fn or var" form))))
(case (cadr form)
((fn)
(list (cons 'extern (walk-function form #f))))
((var)
(list (cons 'extern (walk-generic (cdr form) (list)))))
(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 . _)
('enum . _)
('typedef . _))
(case (cadr form)
((fn)
(walk-function form #f))
((var)
(walk-generic (list 'static (cdr form)) (list)))
((define defmacro import include struct typedef union var)
;; ignore here, used in generating public interface
(process-toplevel-form form))
(process-toplevel-form (cdr form)))
(else
(sex-error form "pub must be followed by a definition" form))))
(error "Pub what?" (cadr form)))))
(define (process-toplevel-form form)
(match form
(('comment . text) (walk-comment text))
(('fn . _) (list 'static (walk-function form)))
(('var . _) (list 'static (walk-var form)))
(('extern . rest) (walk-extern rest))
;; The cdr of a form has no location of its own, so hand it the
;; `pub' form's -- otherwise a complaint about what follows `pub'
;; cannot say where it was written
(('pub . rest) (walk-public (copy-form-source! form 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))))
;; todo: rewrite to match
(case (car form)
((fn) (walk-function form #t))
((extern) (walk-extern form))
((pub) (walk-public form))
(else (walk-generic form (list)))))
(define (emit-c sex-forms)
(for-each (lambda (form)
;; Forms the reader did not produce -- the prelude, and
;; anything a macro built that we could not attribute --
;; have no location and get no directive.
(let ((src (and (not (eq? (sex-line-directives) 'none))
(form-source form))))
(when src
(fmt #t (c-expr (line-directive src)))))
(fmt #t (c-expr (process-toplevel-form form)) nl))
(pack-comments sex-forms)))
(fmt #t (c-expr (car (process-toplevel-form form))) nl))
sex-forms))

919
fmt-c.scm Normal file
View File

@@ -0,0 +1,919 @@
;;;; fmt-c.scm -- fmt module for emitting/pretty-printing C code
;;
;; Copyright (c) 2007 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; additional state information
(declare (unit fmt-c))
(import fmt
srfi-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 (c-op<= (fmt-op st) op)
(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)
(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 (not (null? 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) ""))))))
(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
(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-type (car x) (cadr x)))
(else (error "missing type" x))))
(define (c-field x)
(cond
((procedure? x) x)
((pair? x)
(if (list? (car x))
(case (caar x)
((union struct class)
(if (> (length x) 1)
(c-type (car x)
(cadr x))
(c-type (car x))))
(else (c-type (car x) (cadr x))))
(c-type (car x)
(fmt-join c-expr (cdr x) ", "))))
(else (error "missing type" x))))
(define (c-param-list ls)
(if (null? ls)
(c-type 'void)
(c-in-expr (fmt-join/dot c-param (lambda (dot) (dsp "...")) ls ", "))))
(define (c-fun type name params . body)
(cat (c-block (c-in-expr (c-prototype type name params))
(c-in-stmt (apply c-begin body)))
fl))
(define (c-prototype type name params . o)
(c-wrap-stmt
(cat (c-type type) " " (c-expr name) " (" (c-param-list params) ")"
(fmt-join/prefix c-expr o " "))))
(define (c-static x) (cat "static " (c-expr x)))
(define (c-const x) (cat "const " (c-expr x)))
(define (c-restrict x) (cat "restrict " (c-expr x)))
(define (c-volatile x) (cat "volatile " (c-expr x)))
(define (c-auto x) (cat "auto " (c-expr x)))
(define (c-inline x) (cat "inline " (c-expr x)))
(define (c-extern x) (cat "extern " (c-expr x)))
(define (c-extern/C . body)
(cat "extern \"C\" {" nl (apply c-begin body) nl "}" nl))
(define (c-type type . o)
(let ((name (and (pair? o) (car o))))
(cond
((pair? type)
(case (car type)
((%fun)
(cat (c-type (cadr type) #f)
" (*" (or name "") ")("
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
((%array)
(let ((name (cat name "[" (if (pair? (cddr type))
(c-expr (caddr type))
"")
"]")))
(c-type (cadr type) name)))
((%pointer *)
(let ((name (cat "*" (if name (c-expr name) ""))))
(c-type (cadr type)
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
(c-paren name)
name))))
((enum) (apply c-enum name (cdr type)))
((struct union class)
(cat (apply c-struct/aux (car type) (cdr type)) (if name (cat " " name) "")))
(else (fmt-join/last c-expr (lambda (x) (c-type x name)) type " "))))
((not type)
(lambda (st) ((c-type (or (fmt-default-type st) 'int) name) st)))
(else
(cat (if (eq? '%pointer type) '* type) (if name (cat " " name) ""))))))
(define (c-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)) "--"))

45
infer.module.scm
View File

@@ -1,45 +0,0 @@
(module infer
(;; The IR
tvar?
tvar-id
tvar-classes
tvar-rigid?
fresh-tvar
fresh-rigid-tvar
prim-type? prim-name prim-quals make-prim
ptr-type? ptr-target ptr-quals make-ptr
array-type? array-elt array-size make-array-type
fn-type? fn-ret fn-args fn-variadic? make-fn-type
agg-type? agg-kind agg-name agg-spelling agg-quals make-agg
alias-type? alias-name alias-expansion alias-quals make-alias
unknown-type? the-unknown-type
resolve
underlying
c-primitive?
type-quals
free-tvars
decay
;; The boundary
parse-type
unparse-type
;; Constraints
register-class!
add-instance!
entails?
default-tvar!
default-type-variables!
;; Unification
unify
;; Type schemes
scheme? scheme-vars scheme-constraints scheme-type
make-scheme
generalize
instantiate
substitute)
"infer.scm")

644
infer.scm
View File

@@ -1,644 +0,0 @@
;;; Type inference, layer 0: the type representation and unification.
;;;
;;; Nothing in the compiler calls this unit yet. It is the ground floor
;;; of the pass described in Type-inference.org -- built and tested on
;;; its own before a single form is routed through it.
;;;
;;; Two representations meet here. *Surface* types are the forms the
;;; rest of the compiler passes around -- `int', `(* const char)',
;;; `(¤ int 16)', `(fn ((int)) int)'. They are what the reader
;;; produces, what the C writer consumes and what `type-match' compares
;;; with `equal?', and they are hopeless for unification. The *IR*
;;; below is the other one: mutable cells, so that solving a type
;;; variable is a side effect rather than a substitution rebuilt at
;;; every step.
;;;
;;; `parse-type' and `unparse-type' are the boundary between the two,
;;; and they carry the whole compatibility burden: `unparse-type' must
;;; produce the exact spelling `type-match' compares against, or the
;;; reflection macros break by silently falling into their `else'
;;; branch. That is what the round-trip test in tests/infer.scm is for,
;;; and why it is driven by every type spelling that appears in the
;;; repository.
(import
scheme
(scheme base)
(chicken base)
matchable
srfi-1
srfi-69
types
utils)
;;; ---------------------------------------------------------------
;;; The IR
;;; ---------------------------------------------------------------
;;; A type variable is a mutable cell. `ref' is #f while unsolved and
;;; the type it stands for once bound -- union-find, with the path
;;; compression done in `resolve'.
;;;
;;; `classes' is the list of type classes the variable must satisfy
;;; (`numeric', and one day `ord'); see "constraints" below. `rigid?'
;;; marks a variable that must not unify with anything but itself --
;;; unused until a `fn' grows type parameters, and five lines now
;;; against an IR change later.
(define-record-type <tvar>
(%make-tvar id ref classes rigid?)
tvar?
(id tvar-id)
(ref tvar-ref tvar-ref-set!)
(classes tvar-classes tvar-classes-set!)
(rigid? tvar-rigid?))
;;; A primitive or otherwise nominal type. `name' is the list of words
;;; making it up, so `int', `(unsigned int)' and `(long long)' are all
;;; one node, and so is a name we have never parsed a declaration for
;;; (`size-t', `GLuint'). The two cases are told apart by
;;; `c-primitive?', which is what keeps a constraint over an unparsed C
;;; typedef from being an error.
(define-record-type <prim>
(make-prim name quals)
prim-type?
(name prim-name)
(quals prim-quals))
(define-record-type <ptr>
(make-ptr target quals)
ptr-type?
(target ptr-target)
(quals ptr-quals))
;;; `size' is an integer, or #f for `(¤ int)' -- an array of unwritten
;;; length.
(define-record-type <array>
(make-array-type elt size)
array-type?
(elt array-elt)
(size array-size))
(define-record-type <fn>
(make-fn-type ret args variadic?)
fn-type?
(ret fn-ret)
(args fn-args)
(variadic? fn-variadic?))
;;; struct / union / enum. Nominal: two of them are the same type when
;;; they are the same kind and the same name. `spelling' is the surface
;;; form it was written as, kept verbatim so that an aggregate defined
;;; inline in a type position round-trips unchanged.
(define-record-type <agg>
(make-agg kind name spelling quals)
agg-type?
(kind agg-kind)
(name agg-name)
(spelling agg-spelling)
(quals agg-quals))
;;; A typedef. Transparent to unification -- it unifies as whatever it
;;; expands to -- and opaque to printing, so a diagnostic and a
;;; generated declaration both say `size-t' rather than `unsigned long'.
(define-record-type <alias>
(make-alias name expansion quals)
alias-type?
(name alias-name)
(expansion alias-expansion)
(quals alias-quals))
;;; `?'. Sex has full C interop, so `printf', `SDL-CreateWindow' and
;;; `size-t' arrive from headers nobody parsed. Rather than reject
;;; every real program, the lattice gets a top element: `?' is
;;; consistent with every type and constrains nothing.
(define-record-type <unknown>
(%make-unknown)
unknown-type?)
(define the-unknown-type (%make-unknown))
(define tvar-counter 0)
(define (fresh-tvar . classes)
(set! tvar-counter (+ tvar-counter 1))
(%make-tvar tvar-counter #f (if (null? classes) (list) (car classes)) #f))
(define (fresh-rigid-tvar . classes)
(set! tvar-counter (+ tvar-counter 1))
(%make-tvar tvar-counter #f (if (null? classes) (list) (car classes)) #t))
;;; Follow a bound variable to what it stands for, compressing the path
;;; on the way out. Every procedure that looks at a type's shape starts
;;; here.
(define (resolve type)
(if (and (tvar? type) (tvar-ref type))
(let ((target (resolve (tvar-ref type))))
(tvar-ref-set! type target)
target)
type))
;;; ...and through any typedef as well, for the places that care what a
;;; type *is* rather than what it is called.
(define (underlying type)
(let ((t (resolve type)))
(if (alias-type? t)
(underlying (alias-expansion t))
t)))
(define (type-quals type)
(cond ((prim-type? type) (prim-quals type))
((ptr-type? type) (ptr-quals type))
((agg-type? type) (agg-quals type))
((alias-type? type) (alias-quals type))
(else (list))))
;;; Array-to-pointer and function-to-function-pointer, for the
;;; positions where C decays: a call argument, an operand of `+', the
;;; subscripted half of `(¤ a i)'.
(define (decay type)
(let ((t (underlying type)))
(cond ((array-type? t) (make-ptr (array-elt t) (list)))
((fn-type? t) (make-ptr t (list)))
(else (resolve type)))))
(define (free-tvars type)
(let collect ((t type) (acc (list)))
(let ((t (resolve t)))
(cond ((tvar? t) (if (memq t acc) acc (cons t acc)))
((ptr-type? t) (collect (ptr-target t) acc))
((array-type? t) (collect (array-elt t) acc))
((alias-type? t) (collect (alias-expansion t) acc))
((fn-type? t) (fold collect (collect (fn-ret t) acc) (fn-args t)))
(else acc)))))
;;; ---------------------------------------------------------------
;;; Surface -> IR
;;; ---------------------------------------------------------------
(define +qualifiers+ '(const volatile restrict))
(define (qualifier? word) (memq word +qualifiers+))
;;; `(const char)' written as `((const char))' is the same type: a
;;; sublist that merely groups. The C writer unwraps these too.
(define (maybe-unwrap type)
(if (and (list? type) (= 1 (length type)))
(car type)
type))
(define (parse-type surface)
(cond
((symbol? surface) (parse-words (list surface) (list) surface))
((not (pair? surface)) (sex-error surface "not a type" surface))
((eq? (car surface) '¤) (parse-array surface))
((eq? (car surface) 'fn) (parse-fn surface))
((memq '* surface) (parse-pointer-chain surface))
(else (parse-words surface (list) surface))))
;;; A `*'-free run of words: qualifiers, then whatever they qualify.
;;; `form' is only carried along so a complaint can say where it was
;;; written.
(define (parse-words words quals form)
(cond
((null? words) (sex-error form "type is nothing but qualifiers" form))
((qualifier? (car words))
(parse-words (cdr words) (cons (car words) quals) form))
;; A single sublist left: grouping parens, as in (* (const struct s))
((and (null? (cdr words)) (pair? (car words)))
(with-quals (parse-type (car words)) (reverse quals)))
((memq (car words) '(struct union enum)) (parse-agg words (reverse quals)))
((eq? (car words) '¤) (parse-array words))
((eq? (car words) 'fn) (parse-fn words))
((memq '* words) (parse-pointer-chain (append (reverse quals) words)))
(else (parse-name words (reverse quals) form))))
;;; A name, one word or several: `int', `size-t', `(unsigned int)'.
(define (parse-name words quals form)
(cond
((not (every symbol? words)) (sex-error form "malformed type" form))
;; The type-level wildcard. It is a fresh variable wherever it
;; appears, which is what makes partial types -- `(* _)', `(¤ _ 4)'
;; -- fall out for free rather than needing their own grammar.
((equal? words '(_)) (fresh-tvar))
((and (null? (cdr words)) (get-underlying-type (car words)))
=> (lambda (target)
(make-alias (car words) (parse-type target) quals)))
(else (make-prim words quals))))
;;; ([pub] struct name), (struct name (fields ...)), (struct (fields ...))
(define (parse-agg words quals)
(let* ((kind (car words))
(name (and (pair? (cdr words)) (symbol? (cadr words)) (cadr words))))
(make-agg kind name words quals)))
;;; (¤ elt ... size) -- the size is the last element when it is an
;;; integer, and absent otherwise. The element words are unwrapped the
;;; way the C writer unwraps them, so `[int 16]' and `[(int) 16]' are
;;; one type.
(define (parse-array surface)
(let* ((rest (cdr surface))
(sized? (and (pair? rest) (integer? (last rest))))
(size (and sized? (last rest)))
(words (if sized? (drop-right rest 1) rest)))
(when (null? words)
(sex-error surface "array type without an element type" surface))
(make-array-type (parse-type (maybe-unwrap words)) size)))
;;; (fn ((int) (float)) void). Argument entries are types, not named
;;; parameters -- a `fn' in type position has no room for names.
(define (parse-fn surface)
(match surface
(('fn (? list? arglist) ret)
(let* ((variadic? (and (pair? arglist) (variadic-marker? (last arglist))))
(entries (if variadic? (drop-right arglist 1) arglist)))
(make-fn-type (parse-type ret)
(map (lambda (entry) (parse-type (maybe-unwrap entry)))
entries)
variadic?)))
(else (sex-error surface "malformed function type" surface))))
;;; `...' in an arglist, written bare or wrapped the way every other
;;; entry is.
(define (variadic-marker? entry)
(or (eq? entry '...) (equal? entry '(...))))
;;; Pointer chains are written flat and read right to left: the last
;;; `*'-separated run is the pointed-to type, and each run before it
;;; qualifies one level of indirection. `(const * const char)' is a
;;; const pointer to a const char.
(define (parse-pointer-chain words)
(let* ((segments (list-split words '*))
(base (last segments))
(levels (reverse (drop-right segments 1))))
(when (null? base)
(sex-error words "pointer to nothing" words))
(fold (lambda (level acc)
(unless (every qualifier? level)
(sex-error words "only qualifiers may sit between two `*'" words))
(make-ptr acc level))
(parse-words (maybe-unwrap-segment base) (list) words)
levels)))
(define (maybe-unwrap-segment segment)
(let ((s (maybe-unwrap segment)))
(if (list? s) s (list s))))
;;; Re-qualify a parsed type, for the grouping case `(const (struct s))'
;;; where the qualifier is read before the thing it qualifies.
(define (with-quals type quals)
(if (null? quals)
type
(cond ((prim-type? type) (make-prim (prim-name type)
(append quals (prim-quals type))))
((ptr-type? type) (make-ptr (ptr-target type)
(append quals (ptr-quals type))))
((agg-type? type) (make-agg (agg-kind type) (agg-name type)
(agg-spelling type)
(append quals (agg-quals type))))
((alias-type? type) (make-alias (alias-name type)
(alias-expansion type)
(append quals (alias-quals type))))
(else type))))
;;; ---------------------------------------------------------------
;;; IR -> surface
;;; ---------------------------------------------------------------
;;; Every result here has to be the spelling the rest of the compiler
;;; already writes by hand, since `type-match' compares with `equal?'
;;; and a near miss is silent.
(define (unparse-type type)
(let ((t (resolve type)))
(cond
((tvar? t) '_)
((unknown-type? t) '?)
((alias-type? t) (qualify (alias-quals t) (list (alias-name t))))
((prim-type? t) (qualify (prim-quals t) (prim-name t)))
((agg-type? t) (qualify (agg-quals t) (agg-spelling t)))
((ptr-type? t)
(append (ptr-quals t) (list '*) (as-words (unparse-type (ptr-target t)))))
((array-type? t)
(let ((elt (as-words (unparse-type (array-elt t)))))
(append (list '¤)
(if (and (pair? elt) (eq? (car elt) '¤)) (list elt) elt)
(if (array-size t) (list (array-size t)) (list)))))
((fn-type? t)
(list 'fn
(append (map (lambda (arg) (as-arg (unparse-type arg))) (fn-args t))
(if (fn-variadic? t) (list '(...)) (list)))
(unparse-type (fn-ret t))))
(else (error "unparse-type: not a type" t)))))
;;; A one-word type is written bare, anything longer as a list --
;;; `int', but `(const int)' and `(struct point)'.
(define (qualify quals words)
(let ((all (append quals words)))
(if (and (null? quals) (= 1 (length all)))
(car all)
all)))
;;; An argument in a `fn' type is written as a list even when it is one
;;; word -- `((int) (float))' -- so only an atom needs wrapping.
(define (as-arg surface)
(if (pair? surface) surface (list surface)))
;;; Splice a type into a surrounding word list, the way `(* const char)'
;;; and `[* const char]' splice theirs. An array keeps its parentheses:
;;; `(¤ ¤ char 4)' would read back as something else entirely.
(define (as-words surface)
(cond ((not (pair? surface)) (list surface))
((memq (car surface) '(¤ fn)) (list surface))
(else surface)))
;;; ---------------------------------------------------------------
;;; Constraints
;;; ---------------------------------------------------------------
;;; `(numeric a)' is already a type class, so it is written as one from
;;; the start: one representation, one table, one entailment check. A
;;; trait bound `(ord (struct circle))' is the same shape, discharged
;;; the same way, and reported by the same procedure -- which is the
;;; whole reason to build it this way while there is only one kind of
;;; constraint to build.
;;;
;;; `default' is the type an unresolved constraint falls back to, the
;;; way Haskell defaults `Num a' to Integer. `test' is how the built-in
;;; classes say "every arithmetic type" without enumerating twenty
;;; spellings as instances; a user trait has no test and lives entirely
;;; in the instance table. `strict?' marks a class that must not be
;;; guessed at: static dispatch needs a real instance, so `?' fails it.
(define-record-type <type-class>
(%make-type-class name default test strict?)
type-class?
(name type-class-name)
(default type-class-default)
(test type-class-test)
(strict? type-class-strict?))
(define +classes+ (make-hash-table))
(define +instances+ (make-hash-table))
(define (register-class! name default test strict?)
(hash-table-set! +classes+ name (%make-type-class name default test strict?)))
(define (get-class name)
(or (hash-table-ref/default +classes+ name #f)
(error "no such type class" name)))
;;; Instances key on the *resolved* type, so `(impl show for size-t)'
;;; and `(impl show for unsigned long)' collide rather than quietly
;;; coexisting as two instances of one C type.
(define (instance-key type)
(unparse-type (underlying type)))
(define (add-instance! class-name type)
(hash-table-set! +instances+ (cons class-name (instance-key type)) #t))
(define (has-instance? class-name type)
(hash-table-exists? +instances+ (cons class-name (instance-key type))))
;;; #t, #f, or 'unknown -- and the third answer is the important one.
;;; A C name we never parsed a declaration for might well be numeric;
;;; saying #f there would reject working programs, and saying #t would
;;; invent knowledge. 'unknown means "do not constrain, do not
;;; complain".
(define (entails? class-name type)
(let ((cls (get-class class-name))
(t (underlying type)))
(cond
((tvar? t) 'unknown)
;; `?' is consistent with every type, but it entails nothing:
;; there is no instance to select and no name to mangle.
((unknown-type? t) (if (type-class-strict? cls) #f 'unknown))
((has-instance? class-name t) #t)
((type-class-test cls) => (lambda (test) (test t)))
(else #f))))
(define +integer-words+ '(char short int long signed unsigned bool _Bool))
(define +float-words+ '(float double))
(define +known-words+ (append '(void) +integer-words+ +float-words+))
;;; A prim built only out of words we recognise. Anything else is a
;;; name from a header, and we have no opinion about it.
(define (c-primitive? t)
(and (prim-type? t)
(every (lambda (word) (memq word +known-words+)) (prim-name t))))
(define (void-type? t)
(and (prim-type? t) (equal? (prim-name t) '(void))))
(define (arithmetic-type? t)
(cond ((and (agg-type? t) (eq? (agg-kind t) 'enum)) #t) ; an enum is an integer
((not (prim-type? t)) #f)
((not (c-primitive? t)) 'unknown)
((void-type? t) #f)
(else #t)))
(define (integral-type? t)
(cond ((and (agg-type? t) (eq? (agg-kind t) 'enum)) #t)
((not (prim-type? t)) #f)
((not (c-primitive? t)) 'unknown)
((void-type? t) #f)
((any (lambda (word) (memq word +float-words+)) (prim-name t)) #f)
(else #t)))
(define (floating-type? t)
(cond ((not (prim-type? t)) #f)
((not (c-primitive? t)) 'unknown)
(else (and (any (lambda (word) (memq word +float-words+)) (prim-name t))
#t))))
(define (scalar-type? t)
(cond ((ptr-type? t) #t)
((array-type? t) #t) ; decays to one
((fn-type? t) #t) ; likewise
(else (arithmetic-type? t))))
;;; The built-ins. They are ordinary classes, registered the same way a
;;; trait will be -- that is the point.
(register-class! 'numeric 'int arithmetic-type? #f)
(register-class! 'integral 'int integral-type? #f)
(register-class! 'floating 'double floating-type? #f)
(register-class! 'scalar #f scalar-type? #f)
;;; A constraint that survives to the end of a function is defaulted:
;;; `(numeric a)' with nothing else known is an `int'. A *strict*
;;; class has no default and no business guessing, so an unresolved one
;;; is an error -- the rule is worth stating while there is only one
;;; kind of constraint to state it about.
(define (default-tvar! v form)
(let ((strict (find (lambda (c) (type-class-strict? (get-class c)))
(tvar-classes v))))
(cond
(strict (sex-error form "unresolved constraint" (list strict (unparse-type v))))
((find (lambda (c) (type-class-default (get-class c))) (tvar-classes v))
=> (lambda (c)
(tvar-ref-set! v (parse-type (type-class-default (get-class c))))
#t))
(else #f))))
;;; Default every variable still open in TYPE. Returns #t when none is
;;; left unsolved, so a caller can tell "inferred" from "give up and
;;; ask for the type in writing".
(define (default-type-variables! type form)
(fold (lambda (v ok) (and (default-tvar! v form) ok))
#t
(free-tvars type)))
(define (check-classes classes type form)
(for-each
(lambda (c)
(when (eq? #f (entails? c type))
(sex-error form "type does not satisfy a constraint"
(list c (unparse-type type)))))
classes))
;;; ---------------------------------------------------------------
;;; Unification
;;; ---------------------------------------------------------------
;;; Consistency in the gradual-typing sense rather than equality: `?'
;;; succeeds against anything and binds nothing, which is what keeps
;;; the pass from rejecting every program that includes a C header.
;;;
;;; FORM is carried only so a failure can say where it was written.
(define (unify t1 t2 form)
(let ((a (resolve t1))
(b (resolve t2)))
(cond
((eq? a b) #t)
((unknown-type? a) #t)
((unknown-type? b) #t)
;; Whichever side is free takes the binding: `(unify a r)' and
;; `(unify r a)' both leave `a' bound to `r'. Two rigid and
;; distinct is the mismatch `eq?' above let through.
((and (tvar? a) (not (tvar-rigid? a))) (bind-tvar! a b form))
((and (tvar? b) (not (tvar-rigid? b))) (bind-tvar! b a form))
((or (tvar? a) (tvar? b)) (type-mismatch a b form))
;; A typedef unifies as what it stands for. Its name survives in
;; whichever side is printed later, since neither side is rebuilt.
((alias-type? a) (unify (alias-expansion a) b form))
((alias-type? b) (unify a (alias-expansion b) form))
((and (prim-type? a) (prim-type? b))
(check-quals a b form)
(or (equal? (prim-name a) (prim-name b))
(type-mismatch a b form)))
((and (ptr-type? a) (ptr-type? b))
(check-quals a b form)
(unify (ptr-target a) (ptr-target b) form))
((and (array-type? a) (array-type? b))
;; One of them may be `(¤ int)': an unwritten length constrains
;; nothing, the way it does not in C either.
(when (and (array-size a) (array-size b)
(not (= (array-size a) (array-size b))))
(type-mismatch a b form))
(unify (array-elt a) (array-elt b) form))
((and (fn-type? a) (fn-type? b))
(unless (and (= (length (fn-args a)) (length (fn-args b)))
(eq? (fn-variadic? a) (fn-variadic? b)))
(type-mismatch a b form))
(unify (fn-ret a) (fn-ret b) form)
(for-each (lambda (x y) (unify x y form)) (fn-args a) (fn-args b))
#t)
((and (agg-type? a) (agg-type? b))
(check-quals a b form)
(or (and (eq? (agg-kind a) (agg-kind b))
(if (and (agg-name a) (agg-name b))
(eq? (agg-name a) (agg-name b))
(equal? (agg-spelling a) (agg-spelling b))))
(type-mismatch a b form)))
(else (type-mismatch a b form)))))
(define (type-mismatch a b form)
(sex-error form "type mismatch: expected"
(unparse-type a) 'got (unparse-type b)))
;;; Qualifiers are compared, and a mismatch is a warning rather than a
;;; failure: C's const-correctness is not this pass's fight yet, and
;;; making it one would reject programs that compile today.
(define (check-quals a b form)
(let ((qa (type-quals a))
(qb (type-quals b)))
(unless (lset= eq? qa qb)
(sex-warning form "qualifiers differ between"
(unparse-type a) "and" (unparse-type b)))))
(define (bind-tvar! v t form)
(cond
;; Without recursive types this cannot trigger. It is four lines,
;; and the alternative to having it is a hang.
((occurs? v t) (sex-error form "recursive type" (unparse-type v)))
;; A rigid variable is a type *parameter*: inside a generic body it
;; stands for one specific unknown type and must not be solved.
((tvar-rigid? v) (type-mismatch v t form))
(else
(when (tvar? t)
(tvar-classes-set! t (lset-union eq? (tvar-classes t) (tvar-classes v))))
(tvar-ref-set! v t)
(unless (tvar? t)
(check-classes (tvar-classes v) t form))
#t)))
(define (occurs? v type)
(let ((t (resolve type)))
(cond ((eq? v t) #t)
((ptr-type? t) (occurs? v (ptr-target t)))
((array-type? t) (occurs? v (array-elt t)))
((alias-type? t) (occurs? v (alias-expansion t)))
((fn-type? t) (or (occurs? v (fn-ret t))
(any (lambda (a) (occurs? v a)) (fn-args t))))
(else #f))))
;;; ---------------------------------------------------------------
;;; Type schemes
;;; ---------------------------------------------------------------
;;; Nothing generalizes yet -- every `fn' in Sex carries a written
;;; signature and there is no polymorphism to abstract over. These are
;;; here because they are ten lines on top of unification and because
;;; they are exactly what a `fn' with type parameters needs, and
;;; because a scheme without a constraint list is the wrong shape for
;;; every bounded generic. `(forall vars constraints type)' it is,
;;; from the start.
(define-record-type <scheme>
(make-scheme vars constraints type)
scheme?
(vars scheme-vars)
(constraints scheme-constraints)
(type scheme-type))
;;; Quantify over everything free in TYPE that is not also free in the
;;; environment, carrying each variable's class constraints along as
;;; the scheme's context.
(define (generalize type env-tvars)
(let ((vars (lset-difference eq? (free-tvars type) env-tvars)))
(make-scheme vars
(append-map (lambda (v)
(map (lambda (c) (cons c v)) (tvar-classes v)))
vars)
type)))
(define (instantiate scheme)
(let ((subst (map (lambda (v) (cons v (fresh-tvar (tvar-classes v))))
(scheme-vars scheme))))
(substitute (scheme-type scheme) subst)))
;;; Structural copy with the variables in SUBST replaced. Copying is
;;; how a generic body must be handled anyway -- `form-type' is keyed
;;; by cons cell, one form one type, so an instantiation gets fresh
;;; cells rather than a second type for the same cell.
(define (substitute type subst)
(let ((t (resolve type)))
(cond
((tvar? t) (let ((hit (assq t subst))) (if hit (cdr hit) t)))
((ptr-type? t) (make-ptr (substitute (ptr-target t) subst) (ptr-quals t)))
((array-type? t) (make-array-type (substitute (array-elt t) subst)
(array-size t)))
((alias-type? t) (make-alias (alias-name t)
(substitute (alias-expansion t) subst)
(alias-quals t)))
((fn-type? t) (make-fn-type (substitute (fn-ret t) subst)
(map (lambda (a) (substitute a subst))
(fn-args t))
(fn-variadic? t)))
(else t))))

3
main.scm
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)

6
reader.module.scm
View File

@@ -1,6 +0,0 @@
(module reader (read-from-file
read-raw-forms
current-features
platform-features)
"reader.scm")

353
reader.scm
View File

@@ -1,353 +0,0 @@
;;; Sex reader
;;;
;;; A hand-written tokenizer + recursive-descent parser that replaces
;;; CHICKEN's built-in `read'. We need our own reader because the
;;; features Sex requires cannot be expressed on top of `read':
;;; - [ ... ] array/pointer sugar, read as (¤ ...)
;;; - a leading `.' rewritten to the symbol `dot-access'
;;; - `;' comments preserved as (comment "...") forms, so they can be
;;; re-emitted into the generated C (keeping the source mapping)
;;; - #+ / #- feature expressions, which decide at read time what the
;;; compiler gets to see at all
;;; It also records the source location of every form it reads (see
;;; utils' form-source), so the C writer can emit #line directives.
(import
scheme
(scheme base) ; make-parameter
(chicken base)
(chicken pathname)
(chicken platform) ; software-version, machine-type
(only srfi-1 every any) ; srfi-1 also has an append-reverse
utils)
;;; Sentinels for structural tokens
(define close-paren (list '%close-paren))
(define close-bracket (list '%close-bracket))
(define dot-token (list '%dot))
;;; Current source line. Tracked as characters are consumed
(define current-line (make-parameter 1))
(define (get-ch port)
(let ((c (read-char port)))
(when (and (char? c) (char=? c #\newline))
(current-line (+ 1 (current-line))))
c))
(define (peek port)
(peek-char port))
;;; Record where a form started. Called with the line of the opening
;;; delimiter, sampled before it is consumed
(define (stamp form line)
(when (pair? form)
(set-form-source! form (current-source-file) line))
form)
(define (delimiter? c)
(or (eof-object? c)
(char-whitespace? c)
(memv c '(#\( #\) #\[ #\] #\" #\; #\' #\` #\,))))
;;; Skip whitespace. `;' comments are NOT skipped here: they are read
;;; as (comment "...") forms by the tokenizer. Block comments (#| |#)
;;; and datum comments (#;) are discarded in the tokenizer's `#'
;;; dispatch, since `#' also introduces real data (#t, #f, #\c, #(...))
(define (skip-whitespace port)
(let ((c (peek port)))
(cond
((eof-object? c) #t)
((char-whitespace? c) (get-ch port) (skip-whitespace port))
(else #t))))
;;; A `;' comment, read as (comment "<rest of line>"). The leading `;'
;;; is consumed; the newline is left in the stream so line tracking and
;;; the surrounding parser see it normally
(define (read-comment port)
(get-ch port) ; consume the leading ;
(let loop ((chars (list)))
(let ((c (peek port)))
(if (or (eof-object? c) (char=? c #\newline))
(list 'comment (list->string (reverse chars)))
(begin (get-ch port)
(loop (cons c chars)))))))
;;; Read the next token: a datum, one of the structural sentinels
;;; (close-paren / close-bracket / dot-token), or the eof-object
(define (next-token port)
(skip-whitespace port)
(let ((c (peek port)))
(cond
((eof-object? c) c)
((char=? c #\()
(let ((line (current-line)))
(get-ch port)
(stamp (read-list port close-paren) line)))
((char=? c #\[)
(let ((line (current-line)))
(get-ch port)
(stamp (cons '¤ (read-list port close-bracket)) line)))
((char=? c #\)) (get-ch port) close-paren)
((char=? c #\]) (get-ch port) close-bracket)
((char=? c #\;)
(let ((line (current-line)))
(stamp (read-comment port) line)))
((char=? c #\") (read-string-lit port))
((char=? c #\') (get-ch port) (list 'quote (read-datum port)))
((char=? c #\`) (get-ch port) (list 'quasiquote (read-datum port)))
((char=? c #\,)
(get-ch port)
(if (eqv? (peek port) #\@)
(begin (get-ch port) (list 'unquote-splicing (read-datum port)))
(list 'unquote (read-datum port))))
((char=? c #\#) (get-ch port) (read-hash port))
(else (read-atom port)))))
;;; Like next-token, but a full datum is required: the structural
;;; sentinels and eof are errors here (e.g. after a quote or `.')
(define (read-datum port)
(let ((tok (next-token port)))
(cond
((eof-object? tok) (error "Unexpected end of input"))
((eq? tok close-paren) (error "Unexpected )"))
((eq? tok close-bracket) (error "Unexpected ]"))
((eq? tok dot-token) (error "Unexpected ."))
(else tok))))
;;; A token that stands for a datum
(define (datum-token? tok)
(not (or (eof-object? tok)
(eq? tok close-paren)
(eq? tok close-bracket)
(eq? tok dot-token))))
;;; next-token, sans the comments
(define (next-code-token port)
(let loop ()
(let ((tok (next-token port)))
(if (comment-form? tok)
(loop)
tok))))
;;; Read list elements up to close-paren or close-bracket,
;;; honoring dotted-pair notation (a b . c)
(define (read-list port closer)
(let loop ((acc (list)))
(let ((tok (next-token port)))
(cond
((eof-object? tok) (error "Unexpected end of input inside list"))
((eq? tok close-paren)
(if (eq? closer close-paren)
(reverse acc)
(error "Unmatched closing bracket")))
((eq? tok close-bracket)
(if (eq? closer close-bracket)
(reverse acc)
(error "Unmatched closing bracket")))
((eq? tok dot-token)
(if (null? acc)
;; Leading `.': the member/method access operator. It reads
;; as an ordinary `dot-access' symbol in first position.
(loop (cons 'dot-access acc))
;; Otherwise: ordinary dotted-pair notation (a b . c).
(let ((tail (read-datum port))
(end (next-token port)))
(unless (eq? end closer)
(error "Malformed dotted list"))
(append-reverse acc tail))))
(else (loop (cons tok acc)))))))
;;; Append the reversed list `rev' in front of `tail', producing a
;;; possibly-improper list (used for dotted pairs)
(define (append-reverse rev tail)
(if (null? rev)
tail
(append-reverse (cdr rev) (cons (car rev) tail))))
;;; A bare atom: symbol or number, or the dot token when it is exactly "."
(define (read-atom port)
(let loop ((chars (list)))
(let ((c (peek port)))
(if (delimiter? c)
(finish-atom (list->string (reverse chars)))
(begin (get-ch port) (loop (cons c chars)))))))
(define (finish-atom s)
(cond
((string=? s ".") dot-token)
((string->number s) => identity)
(else (string->symbol s))))
;;; #-dispatch: booleans, characters, vectors, block/datum comments,
;;; feature expressions
(define (read-hash port)
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unexpected end of input after #"))
((or (char=? c #\t) (char=? c #\T)) (read-bool port #t))
((or (char=? c #\f) (char=? c #\F)) (read-bool port #f))
((char=? c #\\) (read-char-lit port))
((char=? c #\() (list->vector (read-list port close-paren)))
((char=? c #\|) (skip-block-comment port 1) (next-token port))
((char=? c #\;) (read-datum port) (next-token port)) ; datum comment
((char=? c #\+) (read-conditional port #t))
((char=? c #\-) (read-conditional port #f))
(else (error "Unsupported # syntax" c)))))
;;; Feature expressions
;;;
;;; #+linux (include GL/gl.h) kept on Linux
;;; #-macosx (foo) kept only on other than macOS
;;; #+(and unix (not macosx)) (bar) and / or / not combine them
;;;
(define (platform-features)
(list (software-version) (software-type) (machine-type)))
;;; The host's features are the default, so anything reading Sex sees
;;; what the compiler would. sexc rebinds this to add --features
(define current-features (make-parameter (platform-features)))
(define (feature-true? test)
(cond
((symbol? test) (and (memq test (current-features)) #t))
((pair? test)
(case (car test)
((and) (every feature-true? (cdr test)))
((or) (any feature-true? (cdr test)))
((not)
(if (and (pair? (cdr test)) (null? (cddr test)))
(not (feature-true? (cadr test)))
(error "Feature expression `not' takes exactly one operand" test)))
(else (error "Unknown operator in feature expression" (car test)))))
(else (error "Malformed feature expression" test))))
;;; The #-/#+ preceded datum is always read -- there is no other way
;;; to know where it ends -- and then either returned or dropped. What
;;; follows a dropped datum is read in its place: `#+x #+y (a) (b)'
;;; with only x is (b).
;;;
;;; That next thing may be nothing: the end of the file, or the
;;; paren closing the list we are in
(define (read-conditional port keep-when)
(let* ((test (next-code-token port))
(keep (begin
(unless (datum-token? test)
(error "Unexpected end of input in feature expression"))
(eq? keep-when (feature-true? test))))
(guarded (next-code-token port)))
(cond
(keep guarded)
;; A datum was dropped, so the next one stands in for it
((datum-token? guarded) (next-token port))
(else guarded))))
;;; #t / #true / #f / #false. `val' is the boolean; consume any
;;; trailing name characters and validate
(define (read-bool port val)
(let ((rest (read-atom-string port)))
(cond
((string=? rest "") val)
((and val (string=? rest "rue")) val)
((and (not val) (string=? rest "alse")) val)
(else (error "Malformed boolean literal" rest)))))
(define (read-atom-string port)
(let loop ((chars (list)))
(let ((c (peek port)))
(if (delimiter? c)
(list->string (reverse chars))
(begin (get-ch port) (loop (cons c chars)))))))
(define named-chars
'(("space" . #\space) ("newline" . #\newline) ("tab" . #\tab)
("return" . #\return) ("nul" . #\nul) ("null" . #\nul)
("delete" . #\delete) ("escape" . #\escape) ("alarm" . #\alarm)
("backspace" . #\backspace)))
(define (read-char-lit port)
(let ((first (get-ch port)))
(when (eof-object? first)
(error "Unexpected end of input in character literal"))
(if (char-alphabetic? first)
(let ((rest (read-atom-string port)))
(if (string=? rest "")
first
(let ((name (string-append (string first) rest)))
(cond
((assoc name named-chars) => cdr)
(else (error "Unknown character name" name))))))
first)))
;;; String literal with escape processing, matching the common escapes
;;; the previous reader (CHICKEN `read') interpreted
(define (read-string-lit port)
(get-ch port) ; consume opening quote
(let loop ((chars (list)))
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unterminated string literal"))
((char=? c #\") (list->string (reverse chars)))
((char=? c #\\) (loop (cons (read-escape port) chars)))
(else (loop (cons c chars)))))))
(define (read-escape port)
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unterminated string literal"))
((char=? c #\n) #\newline)
((char=? c #\t) #\tab)
((char=? c #\r) #\return)
((char=? c #\a) #\alarm)
((char=? c #\b) #\backspace)
((char=? c #\f) (integer->char 12))
((char=? c #\v) (integer->char 11))
((char=? c #\0) #\nul)
(else c)))) ; \" \\ and anything else: literal
(define (skip-block-comment port depth)
(if (= depth 0)
#t
(let ((c (get-ch port)))
(cond
((eof-object? c) (error "Unterminated block comment"))
((and (char=? c #\|) (eqv? (peek port) #\#))
(get-ch port) (skip-block-comment port (- depth 1)))
((and (char=? c #\#) (eqv? (peek port) #\|))
(get-ch port) (skip-block-comment port (+ depth 1)))
(else (skip-block-comment port depth))))))
;;; Read every top-level form from `port'. Locations are recorded by
;;; next-token, for every form rather than only these
(define (parse-all port)
(parameterize ((current-line 1))
(let loop ((acc (list)))
(skip-whitespace port)
(let ((tok (next-token port)))
(cond
((eof-object? tok) (reverse acc))
((or (eq? tok close-paren)
(eq? tok close-bracket))
(error "Unmatched closing bracket at top level"))
((eq? tok dot-token)
(error "Unexpected . at top level"))
(else
(loop (cons tok acc))))))))
;;; Entry point: read all forms from a file, or from the current input
;;; port when the source is 'stdin
(define (read-from-file file)
;; Resolve the name before with-directory moves us, so an imported
;; module's forms carry that module's path rather than the importer's
(let ((source-file (to-absolute-pathname file)))
(with-directory file
(with-input-from-file (pathname-strip-directory file)
(lambda ()
(parameterize ((current-source-file source-file))
(parse-all (current-input-port))))))))
(define (read-raw-forms input-source)
(if (eq? input-source 'stdin)
(parameterize ((current-source-file "stdin"))
(parse-all (current-input-port)))
(read-from-file input-source)))

2
semen.module.scm
View File

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

1240
semen.scm
View File

File diff suppressed because it is too large Load Diff

1083
sex-fmt-c.scm
View File

File diff suppressed because it is too large Load Diff

9
sex-macros.module.scm
View File

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

29
sex-macros.scm
View File

@@ -1,50 +1,31 @@
(declare (unit sex-macros))
(import
scheme
(only fmt fmt)
(chicken base)
(chicken plist)
(chicken string))
(define (cat-syms s-1 s-2)
(import fmt)
(fmt #f s-1 s-2))
(define (cat sym-1 sym-2)
(string->symbol (cat-syms sym-1 sym-2)))
;;; The reader keeps `;' comments as (comment "...") forms so they can
;;; be re-emitted into the generated C. In a macro body a comment
;;; should be a call which does nothing, hence this one
(define (comment . _)
(void))
(define (register-macro name arglist body)
(put! name 'sex-macro
`(lambda ,arglist
;; A macro body is ordinary Scheme, evaluated at compile
;; time. It gets `cat' for building names, and read access to
;; the type database
(import scheme
(scheme base)
;; a type is a list, so a macro reading one wants
;; `(third type)' rather than `(caddr type)'
(only srfi-1 first second third fourth fifth last)
(only sex-macros cat comment)
(only types get-type-info get-tag-info get-fields
get-underlying-type type-match type-pattern-matches?
map-fields
get-name-type get-return-type type-of))
,@body)))
(define (get-macro name)
(eval (get name 'sex-macro)))
(define (macro? form)
(define (sex-macro? form)
(and (list? form)
(symbol? (car form))
(get (car form) 'sex-macro)))
(define (apply-macro form)
(assert (macro? form)
(assert (sex-macro? form)
(fmt #f (car form) " is not a macro"))
(apply (get-macro (car form))
(cdr form)))

4
sex-mode.el
View File

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

5
sex-modules.module.scm
View File

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

78
sex-modules.scm
View File

@@ -1,25 +1,21 @@
(import
scheme
brev-separate
(chicken base)
(chicken file)
(chicken load)
(chicken pathname)
(chicken process-context)
(chicken string)
fmt
matchable
reader
srfi-1
utils)
; Why `sex-modules`? Probably `modules` unit is reserved by chicken,
; things start to break.
(declare (unit sex-modules)
(uses sex-reader
utils))
(import brev-separate
(chicken file)
(chicken load)
(chicken pathname)
(chicken process-context)
(chicken string)
fmt
srfi-1)
(define +persistent-module-paths+ (list))
;;; for guarding against multiple imports (sort of mandatory #pragma
;;; once)
(define +imported-modules+ (list))
(define (get-modules-public-forms module-list)
(define (get-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
@@ -34,11 +30,7 @@
(let ((module-path (locate-module name)))
(assert module-path (fmt #f "Failed to find module " name " in "
(get-module-paths)))
(if (member module-path +imported-modules+)
(list)
(begin
(set! +imported-modules+ (cons module-path +imported-modules+))
(read-public-interface module-path)))))
(read-public-interface module-path)))
(define (get-module-paths)
(cons (current-directory)
@@ -72,35 +64,19 @@
(list)
raw-forms)))
(define (public-fn-interface raw-form)
;; (pub fn name args ret . body) -> prototype, keeping a docstring so
;; the importer can emit it above the declaration
(let ((form (strip-header-comments raw-form 5)))
(match form
(('pub 'fn name args ret)
form)
(('pub 'fn name args ret ('comment . _) . rest)
(public-fn-interface `(pub fn ,name ,args ,ret ,@rest)))
(('pub 'fn name args ret (? string? doc) . _)
`(pub fn ,name ,args ,ret ,doc))
(('pub 'fn name args ret . _)
`(pub fn ,name ,args ,ret)))))
;;; TODO: use semen facilities to analyze modules
(define (process-public-interface-form form acc)
(match form
;; Reduced to a prototype, still `pub', so the importer declares it
;; with external linkage
(('pub 'fn . _)
(cons (copy-form-source! form (public-fn-interface form)) acc))
(('pub 'var . _)
(match-let ((('pub 'var name type . _) (strip-header-comments form 4)))
(cons (copy-form-source! form `(extern var ,name ,type)) acc)))
(('pub (or 'define 'defmacro 'enum 'import 'include 'struct 'typedef 'union) . _)
(cons (copy-form-source! form (cdr form)) acc))
(('pub . _)
(sex-error form "pub must be followed by a definition" 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

22
sex-reader.scm Normal file
View File

@@ -0,0 +1,22 @@
(declare (unit sex-reader))
(include "utils.macros.scm")
(import (chicken pathname)
brev-separate
fmt)
(define (read-forms acc)
(let ((r (read)))
(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-raw-forms input-source)
(if (eq? input-source 'stdin)
(read-forms (list))
(read-from-file input-source)))

BIN
sex.png
View File

Binary file not shown.
Side by Side

Before

Width:  |  Height:  |  Size: 600 KiB

1
sexc.module.scm
View File

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

175
sexc.scm
View File

@@ -1,24 +1,22 @@
(import scheme
(scheme base) ; call/cc
brev-separate
(chicken base)
(chicken condition) ; handle-exceptions
(declare (unit sexc)
(uses fmt-c-writer
sex-reader
semen))
(include "utils.macros.scm")
(import brev-separate
(chicken file)
(chicken plist)
(chicken pretty-print)
(chicken process)
(chicken process-context)
(chicken port)
(chicken string) ; string-split
fmt
fmt-c-writer
getopt-long
sex-macros
sex-modules
reader
semen
srfi-1 ; list routines
utils)
srfi-13
tree)
;;; Main function facilities
@@ -32,21 +30,10 @@
(required #f)
(value #f)
(single-char #\c))
(features ,(fmt #f "Comma-separated feature names, added to the host's own" nl
(pad padding) "for #+ and #- feature expressions. May be given" nl
(pad padding) "more than once")
(required #f)
(value #t)
(single-char #\f))
(no-platform-features
,(fmt #f "Leave out the host's own features. With --features," nl
(pad padding) "this reads a file the way another platform would")
(required #f)
(value #f))
(emit-c "Emit C code"
(required #f)
(value #f)
(single-char #\C))
(required #f)
(value #f)
(single-char #\C))
(public-interface "Get module's public interface"
(required #f)
(value #f))
@@ -62,14 +49,7 @@
(pad padding) "If -E or -m options are provided, defaults to stdout")
(required #f)
(value #t)
(single-char #\o))
(line-directives
,(fmt #f "How much #line information to emit: statement (default)," nl
(pad padding) "toplevel, or none. `statement' is what makes a debugger" nl
(pad padding) "land on the right source line; `none' is for reading -C" nl
(pad padding) "output by eye")
(required #f)
(value #t)))))
(single-char #\o)))))
(define (print-help)
(fmt #t "Usage: sexc [options] filename [-- options-for-c-compiler]\n")
@@ -85,39 +65,11 @@
(if arg (cdr arg)
default)))
;;; Everything before the first `--' is ours to parse, everything after
;;; is handed to the C compiler verbatim
(define (separator? a)
(string=? a "--"))
(define (args-before-separator argv)
(take-while (complement separator?) argv))
(define (args-after-separator argv)
(let ((tail (drop-while (complement separator?) argv)))
(if (null? tail)
(list)
(cdr tail))))
(define (get-rest-args args)
(cdr (assoc '@ args)))
(define (line-directives-arg args)
(let ((v (get-arg args 'line-directives "statement")))
(cond ((equal? v "statement") 'statement)
((equal? v "toplevel") 'toplevel)
((equal? v "none") 'none)
(else (error "--line-directives must be statement, toplevel or none, got" v)))))
;;; --features may be given more than once, and each may name several.
;;; Collect all of them
(define (cli-features args)
(append-map (lambda (entry)
(map string->symbol (string-split (cdr entry) ",")))
(filter (lambda (entry) (eq? (car entry) 'features)) 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)))
@@ -133,69 +85,40 @@
(define (emit-c-or-sex sex-forms output args)
(write-to-file-or-stdout output
(lambda ()
(if (get-arg args 'macro-expand #f)
(map pp sex-forms)
(emit-c sex-forms)))))
(lambda ()
(if (get-arg args 'macro-expand #f)
(map pp sex-forms)
(emit-c sex-forms)))))
(define (compile-to-file sex-forms output args cc-args)
"Hand the generated C to the C compiler. Returns the compiler's exit
status, which is ours to pass on."
(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))
;; The generated C goes to a temporary .c file rather than the
;; compiler's stdin. It is removed however we leave -- emit-c
;; can throw, and used to leave the file behind when it did
(c-file (create-temporary-file "c")))
;; An unhandled error ends the process without unwinding, so the
;; cleanup cannot be left to dynamic-wind
(handle-exceptions exn
(begin (delete-file* c-file) (abort exn))
(with-output-to-file c-file
(lambda () (emit-c sex-forms)))
(let ((proc (process compiler (append (list "-o" out-file)
(if (get-arg args 'compile-object #f)
(list "-c")
(list))
(list c-file)
cc-args))))
(call-with-values (lambda () (process-wait proc))
(lambda (pid normal-exit? status)
(delete-file* c-file)
(if normal-exit? status 1)))))))
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
(append
'((include inttypes.h)
(include stdbool.h)
(include stddef.h) ; max_align_t, for closure environments
(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))
;; The closure environment is the part of the ABI, so include it in
;; every module
(list (closure-env-declaration))))
(semen-process raw-forms))))
(define (main)
(let* ((argv (command-line-arguments))
(raw-args (args-before-separator argv))
(cc-args (args-after-separator argv))
(let* ((raw-args (command-line-arguments))
(args (getopt-long raw-args
opts-grammar))
(output (get-arg args 'output 'default))
@@ -208,14 +131,6 @@ status, which is ours to pass on."
(when help
(print-help)
(return #f))
;; Read time comes before everything, so the features have to be
;; in place before the first form is read
(current-features
(append (if (get-arg args 'no-platform-features #f)
(list)
(platform-features))
(cli-features args)))
(when (get-arg args 'public-interface #f)
(assert (not (eq? input 'stdin)) "Error: --public-interface requires file argument")
@@ -227,21 +142,11 @@ status, which is ours to pass on."
(return #f))
(load-persistent-module-paths)
;; The file name in a #line directive now comes from the form's
;; own recorded location, so imported modules report themselves
;; rather than the unit that imported them
(sex-line-directives (line-directives-arg args))
(when (and (get-arg args 'emit-c #f)
(not (get-arg args 'line-directives #f)))
(sex-line-directives 'none))
(let* ((raw-forms (append prelude (read-raw-forms input)))
(let* ((raw-forms (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! The C compiler's status is ours too
(let ((status (compile-to-file sex-forms output args cc-args)))
(unless (zero? status)
(exit status)))))))))
;; Compile file!
(compile-to-file sex-forms output args)))))))

52
tests/Makefile
View File

@@ -1,53 +1 @@
CHICKEN_C = csc
CSC_FLAGS += -K prefix -static
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
MODULES = utils types infer 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 line-directives codegen args types infer
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
types.o: types.module.scm ../types.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) types.module.scm -o types.o -unit types
infer.o: infer.module.scm ../infer.scm types.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) infer.module.scm -o infer.o -unit infer -link types,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 utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
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 infer.o sex-macros.o sex-modules.o types.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) semen.module.scm -o semen.o -unit semen -link sex-macros,sex-modules,infer,types,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 types.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,types,utils
sexc.o: sexc.module.scm infer.o types.o ../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,infer,types,utils
clean:
rm -f $(SEX_OBJ)
rm -f *.import.scm
rm -f *.link
rm -f sex-tests
.PHONY: clean

55
tests/args.scm
View File

@@ -1,55 +0,0 @@
;;; Splitting the command line at `--'.
;;;
;;; getopt-long cannot do this: it consumes the separator and merges
;;; everything after it into `@' alongside the input file. So sexc
;;; splits the raw argv first, and only the head is parsed as options.
;;; Everything else reaches the C compiler exactly as written --
;;; including the words that do not start with a dash, which a previous
;;; leading-dash heuristic used to drop.
(import sexc)
(define full '("foo.sex" "-o" "bar" "--" "-framework" "OpenGL" "-Wall"))
(test-group "argument separator"
(test "options and input file stay with sexc"
'("foo.sex" "-o" "bar")
(args-before-separator full))
(test "the tail reaches the compiler verbatim"
'("-framework" "OpenGL" "-Wall")
(args-after-separator full))
;; The case that motivated this: `OpenGL' has no leading dash and was
;; silently dropped, leaving `-framework' to swallow whatever flag
;; came next.
(test "a word without a dash survives"
'("-framework" "OpenGL")
(args-after-separator '("x.sex" "--" "-framework" "OpenGL")))
(test "no separator means nothing for the compiler"
'()
(args-after-separator '("foo.sex" "-o" "bar")))
(test "no separator leaves every argument with sexc"
'("foo.sex" "-o" "bar")
(args-before-separator '("foo.sex" "-o" "bar")))
(test "a trailing separator is allowed"
'()
(args-after-separator '("foo.sex" "--")))
(test "a leading separator leaves no input file"
'()
(args-before-separator '("--" "-lm")))
;; Only the first `--' separates; a later one is an ordinary compiler
;; argument (ld takes several).
(test "only the first separator counts"
'("-Wl,--as-needed" "--" "-lm")
(args-after-separator '("x.sex" "--" "-Wl,--as-needed" "--" "-lm")))
(test "an empty command line is handled"
'()
(args-before-separator '())))

76
tests/basic.scm
View File

@@ -1,51 +1,35 @@
(import fmt-c-writer)
(test-begin "basic")
(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 '--->>>))
;; 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 '%var (atom-to-fmt-c 'var))
(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))
(test '%cast (atom-to-fmt-c 'cast))
;; Non-ASCII identifiers must survive intact. The `regex' egg's
;; string-substitute drops one trailing character per multi-byte
;; character, which renames things silently -- the C still compiles,
;; just under a different name than was written.
(test 'naïve_count (unkebabify 'naïve-count))
(test 'aï_b (unkebabify 'aï-b))
(test 'ïï (unkebabify 'ïï))
;;; c89 stuff
(test 'int (atom-to-fmt-c 'bool))
(test 1 (atom-to-fmt-c 'true))
(test 0 (atom-to-fmt-c 'false))
;; 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 'do))
(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))
;;; make-field-access
(test 'a.b (make-field-access '(.b a)))
(test 'a.b.c (make-field-access '(.c a.b)))
;; C99 onwards, true C spellings for bool
(test 'bool (atom-to-fmt-c 'bool))
(test 'true (atom-to-fmt-c 'true))
(test 'false (atom-to-fmt-c 'false))
;; dot-access -> %. member-access directive (kebab-converted operands)
(test '(%. a b) (walk-expr '(dot-access a b)))
(test '(%. a b c) (walk-expr '(dot-access a b c)))
(test '(%. a_b c) (walk-expr '(dot-access a-b c)))
;; comment -> %comment directive (rendered as /* ... */)
;; The reader eats only the `;' that introduced the line, so ";;; Foo"
;; arrives as ";; Foo"; and c-comment puts nothing between /* */ and
;; the text. Both are handled on the way out.
(test '(%comment " hi ") (walk-expr '(comment " hi")))
(test '(%comment " hi ") (process-toplevel-form '(comment " hi")))
(test '(%comment " Foo ") (walk-expr '(comment ";; Foo")))
(test '(%comment " Foo ") (walk-expr '(comment ";;; Foo "))))
(test-end)

611
tests/codegen.scm
View File

@@ -1,611 +0,0 @@
;;; Codegen details that are easy to get subtly wrong, and that the
;;; walk-* unit tests cannot see: they check the intermediate form we
;;; hand to fmt-c, not the C that fmt-c renders from it.
;;;
;;; Both cases below were found by writing an OpenGL example, not by
;;; the existing suite, because both need an operand shape that no
;;; earlier test program happened to use.
(import (chicken condition)
(chicken port)
(chicken string)
srfi-13
fmt-c-writer
reader
semen
utils)
(define (sex->c source)
"Compile SOURCE, a string of Sex, and return the generated C."
(let ((forms (with-input-from-string source
(lambda ()
(parameterize ((current-source-file "codegen.sex"))
(parse-all (current-input-port)))))))
(with-output-to-string
(lambda ()
(parameterize ((sex-line-directives 'none))
(emit-c (semen-process forms)))))))
(define (emits? source fragment)
(and (string-contains (sex->c source) fragment) #t))
(define (error-message source)
"Compile SOURCE and return the error text as the user sees it --
message plus arguments, the way CHICKEN prints it -- or #f if SOURCE
compiles."
(handle-exceptions e
(with-output-to-string
(lambda ()
(display ((condition-property-accessor 'exn 'message) e))
(for-each (lambda (a) (display " ") (write a))
((condition-property-accessor 'exn 'arguments) e))))
(begin (sex->c source) #f)))
(define (reports? source fragment)
(let ((m (error-message source)))
(and m (string-contains m fragment) #t)))
(define (in-fn body)
(string-append "(fn f ((a int) (b int)) void " body ")"))
(test-group "codegen"
;; c-switch handed its scrutinee straight to `cat', which only works
;; when it is an atom. Anything else was displayed as a raw
;; s-expression: `switch ((%. e type))'.
(test-group "switch scrutinee"
(test-assert "member access"
(emits? "(struct s ((type int))) (fn f ((e (struct s))) void (switch (. e type) (case 1 (g))))"
"switch (e.type)"))
(test-assert "call"
(emits? (in-fn "(switch (g a) (case 1 (h)))")
"switch (g(a))"))
(test-assert "arithmetic"
(emits? (in-fn "(switch (+ a b) (case 1 (h)))")
"switch (a + b)")))
;; A cast binds tighter than every binary operator, so an operand
;; that is itself a binary expression has to be parenthesised --
;; otherwise the cast silently applies to the first operand only.
(test-group "cast precedence"
(test-assert "binary operand is parenthesised"
(emits? (in-fn "(var p (* void) (cast (* 2 (sizeof int)) (* void)))")
"(void *)(2 * sizeof(int))"))
(test-assert "subtraction operand is parenthesised"
(emits? (in-fn "(var f float (cast (- a b) float))")
"(float)(a - b)"))
;; ...but exactly once. The operand used to parenthesise itself
;; again inside the parens the cast had just added.
(test-assert "and not parenthesised twice"
(not (emits? (in-fn "(var f float (cast (- a b) float))")
"(float)((a - b))")))
;; Unary operands are already unary-expressions and must be left
;; alone, or every existing cast in the tree gains noise.
(test-assert "identifier is left bare"
(emits? (in-fn "(var f float (cast a float))")
"(float)a"))
(test-assert "address-of is left bare"
(emits? (in-fn "(var p (* int) (cast (& a) (* int)))")
"(int *)&a"))
(test-assert "sizeof is left bare"
(emits? (in-fn "(var n int (cast (sizeof int) int))")
"(int)sizeof(int)")))
;; A comment among a call's arguments used to become an argument,
;; and c-apply put a comma on each side of it -- which does not
;; compile. It is dropped, as in any other expression context.
(test-group "comments among arguments"
(test-assert "no stray comma"
(not (emits? (in-fn "(g 1 ;; c\n 2)") "*/,")))
(test-assert "the arguments survive"
(emits? (in-fn "(g 1 ;; c\n 2)") "g(1, 2)")))
;; The reader leaves the `;'s that introduced each line, and a run of
;; comment lines arrives as one form per line.
(test-group "comment rendering"
(test-assert "the markers are stripped"
(emits? "(fn f () void ;;; Foo\n (g))" "/* Foo */"))
(test-assert "so none survive into the C"
(not (emits? "(fn f () void ;;; Foo\n (g))" ";;")))
(test-assert "consecutive lines are packed into one comment"
(emits? "(fn f () void\n ;; first\n ;; second\n (g))"
"/* first\n second */"))
;; Packing compares locations rather than just looking for adjacent
;; comment forms, so a blank line still separates them.
(test-assert "a blank line keeps them apart"
(emits? "(fn f () void\n ;; first\n\n ;; second\n (g))" "/* first */")))
;; A `;' comment is a form, so one written inside a construct with
;; positional slots used to land in a slot and shift everything after
;; it -- silently. In an `if' the comment became the then-arm and the
;; then-arm became an `else if' condition, and it still compiled.
;; Comments are now taken out of the slots and emitted just before the
;; statement; comments in a body stay where they were written.
(test-group "comments in positional slots"
(test-assert "an if arm is not shifted"
(not (emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "else if")))
(test-assert "and both arms survive"
(emits? (in-fn "(if 1 ;; c\n (g 1) (g 2))") "g(1)"))
(test-assert "the comment survives too"
(emits? (in-fn "(if 1 ;; kept here\n (g 1) (g 2))") "kept here"))
(test-assert "a for header is not shifted"
(emits? (in-fn "(for ;; c\n (var i int 0) (< i 2) (++ i) (g i))")
"for (int i = 0; i < 2; ++i)"))
(test-assert "a while condition is not shifted"
(emits? (in-fn "(while ;; c\n (< a b) (g 1))") "while (a < b)"))
(test-assert "a var is not shifted"
(emits? (in-fn "(var ;; c\n x int 5)") "int x = 5"))
(test-assert "a cast is not shifted"
(emits? (in-fn "(var y int (cast ;; c\n a int))") "(int)a"))
;; Bodies are a statement sequence, so comments there stay put.
(test-assert "a comment in a body stays in the body"
(emits? (in-fn "(while (< a b) ;; inside\n (g 1))")
"while (a < b) {")))
(test-group "pub enum"
(test-assert "is emitted"
(emits? "(pub enum color (red green blue))" "enum color"))
(test-assert "with its values"
(emits? "(pub enum color (red green blue))" "red"))
(test-assert "and a non-pub enum still is too"
(emits? "(enum color (red green blue))" "enum color"))
;; Naming an enum as a type, rather than defining it, had no
;; walk-enum clause and died with `(match) no matching pattern'
(test-assert "and it can then be used as a type"
(emits? "(enum color (red green blue)) (fn f () void (var m (enum color) red))"
"enum color m = red"))
(test-assert "a malformed enum is rejected with its location"
(reports? "(enum)" "codegen.sex:1:"))
;; c-type handed the declarator's name to c-enum as the enum tag,
;; so this emitted `enum m { up, down }' with no variable at all
(test-assert "an anonymous enum keeps the variable"
(emits? "(fn f () void (var e (enum (up down)) up))" "} e = up"))
(test-assert "and a named definition keeps both"
(emits? "(fn f () void (var n (enum named (a b)) a))" "enum named{")))
;; `|', `||' and `|=' read as ordinary symbols -- our own reader has
;; no |symbol| syntax for them to collide with -- but fmt-c cannot
;; dispatch on a symbol whose name it cannot write in Scheme source,
;; so they used to fall through to the function-call path and emit
;; `|\||(a, b)'. The writer renames them to heads fmt-c spells with
;; a string.
(test-group "bitwise and logical operators"
(test-assert "bit-or"
(emits? (in-fn "(var x int (| a b))") "int x = a | b"))
(test-assert "logical or"
(emits? (in-fn "(var x int (|| a b))") "int x = a || b"))
(test-assert "or-assign"
(emits? (in-fn "(|= a b)") "a |= b"))
(test-assert "bit-and"
(emits? (in-fn "(var x int (& a b))") "int x = a & b"))
(test-assert "logical and"
(emits? (in-fn "(var x int (&& a b))") "int x = a && b"))
;; Precedence too: the operator reaches fmt-c as a string it looks
;; up, not as a symbol in its table
(test-assert "parenthesised where C needs it"
(emits? (in-fn "(var x int (& (| a b) a))") "(a | b) & a"))
(test-assert "and left alone where it does not"
(emits? (in-fn "(var x int (| a (& a b)))") "int x = a | a & b"))
;; The spelling from before they could be written directly
(test-assert "c-or is still accepted"
(emits? (in-fn "(var x int (c-or a b))") "a || b"))
(test-assert "c-bit-or is still accepted"
(emits? (in-fn "(var x int (c-bit-or a b))") "a | b")))
;; A `;' comment is a form. In a macro body `comment' is a no-op
;; that swallows the comment itself. Inside a quasiquoted payload
;; the same form is data, never evaluated, and reaches the writer
;; intact
(test-group "comments in macros"
(test-assert "a comment in the payload reaches the C"
(emits? "(defmacro (m-kept) `(fn f () void\n ;; this survives\n (g)))\n(m-kept)"
"this survives"))
(test-assert "a comment about the macro does not"
(not (emits? "(defmacro (m-dropped)\n ;; this vanishes\n `(fn f () void (g)))\n(m-dropped)"
"this vanishes")))
(test-assert "and the macro still expands"
(emits? "(defmacro (m-both)\n ;; about the macro\n `(fn f () void (g)))\n(m-both)"
"void f (void)")))
;; Diagnostics name also the place. Every form carries a (file
;; . line), so an error can cite it
(test-group "errors cite the source location"
(test-assert "unknown toplevel form"
(reports? "(include stdio.h)\n(wat 1 2)" "codegen.sex:2: unknown top level form"))
(test-assert "the offending form is shown too"
(reports? "(include stdio.h)\n(wat 1 2)" "(wat 1 2)"))
(test-assert "pub with nothing to define"
(reports? "(pub 1)" "codegen.sex:1:")))
;; A nested pointer chain used to silently lose a level:
;; (var p (* (* char))) emitted `char *p'
(test-group "malformed types are rejected"
(test-assert "nested pointer chain"
(reports? (in-fn "(var p (* (* char)))") "pointer chains are written flat"))
(test-assert "and names the line"
(reports? "(pub fn f () void\n (var p (* (* char))))" "codegen.sex:2:"))
;; A sublist that only groups has no `*' in it and must still work.
(test-assert "grouping sublist still accepted"
(emits? (in-fn "(var s (* (const struct suc)) 0)") "const struct suc * s"))
(test-assert "flat chain still accepted"
(emits? (in-fn "(var q (* * const char) 0)") "const char * * q")))
;; A string as the first body form (or after the name of a struct,
;; union or enum) is a docstring: it becomes a comment immediately
;; before the declaration, not a statement inside it.
(test-group "docstrings"
(test-assert "appears before the function"
(emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
"/* Greet NAME. */"))
(test-assert "and not inside the body as a statement"
(not (emits? "(fn greet ((name (* char))) void \"Greet NAME.\" (printf \"hi\" name))"
"\"Greet NAME.\"")))
(test-assert "multiline keeps its paragraphs"
(emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
"Entry point."))
(test-assert "and the second paragraph too"
(emits? "(pub fn main () int \"Entry point.\n\nARGC and ARGV.\" (return 0))"
"ARGC and ARGV."))
(test-assert "a prototype with only a docstring stays a prototype"
(emits? "(fn helper ((a int)) int \"Forward.\")"
"helper (int a);"))
(test-assert "a string after the first statement is left alone"
(emits? "(fn f () void (g) \"not a docstring\")"
"\"not a docstring\""))
(test-assert "a struct docstring sits above the struct"
(emits? "(struct point \"A 2D point.\" ((x int) (y int)))"
"/* A 2D point. */"))
(test-assert "and an enum docstring too"
(emits? "(enum color \"RGB.\" (red green blue))"
"/* RGB. */")))
;; `static-assert' is the keyword rather than the <assert.h> macro, so
;; a static assertion costs no include. Mapped in `atom-to-fmt-c'
;; because `unkebabify' alone would spell it `static_assert'.
(test-group "static-assert"
(test-assert "emits the C11 keyword"
(emits? (in-fn "(static-assert (== (sizeof int) 4) \"int is four bytes\")")
"_Static_assert(sizeof(int) == 4, \"int is four bytes\")"))
(test-assert "and not the header macro"
(not (emits? (in-fn "(static-assert (== (sizeof int) 4) \"x\")")
"static_assert("))))
;; A closure is a code pointer beside its captures. The struct is
;; named from the signature, so separate translation units agree on
;; it, and calling one goes through `code' with `env' passed first.
;;
;; A closure struct, and the helper its calls go through, are each
;; emitted once per signature; the registries deciding that are
;; compile-time state like the type databases, and outlive a single
;; `sex->c' here. So every case below that looks for a *definition*
;; uses a signature of its own -- cases looking at a call site can
;; share one.
(test-group "closures"
(test-assert "the type becomes a struct named for its signature"
(emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
"struct ƛint_int"))
;; The environment is one shared union, declared in the prelude --
;; its layout is part of the ABI two units agree on, so it cannot
;; depend on what either file contains. `sex->c' has no prelude, so
;; what is visible here is the member
(test-assert "whose environment is the shared union"
(emits? "(fn f ((c (closure ((float)) int))) int (return (c 1.0)))"
"union ƛenv env;"))
;; The receiver goes through a helper rather than being written
;; out twice, so that `[table (++ i)]' evaluates its index once,
;; exactly as it would for an array of function pointers
(test-assert "a call passes the receiver to a helper"
(emits? "(fn f ((c (closure ((int)) int))) int (return (c 1)))"
"ƛint_int_call(c, 1)"))
(test-assert "and the helper is what dereferences it"
(emits? "(fn f ((c (closure ((long)) int))) int (return (c 1)))"
"ƛc.code(&ƛc.env, ƛa0)"))
(test-assert "a subscript receiver is evaluated once"
(emits? "(fn f ((t (¤ (closure ((int)) int) 4)) (i int)) int (return ((¤ t (++ i)) 1)))"
"ƛint_int_call(t[++i], 1)"))
(test-assert "so is a member receiver"
(emits? "(struct h ((cb (closure ((int)) int))))
(fn f ((s (struct h))) int (return ((. s cb) 1)))"
"ƛint_int_call(s.cb, 1)"))
(test-assert "a captured name is rebound in the lifted body"
(emits? "(fn f ((n int)) (closure ((char)) int) (return (closure ((x char)) int (n) (return n))))"
"int n = ƛcaptures->n;"))
(test-assert "captures are checked against the environment"
(emits? "(fn f ((n int)) (closure ((short)) int) (return (closure ((x short)) int (n) (return n))))"
"_Static_assert(sizeof(struct"))
;; A closure over nothing has no record to point at, and C has no
;; empty struct to declare for it
(test-assert "no captures means no capture record"
(not (emits? "(fn f () (closure () int) (return (closure () int () (return 7))))"
"_captures {")))
;; `(name expr)' names a capture and gives what it holds, so the
;; expression is evaluated once, where the closure is written
(test-assert "a named capture takes its type from the expression"
(emits? "(struct p ((x int) (y int)))
(fn f ((s (struct p))) (closure () int)
(return (closure () int ((sum (+ (. s x) (. s y)))) (return sum))))"
"int sum;"))
(test-assert "and the constructor is handed the expression"
(emits? "(struct p ((x int) (y int)))
(fn f ((s (struct p))) (closure () int)
(return (closure () int ((sum (+ (. s x) (. s y)))) (return sum))))"
"_make(s.x + s.y)"))
(test-assert "capturing a pointer is how by-reference is spelled"
(emits? "(struct p ((x int)))
(fn f ((s (* (struct p)))) (closure () int)
(return (closure () int ((q s)) (return (-> q x)))))"
"struct p* q;"))
;; A bare function is a closure that captures nothing, so it
;; converts wherever one is expected -- the pointer goes in the
;; environment and one thunk per signature reads it back out
(test-assert "a named function in a var initializer"
(emits? "(fn g ((n int)) int (return n))
(fn f () void (var c (closure ((int)) int) g))"
"ƛint_int_fromfn(g)"))
(test-assert "a lambda, which is a bare function too"
(emits? "(fn f () void (var c (closure ((int)) int)
(lambda ((n int)) int (return n))))"
"ƛint_int_fromfn(λ0_f)"))
(test-assert "an argument, against the parameter that signature wrote"
(emits? "(fn g ((n int)) int (return n))
(fn h ((c (closure ((int)) int))) int (return (c 1)))
(fn f () int (return (h g)))"
"h(ƛint_int_fromfn(g))"))
(test-assert "a return, against the declared return type"
(emits? "(fn g ((n int)) int (return n))
(fn f () (closure ((int)) int) (return g))"
"return ƛint_int_fromfn(g)"))
(test-assert "the thunk reads the pointer out of the environment"
(emits? "(fn g ((n float)) int (return 1))
(fn f () void (var c (closure ((float)) int) g))"
"return ƛcaptures->f(ƛa0)"))
;; a signature that does not match is left alone, and C rejects it
(test-assert "a function of the wrong signature does not convert"
(not (emits? "(fn g ((n float)) int (return 1))
(fn f () void (var c (closure ((int)) int) g))"
"_fromfn(g)")))
;; a closure is lifted into the function it was written in, so
;; there has to be one
(test-assert "a closure at toplevel is refused"
(reports? "(var c (closure () int) (closure () int () (return 1)))"
"only be written inside a function"))
(test-assert "and so is one in a struct field"
(reports? "(struct s ((f (closure () int) (closure () int () (return 1)))))"
"only be written inside a function"))
;; A block opens a scope, so what it declares ends with it
(test-assert "a name shadowed in a block does not escape it"
(emits? "(fn mk () (closure () int) (return (closure () int () (return 1))))
(fn f () int (var c (closure () int) (mk))
(do (var c int 9) (g c))
(return (c)))"
"ƛvoid_int_call(c)"))
(test-assert "and the shadowing declaration is what the block sees"
(emits? "(fn mk () (closure () int) (return (closure () int () (return 1))))
(fn f () int (var c (closure () int) (mk))
(do (var c int 9) (g c))
(return (c)))"
"g(c)"))
;; The receiver is written twice, so a name used as an argument
;; must not be mistaken for a call of its own
(test-assert "a closure passed as an argument stays a value"
(emits? "(fn g ((c (closure ((int)) int))) int (return 0))
(fn f ((c (closure ((int)) int))) int (return (g c)))"
"g(c)")))
;; a macro body reads types as lists, so the srfi-1 accessors are in
;; scope beside the type database
(test-group "macro list accessors"
(test-assert "third reads an array's length"
(emits? "(defmacro (len t) (third t))
(fn f () int (return (len (¤ int 7))))"
"return 7;"))
(test-assert "second reads a tag"
(emits? "(defmacro (tag t) (symbol->string (second t)))
(fn f () void (g (tag (struct point))))"
"g(\"point\")")))
;; `type-of' hands a macro the type of an *expression*, where
;; `get-name-type' only answers for a name. The macro is expanded
;; during the walk rather than before it, so the scope is still live.
(test-group "type-of"
(test-assert "a local, from its declaration"
(emits? "(defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
(fn f () int (var n int 0) (return (t n)))"
"return 1;"))
(test-assert "an expression, not just a name"
(emits? "(defmacro (t x) (type-match (type-of x) (double 1) (else 0)))
(fn f () int (var d double 0.0) (return (t (+ d 1))))"
"return 1;"))
(test-assert "a call, through the callee's signature"
(emits? "(fn g () float (return 1.0))
(defmacro (t x) (type-match (type-of x) (float 1) (else 0)))
(fn f () int (return (t (g))))"
"return 1;"))
;; a macro is shown the written spelling, not the generated struct
(test-assert "a closure, spelled the way it was written"
(emits? "(fn mk () (closure ((int)) int)
(return (closure ((b int)) int () (return b))))
(defmacro (t x) (type-match (type-of x) ((closure _ _) 1) (else 0)))
(fn f () int (var c _ (mk)) (return (t c)))"
"return 1;"))
(test-assert "and calling one has the closure's return type"
(emits? "(fn mk () (closure ((int)) int)
(return (closure ((b int)) int () (return b))))
(defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
(fn f () int (var c _ (mk)) (return (t (c 1))))"
"return 1;"))
;; outside an expansion there is no scope to ask about
(test-assert "a name the walk has not reached is unknown"
(emits? "(defmacro (t x) (type-match (type-of x) (int 1) (else 0)))
(fn f () int (return (t nope)))"
"return 0;")))
;; `_' as a type is written out from what the initializer says. The
;; answer comes from declarations and from the signature a call names,
;; never from unification -- a partial type would need one.
(test-group "wildcard types"
(test-assert "an integer literal"
(emits? (in-fn "(var x _ 42)") "int x = 42"))
(test-assert "a float literal"
(emits? (in-fn "(var x _ 3.5)") "double x = 3.5"))
(test-assert "a string literal"
(emits? (in-fn "(var x _ \"hi\")") "const char * x"))
(test-assert "a call, through the name table"
(emits? "(fn g ((a int)) float (return 1.0))
(fn f () void (var x _ (g 1)))"
"float x = g(1)"))
(test-assert "a struct member"
(emits? "(struct p ((a int) (b float)))
(fn f ((s (struct p))) void (var x _ (. s b)))"
"float x = s.b"))
(test-assert "an address, which composes"
(emits? "(struct p ((a int)))
(fn f ((s (struct p))) void (var x _ (& s)))"
"struct p* x = &s"))
(test-assert "a comparison is a bool"
(emits? (in-fn "(var x _ (< a b))") "bool x = a < b"))
;; a wildcard inside a spelling is solved in place, leaving the rest
;; of the written type alone -- this is what needs the unifier
(test-assert "a wildcard inside a pointer"
(emits? "(struct p ((a int)))
(fn f ((s (struct p))) void (var x (* _) (& s)))"
"struct p* x = &s"))
(test-assert "a wildcard inside an array"
(emits? (in-fn "(var t (¤ _ 3) #((¤ int 3) : 1 2 3))") "int t[3]"))
;; a compound literal carries its own type, where a brace
;; initializer has none and takes one from its context
(test-assert "a compound literal answers a bare wildcard"
(emits? "(struct p ((a int) (b int)))
(fn f () void (var x _ #((struct p) : 1 2)))"
"struct p x = (struct p){1, 2}"))
(test-assert "a brace initializer cannot"
(reports? (in-fn "(var x _ #(1 2))") "cannot infer the type"))
;; ...but its elements still solve the hole in an array type
(test-assert "elements solve an array's element type"
(emits? (in-fn "(var t (¤ _ 4) #(0 1 4 9))") "int t[4] = {0, 1, 4, 9}"))
(test-assert "including when there are fewer than the length"
(emits? (in-fn "(var t (¤ _ 10) #(1 2))") "int t[10] = {1, 2}"))
(test-assert "and they have to agree with each other"
(reports? (in-fn "(var t (¤ _ 2) #(1 \"s\"))") "type mismatch"))
;; a closure type reaches the solver as the struct that stands for
;; it, which is the spelling `parse-type' knows
(test-assert "a closure, from the signature that produced it"
(emits? "(fn mk () (closure ((int)) int)
(return (closure ((b int)) int () (return b))))
(fn f () void (var c _ (mk)))"
"struct ƛint_int c = mk()"))
(test-assert "and it is callable once inferred"
(emits? "(fn mk () (closure ((int)) int)
(return (closure ((b int)) int () (return b))))
(fn f () int (var c _ (mk)) (return (c 1)))"
"ƛint_int_call(c, 1)"))
;; C's usual arithmetic conversions, far enough to answer `_'
(test-assert "floating beats integral"
(emits? (in-fn "(var d double 1.0) (var x _ (+ a d))") "double x = a + d"))
(test-assert "the wider integer wins"
(emits? (in-fn "(var l long 1) (var x _ (+ a l))") "long x = a + l"))
(test-assert "double beats float"
(emits? (in-fn "(var g float 1.0) (var d double 1.0) (var x _ (+ g d))")
"double x = g + d"))
(test-assert "and same-width operands stay put"
(emits? (in-fn "(var g float 1.0) (var x _ (+ g g))") "float x = g + g"))
(test-assert "a pointer operand makes it pointer arithmetic"
(emits? "(struct p ((a int)))
(fn f ((s (struct p))) void (var x _ (+ (& s) 1)))"
"struct p* x = &s + 1"))
;; a written type that cannot match what the initializer gives
(test-assert "a mismatch is reported, not papered over"
(reports? (in-fn "(var p (* _) 42)") "type mismatch"))
;; a wildcard that cannot be answered is an error, not a guess
(test-assert "with no initializer there is nothing to infer from"
(reports? (in-fn "(var x _)") "cannot infer the type"))
(test-assert "nor from a name the compiler never saw declared"
(reports? (in-fn "(var x _ (never-declared))") "cannot infer the type")))
;; `(car res)' on the expansion assumed it was a pair, so a macro
;; computing a value rather than building a form crashed the compiler.
(test-group "macro expanding to an atom"
(test-assert "a number"
(emits? "(defmacro (two) 2) (fn f () int (return (two)))"
"return 2;"))
(test-assert "a string"
(emits? "(defmacro (who) \"sex\") (fn f () void (g (who)))"
"g(\"sex\")"))
;; a symbol expansion can stand where a type does, which is what
;; makes a macro able to compute one
(test-assert "a symbol, used as a type"
(emits? "(defmacro (ty) 'int) (fn f () void (var x (ty) 0))"
"int x = 0"))
;; ...and nothing at all, for a macro that only registers something
(test-assert "nothing, at toplevel"
(emits? "(defmacro (quiet) (list)) (quiet) (fn f () int (return 1))"
"return 1;"))
(test-assert "nothing, in a body"
(emits? "(defmacro (quiet) (list)) (fn f () int (quiet) (return 1))"
"return 1;"))
;; several forms need `$', which is what tells a splice from a call
(test-assert "$ splices"
(emits? "(defmacro (pair) (list '$ '(fn a () int (return 1))
'(fn b () int (return 2))))
(pair)"
"b (void)"))
(test-assert "and ($) is nothing at all"
(emits? "(defmacro (quiet) (list '$)) (quiet) (fn f () int (return 1))"
"return 1;"))
;; without `$' a list is one form, so a head that is itself a form
;; stays a call rather than becoming two statements
(test-assert "a computed callee stays one form"
(emits? "(fn mk () (closure ((int)) int)
(return (closure ((b int)) int () (return b))))
(defmacro (apply-it x) `((mk) ,x))
(fn f () int (return (apply-it 5)))"
"ƛint_int_call(mk(), 5)"))
;; spliced, it would have become two forms in the `return' -- the
;; comma operator, and the wrong answer
(test-assert "rather than two forms in its context"
(not (emits? "(fn mk () (closure ((int)) int)
(return (closure ((b int)) int () (return b))))
(defmacro (apply-it x) `((mk) ,x))
(fn f () int (return (apply-it 5)))"
"return mk(), 5"))))
;; A unary expression parenthesised its operand rather than itself, so
;; the parens landed inside: `*(p).x', which C reads as `*(p.x)'.
(test-group "unary operand precedence"
(test-assert "member access through a dereference"
(emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
"(*p).x"))
(test-assert "and not with the parens inside"
(not (emits? "(struct pt ((x int))) (fn f ((p (* (struct pt)))) int (return (. (* p) x)))"
"*(p).x")))
(test-assert "member access through a cast"
(emits? (in-fn "(var n int (. (* (cast a (* (struct s)))) f))")
"(*(struct s*)a).f"))
;; ...without gaining parens where none are due
(test-assert "a bare dereference is left alone"
(emits? (in-fn "(var p (* int) 0) (= a (* p))") "a = *p"))
(test-assert "so is address-of in an argument"
(emits? (in-fn "(g (& a))") "g(&a)"))
(test-assert "and negation beside a binary operator"
(emits? (in-fn "(var n int (+ (- a) b))") "-a + b")))
;; An array bound was taken only when it was an integer literal, so a
;; symbolic one fell into the type: `(¤ int N)' came out `int N a[]'.
(test-group "array bounds"
(test-assert "a symbolic bound"
(emits? "(define N 4) (struct s ((a (¤ int N))))" "int a[N]"))
(test-assert "an expression bound"
(emits? "(define N 4) (struct s ((a (¤ char (* 2 N)))))" "char a[2 * N]"))
(test-assert "an integer bound still works"
(emits? "(struct s ((a (¤ int 4))))" "int a[4]"))
;; a multi-word type is keywords all the way down, so a trailing
;; keyword belongs to the type and leaves the array unsized
(test-assert "a multi-word type is not a bound"
(emits? "(struct s ((a (¤ unsigned int))))" "unsigned int a[]"))
;; ...and a tag always follows its keyword
(test-assert "nor is an aggregate tag"
(emits? "(struct t ((z int))) (struct s ((a (¤ struct t))))" "struct t a[]"))
(test-assert "nor one behind a pointer"
(emits? "(struct t ((z int))) (struct s ((a (¤ * struct t))))" "struct t* a[]"))))

26
tests/exit-code/Makefile
View File

@@ -1,26 +0,0 @@
# The failure paths.
#
# Both need a process to show themselves, so neither fits the unit
# suite: sexc has to fail when cc fails -- exiting 0 after a failed
# compile makes every driver, sextest included, read it as success --
# and it has to clean up its temporary .c when its own emission throws.
#
# Everything is built inside a scratch TMPDIR, so nothing is left here
# to clean up.
SEXC ?= ../../sexc
check:
@d=`mktemp -d`; \
TMPDIR=$$d $(SEXC) nested-pointer.sex -o $$d/out >/dev/null 2>&1; \
if [ -n "`find $$d -name '*.c'`" ]; then \
echo "exit code FAILED: the temporary .c survived a failed emission"; \
rm -rf $$d; exit 1; \
fi; \
if $(SEXC) hello.sex -o $$d/out -- -no-such-cc-flag >/dev/null 2>&1; then \
echo "exit code FAILED: sexc reported success after cc failed"; \
rm -rf $$d; exit 1; \
fi; \
rm -rf $$d; echo "exit code ok"
.PHONY: check

4
tests/exit-code/hello.sex
View File

@@ -1,4 +0,0 @@
;;; Compiles cleanly, so the only way the build can fail is the bogus
;;; flag handed to cc -- which is the point.
(pub fn main () int
(return 0))

4
tests/exit-code/nested-pointer.sex
View File

@@ -1,4 +0,0 @@
;;; Rejected by the writer, so emit-c throws: there is a temporary .c
;;; by then, and it must not survive.
(fn f () void
(var p (* (* char))))

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

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

192
tests/fmt-c-writer.scm
View File

@@ -1,192 +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))))
;;; Initializers and compound literals
(test "a bare initializer is unchanged"
'#(1 2)
(walk-expr '#(1 2)))
(test "`:' ends the type and makes it a compound literal"
'(%compound (struct point) 3 4)
(walk-expr '#(struct point : 3 4)))
(test "the type is bare words, as everywhere else"
'(%compound (const char *) 65)
(walk-expr '#(* const char : 65)))
(test "and may be an array type"
'(%compound (%array int 3) 10 20 30)
(walk-expr '#(¤ int 3 : 10 20 30)))
(test "a grouped type is unwrapped the way a declaration's is"
'(%compound (%array int 3) 10)
(walk-expr '#((¤ int 3) : 10)))
(test "`.field value' is a designated initializer, kebab and all"
'(%compound (struct named) (%designate n 7) (%designate first_name "zoe"))
(walk-expr '#(struct named : .n 7 .first-name "zoe")))
(test "positional and designated may be mixed"
'(%compound (struct point) 1 (%designate y 5))
(walk-expr '#(struct point : 1 .y 5)))
(test "designators work in an untyped initializer too"
'#((%designate y 5))
(walk-expr '#(.y 5)))
;;; Fn defs
(test
'(%fun void puk ((int #f) ((%array float 8) #f)))
(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 bool (int (%array int))) min)))
(walk-struct '(struct mega-kebab
((a int)
(dob (struct ((year int)
(month int)
(day int))))
(min (fn ((int) (¤ int)) bool)))))))

45
tests/infer.module.scm
View File

@@ -1,45 +0,0 @@
(module infer
(;; The IR
tvar?
tvar-id
tvar-classes
tvar-rigid?
fresh-tvar
fresh-rigid-tvar
prim-type? prim-name prim-quals make-prim
ptr-type? ptr-target ptr-quals make-ptr
array-type? array-elt array-size make-array-type
fn-type? fn-ret fn-args fn-variadic? make-fn-type
agg-type? agg-kind agg-name agg-spelling agg-quals make-agg
alias-type? alias-name alias-expansion alias-quals make-alias
unknown-type? the-unknown-type
resolve
underlying
c-primitive?
type-quals
free-tvars
decay
;; The boundary
parse-type
unparse-type
;; Constraints
register-class!
add-instance!
entails?
default-tvar!
default-type-variables!
;; Unification
unify
;; Type schemes
scheme? scheme-vars scheme-constraints scheme-type
make-scheme
generalize
instantiate
substitute)
"../infer.scm")

319
tests/infer.scm
View File

@@ -1,319 +0,0 @@
;;; Type inference, layer 0.
;;;
;;; Names registered in the type database are prefixed, since the
;;; database is one table shared by every suite in the linked binary.
(import infer types (chicken sort))
;;; Parse and print a surface type again. Everything in this suite goes
;;; through this pair, which is deliberate: they are the only thing the
;;; rest of the compiler will ever see of the IR.
(define (round-trip surface)
(unparse-type (parse-type surface)))
(test-group "infer"
(test-group "round-trip"
;; Every spelling below appears in example/ or tests/, or is one
;; the C writer documents in walk-type. `type-match' compares types
;; with equal?, so a near miss here is not a cosmetic bug -- it is
;; a reflection macro silently falling into its else branch.
(for-each
(lambda (surface)
(test (conc "round-trips: " surface) surface (round-trip surface)))
'(int
void
char
float
double
size-t
GLfloat
(unsigned int)
(long long)
(const int)
(const char)
(* char)
(* void)
(* const char)
(* * char)
(* const * const char)
(const * const char)
(* FILE)
(* SDL-Window)
(struct point)
(struct list-int)
(union value)
(enum mood)
(const struct list-int)
(* struct list-int)
(* const struct point)
(¤ int 16)
(¤ char 512)
(¤ GLfloat 15)
(¤ float)
(¤ * const char)
(¤ * const struct res 32)
(¤ (¤ const char))
(fn () void)
(fn ((int)) int)
(fn ((int) (int)) int)
(fn ((* const char)) size-t)
(fn ((* const char) (...)) int)
(fn ((¤ float 4)) void)))
;; Grouping parens are not part of the type, so these come back
;; canonicalised rather than verbatim -- which is the whole reason
;; unparse-type exists rather than "keep what was written".
(test "a grouped element is the same array" '(¤ int 16) (round-trip '(¤ (int) 16)))
(test "a grouped base is the same pointer" '(* const char)
(round-trip '(* (const char))))
(test "a grouped aggregate keeps its qualifier" '(const struct point)
(round-trip '(const (struct point))))
;; A typedef is transparent to unification and opaque to printing:
;; the generated declaration has to say what the programmer said.
(add-typedef 'i-handle '(typedef i-handle int))
(test "a typedef prints as itself" 'i-handle (round-trip 'i-handle))
(test "and qualified, as itself" '(const i-handle) (round-trip '(const i-handle)))
(test "and under a pointer" '(* i-handle) (round-trip '(* i-handle))))
(test-group "wildcards"
(test "a bare _ is a variable" '_ (round-trip '_))
(test "and composes under a pointer" '(* _) (round-trip '(* _)))
(test "and inside an array" '(¤ _ 4) (round-trip '(¤ _ 4)))
(test "and in a signature" '(fn ((_)) _) (round-trip '(fn ((_)) _)))
;; Each _ is its own variable: solving one must not solve the rest.
(let ((t (parse-type '(fn ((_)) _))))
(unify (car (fn-args t)) (parse-type 'int) #f)
(test "one hole at a time" '(fn ((int)) _) (unparse-type t))))
(test-group "structure"
(test-assert "a pointer is a pointer" (ptr-type? (parse-type '(* char))))
(test "and knows what it points at" 'char
(unparse-type (ptr-target (parse-type '(* char)))))
(test "quals sit on the level they were written at" '(const)
(ptr-quals (parse-type '(const * char))))
(test "an unsized array has no size" #f (array-size (parse-type '(¤ int))))
(test "a sized one does" 16 (array-size (parse-type '(¤ int 16))))
(test "an aggregate is nominal" 'point (agg-name (parse-type '(struct point))))
(test-assert "a variadic signature says so"
(fn-variadic? (parse-type '(fn ((* const char) (...)) int))))
(test-assert "and a plain one does not"
(not (fn-variadic? (parse-type '(fn ((int)) int)))))
;; decay: the conversion C performs at a call site, an operand of
;; `+', or the left half of a subscript.
(test "an array decays to a pointer" '(* int) (unparse-type (decay (parse-type '(¤ int 16)))))
(test "a function decays to a pointer to itself" '(* (fn ((int)) int))
(unparse-type (decay (parse-type '(fn ((int)) int)))))
(test "anything else is left alone" 'int (unparse-type (decay (parse-type 'int)))))
(test-group "unification"
(test-assert "a type unifies with itself"
(unify (parse-type 'int) (parse-type 'int) #f))
(test-error "and not with another one"
(unify (parse-type 'int) (parse-type 'char) #f))
(let ((a (fresh-tvar)))
(unify a (parse-type '(* const char)) #f)
(test "a variable takes the shape it is unified with"
'(* const char) (unparse-type a)))
;; The point of the exercise: `(var p (* _) (& x))' with x : int.
(let ((p (parse-type '(* _))))
(unify p (parse-type '(* int)) #f)
(test "a partial type is completed by one step" '(* int) (unparse-type p)))
(let ((a (fresh-tvar))
(b (fresh-tvar)))
(unify a b #f)
(unify b (parse-type 'double) #f)
(test "two variables joined then solved" 'double (unparse-type a)))
(test-error "structure has to match"
(unify (parse-type '(* int)) (parse-type '(* char)) #f))
(test-error "and arity"
(unify (parse-type '(fn ((int)) int))
(parse-type '(fn ((int) (int)) int)) #f))
(test-error "and aggregates are told apart by name"
(unify (parse-type '(struct point)) (parse-type '(struct box)) #f))
(test-error "and by kind"
(unify (parse-type '(struct point)) (parse-type '(union point)) #f))
;; An unwritten array length constrains nothing, the way it does
;; not in C either.
(test-assert "an unsized array unifies with a sized one"
(unify (parse-type '(¤ int)) (parse-type '(¤ int 16)) #f))
(test-error "but two written lengths must agree"
(unify (parse-type '(¤ int 4)) (parse-type '(¤ int 16)) #f))
;; A typedef unifies as whatever it stands for.
(add-typedef 'i-count '(typedef i-count int))
(test-assert "a typedef unifies with its target"
(unify (parse-type 'i-count) (parse-type 'int) #f))
(let ((a (fresh-tvar)))
(unify a (parse-type 'i-count) #f)
(test "and keeps its name when it is the one printed"
'i-count (unparse-type a)))
(test-group "the unknown type"
(test-assert "? is consistent with anything"
(unify the-unknown-type (parse-type '(struct point)) #f))
(test-assert "in either order"
(unify (parse-type 'int) the-unknown-type #f))
;; ...and binds nothing. Degrading to ? is what keeps an
;; unparsed C declaration from poisoning everything it touches.
(let ((a (fresh-tvar)))
(unify a the-unknown-type #f)
(test "a variable met with ? stays open" '_ (unparse-type a))))
(test-group "occurs check"
;; Unreachable without recursive types, and the alternative to
;; having it is not an error but a hang.
(let ((a (fresh-tvar)))
(test-error "a variable may not contain itself"
(unify a (make-ptr a (list)) #f))))
(test-group "rigid variables"
(let ((r (fresh-rigid-tvar))
(a (fresh-tvar)))
(test-error "a type parameter does not unify with a type"
(unify r (parse-type 'int) #f))
(test-assert "an ordinary variable binds to it instead"
(unify a r #f))
;; An unsolved variable resolves to itself.
(test-assert "it is still open" (tvar? (resolve r))))
;; ...and the same the other way round: it is which side is free
;; that decides, not which side was written first.
(let ((r (fresh-rigid-tvar))
(a (fresh-tvar)))
(test-assert "rigid first binds the free one" (unify r a #f))
(test-assert "to the parameter itself" (eq? r (resolve a))))
(let ((r1 (fresh-rigid-tvar))
(r2 (fresh-rigid-tvar)))
(test-error "two parameters do not unify with each other"
(unify r1 r2 #f)))))
(test-group "constraints"
(test #t (entails? 'numeric (parse-type 'int)))
(test #t (entails? 'numeric (parse-type '(unsigned long))))
(test #t (entails? 'integral (parse-type 'char)))
(test #f (entails? 'integral (parse-type 'double)))
(test #t (entails? 'floating (parse-type 'double)))
(test #f (entails? 'floating (parse-type 'int)))
(test #f (entails? 'numeric (parse-type '(* char))))
(test #t (entails? 'scalar (parse-type '(* char))))
(test #f (entails? 'numeric (parse-type 'void)))
(add-enum 'i-mood '(enum i-mood (glad sad)))
(test "an enum is an integer" #t (entails? 'integral (parse-type '(enum i-mood))))
;; The third answer, and the important one. A name from a header
;; might well be numeric; #f would reject working programs and #t
;; would invent knowledge.
(test "an unparsed C name is not known either way"
'unknown (entails? 'numeric (parse-type 'size-t)))
(test "nor is an open variable" 'unknown (entails? 'numeric (fresh-tvar)))
(test "? entails nothing, but says so quietly"
'unknown (entails? 'numeric the-unknown-type))
;; A typedef is entailed by what it resolves to, so an alias cannot
;; sneak past a constraint its target would fail.
(add-typedef 'i-len '(typedef i-len int))
(test "a typedef is judged by its target" #t (entails? 'numeric (parse-type 'i-len)))
;; A constrained variable checks its classes at the moment it is
;; solved, not at the end.
(let ((a (fresh-tvar '(numeric))))
(test-error "solving to a type that fails the class is an error"
(unify a (parse-type '(* char)) #f)))
(let ((a (fresh-tvar '(numeric))))
(test-assert "and to one that satisfies it is not"
(unify a (parse-type 'double) #f)))
;; ...but an unparsed name is not a failure, it is an absence of
;; knowledge, and must stay silent.
(let ((a (fresh-tvar '(numeric))))
(test-assert "an unparsed C name does not trip a constraint"
(unify a (parse-type 'GLuint) #f)))
;; Joining two variables joins what is known about both.
(let ((a (fresh-tvar '(numeric)))
(b (fresh-tvar '(integral))))
(unify a b #f)
(test "constraints merge when variables do"
'("integral" "numeric")
(sort (map symbol->string (tvar-classes b)) string<?)))
(test-group "defaulting"
(let ((a (fresh-tvar '(numeric))))
(default-type-variables! a #f)
(test "an open numeric is an int" 'int (unparse-type a)))
(let ((a (fresh-tvar '(floating))))
(default-type-variables! a #f)
(test "an open floating is a double" 'double (unparse-type a)))
(let ((a (fresh-tvar)))
(test "a variable with nothing known about it cannot be defaulted"
#f (default-type-variables! a #f))
(test "and stays a hole, for the caller to complain about"
'_ (unparse-type a)))
;; Defaulting reaches into the structure, since the hole may be
;; anywhere: `(var p (* _) ...)'.
(let ((t (parse-type '(* _))))
(unify (ptr-target t) (fresh-tvar '(numeric)) #f)
(default-type-variables! t #f)
(test "and it reaches inside a type" '(* int) (unparse-type t))))
(test-group "user classes"
;; A trait bound is the same shape as `numeric', discharged by
;; the same procedure -- that is the point of one representation.
;; It differs in two rules, and both are stated while there is
;; still only one kind of constraint to state them about.
(register-class! 'i-ord #f #f #t)
(add-struct 'i-circle '(struct i-circle ((r int))))
(test "no instance, no entailment" #f (entails? 'i-ord (parse-type '(struct i-circle))))
(add-instance! 'i-ord (parse-type '(struct i-circle)))
(test "and with one, entailment" #t (entails? 'i-ord (parse-type '(struct i-circle))))
;; Instances key on the resolved type, so an alias cannot be
;; registered twice under two names.
(add-typedef 'i-circle-alias '(typedef i-circle-alias (struct i-circle)))
(test "an alias of an instance is the same instance"
#t (entails? 'i-ord (parse-type 'i-circle-alias)))
;; Decision 2: static dispatch cannot select an instance for a
;; type it does not know, so a strict class says no to ? rather
;; than shrugging the way `numeric' does.
(test "a strict class refuses ?" #f (entails? 'i-ord the-unknown-type))
(test "where a lenient one abstains" 'unknown (entails? 'numeric the-unknown-type))
;; ...and it has no default to fall back on.
(let ((a (fresh-tvar '(i-ord))))
(test-error "an unresolved user constraint is an error, not a guess"
(default-type-variables! a #f)))))
(test-group "schemes"
;; Nothing generalizes yet. The shape is here because a scheme
;; without a constraint list is the wrong shape for every bounded
;; generic, and because instantiation is how a generic body gets
;; fresh cells instead of a second type for the same one.
(let* ((a (fresh-tvar '(numeric)))
(id (make-fn-type a (list a) #f))
(s (generalize id (list))))
(test "the free variable is quantified" 1 (length (scheme-vars s)))
(test "carrying its class as the scheme's context"
'((numeric)) (list (map car (scheme-constraints s))))
(let ((one (instantiate s))
(two (instantiate s)))
(test "an instantiation is still open" '(fn ((_)) _) (unparse-type one))
(unify (fn-ret one) (parse-type 'int) #f)
(test "solving one instantiation" '(fn ((int)) int) (unparse-type one))
(test "leaves the other alone" '(fn ((_)) _) (unparse-type two))
(test "and the scheme itself untouched" '(fn ((_)) _) (unparse-type id))))
(let* ((a (fresh-tvar))
(b (fresh-tvar))
(s (generalize (make-fn-type a (list b) #f) (list b))))
(test "a variable free in the environment is not quantified"
1 (length (scheme-vars s)))
(let ((inst (instantiate s)))
(unify (car (fn-args inst)) (parse-type 'char) #f)
(test "so instantiating solves it for everyone" 'char (unparse-type b))))))

242
tests/line-directives.scm
View File

@@ -1,242 +0,0 @@
;;; Source-line mapping.
;;;
;;; Every construct in the generated C must be attributed, through
;;; #line directives, to the source line of the Sex form it came from.
;;; That mapping is the whole basis of source-level debugging.
;;;
;;; It cannot be left to the C compiler's implicit line counting,
;;; because a Sex form and its C rendering may or may not occupy the
;;; same number of lines. A call written across four lines renders as
;;; one C line; a one-line `for' renders as a braced block of
;;; four. Either way every following line drifts, and the drift
;;; accumulates over a function body.
;;;
;;; The tests below pin one construct per statement kind. Each carries
;;; a unique numeric marker chosen so that it lands on the first C line
;;; that construct emits; the marker is then located in the fixture (to
;;; get the true source line) and in the C output (to get the line the
;;; directives claim). The two must agree.
(import (chicken port)
(chicken string)
srfi-1
srfi-13
fmt-c-writer
reader
semen
utils)
;;; ------------------------------------------------------------------
;;; Fixture. Line numbers are in the trailing comments; keep them
;;; correct when editing. Markers are distinct 3-digit integers, and no
;;; other literal in the fixture contains one as a substring.
(define fixture-lines
'("(include stdio.h)" ; 1
"" ; 2
"(struct pt" ; 3 multi-line toplevel
" ((x int)" ; 4
" (y int)))" ; 5
"" ; 6
"(enum color (red green blue))" ; 7
"" ; 8
"(typedef byte u8)" ; 9
"" ; 10
"(define MAXN 101)" ; 11
"" ; 12
"(var gvar int 102)" ; 13
"" ; 14
"(extern var evar int)" ; 15
"" ; 16
"(fn helper ((a int)) int)" ; 17 prototype
"" ; 18
"(pub fn main () int" ; 19
" (var mvar int 103)" ; 20
" (var p (struct pt))" ; 21
" (var arr [int 4])" ; 22
" (= (. p x) 104)" ; 23
" (+= mvar 105)" ; 24
" (++ mvar)" ; 25
" (= [arr 0] 106)" ; 26
" (putchar (+ 107" ; 27 form spanning 3 lines,
" mvar" ; 28 emitted as one C line:
" 0))" ; 29 everything after drifts
" (var aftercall int 108)" ; 30
" (if (< mvar 109)" ; 31
" (putchar 110))" ; 32
" (if (< mvar 111)" ; 33
" (putchar 112)" ; 34
" (putchar 113))" ; 35
" (while (< mvar 114)" ; 36
" (++ mvar))" ; 37
" (for (var i int 115)" ; 38
" (< i 116)" ; 39
" (++ i)" ; 40
" (continue))" ; 41
" (switch 117" ; 42
" (case 118" ; 43
" (putchar 119)" ; 44
" (break))" ; 45
" (default" ; 46
" (putchar 120)))" ; 47
" (do" ; 48
" (var bvar int 121)" ; 49
" (putchar bvar))" ; 50
" (goto done)" ; 51
" (: done)" ; 52
" (var svar u64 (sizeof (struct pt)))" ; 53
" (var cvar int (cast mvar int))" ; 54
" (return 122))" ; 55
))
(define fixture (string-intersperse fixture-lines "\n"))
;;; ------------------------------------------------------------------
;;; Pipeline and #line accounting
(define (compile-to-c source)
"Run reader -> semen -> writer on SOURCE, returning the generated C.
parse-all is called directly rather than through read-raw-forms so the
fixture can be given a file name: a location is (file . line), and the
file is what makes an imported module report itself rather than the unit
that imported it."
(let ((forms (with-input-from-string source
(lambda ()
(parameterize ((current-source-file "fixture.sex"))
(parse-all (current-input-port)))))))
(with-output-to-string
(lambda () (emit-c (semen-process forms))))))
(define (split-lines s)
(let loop ((i 0) (start 0) (acc (list)))
(cond
((= i (string-length s))
(reverse (if (> i start) (cons (substring s start i) acc) acc)))
((char=? (string-ref s i) #\newline)
(loop (+ i 1) (+ i 1) (cons (substring s start i) acc)))
(else (loop (+ i 1) start acc)))))
(define (directive-line text)
"The N of a `#line N \"file\"' directive, or #f if TEXT is not one."
(let ((t (string-trim text)))
(and (string-prefix? "#line " t)
(string->number (car (string-split (substring t 6) " "))))))
(define (directive-file text)
"The file name of a `#line N \"file\"' directive, or #f."
(let ((t (string-trim text)))
(and (string-prefix? "#line " t)
(let ((parts (string-split (substring t 6) " ")))
(and (pair? (cdr parts)) (cadr parts))))))
(define (attributed-lines c-source)
"Pair every non-directive C line with the source line it is
attributed to. `#line N' says the *next* physical line is N; each line
after that is one more. Lines before the first directive get #f."
(let loop ((lines (split-lines c-source)) (cur #f) (acc (list)))
(if (null? lines)
(reverse acc)
(cond
((directive-line (car lines))
=> (lambda (n) (loop (cdr lines) n acc)))
(else
(loop (cdr lines)
(and cur (+ cur 1))
(cons (cons (car lines) cur) acc)))))))
(define (sex-line token)
"1-based fixture line containing TOKEN."
(let loop ((lines fixture-lines) (n 1))
(cond ((null? lines) #f)
((string-contains (car lines) token) n)
(else (loop (cdr lines) (+ n 1))))))
(define (claimed-line attributed token)
"The source line the generated C attributes TOKEN to."
(let ((hit (find (lambda (p) (string-contains (car p) token)) attributed)))
(and hit (cdr hit))))
;;; ------------------------------------------------------------------
(define c-out (compile-to-c fixture))
(define attributed (attributed-lines c-out))
;;; MAPS checks a construct found under the same token on both sides.
;;; MAPS/TOKENS is for constructs that are spelled differently in Sex
;;; and in C (`(break)' -> `break;', `(: done)' -> `done:').
(define-syntax maps
(syntax-rules ()
((maps name token)
(test name (sex-line token) (claimed-line attributed token)))))
(define-syntax maps/tokens
(syntax-rules ()
((maps/tokens name sex-token c-token)
(test name (sex-line sex-token) (claimed-line attributed c-token)))))
(test-group "line-directives"
;; Toplevel forms
(test-group "toplevel"
(maps/tokens "include" "(include stdio.h)" "#include")
(maps/tokens "struct" "(struct pt" "struct pt {")
(maps/tokens "enum" "(enum color" "enum color {")
(maps/tokens "typedef" "(typedef byte u8)" "typedef u8 byte;")
(maps "define" "101")
(maps "global var" "102")
(maps/tokens "extern var" "(extern var evar" "extern int evar")
(maps/tokens "prototype" "(fn helper" "int helper (int a)")
(maps/tokens "function" "(pub fn main" "int main (void)"))
;; Declarations and expression statements
(test-group "statements"
(maps "var decl" "103")
(maps "member assignment" "104")
(maps "compound assignment" "105")
(maps/tokens "increment" "(++ mvar)" "++mvar;")
(maps "array assignment" "106")
;; The point of the whole exercise: a call spread over three source
;; lines collapses to one C line, so the statement after it must be
;; re-anchored or it is reported two lines too early. The call
;; itself anchors to the line it *starts* on, which is where a
;; debugger should report it.
(maps "multi-line call" "107")
(maps "statement after it" "108"))
;; Control flow
(test-group "control flow"
(maps "if" "109")
(maps "if body" "110")
(maps "if/else" "111")
(maps "then branch" "112")
(maps "else branch" "113")
(maps "while" "114")
(maps "for" "115")
(maps/tokens "continue" "(continue)" "continue;")
(maps "switch" "117")
;; The `case 118:' label line itself is deliberately not pinned.
;; c-switch requires every clause to be a case/default form and
;; rejects anything else, so no anchor can be placed between
;; clauses. The clause *bodies* are anchored from inside, which is
;; what matters -- a label is not a statement a debugger stops on.
(maps "case body" "119")
(maps/tokens "break" "(break)" "break;")
(maps "default body" "120")
(maps "block" "121")
(maps/tokens "goto" "(goto done)" "goto done;")
(maps/tokens "label" "(: done)" "done:")
(maps "return" "122"))
;; Expressions that are their own statement
(test-group "expressions"
(maps/tokens "sizeof" "(var svar" "sizeof")
(maps/tokens "cast" "(var cvar" "(int)mvar"))
;; A location is (file . line); every directive must name the file the
;; form was read from.
(test-group "file name"
(test "every directive names the fixture"
(list "\"fixture.sex\"")
(delete-duplicates
(filter values (map directive-file (split-lines c-out)))))))

38
tests/modules/Makefile
View File

@@ -1,38 +0,0 @@
# Multi-module linking.
#
# Modules are only testable end to end, and nothing else in the suite
# links more than one translation unit. Three things have to hold at
# once: an imported `pub fn' comes out as a prototype with external
# linkage, an imported `pub var' as an extern declaration, and the
# module's object survives being passed after `--'. Get any of them
# wrong and this fails to link -- or, in the `pub var' case, links and
# quietly counts into a private copy.
#
# It also checks what only a second translation unit can check: that an
# imported type reaches the type database, by expanding a macro that
# reads the imported struct's fields; and that a closure type crossing
# the boundary works both ways -- one built in the module and called
# here, one built here and called there, through a code pointer that is
# static in the other object.
#
# The public forms carry comments in their headers, which the reduction
# to a prototype and to an extern both have to look past.
SEXC ?= ../../sexc
EXPECTED = hello, world\nhello, sex\n2 greetings\ntext times \ntext times \nmood 1\nclosure 15 21 201
check:
@$(SEXC) greet.sex -c -o greet.o
@$(SEXC) greet-app.sex -o greet-app -- greet.o
@if [ "`./greet-app`" = "`printf '$(EXPECTED)\n'`" ]; then \
echo "modules ok"; \
else \
echo "modules FAILED, got:"; ./greet-app; $(MAKE) clean; exit 1; \
fi
@$(MAKE) --no-print-directory clean
clean:
@rm -f greet.o greet-app
.PHONY: check clean

36
tests/modules/greet-app.sex
View File

@@ -1,36 +0,0 @@
;;; Uses the greet module. Build both, then link them:
;;;
;;; ./sexc example/greet.sex -c -o greet.o
;;; ./sexc example/greet-app.sex -o greet-app -- greet.o
;;;
;;; `(import greet)' pastes greet's public declarations here: `greet'
;;; as a prototype and `greet-count' as an extern. Both keep external
;;; linkage, so they refer to the one definition in greet.o rather than
;;; to private copies.
;;;
;;; Also check that import populates type-database, by means of
;;; describe-fields macro, which should work on imported type.
(include stdio.h)
(import greet)
(pub fn main () int
(greet "world")
(greet "sex")
(printf "%d greetings\n" greet-count)
(describe-fields greeting)
(printf "\n")
;; ...and through the imported typedef for it
(describe-fields greeting-t)
(printf "\n")
(var m (enum mood) grumpy)
(printf "mood %d\n" m)
(var add-10 (closure ((int)) int) (make-adder 10))
(printf "closure %d %d" (add-10 5) (apply-twice add-10 1))
(var base int 100)
(var here (closure ((int)) int)
(closure ((x int)) int (base) (return (+ base x))))
(printf " %d\n" (apply-twice here 1))
(return 0))

53
tests/modules/greet.sex
View File

@@ -1,53 +0,0 @@
;;; A module. Everything marked `pub' forms its public interface;
;;; everything else is private to this file.
;;;
;;; Importing a module does not link it: it pastes the declarations, so
;;; the compiled object still has to be handed to the C compiler. See
;;; greet-app.sex.
(include stdio.h)
(pub var greet-count ;; a comment in the header of a public form is
;; not part of it: what the importer is given has
;; to be `extern int greet-count', not a form
;; counted off by one
int 0)
(pub struct greeting
"A greeting to print."
((text (* const char)) (times int)))
(pub enum mood (cheerful grumpy))
(pub typedef greeting-t (struct greeting))
;;; Compile-time reflection across the module boundary: both the macro
;;; and the struct it asks about are exported, and the importing unit
;;; has to know the struct's fields to expand this.
(pub defmacro (describe-fields type)
`(do ,@(map-fields type
(lambda (name field-type)
`(printf "%s " ,(symbol->string name))))))
(pub fn greet ;; ...and here the prototype would lose its return type
((name (* const char))) void
"Print a greeting for NAME."
(++ greet-count)
(printf "hello, %s\n" name))
;;; A closure type crossing the boundary. Both units generate the
;;; struct for this signature independently, so they have to agree on
;;; its tag and its layout, or the value is passed wrong and nothing
;;; says so.
(pub fn make-adder ((n int)) (closure ((int)) int)
(return (closure ((b int)) int (n)
(return (+ n b)))))
;;; The other direction: a closure built by the importer, whose code
;;; pointer is static in *its* object, called from here
(pub fn apply-twice ((f (closure ((int)) int)) (x int)) int
(return (f (f x))))
;;; Not `pub': invisible to importers, and static in the generated C.
(fn unused-helper () void
(printf "private\n"))

3
tests/reader.module.scm
View File

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

102
tests/reader.scm
View File

@@ -1,102 +0,0 @@
(import (chicken port)
reader)
(define-syntax feature-test
(syntax-rules ()
((feature-test result features string)
(test result
(parameterize ((current-features 'features))
(with-input-from-string string
(lambda () (read-raw-forms 'stdin))))))))
(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]]")
;; leading `.' becomes the dot-access operator
(reader-test '((dot-access obj field)) "(. obj field)")
(reader-test '((dot-access obj method a b)) "(. obj method a b)")
(reader-test '((dot-access a b)) "(. a b)")
;; nested leading dot
(reader-test '((foo (dot-access a b))) "(foo (. a b))")
;; dotted pairs are preserved (only a *leading* dot is special)
(reader-test '((a . b)) "(a . b)")
(reader-test '((a b . c)) "(a b . c)")
(reader-test '((quote (a . b))) "'(a . b)")
;; a `.'-prefixed symbol is an ordinary symbol, not dot-access
(reader-test '((.field obj)) "(.field obj)")
;; `;' comments are preserved as (comment "...") forms
(reader-test '((comment " hi")) "; hi")
(reader-test '((comment ";; Prototypes")) ";;; Prototypes")
(reader-test '((foo (comment " c") bar)) "(foo ; c\n bar)")
;; a trailing top-level comment is its own form
(reader-test '((a b) (comment " t")) "(a b) ; t")
;; a `;' inside a string is not a comment
(reader-test '("a;b") "\"a;b\"")
;; #+ / #- feature expressions. What does not apply is read and
;; dropped, so it never reaches the compiler at all
(feature-test '((a)) (linux) "#+linux (a)")
(feature-test '() (macosx) "#+linux (a)")
(feature-test '() (linux) "#-linux (a)")
(feature-test '((a)) (macosx) "#-linux (a)")
;; the guarded datum can be anything, not only a list
(feature-test '(42) (x) "#+x 42")
(feature-test '("s") (x) "#+x \"s\"")
;; and / or / not
(feature-test '((a)) (unix linux) "#+(and unix linux) (a)")
(feature-test '() (unix) "#+(and unix linux) (a)")
(feature-test '((a)) (unix) "#+(or linux unix) (a)")
(feature-test '() (bsd) "#+(or linux unix) (a)")
(feature-test '((a)) (unix) "#+(and unix (not macosx)) (a)")
(feature-test '() (unix macosx) "#+(and unix (not macosx)) (a)")
;; (and) is true and (or) is false, as they are in CL
(feature-test '((a)) () "#+(and) (a)")
(feature-test '() () "#+(or) (a)")
;; a guard inside a form, including as the last element -- dropping
;; continues with the next token, so the closing paren still arrives
(feature-test '((f 1 3)) (a) "(f #+a 1 #-a 2 3)")
(feature-test '((f 2 3)) (b) "(f #+a 1 #-a 2 3)")
(feature-test '((f 1)) (a) "(f #+a 1 #+b 2)")
(feature-test '((f)) (b) "(f #+a 1)")
;; ...and as the last form in the file
(feature-test '((a)) (x) "(a) #+y (b)")
;; guards nest
(feature-test '((a)) (x y) "#+x #+y (a)")
(feature-test '((b)) (x) "#+x #+y (a) (b)")
;; ...and the inner one may leave nothing behind: the end of the
;; file, or the paren closing the list, is what the outer one then
;; produces, and neither is an error
(feature-test '() (x) "#+x #+y (a)")
(feature-test '((f)) (x) "(f #+x #+y 1)")
(feature-test '((f 2)) (x) "(f #+x #+y 1 2)")
(feature-test '((a)) (x) "(a) #+x #+y (b)")
;; a comment between a guard and the form it guards describes the
;; guard. Taking it for the guarded datum would leave the form itself
;; unconditional
(feature-test '((a)) (x) "#+x ;; why\n (a)")
(feature-test '() (y) "#+x ;; why\n (a)")
(feature-test '((b)) (y) "#+x ;; why\n (a) (b)")
;; a comment after the guarded form is an ordinary form, and stays
(feature-test '((comment "; tail")) (y) "#+x (a) ;; tail")
;; a feature the program was not given is simply absent
(feature-test '() () "#+anything (a)")
)

14
tests/run.scm
View File

@@ -1,16 +1,14 @@
(declare (uses fmt-c-writer
semen))
(import
(chicken process)
(chicken process-context)
srfi-1
test)
(include "basic.scm")
(include "semen.scm")
(include "reader.scm")
(include "fmt-c-writer.scm")
(include "utils.scm")
(include "line-directives.scm")
(include "codegen.scm")
(include "args.scm")
(include "types.scm")
(include "infer.scm")
;;; Should be the last in the test suite
(test-exit)

2
tests/semen.module.scm
View File

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

150
tests/semen.scm
View File

@@ -1,131 +1,53 @@
(import srfi-69
semen
types)
(define print-str-fn
'(fn print-str ((s string)) void
'(fn void print-str ((string s))
(printf "%s" s)))
(define sum-fn
'(pub fn sum ((a int) (b int)) float
(return (cast (+ a b) float))))
'(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 '((s string)) (sex-fn-arglist print-str-fn))
(test '(fn print-str ((s string)) void) (sex-fn-prototype print-str-fn))
(test '((printf "%s" s)) (sex-fn-body print-str-fn))
(test-begin "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 '((a int) (b int)) (sex-fn-arglist sum-fn))
(test '(pub fn sum ((a int) (b int)) float) (sex-fn-prototype sum-fn))
(test '((return (cast (+ a b) float))) (sex-fn-body sum-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))
(test-assert (sex-fn? '(extern fn foo () void)))
(test 'foo (sex-fn-name '(extern fn foo () void)))
(test #f (sex-fn? '(struct point ((x int)))))
(let ((sex-code
'((defmacro (sum-var name a b c)
`(var ,name ,(+ a b c)))
(let ((sex-code
'((defmacro (sum-var name a b c)
`(var ,name ,(+ a b c)))
(sum-var v 1 2 3))))
(sum-var v 1 2 3))))
(test '((var v 6)) (semen-process sex-code)))
(test '((var v 6)) (semen-process sex-code)))
;;; Macro expansion
(define (form-identity form env)
form)
(test 'a (semen-walk-form 'a identity))
(test '(a b c) (semen-walk-form '(a b c) identity))
(test 'a (walk-form 'a form-identity (make-hash-table)))
(test '(a b c) (walk-form '(a b c) form-identity (make-hash-table)))
(test 'a (semen-macro-expand 'a))
(test '(a b c) (semen-macro-expand '(a b c)))
(test 'a (macro-expand 'a))
(test '(a b c) (macro-expand '(a b c)))
(let ((sex-code-macro
'((defmacro (x10 a)
`(* 10 ,a))
(let ((sex-code-macro
'((defmacro (x10 a)
`(* 10 ,a))
(fn void foo ((int a) (int b))
(return (+ a (x10 b)))))))
(fn foo ((a int) (b int)) void
(return (+ a (x10 b)))))))
(test '((fn void foo ((int a) (int b))
(return (+ a (* 10 b)))))
(semen-process sex-code-macro)))
(test '((fn foo ((a int) (b int)) void
(return (+ a (* 10 b)))))
(semen-process sex-code-macro)))
;;; Docstrings are lifted out as comment forms sitting before the
;;; declaration. A string later in a body is left alone.
(test '((comment "Greet NAME.")
(fn greet ((name (* char))) void
(printf "Hello %s!\n" name)))
(semen-process
'((fn greet ((name (* char))) void
"Greet NAME."
(printf "Hello %s!\n" name)))))
(test '((comment "Public entry.")
(pub fn main () int
(return 0)))
(semen-process
'((pub fn main () int
"Public entry."
(return 0)))))
;; A prototype whose only "body" is a docstring stays a prototype
(test '((comment "Forward.")
(fn helper ((a int)) int))
(semen-process
'((fn helper ((a int)) int
"Forward."))))
(test '((fn f () void (g) "not a docstring"))
(semen-process
'((fn f () void (g) "not a docstring"))))
;; `;' comments before the string are skipped when looking for it,
;; and stay in the body
(test '((comment "Kept.")
(fn f () void (comment " note") (g)))
(semen-process
'((fn f () void (comment " note") "Kept." (g)))))
(test '((comment "A 2D point.")
(struct t-doc-pt ((x int) (y int))))
(semen-process
'((struct t-doc-pt "A 2D point." ((x int) (y int))))))
(test '((x int) (y int))
(get-fields 't-doc-pt))
(test '((comment "RGB.")
(enum t-doc-color (red green blue)))
(semen-process
'((enum t-doc-color "RGB." (red green blue)))))
(test '((comment "Either.")
(union t-doc-val ((i int) (f float))))
(semen-process
'((union t-doc-val "Either." ((i int) (f float))))))
;; Includes
(test '((include stdio.h))
(semen-process
'((include stdio.h))))
(test '((include stdio.h)
(include stdlib.h))
(semen-process
'((include stdio.h
stdlib.h))))
(test '()
(semen-process
'((include))))
)
(test-end)

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

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

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

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

28
tests/sex-programs/c99.sex
View File

@@ -1,28 +0,0 @@
(compilation "-- -std=c99 -pedantic-errors")
(input)
(output "c99: 42")
(return 0)
;;; The closure environment is part of the ABI, so its union is declared
;;; in every translation unit whether or not one is used. That put
;;; whatever it was written with into every program: `max_align_t' named
;;; the alignment in one word, and made C11 the floor for a program with
;;; no closure in it at all.
;;;
;;; The widest built-ins say the same thing -- a union is aligned for the
;;; strictest of its members -- and say it in C99.
;;;
;;; Closures themselves still want C11 for the `_Static_assert' that
;;; checks the captures fit, so this program keeps clear of them.
(include stdio.h)
(struct point ((x int) (y int)))
(fn area ((p (struct point))) int
(return (* (. p x) (. p y))))
(pub fn main () int
(var p (struct point) #((struct point) : 6 7))
(printf "c99: %d\n" (area p))
(return 0))

52
tests/sex-programs/closure-signatures.sex
View File

@@ -1,52 +0,0 @@
(input)
(output "one argument of two words: 7"
"two arguments of one: 7"
"unsigned, one argument: 9"
"unsigned, two arguments: 3"
"captured global: 12"
"captured function: 8")
(return 0)
;;; A closure's struct is named after its signature, so that two
;;; translation units agree on it without sharing a header. The name is
;;; built by flattening the argument list, and flattening loses where one
;;; argument ends and the next begins: `((long long))' and
;;; `((long) (long))' are different signatures that used to mangle alike,
;;; and the second quietly reused the first one's struct.
;;;
;;; A capture that borrows a name reads it from wherever the name is
;;; declared, a global or a function included.
(include stdio.h)
(var scale int 3)
(fn double-it ((n int)) int
(return (* n 2)))
(pub fn main () int
(var one-wide (closure ((long long)) int)
(closure ((a (long long))) int () (return (cast a int))))
(printf "one argument of two words: %d\n" (one-wide 7))
(var two-longs (closure ((long) (long)) int)
(closure ((a long) (b long)) int () (return (cast (+ a b) int))))
(printf "two arguments of one: %d\n" (two-longs 3 4))
(var one-unsigned (closure ((unsigned int)) int)
(closure ((a (unsigned int))) int () (return (cast a int))))
(printf "unsigned, one argument: %d\n" (one-unsigned 9))
(var two-unsigned (closure ((unsigned) (int)) int)
(closure ((a unsigned) (b int)) int () (return (+ (cast a int) b))))
(printf "unsigned, two arguments: %d\n" (two-unsigned 1 2))
;; a capture names what it borrows, and the name need not be a local
(var scaled (closure ((int)) int)
(closure ((x int)) int (scale) (return (* x scale))))
(printf "captured global: %d\n" (scaled 4))
(var doubled (closure ((int)) int)
(closure ((x int)) int (double-it) (return (double-it x))))
(printf "captured function: %d\n" (doubled 4))
(return 0))

121
tests/sex-programs/closures.sex
View File

@@ -1,121 +0,0 @@
(input)
(output "Adders: 15 25"
"Two captures: 47"
"No captures: 7"
"Through a parameter: 110"
"From an array: 1 2 3"
"Index evaluated once: 21 i 1"
"Through a struct member: 8"
"Shadowed in a block: 9 then 15"
"Nested: 33"
"Named capture: 7"
"Captured pointer: 11 then 12"
"From a bare fn: 20 42 7")
(return 0)
;;; A closure is a code pointer beside its captures, so what this
;;; checks is that the captures survive the lifting -- that two
;;; closures of one shape keep their own environments, that a closure
;;; outlives the call that built it, and that calling one through a
;;; parameter, an array element or a struct member resolves the same
;;; way as through a local.
;;;
;;; A receiver is also an ordinary expression: `[table (++ i)]' has to
;;; evaluate its index exactly once, the way it would for an array of
;;; function pointers.
(include stdio.h)
(fn double-it ((n int)) int
(return (* n 2)))
;;; a bare function is a closure that captures nothing, so it converts
;;; wherever one is expected -- here a declared return type
(fn as-closure () (closure ((int)) int)
(return double-it))
(fn make-adder ((n int)) (closure ((int)) int)
(return (closure ((b int)) int (n)
(return (+ n b)))))
(fn make-affine ((k int) (b int)) (closure ((int)) int)
(return (closure ((x int)) int (k b)
(return (+ (* k x) b)))))
(fn make-const-7 () (closure () int)
(return (closure () int ()
(return 7))))
;;; A closure arriving as a parameter: its type is written, so the call
;;; resolves without knowing where it came from
(fn apply-twice ((f (closure ((int)) int)) (x int)) int
(return (f (f x))))
(struct handlers ((on-tick (closure ((int)) int))))
(pub fn main () int
(var add-10 (closure ((int)) int) (make-adder 10))
(var add-20 (closure ((int)) int) (make-adder 20))
(printf "Adders: %d %d\n" (add-10 5) (add-20 5))
(var affine (closure ((int)) int) (make-affine 5 2))
(printf "Two captures: %d\n" (affine 9))
(var seven (closure () int) (make-const-7))
(printf "No captures: %d\n" (seven))
(printf "Through a parameter: %d\n" (apply-twice (make-adder 50) 10))
(var table (¤ (closure ((int)) int) 3))
(var i int 0)
(for (= i 0) (< i 3) (++ i)
(= (¤ table i) (make-adder i)))
(printf "From an array: %d %d %d\n"
((¤ table 0) 1) ((¤ table 1) 1) ((¤ table 2) 1))
;; the index must be evaluated once, so `i' ends at 1 and not 2 --
;; read in a separate statement, since reading and bumping it in one
;; printf would be unsequenced whatever the closure did
(= i 0)
(var once int ([table (++ i)] 20))
(printf "Index evaluated once: %d i %d\n" once i)
(var h (struct handlers) #((struct handlers) : .on-tick (make-adder 5)))
(printf "Through a struct member: %d\n" ((. h on-tick) 3))
;; a block opens a scope: the inner `add-10' ends with it, and the
;; call after it is the closure again
(do (var add-10 int 9)
(printf "Shadowed in a block: %d then " add-10))
(printf "%d\n" (add-10 5))
;; a closure built inside a closure, capturing that one's capture
(var outer (closure ((int)) int)
(closure ((x int)) int ()
(var inner (closure ((int)) int) (make-adder x))
(return (inner 3))))
(printf "Nested: %d\n" (outer 30))
;; a capture can name what it holds rather than borrow a variable's
;; name, and the expression is evaluated where the closure is written
(var pt (struct handlers))
(var sum-once (closure () int)
(closure () int ((sum (+ 3 4))) (return sum)))
(printf "Named capture: %d\n" (sum-once))
;; capturing a pointer is how by-reference is spelled; the caller owns
;; what it points at
(var counter int 11)
(var peek (closure () int)
(closure () int ((at (& counter))) (return (* at))))
(printf "Captured pointer: %d then " (peek))
(++ counter)
(printf "%d\n" (peek))
;; ...and in an initializer, as an argument, and as a return
(var from-fn (closure ((int)) int) double-it)
(printf "From a bare fn: %d %d %d\n"
(apply-twice from-fn 5)
((as-closure) 21)
(apply-twice (lambda ((n int)) int (return (+ n 1))) 5))
(return 0))

13
tests/sex-programs/comments.sex
View File

@@ -1,13 +0,0 @@
(input)
(output "start" "end")
(return 0)
;;; A top-level comment, preserved into the generated C.
(include stdio.h)
;; Another top-level comment, right before the function.
(pub fn main () int
;; a comment in statement position
(puts "start")
(puts "end") ; a trailing comment after a statement
(return 0))

49
tests/sex-programs/compound-literals.sex
View File

@@ -1,49 +0,0 @@
(input)
(output "plain 1 2"
"literal 3 4"
"designated zoe 7"
"through a pointer 9"
"array 10 20 30"
"argument 6"
"mixed 1 5")
(return 0)
;;; `:' inside #(...) ends a type and makes the rest a C99 compound
;;; literal. Without one, #(...) is the brace initializer it always was.
(include stdio.h)
(struct point ((x int) (y int)))
(struct named ((first-name (* const char)) (n int)))
(fn sum ((p (struct point))) int
(return (+ (. p x) (. p y))))
(pub fn main () int
;; unchanged: a bare initializer has no type of its own
(var p (struct point) #(1 2))
(printf "plain %d %d\n" (. p x) (. p y))
(var q (struct point) #(struct point : 3 4))
(printf "literal %d %d\n" (. q x) (. q y))
;; designated, out of declaration order, and kebab-cased
(var r (struct named) #(struct named : .n 7 .first-name "zoe"))
(printf "designated %s %d\n" (. r first-name) (. r n))
;; a compound literal is an lvalue, so its address can be taken --
;; until the end of the enclosing block, and no longer
(var pp (* struct point) (& #(struct point : 9 9)))
(printf "through a pointer %d\n" (-> pp x))
;; an array literal decays the way an array does
(var a (* int) #([int 3] : 10 20 30))
(printf "array %d %d %d\n" (¤ a 0) (¤ a 1) (¤ a 2))
(printf "argument %d\n" (sum #(struct point : 2 4)))
;; positional and designated may be mixed, as in C
(var m (struct point) #(struct point : 1 .y 5))
(printf "mixed %d %d\n" (. m x) (. m y))
(return 0))

25
tests/sex-programs/feature-flags.sex
View File

@@ -1,25 +0,0 @@
(compilation "-f alpha -f beta,gamma --features=delta --no-platform-features")
(input)
(output "alpha" "beta" "gamma" "delta" "elsewhere")
(return 0)
;;; The flags naming the features, in every spelling sexc takes. This
;;; is not pedantry about the command line: sextest reads the program
;;; itself and prints the surviving forms to sexc, so a spelling it
;;; does not recognise leaves the guards below resolved against the
;;; wrong set -- quietly, since the test then checks the output of a
;;; program it did not mean to compile.
;;;
;;; --no-platform-features is what makes `#-unix' true wherever this is
;;; compiled, and it has to be honoured on both sides for that to hold.
(include stdio.h)
(pub fn main () int
#+alpha (puts "alpha")
#+beta (puts "beta")
#+gamma (puts "gamma")
#+delta (puts "delta")
#-unix (puts "elsewhere")
#+unix (puts "here")
(return 0))

23
tests/sex-programs/features.sex
View File

@@ -1,23 +0,0 @@
(compilation "--features=test-on")
(input)
(output "selected" "on" "and-not")
(return 0)
;;; #+ and #- pick what the compiler gets to see. `test-on' is handed
;;; to sexc by the (compilation ...) form above, so this program reads
;;; the same way on every platform.
(include stdio.h)
#+test-on (define GREETING "on")
#-test-on (define GREETING "off")
#-test-on (pub fn main () int (puts "the whole function is dropped") (return 1))
(pub fn main () int
;; ...and inside a form, not only at toplevel
(puts #+test-on "selected" #-test-on "rejected")
(puts GREETING)
#+(and test-on (not test-off)) (puts "and-not")
#-test-on (puts "never printed")
(return 0))

61
tests/sex-programs/fixpoint.sex
View File

@@ -1,61 +0,0 @@
(input)
(output "direct: 120"
"fac: 120 3628800"
"fib: 55 6765"
"applied on the spot: 120")
(return 0)
;;; A fixed point built out of closures, which is the hardest thing to
;;; ask of them: recursion with no recursive function anywhere, only
;;; self-application.
;;;
;;; Self-application needs `x x' and so a recursive type, which is
;;; spelled here by routing it through a named struct whose field is a
;;; closure whose own signature mentions that struct. The generated
;;; closure struct is written before `struct rec' is, so this only
;;; compiles because a forward declaration is emitted ahead of both.
;;;
;;; Note what `fix' captures: a *pointer* to the knot, not the knot. A
;;; closure is a code pointer beside N bytes of environment, so
;;; capturing one by value would need N >= 8 + N. No budget makes that
;;; true, and the static assertion says so rather than letting it
;;; corrupt anything.
(include stdio.h)
(struct rec ((f (closure (((* (struct rec))) (int)) int))))
;;; Takes a step that expects itself, returns an ordinary closure with
;;; the self-application hidden inside
(fn fix ((step (* (struct rec)))) (closure ((int)) int)
(return (closure ((n int)) int (step)
(return ((-> step f) step n)))))
(pub fn main () int
(var fac-knot (struct rec))
(= (. fac-knot f)
(closure ((self (* (struct rec))) (n int)) int ()
(if (<= n 1) (return 1))
(return (* n ((-> self f) self (- n 1))))))
;; the knot applied to itself directly, without fix
(printf "direct: %d\n" ((. fac-knot f) (& fac-knot) 5))
(var fib-knot (struct rec))
(= (. fib-knot f)
(closure ((self (* (struct rec))) (n int)) int ()
(if (< n 2) (return n))
(return (+ ((-> self f) self (- n 1))
((-> self f) self (- n 2))))))
;; one combinator, two different recursions
(var fac (closure ((int)) int) (fix (& fac-knot)))
(var fib (closure ((int)) int) (fix (& fib-knot)))
(printf "fac: %d %d\n" (fac 5) (fac 10))
(printf "fib: %d %d\n" (fib 10) (fib 20))
;; the combinator's result invoked where it is returned, with no
;; intervening `var' -- the receiver's type is the return type of the
;; signature it came from, which is what the name table records
(printf "applied on the spot: %d\n" ((fix (& fac-knot)) 5))
(return 0))

13
tests/sex-programs/hello-world.sex
View File

@@ -1,13 +0,0 @@
(input "Sextest")
(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
(return 255)
(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 255))

178
tests/sex-programs/inference.sex
View File

@@ -1,178 +0,0 @@
(input)
(output "15"
"42 0.25"
"(5, 7)"
"(1, 2)"
"3"
"(5, 7)"
"0 1 4 9 "
"4"
"42"
"<closure of 0: 10>"
"42"
"2 1"
"Hello from Sex!")
(return 0)
;;; Both halves of inference, from the two sides that read the same
;;; answers: `_' in a type means "work it out", and `type-of' hands a
;;; macro the type of an expression.
;;;
;;; This was written as a draft before either existed, to be read
;;; before it was built. It is registered now.
;;;
;;; Two features, one mechanism:
;;;
;;; `_' in a type means "work it out", and
;;; `type-of' hands a macro the type of an expression.
;;;
;;; Both are the same solved constraint store, read from two sides.
(include stdio.h)
(include string.h)
;;; `(include string.h)' is for the C compiler; it tells Sex nothing.
;;; A signature has to be written before `_' can be resolved from a
;;; call to `strlen' -- without one the call's type is `?', and a `_'
;;; that resolves to `?' is an error, not a silent int.
(extern fn strlen ((s (* const char))) size-t)
(struct point ((x int) (y int)))
(fn midpoint ((a (* const struct point)) (b (* const struct point))) (struct point)
(var m (struct point))
;; No `_' here: `m' has no initializer to infer from. Inference fills
;; in a type, it does not invent one.
(= (. m x) (/ (+ (-> a x) (-> b x)) 2))
(= (. m y) (/ (+ (-> a y) (-> b y)) 2))
(return m))
;;; The closure's type is written once, in the signature; `_' reads it
;;; from there at every use.
(fn make-adder ((n int)) (closure ((int)) int)
(return (closure ((b int)) int (n)
(return (+ n b)))))
;;; A macro that asks what it was handed.
;;;
;;; `type-of' returns a *surface* type -- the same spelling the type
;;; database hands to `map-fields' -- so it composes with the
;;; `type-match' that already exists, and dispatch over a user struct
;;; costs nothing extra.
(defmacro (print x)
(type-match (type-of x)
(int `(printf "%d\n" ,x))
(size-t `(printf "%zu\n" ,x))
(double `(printf "%g\n" ,x))
((* const char) `(printf "%s\n" ,x))
;; NOTE: ,x twice -- a macro that duplicates its argument still has
;; to think about evaluating it twice. Inference does not fix that.
((struct point) `(printf "(%d, %d)\n" (. ,x x) (. ,x y)))
;; a closure is a type like any other, so it dispatches like one --
;; and `_' saves a clause per signature
((closure _ int) `(printf "<closure of 0: %d>\n" (,x 0)))
(else (error "print: don't know how to print" (type-of x)))))
;;; The temporary's type is the thing the macro could not write down
;;; before. Either spelling works -- `_' is the lazier one, and it is
;;; inferred in the expansion's own scope.
(defmacro (swap a b)
`(do (var tmp _ ,a)
(= ,a ,b)
(= ,b tmp)))
(pub fn main () int
;; Written out, for contrast with everything below it.
(var greeting (* const char) "Hello from Sex!")
;; size-t, from the signature above -- not int, and not a guess.
(var n _ (strlen greeting))
(printf "%zu\n" n)
;; Literals carry a constraint, not a type: the int-ish one defaults
;; to int, and the mixed division joins to double the way C does.
(var count _ (+ 20 22))
(var half _ (/ 1.0 4))
(printf "%d %g\n" count half)
;; An aggregate initializer has no type of its own, so the type flows
;; in and has to be written. `(var origin _ #(3 4))' is an error --
;; there is nothing to infer from.
(var origin (struct point) #(3 4))
(var corner (struct point) #(7 10))
;; A compound literal is the way out of that rule: the `:' is where an
;; initializer stops needing a type from its context, so `_' has
;; something to read after all.
(var centre _ #((struct point) : 5 7))
(print centre)
;; ...and the same designated, which names fields instead of counting
;; positions.
(var offset _ #((struct point) : .x 1 .y 2))
(print offset)
;; A partial type: "a pointer to something". The something arrives
;; from the initializer. This is why the wildcard lives in the type
;; grammar rather than beside it -- it composes.
(var p (* _) (& origin))
;; Member access reads the same type database the macros do.
(var x _ (-> p x))
(printf "%d\n" x)
;; A call into a function Sex has actually parsed: the return type is
;; the whole answer, and `print' then dispatches on it.
(var mid _ (midpoint (& origin) (& corner)))
(print mid)
;; The loop variable, which is where `_' earns its keep most often.
(for (var i _ 0) (< i 4) (++ i)
(printf "%d " (* i i)))
(printf "\n")
;; Four of something: the element type is fixed by the initializer,
;; the count by the type. Subscripting gives the element type back.
(var squares [_ 4] #(0 1 4 9))
(print [squares 2])
;; A closure's type comes from the signature that produced it, and
;; calling one needs that type and nothing else.
(var add-10 _ (make-adder 10))
(print (add-10 32))
(print add-10)
;; ...including where it is returned, with no name in between.
(print ((make-adder 20) 22))
;; A macro writing a declaration it could not have written before.
(var a _ 1)
(var b _ 2)
(swap a b)
(printf "%d %d\n" a b)
(print greeting)
(return 0))
;;; Open questions this draft raises, to settle before Layer 2 ships:
;;;
;;; 1. SETTLED. `type-match' took `_' on the pattern side, so
;;; `(closure _ int)' above is one clause rather than one per
;;; signature, and `(* _)' and `(¤ _ _)' say "any pointer" and "any
;;; array". A `_' written last takes the rest, since a type's words
;;; are spread and not nested: `(* const char)' is three elements.
;;; Nothing destructures -- a macro body is Scheme and a type is a
;;; list, so `(caddr (type-of x))' reads an array's length.
;;;
;;; 2. SETTLED, allowed. `[_ 4]' against `#(0 1 4 9)' unifies each
;;; element with the hole, so the element type comes from the
;;; literals and the length stays as written -- `[_ 10]' with two
;;; initializers is still ten. Elements that disagree are a type
;;; mismatch. A bare `_' is still refused: `#(0 1 4 9)' has no type
;;; of its own, only elements.
;;;
;;; 3. POSTPONED to the standard library design. `(extern fn strlen
;;; ...)' above duplicates string.h, which is the same bargain every
;;; FFI makes, but it is where "no C header parsing" starts costing
;;; the user something. A `sex/libc' module of prototypes is the
;;; obvious answer and belongs with the rest of the stdlib.

44
tests/sex-programs/lambdas.sex
View File

@@ -1,44 +0,0 @@
(input)
(output "Named fn through a pointer: 30"
"Lambda through a pointer: 30"
"Lambda called in place: 130"
"Nested lambdas: 666")
(return 0)
;;; Lambdas are lifted into toplevel functions by semen, so what this
;;; really checks is that the lifted `fn' comes out in the argument
;;; order the writer expects -- (fn name arglist ret-type . body).
(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 sum-fn (fn ((int) (int)) int) sum)
(printf "Named fn through a pointer: %d\n" (sum-fn a b))
(var sum-lambda (fn ((int) (int)) int)
(lambda ((a int) (b int)) int
(return (+ a b))))
(printf "Lambda through a pointer: %d\n" (sum-lambda a b))
(printf "Lambda called in place: %d\n"
((lambda ((a int) (b int)) int
(return (+ a b 100)))
a b))
;; A lambda inside a lambda: the inner one is lifted out of a
;; function that is itself being lifted
(var outer (fn ((int)) int)
(lambda ((x int)) int
(var inner (fn ((int)) int)
(lambda ((y int)) int
(return (+ 60 y))))
(return (+ 600 (inner x)))))
(printf "Nested lambdas: %d\n" (outer 6))
(return 0))

48
tests/sex-programs/list-macros.sex
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)))
`(do
(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))))))

50
tests/sex-programs/lists.sex
View File

@@ -1,50 +0,0 @@
(input)
(output "Size of the list: 0"
"Size of the list: 2"
"3 4 "
"Size of the list: 2")
(return 0)
(include stdlib.h)
(include stddef.h)
(include stdio.h)
(import list-macros)
(struct foo
((a-field float)
(b int)
(c (* const char))
(not (fn ((val bool)) bool))))
(var f (struct foo))
(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)
(extern fn puk ((a int) (b float)) void)
(pub fn baz () bool
(return true))
(extern var i int)
(var j int)
(pub var k int)
(pub fn main () int
(var l (* struct list-int) (make-list-int))
(printf "Size of the list: %lu\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 "%d " v))
(printf "\n")
(printf "Size of the list: %lu\n" (length-list-int l))
(return 0))
(pub fn print-list ((l (* const struct list-int))) void
(list-for-each (const struct list-int) l int v (printf "%d " v))
(printf "\n"))

90
tests/sex-programs/operators.sex
View File

@@ -1,90 +0,0 @@
(input)
(output "logical: 1 1 0"
"bitwise: 7 2 5"
"shifts: 48 0 12"
"increment: 7"
"decayed: 2 2 there"
"unsigned wins either way: 4294967295 4294967295"
"toplevel: 1 2.5 hi 12"
"closure in place: 5"
"a type is not a call: 7")
(return 0)
;;; The walk types an expression by its head, and the heads it had a
;;; rule for were the ones inference was written against. `&&', the
;;; bitwise operators, the shifts and `++' were not among them and each
;;; stopped with `cannot infer'.
;;;
;;; The rest of this is the same mistake in three other places: an array
;;; is a pointer the moment it is an operand, a rank tie is not decided
;;; by which operand was written first, and `_' is not a local's
;;; privilege.
(include stdio.h)
(fn area ((w int) (h int)) int
(return (* w h)))
;;; a toplevel `_' reads the same table a local's does, so it can name
;;; anything declared above it
(var n _ 1)
(var d _ 2.5)
(var s _ "hi")
(var a _ (+ 3 (* 3 3)))
(fn make-adder ((k int)) (closure ((int)) int)
(return (closure ((b int)) int (k) (return (+ k b)))))
(pub fn main () int
(var x int 6)
(var y int 3)
(var ok _ (&& x y))
(var orr _ (|| x y))
(var neg _ (! x))
(printf "logical: %d %d %d\n" ok orr neg)
(var bor _ (| x y))
(var band _ (& x y))
(var bxor _ (^ x y))
(printf "bitwise: %d %d %d\n" bor band bxor)
;; a shift is the promoted left operand, not a join: the right one
;; says only how far
(var c char 12)
(var shl _ (<< x y))
(var shr _ (>> x y))
(var wide _ (>> c 0))
(printf "shifts: %d %d %d\n" shl shr wide)
;; ...and an increment is the operand, unpromoted
(var inc _ (++ x))
(printf "increment: %d\n" inc)
;; an array operand decays, so this is a pointer and not an array
(var xs (¤ int 4) #(1 2 3 4))
(var p _ (+ xs 1))
(var q _ (+ 1 xs))
(var names (¤ (* const char) 2) #("hi" "there"))
(var np _ (+ names 1))
(printf "decayed: %d %d %s\n" (* p) (* q) (* np))
;; at equal rank C takes the unsigned operand, whichever side it is on
(var i int -1)
(var u (unsigned int) 1)
(var u1 _ (+ i u))
(var u2 _ (+ u i))
(printf "unsigned wins either way: %u %u\n" (- u1 1) (- u2 1))
(printf "toplevel: %d %g %s %d\n" n d s a)
;; a closure literal is its own type, so it can be called where it is
;; written, the way a lambda already could
(printf "closure in place: %d\n"
((closure ((v int)) int () (return v)) 5))
;; a `fn' type's parameter list looks exactly like a call; with a
;; closure named `f' in scope it used to be read as one
(var f (closure ((int)) int) (make-adder 1))
(var fp (fn ((f int) (g int)) int) area)
(printf "a type is not a call: %d\n" (f 6))
(return 0))

37
tests/sex-programs/serialize.sex
View File

@@ -1,37 +0,0 @@
(input)
(output "box { w=3 h=4 label=wide }")
(return 0)
;;; A macro generating code from the type database: it is handed a
;;; struct name, walks its fields with map-fields, and picks a printf
;;; conversion per field with type-match. Exercises semen registering
;;; the struct and the macro reading it back at expansion time.
(include stdio.h)
(defmacro (print-struct type-name)
(let ((printers
(map-fields type-name
(lambda (name type)
`(printf ,(string-append " " (symbol->string name) "="
(type-match type
(int "%d")
((* const char) "%s")
(else (error "print-struct: unsupported field type"
name type))))
(-> v ,name))))))
(if (not printers)
(error "print-struct: no such struct" type-name)
`(fn ,(cat 'print- type-name) ((v (* const struct ,type-name))) void
(printf ,(string-append (symbol->string type-name) " {"))
,@printers
(printf " }\n")))))
(struct box ((w int) (h int) (label (* const char))))
(print-struct box)
(pub fn main () int
(var b (struct box) #(3 4 "wide"))
(print-box (& b))
(return 0))

72
tests/sex-programs/type-shapes.sex
View File

@@ -1,72 +0,0 @@
(input)
(output "aggregate element: 3 4"
"pointer element: there"
"multi-word element: 9"
"through a pointer: 55"
"unsized of a typedef: 1 2"
"unsized of a pointer: 5"
"unnamed parameters: 7 -1 2")
(return 0)
;;; Three questions about a written type that used to be answered in
;;; three places and disagreed: is `(a b)' a named parameter or a bare
;;; type, is the last element of a `¤' its bound or the last word of
;;; its element type, and what is one element of an array.
;;;
;;; They are one question -- where does the type end -- so the answer
;;; lives in `types' and everything else asks it.
(include stdio.h)
(struct point ((x int) (y int)))
(typedef small int)
;;; a parameter that names nothing is a type, however many words it
;;; takes: `(unsigned int)' is one of them, not a `unsigned' called
;;; `int'
(fn width ((n unsigned int)) int
(return (cast n int)))
(fn sign ((c const char)) int
(if (== c #\a) (return -1))
(return 1))
(fn twice ((n small)) int
(return (* n 2)))
(pub fn main () int
;; an element keeps every word of its type, tag and all
(var pts (¤ (struct point) 2) #(#((struct point) : 1 2)
#((struct point) : 3 4)))
(var p _ (¤ pts 1))
(printf "aggregate element: %d %d\n" (. p x) (. p y))
(var names (¤ (* const char) 2) #("hi" "there"))
(var s _ (¤ names 1))
(printf "pointer element: %s\n" s)
(var nums (¤ unsigned int 3) #(7 8 9))
(var u _ (¤ nums 2))
(printf "multi-word element: %u\n" u)
;; subscripting a pointer answers the same as subscripting an array
(var q (* (struct point)) (& (¤ pts 0)))
(var r _ (¤ q 1))
(printf "through a pointer: %d\n" (+ (. r x) (* 13 (. r y))))
;; the last word of an unsized array's type is not its bound: neither
;; a typedef name nor the target of a `*' can be one
(var tail (¤ const small) #(1 2))
(printf "unsized of a typedef: %d %d\n" (¤ tail 0) (¤ tail 1))
(var one size-t 5)
(var sizes (¤ * size-t) #((& one)))
(var w _ (¤ sizes 0))
(printf "unsized of a pointer: %d\n" (cast (* w) int))
;; the same question in type position: `(fn ((unsigned int)) int)'
;; takes one parameter, not two
(var fp (fn ((unsigned int)) int) width)
(printf "unnamed parameters: %d %d %d\n" (fp 7) (sign #\a) (twice 1))
(return 0))

24
tests/sex-programs/unicode.sex
View File

@@ -1,24 +0,0 @@
(input)
(output "café 日本語 🍺" "café1" "naïve: 3")
(return 0)
;;; Non-ASCII string literals and identifiers.
;;;
;;; Two things are pinned here. First, a character outside printable
;;; ASCII must reach the C compiler as the UTF-8 bytes it was written
;;; as. Octal escapes are used because C's \x escape swallows every
;;; following hex digit: "café1" is the case that catches it, since a
;;; hex escape would run "\xc3\xa9" into the "1" and produce a value out
;;; of range for a char. Second, a kebab-case identifier containing
;;; non-ASCII characters must survive unkebabify intact -- getting this
;;; wrong truncates the name silently, and the program still compiles
;;; and runs, just under a different name than the one written.
(include stdio.h)
(pub fn main () int
(puts "café 日本語 🍺")
(puts "café1")
(var naïve-count int 3)
(printf "naïve: %d\n" naïve-count)
(return 0))

51
tests/sex-programs/unnamed-params.sex
View File

@@ -1,51 +0,0 @@
(input)
(output "one word: 7"
"pointer: 2"
"aggregate: 3"
"array: 2.5"
"variadic: 1 two")
(return 0)
;;; A parameter that names nothing still has to reach the C writer as a
;;; type and a name, the name being absent. Handed the bare type
;;; instead, fmt-c read the type's own second word as the name -- so
;;; `(* const char)' came out `const char', which is a different
;;; function -- and a one-word type had no second word to read at all.
(include stdio.h)
(include stdarg.h)
(struct point ((x int) (y int)))
;;; declared here rather than included, so the prototype we emit is the
;;; one the C compiler checks the call against
(extern fn abs ((int)) int)
(extern fn strlen ((* const char)) size-t)
(fn origin-x ((p (* (struct point)))) int
(return (. (* p) x)))
(fn second-of ((xs (¤ float 4))) float
(return (¤ xs 1)))
(fn say ((fmt (* const char)) ...) void
(var ap va-list)
(va-start ap fmt)
(vprintf fmt ap)
(va-end ap))
(pub fn main () int
(printf "one word: %d\n" (abs -7))
(printf "pointer: %d\n" (cast (strlen "hi") int))
;; the same parameter lists written as types
(var p (struct point) #((struct point) : 3 4))
(var f (fn ((* (struct point))) int) origin-x)
(printf "aggregate: %d\n" (f (& p)))
(var xs (¤ float 4) #(1.5 2.5 3.5 4.5))
(var g (fn ((¤ float 4)) float) second-of)
(printf "array: %g\n" (g xs))
(say "variadic: %d %s\n" 1 "two")
(return 0))

109
tests/sex-programs/wildcards.sex
View File

@@ -1,109 +0,0 @@
(input)
(output "literals: 42 3.5 hello"
"calls: 12"
"members: 1 2.5"
"pointers: 1 2.5"
"arrays: 30"
"loop: 0 1 2"
"shadowed: 9 then 42"
"still an int: 200"
"partial: 1 2.5"
"joined: 43.5 84 49 1"
"promoted: 200 60000 3705032704"
"from elements: 4 9 0")
(return 0)
;;; `_' as a type means "work it out from the initializer". What the
;;; pass can answer comes from declarations -- Sex writes a type at
;;; every binding site -- and from the signature of whatever a call
;;; names. A partial type like `(* _)' is solved by unifying what was
;;; written against what the initializer gives, so only the wildcard
;;; inside the spelling is filled in.
(include stdio.h)
(struct point ((x int) (y float)))
(fn area ((w int) (h int)) int
(return (* w h)))
(pub fn main () int
(var n _ 42)
(var f _ 3.5)
(var s _ "hello")
(printf "literals: %d %g %s\n" n f s)
(var a _ (area 3 4))
(printf "calls: %d\n" a)
(var p (struct point) #((struct point) : .x 1 .y 2.5))
(var px _ (. p x))
(var py _ (. p y))
(printf "members: %d %g\n" px py)
(var pp _ (& p))
(printf "pointers: %d %g\n" (-> pp x) (-> pp y))
(var table (¤ int 3))
(= (¤ table 0) 10)
(= (¤ table 1) 20)
(var first _ (¤ table 0))
(var second _ (¤ table 1))
(printf "arrays: %d\n" (+ first second))
;; a for opens a scope, and its initializer is declared inside it
(printf "loop:")
(for (var i _ 0) (< i 3) (++ i)
(printf " %d" i))
(printf "\n")
;; a block's declarations end with it, and so do the declarations of
;; everything else C brackets -- a `while' body is a block with no
;; `do' written around it
(do (var n _ 9)
(printf "shadowed: %d then " n))
(printf "%d\n" n)
(var wide int 200)
(while false (var wide char 1) (printf "%d" wide))
(if false (do (var wide char 1) (printf "%d" wide)))
;; a statement before the declaration: a label may not be followed by
;; one until C23
(switch a (case 1 (printf "") (var wide char 1) (printf "%d" wide) (break)))
;; a copy, not a sum: an arithmetic result would be promoted to `int'
;; whatever leaked, and say nothing
(var copy _ wide)
(printf "still an int: %d\n" copy)
;; a wildcard inside a written type: only it is solved
(var pp2 (* _) (& p))
(printf "partial: %d %g\n" (-> pp2 x) (-> pp2 y))
;; C's usual arithmetic conversions, far enough to answer `_'
(var d double 1.5)
(var l long 7)
(var g float 0.5)
(var mixed _ (+ n d))
(var same _ (+ n n))
(var wider _ (+ n l))
(var single _ (+ g g))
(printf "joined: %g %d %ld %g\n" mixed same wider single)
;; ...including the promotions, which two operands of one narrow type
;; are exactly where they show: `char' + `char' is an `int'
(var c1 char 100)
(var c2 char 100)
(var h1 short 30000)
(var narrow _ (+ c1 c2))
(var narrower _ (+ h1 h1))
(var kept (unsigned int) 4000000000)
(var unpromoted _ (+ kept kept))
(printf "promoted: %d %d %u\n" narrow narrower unpromoted)
;; a brace initializer has no type of its own, but its elements solve
;; the hole in the array type around it -- and the length stays as
;; written, whether or not every slot is initialized
(var squares (¤ _ 4) #(0 1 4 9))
(var sparse (¤ _ 8) #(0 1))
(printf "from elements: %d %d %d\n" (¤ squares 2) (¤ squares 3) (¤ sparse 7))
(return 0))

3
tests/sexc.module.scm
View File

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

28
tests/types.module.scm
View File

@@ -1,28 +0,0 @@
(module types
(add-struct
add-union
add-enum
add-typedef
add-define
type-match
type-pattern-matches?
map-fields
add-name-type!
get-name-type
type-of
current-type-of
get-return-type
get-type-info
get-tag-info
get-fields
get-underlying-type
type-head?
named-arg?
typedef-name?
array-bound?
array-element-type)
"../types.scm")

220
tests/types.scm
View File

@@ -1,220 +0,0 @@
;;; The type database.
;;;
;;; Names here are prefixed so they cannot collide with the types the
;;; other suites register: the database is one table in the linked
;;; binary, and semen fills it in whenever a suite compiles a struct.
(import types)
(test-group "types"
(add-struct 't-point '(struct t-point ((x int) (y int))))
(test "fields come back as (name type)"
'((x int) (y int))
(get-fields 't-point))
(test "and the whole entry is tagged"
'(struct t-point ((x int) (y int)))
(get-type-info 't-point))
;; Fields are written with the type last, so one entry can declare
;; several names. They come back as one field each.
(add-struct 't-settings
'(pub struct t-settings ((x y w h u32) (title (* const char)))))
(test "names sharing a type are split apart"
'((x u32) (y u32) (w u32) (h u32) (title (* const char)))
(get-fields 't-settings))
(add-struct 't-commented '(struct t-commented ((comment " hi") (a int))))
(test "a comment among the fields is not a field"
'((a int))
(get-fields 't-commented))
(add-union 't-value '(union t-value ((i int) (f float))))
(test "unions have fields too"
'((i int) (f float))
(get-fields 't-value))
(add-enum 't-color '(enum t-color (red green blue)))
(test "enums keep their values"
'(enum t-color (red green blue))
(get-type-info 't-color))
(test "but have no fields"
#f
(get-fields 't-color))
(add-typedef 't-u8 '(typedef t-u8 uint8-t))
(test "a typedef resolves to its target"
'uint8-t
(get-underlying-type 't-u8))
(add-typedef 't-byte '(typedef t-byte t-u8))
(test "and chains are followed to the end"
'uint8-t
(get-underlying-type 't-byte))
(test "a struct is not a typedef"
#f
(get-underlying-type 't-point))
;; Reflection through an alias. Both spellings of the target occur:
;; (typedef point-t point) and (typedef point-t (struct point)).
(add-typedef 't-point-t '(typedef t-point-t t-point))
(test "a typedef to a struct has the struct's fields"
'((x int) (y int))
(get-fields 't-point-t))
(add-typedef 't-point-s '(typedef t-point-s (struct t-point)))
(test "written the other way round too"
'((x int) (y int))
(get-fields 't-point-s))
(add-typedef 't-point-2 '(typedef t-point-2 t-point-t))
(test "and through a chain of them"
'((x int) (y int))
(get-fields 't-point-2))
(test "map-fields follows an alias as well"
'((x int) (y int))
(map-fields 't-point-t (lambda (name type) (list name type))))
(add-typedef 't-color-t '(typedef t-color-t t-color))
(test "an aliased enum is still named as it was declared"
'((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
(map-fields 't-color-t (lambda (name type) (list name type))))
(test "a typedef to a primitive has no fields"
#f
(get-fields 't-u8))
;; C keeps typedefs and ordinary identifiers apart, and the canonical way
;; to declare a struct uses both names at once. Neither declaration
;; may stand on the other.
(add-struct 't-node '(struct t-node ((next (* t-node)) (v int))))
(add-typedef 't-node '(typedef t-node (struct t-node)))
(test "a typedef of a struct's own name keeps the struct reachable"
'((next (* t-node)) (v int))
(get-fields 't-node))
(test "and the tag is there under its own name"
'(struct t-node ((next (* t-node)) (v int)))
(get-tag-info 't-node))
(add-struct 't-rect '(struct t-rect ((w int) (h int))))
(add-define 't-rect '(define t-rect 3))
(test "a define of a tag's name does not hide the fields"
'((w int) (h int))
(get-fields 't-rect))
;; A type built over a struct is not that struct. Handing back the
;; element's fields would have a macro write v->x for an array
(add-typedef 't-points '(typedef t-points (¤ t-point 4)))
(test "an array of a struct has no fields of its own"
#f
(get-fields 't-points))
(add-typedef 't-point-p '(typedef t-point-p (* t-point)))
(test "nor does a pointer to one"
#f
(get-fields 't-point-p))
(add-typedef 't-cb '(typedef t-cb (fn ((t-point)) void)))
(test "nor a function type over one"
#f
(get-fields 't-cb))
;; A typedef can be written to lead back to itself. Resolving it must
;; stop rather than spin
(add-typedef 't-loop-a '(typedef t-loop-a t-loop-b))
(add-typedef 't-loop-b '(typedef t-loop-b t-loop-a))
(test "a typedef cycle terminates"
't-loop-a
(get-underlying-type 't-loop-a))
(test "and has no fields"
#f
(get-fields 't-loop-a))
;; A #define keeps its value forms -- there can be more than one.
(add-define 't-maxn '(define t-maxn 8))
(test "defines are recorded"
'(define t-maxn (8))
(get-type-info 't-maxn))
;; map-fields walks an aggregate, handing each field to a function.
(test "map-fields visits every field"
'((x int) (y int))
(map-fields 't-point (lambda (name type) (list name type))))
(test "and splits shared names apart too"
'(x y w h title)
(map-fields 't-settings (lambda (name type) name)))
;; An enumerator's type is the enum itself.
(test "enum values are fields whose type is the enum"
'((red (enum t-color)) (green (enum t-color)) (blue (enum t-color)))
(map-fields 't-color (lambda (name type) (list name type))))
(test "a typedef has no fields to map"
#f
(map-fields 't-u8 (lambda (name type) name)))
(test "nor does an undeclared name"
#f
(map-fields 't-nothing (lambda (name type) name)))
;; type-match compares whole types, since a type is a form.
(test "a bare type matches" 'yes (type-match 'int (int 'yes) (else 'no)))
(test "so does a compound one" 'yes (type-match '(* const char)
(int 'no)
((* const char) 'yes)
(else 'no)))
;; The [int 10] of the docstring is Sex notation: the Sex reader turns
;; brackets into a ¤ form, while CHICKEN reads them as plain parens.
;; In a .scm file the array type has to be written out.
(test "and an array" 'yes (type-match '(¤ int 10)
((¤ int 10) 'yes)
(else 'no)))
(test "else catches the rest" 'no (type-match '(* void) (int 'yes) (else 'no)))
(test "a near miss does not match" 'no (type-match '(¤ int 20)
((¤ int 10) 'yes)
(else 'no)))
(test "no clause matching and no else is #f"
#f
(type-match 'float (int 'yes)))
;; `_' in a pattern matches anything in that position; written last it
;; takes the rest, since a type's words are spread and not nested
(test "a wildcard matches an atom"
'yes (type-match 'int (_ 'yes) (else 'no)))
(test "a pointer to anything"
'yes (type-match '(* int) ((* _) 'yes) (else 'no)))
(test "including one spelled with qualifiers"
'yes (type-match '(* const char) ((* _) 'yes) (else 'no)))
(test "an array of anything, any length"
'yes (type-match '(¤ int 4) ((¤ _ _) 'yes) (else 'no)))
(test "but a sized pattern does not match an unsized array"
'no (type-match '(¤ int) ((¤ _ _) 'yes) (else 'no)))
(test "an aggregate of any tag"
'yes (type-match '(struct point) ((struct _) 'yes) (else 'no)))
(test "and the keyword still has to agree"
'no (type-match '(union point) ((struct _) 'yes) (else 'no)))
(test "a closure of any signature"
'yes (type-match '(closure ((float)) int) ((closure _ _) 'yes) (else 'no)))
(test "an exact pattern is still exact"
'no (type-match '(* int) ((* const char) 'yes) (else 'no)))
(test "an undeclared name has no entry"
#f
(get-type-info 't-never-declared))
(test "and no fields"
#f
(get-fields 't-never-declared))
;; What type a *name* has -- the third table, which functions and
;; variables share because a function type has a surface spelling
(add-name-type! 't-sum '(fn ((int) (int)) int))
(add-name-type! 't-origin '(struct t-point))
(test "a function's signature comes back whole"
'(fn ((int) (int)) int)
(get-name-type 't-sum))
(test "and a variable's type"
'(struct t-point)
(get-name-type 't-origin))
(test "the return type is what a call site wants"
'int
(get-return-type 't-sum))
(test "a variable has no return type"
#f
(get-return-type 't-origin))
;; not an error: this is how a name from an included C header looks,
;; and the caller decides what to make of it
(test "an undeclared name has no type"
#f
(get-name-type 't-never-declared))
(test "nor a return type"
#f
(get-return-type 't-never-declared)))

3
tests/utils.module.scm
View File

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

24
tests/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) '*))
)

23
tools/sextest/Makefile
View File

@@ -1,23 +0,0 @@
CHICKEN_C = csc
CSC_FLAGS += -K prefix -static
MODULE_FLAGS = -emit-all-import-libraries -module-registration -c
ROOT = ../..
# sextest reuses sexc's reader (and its utils dependency) instead of
# duplicating the S-expression reader. The module wrappers here include
# the shared sources from the project root.
sextest: sextest.scm reader.o utils.o
$(CHICKEN_C) $(CSC_FLAGS) sextest.scm -o sextest -link reader,utils
utils.o: utils.module.scm $(ROOT)/utils.scm
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) utils.module.scm -o utils.o -unit utils
reader.o: reader.module.scm $(ROOT)/reader.scm utils.o
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) reader.module.scm -o reader.o -unit reader -link utils
clean:
rm -f *.o *.import.scm *.link sextest
.PHONY: clean

26
tools/sextest/README.org
View File

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

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

@@ -1,13 +0,0 @@
(input "Sextest")
(output "Hello from Sex!" "What is your name?" "Hello, Sextest!")
(return 255)
(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 255))

6
tools/sextest/reader.module.scm
View File

@@ -1,6 +0,0 @@
(module reader (read-from-file
read-raw-forms
current-features
platform-features)
"../../reader.scm")

199
tools/sextest/sextest.scm
View File

@@ -1,199 +0,0 @@
(import scheme
(scheme base) ; let-values
brev-separate
(chicken base)
(chicken file)
(chicken io)
(chicken pathname)
(chicken port)
(chicken process)
(chicken process-context)
(chicken string) ; string-split
fmt
getopt-long
reader ; read-raw-forms, shared with sexc
srfi-1
srfi-13) ; string-prefix?
(define (print-help)
(fmt #t "Usage: sextest [options] filename" nl
"Options:" nl
(usage opts-grammar) nl))
(define (split-settings contents)
(foldl (lambda (acc elt)
(case (car elt)
((compilation input output return)
(cons
(append (car acc) (list elt))
(cdr acc)))
(else
(cons
(car acc)
(append (cdr acc) (list elt))))))
(cons (list) (list))
contents))
;;; The feature flags of the (compilation ...) form, which we have to
;;; honour ourselves: the program is read here and printed back out for
;;; sexc, so #+ and #- are resolved on this side.
;;;
;;; Returns the named features and whether the host's own are in play
(define (compilation-features settings)
(let ((compilation (assoc 'compilation settings)))
(let loop ((flags (if compilation
(string-split (cadr compilation))
(list)))
(features (list))
(platform #t))
(define (add names rest)
(loop rest
(append features (map string->symbol (string-split names ",")))
platform))
(cond
((null? flags) (values features platform))
;; past `--' the flags are the C compiler's
((string=? (car flags) "--") (values features platform))
((string=? (car flags) "--no-platform-features")
(loop (cdr flags) features #f))
((and (member (car flags) '("-f" "--features")) (pair? (cdr flags)))
(add (cadr flags) (cddr flags)))
((string-prefix? "--features=" (car flags))
(add (substring (car flags) 11) (cdr flags)))
((string-prefix? "-f" (car flags))
(add (substring (car flags) 2) (cdr flags)))
(else (loop (cdr flags) features platform))))))
(define (process-file target-path)
(let ((first-pass (split-settings (read-raw-forms target-path))))
(let-values (((features platform?) (compilation-features (car first-pass))))
(if (and (null? features) platform?)
first-pass
(parameterize ((current-features
(append (if platform? (platform-features) (list))
features)))
(split-settings (read-raw-forms target-path)))))))
(define (compile src compilation sexc)
(let ((compiler (or
(and sexc (cdr sexc))
(get-environment-variable "SEXC")
"sexc"))
;; (compilation "--features=x -- -O2") -- one string
(flags (if compilation
(string-split (cadr compilation))
(list)))
(compiled-file (create-temporary-file)))
;; `process' returns one record; `process-input-port' is named from
;; the child's side, so it is the port we write to.
;;
;; Sex reads no symbol escaping -- `|' is an operator there. Left
;; on, `(|| a b)' leaves here as `(|\|\|| a b)' and reaches sexc
;; as a different symbol.
(let* ((proc (process compiler (append (list "-o" compiled-file) flags)))
(sexc-stdin (process-input-port proc)))
(symbol-escape #f)
(with-output-to-port sexc-stdin
(fn (map (fn (fmt #t x)) src)))
(close-output-port sexc-stdin)
(call-with-values
(fn (process-wait proc))
(lambda (pid exited retcode)
(if (= 0 retcode)
compiled-file
#f))))))
(define (run-and-check file in out ret)
(let* ((proc (process file))
(out-port (process-output-port proc)) ; the program's stdout
(in-port (process-input-port proc))) ; the program's stdin
(let ()
(when in
(with-output-to-port in-port
(fn (map (fn (fmt #t x))
(cdr in))))
(close-output-port in-port))
(let ((out-lines
(with-input-from-port out-port
(fn
(let loop ((line (read-line))
(lines (list)))
(if (eof-object? line)
(reverse lines)
(loop (read-line)
(cons line lines)))))))
(ret-code
(call-with-values
;; TODO: what if the program hangs
;; we need some kind of timeout mechanism
(fn
(process-wait proc))
(lambda (pid exited retcode)
retcode))))
(and
(if (not (= ret-code (cadr ret)))
(begin
(fmt #t "Retcode differs. Got " ret-code ", expected " (cadr ret) nl)
#f)
#t)
(if (not (equal? out-lines (cdr out)))
(begin
(fmt #t "Output differs. Got " out-lines " expected " (cdr out) nl)
#f)
#t))))))
(define opts-grammar
`((sexc ,(fmt #f "Path to sexc compiler. Defaults to value of SEXC" nl
(pad 26) "environment variable, ot if it's empty, to sexc" nl )
(required #f)
(value #t))
(help "Show this help"
(required #f)
(value #f)
(single-char #\h))))
(define (process-test-file sexc path)
(set-environment-variable! "SEX_MODULE_PATH"
(normalize-pathname (make-absolute-pathname
(current-directory)
(pathname-directory path))))
(let* ((settings-and-src (process-file path))
(settings (car settings-and-src))
(src (cdr settings-and-src))
(compiled-file (compile src (assoc 'compilation settings) sexc)))
(if (not compiled-file)
(begin (fmt #t "Failed to compile " path nl)
#f)
(if (run-and-check
compiled-file
(assoc 'input settings)
(assoc 'output settings)
(assoc 'return settings))
(begin (fmt #t ".")
#t)
(begin (fmt #t ",")
#f)))))
(define (main)
(let ((args (getopt-long (command-line-arguments)
opts-grammar)))
(when (assoc 'help args)
(print-help)
(exit 0))
(when (null? (cdr (assoc '@ args)))
(fmt #t "Missing target file" nl)
(print-help)
(exit 1))
(unless
(foldl (lambda (a b) (and a b))
#t
(map (fn (process-test-file (assoc 'sexc args) x))
(cdr (assoc '@ args))))
;; TODO: add more verbose and human readable output and reporting
(fmt #t nl)
(exit 2))
(fmt #t nl)
(exit 0)))
(main)

21
tools/sextest/utils.module.scm
View File

@@ -1,21 +0,0 @@
(module utils
(get-env-var
set-working-directory
to-absolute-pathname
comment-form?
strip-header-comments
list-split
list-join
recons
current-source-file
set-form-source!
form-source
form-file
form-line
copy-form-source!
stamp-form-source!
form-location
sex-error
with-directory
)
"../../utils.scm")

28
types.module.scm
View File

@@ -1,28 +0,0 @@
(module types
(add-struct
add-union
add-enum
add-typedef
add-define
type-match
type-pattern-matches?
map-fields
add-name-type!
get-name-type
type-of
current-type-of
get-return-type
get-type-info
get-tag-info
get-fields
get-underlying-type
type-head?
named-arg?
typedef-name?
array-bound?
array-element-type)
"types.scm")

315
types.scm
View File

@@ -1,315 +0,0 @@
;;; The type database.
;;;
;;; Every named aggregate, typedef and define the semantic engine
;;; walks past is recorded here, so that macros (or other forms) can
;;; ask what a type is made of. That is what lets a macro generate
;;; code from a struct's fields given nothing but its name.
;;;
;;; Entries are filled in as toplevel forms are processed, in order, so
;;; a type has to be declared before the macro that asks about it.
(import
scheme
(scheme base)
(chicken base)
srfi-1
srfi-69)
;;; Two namespaces: `struct point' and a `point' typedef are separate
;;; declarations. Tags -- struct, union and enum alike -- share the
;;; second table between them
(define +type-db+ (make-hash-table)) ; typedefs and defines
(define +tag-db+ (make-hash-table)) ; struct, union and enums
;;; What type a *name* has, which neither of the two above records:
;;;
;;; (fn sum ((a int) (b int)) int ...) -> (fn ((int) (int)) int)
;;; (var origin (struct point) ...) -> (struct point)
(define +name-db+ (make-hash-table))
(define (strip-pub form)
(if (eq? (car form) 'pub) (cdr form) form))
(define (comment-form? f)
(and (pair? f) (eq? (car f) 'comment)))
;;; Fields are written with the type last and one or more names before
;;; it, so ((x y int) (p (* char))) describes three fields. Flatten that
;;; into one (name type) per field, which is what a caller wants.
(define (normalize-fields fields)
(append-map
(lambda (field)
(if (comment-form? field)
(list)
(let ((type (last field))
(names (drop-right field 1)))
(map (lambda (name) (list name type)) names))))
(remove comment-form? fields)))
;;; ([pub] struct name (fields ...) . attrs)
(define (aggregate-fields form)
(let ((f (strip-pub form)))
(if (and (pair? (cddr f)) (list? (caddr f)))
(caddr f)
(list))))
(define (add-struct name form)
(hash-table-set! +tag-db+ name
(list 'struct name (normalize-fields (aggregate-fields form)))))
(define (add-union name form)
(hash-table-set! +tag-db+ name
(list 'union name (normalize-fields (aggregate-fields form)))))
;;; ([pub] enum name (value ...))
(define (add-enum name form)
(let ((f (strip-pub form)))
(hash-table-set! +tag-db+ name
(list 'enum name (if (and (pair? (cddr f)) (list? (caddr f)))
(caddr f)
(list))))))
;;; ([pub] typedef new-name target)
(define (add-typedef name form)
(hash-table-set! +type-db+ name
(list 'typedef name (last (strip-pub form)))))
;;; (define name value ...) -- a C #define, kept so a macro can read a
;;; compile-time constant rather than re-parse the source.
(define (add-define name form)
(hash-table-set! +type-db+ name
(list 'define name (cddr (strip-pub form)))))
;;; `(type-of x)' inside a macro body: the type of the expression the
;;; macro was handed, where `get-name-type' only answers for a name.
;;; The walker that can answer it lives in `semen', which is compiled
;;; after this, so it installs itself here for the length of one
;;; expansion. Outside one there is no scope to ask about, and the
;;; answer is #f.
(define current-type-of (make-parameter (lambda (form) #f)))
(define (type-of form) ((current-type-of) form))
(define (add-name-type! name type)
(hash-table-set! +name-db+ name type))
;;; #f for a name never declared, which is what `printf' looks like
;;; until something parses stdio.h. Not an error here; the caller
;;; decides.
(define (get-name-type name)
(hash-table-ref/default +name-db+ name #f))
;;; What `(make-adder 10)' has for a type: `make-adder's return type,
;;; or #f when NAME is not a function with a signature on record
(define (get-return-type name)
(let ((type (get-name-type name)))
(and (pair? type)
(eq? 'fn (car type))
(= 3 (length type))
(third type))))
(define (get-tag-info name)
(hash-table-ref/default +tag-db+ name #f))
;;; First look up the ordinary identifier, then tag of that id when
;;; no ordinary one was declared, as C does
(define (get-type-info name)
(or (hash-table-ref/default +type-db+ name #f)
(get-tag-info name)))
;;; ((name type) ...) for a struct or union, #f for anything else --
;;; including a name that was never declared. Callers give the better
;;; error, since they know what they wanted it for.
;;;
;;; A typedef is followed to what it stands for, so reflection over an
;;; alias works exactly as it does over the name it aliases.
(define (get-fields name)
(let ((info (resolve-type-info name)))
(and info
(memq (car info) '(struct union))
(caddr info))))
;;; Follow a typedef chain to the name it stands for. #f if NAME is
;;; not a typedef. A typedef that leads back to itself stops rather
;;; than spinning: nothing prevents one from being written.
(define (get-underlying-type name)
(let follow ((name name) (seen (list)))
(and (not (member name seen))
(let ((info (get-type-info name)))
(and info
(eq? (car info) 'typedef)
(let ((target (caddr info)))
(or (and (symbol? target) (follow target (cons name seen)))
target)))))))
;;; The declaration NAME ultimately names. For a typedef that is the
;;; entry of whatever it stands for, and for anything else it is
;;; NAME's own info
(define (target-tag target)
(cond
((symbol? target) target)
((and (pair? target)
(memq (car target) '(struct union enum))
(pair? (cdr target))
(symbol? (cadr target)))
(cadr target))
(else #f)))
(define (resolve-type-info name)
(let ((info (resolve-ordinary-type-info name)))
(if (and info (memq (car info) '(struct union enum)))
info
(or (get-tag-info name) info))))
(define (resolve-ordinary-type-info name)
(let ((info (get-type-info name)))
(and info
(if (eq? (car info) 'typedef)
(let ((tag (target-tag (get-underlying-type name))))
;; A typedef target is written in type position, where
;; `struct point' means the tag
(and tag (or (get-tag-info tag) (get-type-info tag))))
info))))
;;; Type matcher macro
;;; (type-match type
;;; (int ...)
;;; ((* const char) ...)
;;; ([int 10] ...)
;;; ((* _) ...) ; a pointer to anything
;;; ((¤ _ _) ...) ; an array of anything, any length
;;; (else ...))
;;;
;;; A type is a form, not an atom, so patterns are matched structurally
;;; rather than dispatched on like `case'. They are literal types and
;;; are not evaluated; `else' is optional and the whole thing is #f when
;;; nothing matches and there is no else.
;;;
;;; `_' in a pattern matches anything in that position, the same thing
;;; it means in a type. Without it every spelling has to be enumerated:
;;; `(closure ((int)) int)' and `(closure ((float)) int)' are separate
;;; clauses for what is one case.
;;;
;;; A `_' written last takes everything that remains, because a type's
;;; words are spread rather than nested -- `(* const char)' is three
;;; elements, so `(* _)' has to cover two of them to mean "a pointer to
;;; anything".
;;;
;;; Nothing destructures: a macro body is ordinary Scheme and a type is
;;; a list, so `(caddr (type-of x))' already reads the length out of
;;; `(¤ int 4)'.
(define-syntax type-match
(syntax-rules (else)
((_ type) #f)
((_ type (else body ...)) (begin body ...))
((_ type (pattern body ...) clause ...)
(if (type-pattern-matches? 'pattern type)
(begin body ...)
(type-match type clause ...)))))
(define (type-pattern-matches? pattern type)
(cond
((eq? pattern '_) #t)
((and (pair? pattern) (pair? type))
(if (and (eq? (car pattern) '_) (null? (cdr pattern)))
#t ; a trailing `_' takes the rest
(and (type-pattern-matches? (car pattern) (car type))
(type-pattern-matches? (cdr pattern) (cdr type)))))
(else (equal? pattern type))))
;;; Map function to each field/value of a structure/union/enum
;;; For enums, field-type is the type of the enum (since C 23)
;;; (map-fields type-name
;;; (lambda (field-name field-type) ...))
;;;
;;; Returns #f if nothing of that name was declared
(define (map-fields struct-union-enum fn)
(let ((info (resolve-type-info struct-union-enum)))
(and info
(case (car info)
((struct union)
(map (lambda (field) (fn (car field) (cadr field)))
(caddr info)))
;; An enumerator's type is the enum itself -- named as it was
;; declared, since `enum some-typedef' is not a C type.
((enum)
(let ((type (list 'enum (cadr info))))
(map (lambda (value) (fn value type))
(caddr info))))
(else #f)))))
;;; The shape of a written type
;;;
;;; Where a type ends, asked by an arglist and by an array bound:
;;;
;;; (f1 float) a name and a type (unsigned int) a type
;;; (¤ int 4) four of int (¤ const t) unsized, of const t
;;; (¤ mytype N) N of mytype (¤ * size-t) unsized, of (* size-t)
;;; A qualifier cannot end a type: `(¤ const t)' is unsized, `(¤ int 4)'
;;; is four of int.
(define +c-qualifiers+ '(const volatile restrict _Atomic))
(define +c-specifiers+
'(void char short int long float double signed unsigned
bool _Bool complex _Complex))
;;; Does this list start a type rather than name one? `(const char)'
;;; and `(unsigned int)' are types; `(f1 float)' is a named parameter.
(define (type-head? form)
(and (pair? form)
(symbol? (car form))
(or (memq (car form) '(* ¤ struct union enum))
(memq (car form) +c-qualifiers+)
(memq (car form) +c-specifiers+))))
;;; Does the parameter name itself?
;;; (f1 float) does
;;; (float), (const char), (unsigned int) and (¤ float 4) do not
(define (named-arg? arg)
(and (pair? arg)
(pair? (cdr arg)) ; 1 element args are always type
(not (type-head? arg))))
;;; A typedef and a `define' share +type-db+; only the typedef is part
;;; of a type:
;;;
;;; (typedef small int) -> (¤ small N) is N of small
;;; (define CAP 4) -> (¤ int CAP) is CAP of int
(define (typedef-name? name)
(let ((info (and (symbol? name) (get-type-info name))))
(and info (memq (car info) '(typedef struct union enum)) #t)))
;;; The last element is a bound only where what precedes it already
;;; spells a whole type -- a specifier, a tag after its keyword, or a
;;; typedef we have seen declared:
;;;
;;; (¤ int 4) four of int (¤ unsigned int) unsized
;;; (¤ mytype CAP) CAP of mytype (¤ struct point) unsized
;;; (¤ const mytype) unsized (¤ * size-t) unsized
;;;
;;; TYPE is the whole `(¤ ...)' form.
(define (array-bound? type)
(and (> (length type) 2)
(let ((bound (last type))
(preceding (last (drop-right type 1))))
(cond
((not (symbol? bound)) #t)
((or (memq bound +c-specifiers+) (memq bound +c-qualifiers+)) #f)
((memq preceding +c-specifiers+) #t)
;; a tag always follows its keyword, so `(¤ * struct tt)' ends
;; in a name belonging to the type
((memq preceding '(struct union enum)) #f)
(else (typedef-name? preceding))))))
;;; What one element of a written array type is:
;;; (¤ struct point 2) -> (struct point), (¤ * const char 2) -> (* const char)
(define (array-element-type type)
(and (pair? type)
(eq? '¤ (car type))
(pair? (cdr type))
(let ((words (if (array-bound? type)
(drop-right (cdr type) 1)
(cdr type))))
(and (pair? words)
(if (null? (cdr words)) (car words) words)))))

17
utils.macros.scm Normal file
View File

@@ -0,0 +1,17 @@
(import (chicken process-context))
(define-syntax prog1
(syntax-rules ()
((prog1 form . forms)
(let ((res form))
(begin . forms)
res))))
(define-syntax with-directory
(syntax-rules ()
((with-directory path form . forms)
(let ((current-dir (current-directory)))
(set-working-directory path)
(prog1
(begin form . forms)
(change-directory current-dir))))))

24
utils.module.scm
View File

@@ -1,24 +0,0 @@
(module utils
(get-env-var
set-working-directory
to-absolute-pathname
comment-form?
strip-header-comments
list-split
list-join
recons
current-source-file
set-form-source!
form-source
form-file
form-line
copy-form-source!
stamp-form-source!
form-location
set-form-type!
form-type
sex-error
sex-warning
with-directory
)
"utils.scm")

165
utils.scm
View File

@@ -1,27 +1,10 @@
(declare (unit utils))
(include "utils.macros.scm")
(import
scheme
(scheme base) ; make-parameter
(chicken base)
(chicken pathname)
(chicken process-context)
srfi-1
srfi-69)
(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))))))
(chicken process-context))
(define (get-env-var name)
(get-environment-variable name))
@@ -34,141 +17,3 @@
(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 (comment-form? form)
(and (pair? form) (eq? (car form) 'comment)))
;;; Remove the comment forms from the first COUNT elements of FORM --
;;; its header -- so that the positional accessors reading it are not
;;; shifted by one
(define (strip-header-comments form count)
;; This always rebuilds the list, so the location has to be carried
;; over explicitly -- otherwise every form loses it
(copy-form-source!
form
(let loop ((rest form) (kept 0) (acc (list)))
(cond
((null? rest) (reverse acc))
((= kept count) (append (reverse acc) rest))
((comment-form? (car rest)) (loop (cdr rest) kept acc))
(else (loop (cdr rest) (+ kept 1) (cons (car rest) acc)))))))
(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
;; A rebuilt cell is still the same source form, so it keeps the
;; same location
(copy-form-source! old-cons (cons new-car new-cdr))))
;;; Source-location map.
;;; Our hand-written reader records the source location of each form
;;; here, keyed by the form's cons cell (eq?). This replaces CHICKEN's
;;; read-with-source-info / get-line-number, which only works when forms
;;; are produced by the built-in `read'.
;;;
;;; A location is (file . line). The file matters because imported
;;; modules paste their public forms into the current unit: those forms
;;; originate in another file and must be reported as such
(define +form-sources+ (make-hash-table eq?))
;;; The file `parse-all' is currently reading. Bound by the reader
(define current-source-file (make-parameter "<unknown>"))
;;; What type a form has, once something has worked it out. Keyed by
;;; cons cell like the sources above, so one form has one type: a body
;;; typed at two instantiations has to be copied before the second.
(define +form-types+ (make-hash-table eq?))
(define (set-form-type! form type)
(when (pair? form)
(hash-table-set! +form-types+ form type))
type)
(define (form-type form)
(hash-table-ref/default +form-types+ form #f))
(define (set-form-source! form file line)
(hash-table-set! +form-sources+ form (cons file line)))
(define (form-source form)
(hash-table-ref/default +form-sources+ form #f))
(define (form-file form)
(let ((src (form-source form)))
(and src (car src))))
(define (form-line form)
(let ((src (form-source form)))
(and src (cdr src))))
(define (copy-form-source! from to)
"Give TO the location of FROM, if FROM has one. Returns TO, so it can
wrap a form-building expression."
(let ((src (form-source from)))
(when (and src (pair? to))
(hash-table-set! +form-sources+ to src)))
to)
;;; Diagnostics
;;;
;;; Every form carries a location now, so an error can say where the
;;; wrong code was written
(define (form-location form)
"\"file:line: \" for FORM, or \"\" when it has none"
(let ((src (form-source form)))
(if src
(string-append (car src) ":" (number->string (cdr src)) ": ")
"")))
(define (sex-error form message . args)
"Signal an error about FORM, prefixed with where it was written."
(apply error (string-append (form-location form) message) args))
(define (sex-warning form message . args)
"Report something about FORM that does not stop the compilation.
Goes to stderr, prefixed with where the form was written, so a warning
reads like an error and sorts alongside one in a build log."
(let ((port (current-error-port)))
(display (form-location form) port)
(display "warning: " port)
(display message port)
(for-each (lambda (arg) (display " " port) (display arg port)) args)
(newline port)))
(define (stamp-form-source! form src)
"Give FORM and every subform that has none the location SRC. Used for
macro expansions, which inherit the location of the call site the way a
cpp macro does. Forms that already have a location keep it."
(when (and src (pair? form))
(unless (form-source form)
(hash-table-set! +form-sources+ form src))
(stamp-form-source! (car form) src)
(stamp-form-source! (cdr form) src))
form)