Compare commits
6 Commits
type-infer
...
c709c69176
| Author | SHA1 | Date | |
|---|---|---|---|
| c709c69176 | |||
| 1e435f7fdf | |||
| c976378363 | |||
| 5af2e99f5f | |||
| bb1614a123 | |||
| c1fbb02c50 |
@@ -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
|
||||
55
.github/workflows/build.yaml
vendored
Normal file
55
.github/workflows/build.yaml
vendored
Normal file
@@ -0,0 +1,55 @@
|
||||
name: Sex CI
|
||||
|
||||
on:
|
||||
push:
|
||||
branches: [ main ]
|
||||
pull_request:
|
||||
branches: [ main ]
|
||||
|
||||
jobs:
|
||||
build-linux:
|
||||
|
||||
runs-on: ubuntu-latest
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v3
|
||||
- name: Install chicken
|
||||
run: |
|
||||
wget -N https://code.call-cc.org/releases/6.0.0/chicken-6.0.0.tar.gz
|
||||
tar zxf chicken-6.0.0.tar.gz
|
||||
sudo apt install -y make
|
||||
make -C chicken-6.0.0 PLATFORM=linux
|
||||
sudo make -C chicken-6.0.0 PLATFORM=linux install
|
||||
- name: Install dependencies
|
||||
# FIXME: [project-local deps]: use venv or something
|
||||
# run: make deps
|
||||
run: sudo chicken-install $(cat dependencies.txt)
|
||||
- name: Make sure that sexc builds
|
||||
# FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
|
||||
# Without it there will be `Error: cannot load extension: fmt`.
|
||||
run: make sexc && ./sexc --help
|
||||
- name: Run tests
|
||||
# FIXME: [project-local deps]: use local deps or build with -static
|
||||
# run: make run-tests
|
||||
run: make sex-tests && ./sex-tests
|
||||
|
||||
build-macos:
|
||||
|
||||
runs-on: macos-15
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v3
|
||||
- name: Install chicken
|
||||
run: brew install chicken make
|
||||
- name: Install dependencies
|
||||
# FIXME: [project-local deps]: use venv or something
|
||||
# run: make deps
|
||||
run: chicken-install $(cat dependencies.txt)
|
||||
- name: Make sure that sexc builds
|
||||
# FIXME: sexc being built with local .eggs/ libs needs the path at runtime.
|
||||
# Without it there will be `Error: cannot load extension: fmt`.
|
||||
run: make sexc && ./sexc --help
|
||||
- name: Run tests
|
||||
# FIXME: [project-local deps]: use local deps or build with -static
|
||||
# run: make run-tests
|
||||
run: make sex-tests && ./sex-tests
|
||||
9
.gitignore
vendored
9
.gitignore
vendored
@@ -1,14 +1,5 @@
|
||||
# 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
|
||||
|
||||
119
Makefile
119
Makefile
@@ -1,6 +1,4 @@
|
||||
CHICKEN_C ?= csc
|
||||
CHICKEN_INSTALL ?= chicken-install
|
||||
CHICKEN_STATUS ?= chicken-status
|
||||
CHICKEN_C = csc
|
||||
CSC_FLAGS += -K prefix -static
|
||||
# What and why:
|
||||
# -emit-all-import-libraries: Emit import-libraries for all defined modules.
|
||||
@@ -14,42 +12,12 @@ CSC_FLAGS += -K prefix -static
|
||||
# error.
|
||||
# -c: Stop after compilation to object files. This one is obvious.
|
||||
|
||||
# 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 = utils types sex-macros reader sex-modules semen sex-fmt-c fmt-c-writer sexc
|
||||
OBJ = $(MODULES:%=%.o)
|
||||
|
||||
DEPSFILE = dependencies.txt
|
||||
DEPSLOCK = eggs.lock
|
||||
EGGS_DIR := $(abspath .eggs)
|
||||
|
||||
# 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)
|
||||
|
||||
# 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)
|
||||
|
||||
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
|
||||
@@ -63,9 +31,6 @@ utils.o: utils.module.scm utils.scm
|
||||
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
|
||||
|
||||
@@ -75,17 +40,17 @@ reader.o: reader.module.scm reader.scm utils.o
|
||||
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
|
||||
semen.o: semen.module.scm semen.scm 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,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
|
||||
fmt-c-writer.o: fmt-c-writer.module.scm fmt-c-writer.scm sex-fmt-c.o utils.o
|
||||
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
|
||||
|
||||
sexc.o: sexc.module.scm 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
|
||||
sexc.o: sexc.module.scm 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,types,utils
|
||||
|
||||
# Unit testing
|
||||
sex-tests:
|
||||
@@ -96,80 +61,20 @@ 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
|
||||
SEX_TEST_PROGRAMS = hello-world lists comments unicode serialize
|
||||
|
||||
# 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)
|
||||
run-tests: sexc sex-tests sextest
|
||||
./sex-tests && ./sextest --sexc=./sexc $(SEX_TEST_PROGRAMS:%=./tests/sex-programs/%.sex) && $(MAKE) check-modules
|
||||
|
||||
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
|
||||
.PHONY: clean run-tests sex-tests sextest check-modules
|
||||
|
||||
140
Readme.org
140
Readme.org
@@ -12,49 +12,16 @@ Sex is statically typed, compiled general purpose language.
|
||||
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 `cat dependencies.txt`~
|
||||
|
||||
#+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 +31,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
|
||||
@@ -142,90 +101,11 @@ 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
|
||||
|
||||
@@ -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")
|
||||
@@ -3,25 +3,19 @@
|
||||
(fn sum ((a int) (b int)) int
|
||||
(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 main () int
|
||||
(var a int 10)
|
||||
(var b int 20)
|
||||
(var sum-fn (fn ((int) (int)) int) sum)
|
||||
(var (fn ((int) (int)) int) sum-fn sum)
|
||||
|
||||
(var sum-lambda (fn ((int) (int)) int)
|
||||
(var (fn ((int) (int)) int) sum-lambda
|
||||
|
||||
(lambda ((a int) (b int)) int
|
||||
(lambda ((a int) (b int)) int ()
|
||||
(return (+ a b))))
|
||||
|
||||
(var sum-lambda-2 (fn ((int)) int)
|
||||
(var (fn ((int)) int) sum-lambda-2
|
||||
|
||||
(lambda ((a int)) int
|
||||
(lambda ((a int)) int ()
|
||||
(return (+ a 20))))
|
||||
|
||||
(printf "Hello from main fn!\n")
|
||||
@@ -30,19 +24,28 @@
|
||||
(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 ((a int) (b int)) int ()
|
||||
(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 ((a int)) int ()
|
||||
(var (fn ((int)) int) l-2
|
||||
(lambda ((a int)) int ()
|
||||
(return (+ 60 a))))
|
||||
(return (+ 600 (l-2 a)))))
|
||||
(printf "Calling nested lambdas: %d\n" (l-1 6))
|
||||
|
||||
(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))
|
||||
;; Not supported yet
|
||||
;; Closure
|
||||
;; (var (fn (fn ((int)) int) ((int))) make-adder
|
||||
;; (lambda (fn int ((int a))) ()
|
||||
;; (return (lambda int ((int b)) (a)
|
||||
;; (return (+ a b))))))
|
||||
;;
|
||||
;; (var (fn int ((int))) add-10
|
||||
;; (make-adder 10))
|
||||
;; (var (fn int ((int))) add-20
|
||||
;; (make-adder 20))
|
||||
;; (printf "Calling closures: %d\n" (add-10 24))
|
||||
(return 0))
|
||||
|
||||
@@ -8,29 +8,13 @@
|
||||
;;; 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:
|
||||
;;; Build:
|
||||
;;; ./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
|
||||
(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)
|
||||
(include OpenGL/gl3.h)
|
||||
|
||||
(define WINDOW-WIDTH 800)
|
||||
(define WINDOW-HEIGHT 600)
|
||||
|
||||
141
fmt-c-writer.scm
141
fmt-c-writer.scm
@@ -13,7 +13,6 @@
|
||||
(chicken irregex) ; unkebabify
|
||||
srfi-1 ; lists
|
||||
srfi-13 ; strings
|
||||
types ; array-bound?, named-arg?
|
||||
utils)
|
||||
|
||||
;;; egg `tree' not ported to CHICKEN 6 yet
|
||||
@@ -115,13 +114,16 @@ forms, and what remains."
|
||||
((attribute) '%attribute)
|
||||
((¤) '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=)
|
||||
;; uh things we do for c89 compatibility
|
||||
((bool) 'int)
|
||||
((true) 1)
|
||||
((false) 0)
|
||||
(else
|
||||
(if (symbol? atom)
|
||||
(unkebabify atom)
|
||||
@@ -133,6 +135,9 @@ forms, and what remains."
|
||||
(car type)
|
||||
type))
|
||||
|
||||
(define (comment-form? f)
|
||||
(and (pair? f) (eq? (car f) 'comment)))
|
||||
|
||||
;;; Strip ;s so ;;; Foo becomes /* Foo */ and not /* ;; Foo */
|
||||
(define (strip-comment-marker text)
|
||||
(string-trim-both (string-trim text #\;)))
|
||||
@@ -174,7 +179,9 @@ forms, and what remains."
|
||||
|
||||
(define (walk-expr form)
|
||||
(match form
|
||||
((? vector?) (walk-initializer (vector->list form)))
|
||||
((? vector?)
|
||||
(list->vector
|
||||
(walk-expr (vector->list form))))
|
||||
((? atom?)
|
||||
(atom-to-fmt-c form))
|
||||
;; (comment "text") -> /* text */. `%comment' is the fmt-c directive.
|
||||
@@ -234,48 +241,6 @@ forms, and what remains."
|
||||
;; 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)
|
||||
@@ -303,13 +268,18 @@ forms, and what remains."
|
||||
;; (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))
|
||||
(if (integer? (last array-type))
|
||||
;; sized array
|
||||
(let* ((type-list (drop-right array-type 1))
|
||||
(type (maybe-unwrap-type type-list))
|
||||
(size (last array-type)))
|
||||
`(%array ,(walk-type type)
|
||||
,size))
|
||||
;; sugar for pointer... Do we really need it? Guess why not,
|
||||
;; it's a strong semantic cue
|
||||
`(%array ,(walk-type (array-element-type form)))))
|
||||
`(%array ,(walk-type (maybe-unwrap-type array-type)))))
|
||||
(('fn arglist ret-type)
|
||||
`(%fun ,(walk-type ret-type) ,(walk-arg-types arglist)))
|
||||
`(%fun ,(walk-type ret-type) ,(walk-arglist arglist)))
|
||||
(('fn . _)
|
||||
(sex-error form "malformed function type" form))
|
||||
|
||||
@@ -321,13 +291,8 @@ forms, and what remains."
|
||||
(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)))))
|
||||
|
||||
@@ -339,10 +304,6 @@ forms, and what remains."
|
||||
(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
|
||||
@@ -350,12 +311,6 @@ forms, and what remains."
|
||||
;; 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
|
||||
@@ -373,36 +328,35 @@ forms, and what remains."
|
||||
.
|
||||
,(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))))
|
||||
;;; TODO: isn't there a better way?
|
||||
(define (is-probably-type form)
|
||||
(case (car form)
|
||||
((¤ * const volatile struct union) #t)
|
||||
(else #f)))
|
||||
|
||||
;;; 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)))))
|
||||
(map (fn
|
||||
(match x
|
||||
(('¤ . _) (walk-type x))
|
||||
|
||||
;; yeah shitty, but I don't know yet how to determine if the
|
||||
;; first entry is part of the type and not an argument name
|
||||
;; :(
|
||||
((? is-probably-type) (walk-type x))
|
||||
|
||||
;; 1 element args are always type
|
||||
((_) (walk-type x))
|
||||
|
||||
((var . type) (append (list (walk-type (maybe-unwrap-type type)))
|
||||
(list (walk-type var))))))
|
||||
(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
|
||||
;; (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)))))
|
||||
@@ -428,17 +382,10 @@ forms, and what remains."
|
||||
|
||||
(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))))
|
||||
`(enum ,(atom-to-fmt-c name) ,(map atom-to-fmt-c values)))))
|
||||
|
||||
(define (walk-extern form)
|
||||
(match form
|
||||
@@ -463,7 +410,6 @@ forms, and what remains."
|
||||
|
||||
('struct . _)
|
||||
('union . _)
|
||||
('enum . _)
|
||||
|
||||
('typedef . _))
|
||||
;; ignore here, used in generating public interface
|
||||
@@ -477,10 +423,7 @@ forms, and what remains."
|
||||
(('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)))
|
||||
(('pub . rest) (walk-public rest))
|
||||
((or ('struct . _)
|
||||
('union . _)) (walk-struct form))
|
||||
(('enum . _) (walk-enum form))
|
||||
|
||||
@@ -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
644
infer.scm
@@ -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))))
|
||||
@@ -1,6 +1,3 @@
|
||||
(module reader (read-from-file
|
||||
read-raw-forms
|
||||
|
||||
current-features
|
||||
platform-features)
|
||||
read-raw-forms)
|
||||
"reader.scm")
|
||||
|
||||
71
reader.scm
71
reader.scm
@@ -7,8 +7,6 @@
|
||||
;;; - 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.
|
||||
|
||||
@@ -17,8 +15,6 @@
|
||||
(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
|
||||
@@ -115,21 +111,6 @@
|
||||
((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)
|
||||
@@ -179,8 +160,7 @@
|
||||
((string->number s) => identity)
|
||||
(else (string->symbol s))))
|
||||
|
||||
;;; #-dispatch: booleans, characters, vectors, block/datum comments,
|
||||
;;; feature expressions
|
||||
;;; #-dispatch: booleans, characters, vectors, block/datum comments
|
||||
(define (read-hash port)
|
||||
(let ((c (get-ch port)))
|
||||
(cond
|
||||
@@ -191,57 +171,8 @@
|
||||
((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)
|
||||
|
||||
@@ -14,7 +14,6 @@
|
||||
c-in-expr c-in-stmt c-in-test
|
||||
c-paren c-maybe-paren c-type c-literal? c-literal char->c-char
|
||||
c-struct c-union c-class c-enum c-typedef c-cast
|
||||
c-braced-list c-compound c-designate
|
||||
c-expr c-expr/sexp c-apply c-op c-indent c-current-indent-string
|
||||
c-wrap-stmt c-open-brace c-close-brace
|
||||
c-block c-braced-block c-begin
|
||||
@@ -278,8 +277,6 @@
|
||||
((%comment) ((apply c-comment (cdr x)) st))
|
||||
((:) ((apply c-label (cdr x)) st))
|
||||
((%cast) ((apply c-cast (cdr x)) st))
|
||||
((%compound) ((apply c-compound (cdr x)) st))
|
||||
((%designate) ((apply c-designate (cdr x)) st))
|
||||
((+ - & * / % ! ~ ^ && < > <= >= == != << >>
|
||||
= *= /= %= &= ^= >>= <<=) ; |\|| |\|\|| |\|=|
|
||||
((apply c-op x) st))
|
||||
@@ -309,7 +306,17 @@
|
||||
((apply c-op "-=" (cdr x)) st))
|
||||
(else ((c-apply x) st))))))
|
||||
((vector? x)
|
||||
((c-wrap-stmt (c-braced-list (vector->list x))) st))
|
||||
((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))))))
|
||||
|
||||
@@ -633,22 +640,16 @@
|
||||
(define (c-union . args) (apply c-struct/aux "union" args))
|
||||
(define (c-class . args) (apply c-struct/aux "class" args))
|
||||
|
||||
;; MODIFIED FROM UPSTREAM fmt-c: an enum may also be named without
|
||||
;; being defined -- `enum color m;' -- exactly as c-struct/aux
|
||||
;; already allows `struct point p;'. Upstream assumed a value list
|
||||
;; was always present and mapped over whatever stood in its place.
|
||||
(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 (if (null? o) #f (car o)) x)))
|
||||
(if vals
|
||||
(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))))))
|
||||
(c-wrap-stmt (cat "enum " name)))))
|
||||
(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 ", ") "))"))
|
||||
@@ -730,13 +731,10 @@
|
||||
(cat (c-type (cadr type) #f)
|
||||
" (*" (or name "") ")("
|
||||
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
|
||||
;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
|
||||
;; array parameter of a function type, where C has no room
|
||||
;; for a name -- arrives as #f, and upstream printed it
|
||||
((%array)
|
||||
(let ((name (cat (or name "") "[" (if (pair? (cddr type))
|
||||
(c-expr (caddr type))
|
||||
"")
|
||||
(let ((name (cat name "[" (if (pair? (cddr type))
|
||||
(c-expr (caddr type))
|
||||
"")
|
||||
"]")))
|
||||
(c-type (cadr type) name)))
|
||||
((%pointer *)
|
||||
@@ -745,13 +743,7 @@
|
||||
(if (and (pair? (cadr type)) (eq? '%array (caadr type)))
|
||||
(c-paren name)
|
||||
name))))
|
||||
;; MODIFIED FROM UPSTREAM fmt-c: upstream passed the
|
||||
;; declarator's name to c-enum as the enum's tag, so
|
||||
;; `(var m (enum color))' emitted `enum m {...}' and lost the
|
||||
;; variable. Enums are laid out like structs: the type, then
|
||||
;; the name being declared.
|
||||
((enum)
|
||||
(cat (apply c-enum (cdr type)) (if name (cat " " 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 " "))))
|
||||
@@ -769,13 +761,10 @@
|
||||
(cat (c-type (cadr type) #f)
|
||||
" (*" (or name "") ")("
|
||||
(fmt-join (lambda (x) (c-type x #f)) (caddr type) ", ") ")"))
|
||||
;; MODIFIED FROM UPSTREAM fmt-c: a nameless declarator -- an
|
||||
;; array parameter of a function type, where C has no room
|
||||
;; for a name -- arrives as #f, and upstream printed it
|
||||
((%array)
|
||||
(let ((name (cat (or name "") "[" (if (pair? (cddr type))
|
||||
(c-expr (caddr type))
|
||||
"")
|
||||
(let ((name (cat name "[" (if (pair? (cddr type))
|
||||
(c-expr (caddr type))
|
||||
"")
|
||||
"]")))
|
||||
(c-type (cadr type) name)))
|
||||
((%pointer *)
|
||||
@@ -825,25 +814,6 @@
|
||||
(cat "(" (c-with-op 'paren (c-expr expr)) ")")
|
||||
(c-expr expr))))
|
||||
|
||||
;; { a, b, c } -- on one line if it fits, one element per line if not.
|
||||
(define (c-braced-list ls)
|
||||
(fmt-try-fit
|
||||
(fmt-let 'no-wrap? #t (cat "{" (fmt-join c-expr ls ", ") "}"))
|
||||
(lambda (st)
|
||||
(let* ((col (fmt-col st))
|
||||
(sep (string-append "," (make-nl-space col))))
|
||||
((cat "{" (fmt-join c-expr ls sep) "}" nl) st)))))
|
||||
|
||||
;; (T){ ... } -- a C99 compound literal, not a cast: the result is an
|
||||
;; unnamed object and an lvalue, so `&' on it is legal. At block scope
|
||||
;; it lives until the end of the enclosing block and no longer.
|
||||
(define (c-compound type . init)
|
||||
(cat "(" (c-type type) ")" (c-braced-list init)))
|
||||
|
||||
;; .field = value, inside a braced list
|
||||
(define (c-designate field value)
|
||||
(cat "." (c-expr field) " = " (c-expr value)))
|
||||
|
||||
(define (c-typedef type alias . o)
|
||||
(c-wrap-stmt
|
||||
(cat "typedef " (c-type type alias) (fmt-join/prefix c-expr o " "))))
|
||||
@@ -1015,24 +985,9 @@
|
||||
(cat nl (make-space (+ 2 (fmt-col st))) str " "))
|
||||
st))))))))))
|
||||
|
||||
;; `-' arrives as the symbol binary minus uses, and so with binary
|
||||
;; precedence: `(+ (- b) b)' asked under that spelling comes out
|
||||
;; `(-b) + b'.
|
||||
(define (unary-operator op)
|
||||
(case op
|
||||
((-) 'unary-)
|
||||
((+) 'unary+)
|
||||
((*) 'unary-*)
|
||||
((&) 'unary-&)
|
||||
(else op)))
|
||||
|
||||
;; Parenthesises the whole expression rather than the operand: the
|
||||
;; other way round, `(. (* p) x)' came out `*(p).x', which C reads as
|
||||
;; `*(p.x)'.
|
||||
(define (c-unary-op op x)
|
||||
(c-wrap-stmt
|
||||
(c-maybe-paren (unary-operator op)
|
||||
(cat (display-to-string op) (c-expr x)))))
|
||||
(cat (display-to-string op) (c-maybe-paren op (c-expr x)))))
|
||||
|
||||
;; some convenience definitions
|
||||
|
||||
|
||||
@@ -25,14 +25,9 @@
|
||||
;; 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))
|
||||
(only types get-type-info get-fields get-underlying-type
|
||||
type-match map-fields))
|
||||
,@body)))
|
||||
|
||||
(define (get-macro name)
|
||||
|
||||
@@ -8,17 +8,12 @@
|
||||
(chicken process-context)
|
||||
(chicken string)
|
||||
fmt
|
||||
matchable
|
||||
reader
|
||||
srfi-1
|
||||
utils)
|
||||
|
||||
(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)
|
||||
;; Module list is a list of symbols
|
||||
;; How Sex handles modules:
|
||||
@@ -34,11 +29,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 +63,22 @@
|
||||
(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)
|
||||
;; A function is reduced to a prototype and keeps its `pub', so
|
||||
;; the importing unit declares it with external linkage
|
||||
((fn)
|
||||
(cons (copy-form-source! form (take form 5)) acc))
|
||||
;; A variable becomes an `extern' declaration
|
||||
((var)
|
||||
(cons (copy-form-source! form (cons 'extern (take (cdr form) 3))) acc))
|
||||
((define defmacro import include struct typedef union)
|
||||
(cons (copy-form-source! form (cdr form)) acc))
|
||||
(else (sex-error form "pub must be followed by a definition" form))))
|
||||
(else acc)))
|
||||
|
||||
(define (load-persistent-module-paths)
|
||||
(let ((sex-module-path-env-var
|
||||
|
||||
79
sexc.scm
79
sexc.scm
@@ -2,14 +2,12 @@
|
||||
(scheme base) ; call/cc
|
||||
brev-separate
|
||||
(chicken base)
|
||||
(chicken condition) ; handle-exceptions
|
||||
(chicken file)
|
||||
(chicken plist)
|
||||
(chicken pretty-print)
|
||||
(chicken process)
|
||||
(chicken process-context)
|
||||
(chicken port)
|
||||
(chicken string) ; string-split
|
||||
fmt
|
||||
fmt-c-writer
|
||||
getopt-long
|
||||
@@ -32,17 +30,6 @@
|
||||
(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)
|
||||
@@ -110,15 +97,6 @@
|
||||
((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-input-file args)
|
||||
(let ((rest-args (get-rest-args args)))
|
||||
(if (null? rest-args)
|
||||
@@ -139,22 +117,15 @@
|
||||
(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."
|
||||
(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))
|
||||
output)))
|
||||
;; The generated C goes to a temporary .c file rather than the
|
||||
;; compiler's stdin
|
||||
(let ((c-file (create-temporary-file "c")))
|
||||
(with-output-to-file c-file
|
||||
(lambda () (emit-c sex-forms)))
|
||||
(let ((proc (process compiler (append (list "-o" out-file)
|
||||
@@ -164,9 +135,9 @@ status, which is ours to pass on."
|
||||
(list c-file)
|
||||
cc-args))))
|
||||
(call-with-values (lambda () (process-wait proc))
|
||||
(lambda (pid normal-exit? status)
|
||||
(lambda status
|
||||
(delete-file* c-file)
|
||||
(if normal-exit? status 1)))))))
|
||||
(apply values status)))))))
|
||||
|
||||
(define (semantic-process-forms raw-forms input-source)
|
||||
(if (eq? input-source 'stdin)
|
||||
@@ -175,22 +146,16 @@ status, which is ours to pass on."
|
||||
(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))
|
||||
'((include inttypes.h)
|
||||
|
||||
;; The closure environment is the part of the ABI, so include it in
|
||||
;; every module
|
||||
(list (closure-env-declaration))))
|
||||
(typedef u8 uint8-t)
|
||||
(typedef i8 int8-t)
|
||||
(typedef u16 uint16-t)
|
||||
(typedef i16 int16-t)
|
||||
(typedef u32 uint32-t)
|
||||
(typedef i32 int32-t)
|
||||
(typedef u64 uint64-t)
|
||||
(typedef i64 int64-t)))
|
||||
|
||||
(define (main)
|
||||
(let* ((argv (command-line-arguments))
|
||||
@@ -208,14 +173,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")
|
||||
|
||||
@@ -241,7 +198,5 @@ status, which is ours to pass on."
|
||||
(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 cc-args)))))))
|
||||
|
||||
@@ -3,10 +3,10 @@ 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
|
||||
MODULES = utils types 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
|
||||
TESTS = basic semen reader fmt-c-writer utils line-directives codegen args types
|
||||
TEST_SRCS = $(TESTS:%=%.scm)
|
||||
|
||||
sex-tests: run.scm $(TEST_SRCS) $(SEX_OBJ)
|
||||
@@ -20,9 +20,6 @@ utils.o: utils.module.scm ../utils.scm
|
||||
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
|
||||
|
||||
@@ -32,22 +29,20 @@ reader.o: reader.module.scm ../reader.scm utils.o
|
||||
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
|
||||
semen.o: semen.module.scm ../semen.scm 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,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
|
||||
fmt-c-writer.o: fmt-c-writer.module.scm ../fmt-c-writer.scm sex-fmt-c.o utils.o
|
||||
$(CHICKEN_C) $(CSC_FLAGS) $(MODULE_FLAGS) fmt-c-writer.module.scm -o fmt-c-writer.o -unit fmt-c-writer -link sex-fmt-c,utils
|
||||
|
||||
sexc.o: sexc.module.scm 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
|
||||
sexc.o: sexc.module.scm 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,types,utils
|
||||
|
||||
clean:
|
||||
rm -f $(SEX_OBJ)
|
||||
rm -f *.import.scm
|
||||
rm -f *.link
|
||||
rm -f sex-tests
|
||||
|
||||
.PHONY: clean
|
||||
|
||||
@@ -31,10 +31,10 @@
|
||||
(test 'vector-ref (atom-to-fmt-c '¤))
|
||||
(test '%include (atom-to-fmt-c 'include))
|
||||
|
||||
;; 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))
|
||||
;; c89 stuff
|
||||
(test 'int (atom-to-fmt-c 'bool))
|
||||
(test 1 (atom-to-fmt-c 'true))
|
||||
(test 0 (atom-to-fmt-c 'false))
|
||||
|
||||
;; dot-access -> %. member-access directive (kebab-converted operands)
|
||||
(test '(%. a b) (walk-expr '(dot-access a b)))
|
||||
|
||||
@@ -141,28 +141,6 @@ compiles."
|
||||
(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,
|
||||
@@ -230,382 +208,4 @@ compiles."
|
||||
(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[]"))))
|
||||
(emits? (in-fn "(var q (* * const char) 0)") "const char * * q"))))
|
||||
|
||||
@@ -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
|
||||
@@ -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))
|
||||
@@ -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))))
|
||||
@@ -40,15 +40,15 @@
|
||||
(walk-type '(const * const char)))
|
||||
|
||||
(test
|
||||
'(%fun void (int float (%array (struct what * const))))
|
||||
'(%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))))
|
||||
'(%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)))))
|
||||
'(%array (%fun void ((int) (%array float) (%array (struct what * const)))))
|
||||
(walk-type '(¤ (fn ((int) (¤ float) (¤ (const * struct what))) void))))
|
||||
|
||||
;; Type convert to C
|
||||
@@ -101,42 +101,9 @@
|
||||
'(%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)))
|
||||
'(%fun void puk ((int) (%array float 8)))
|
||||
(walk-fn-def '(fn puk ((int) (¤ float 8)) void)))
|
||||
|
||||
(test
|
||||
@@ -183,7 +150,7 @@
|
||||
(test
|
||||
'(struct mega_kebab ((int a)
|
||||
((struct ((int year) (int month) (int day))) dob)
|
||||
((%fun bool (int (%array int))) min)))
|
||||
((%fun int ((int) (%array int))) min)))
|
||||
(walk-struct '(struct mega-kebab
|
||||
((a int)
|
||||
(dob (struct ((year int)
|
||||
|
||||
@@ -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
319
tests/infer.scm
@@ -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))))))
|
||||
@@ -7,20 +7,10 @@
|
||||
# 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
|
||||
EXPECTED = hello, world\nhello, sex\n2 greetings
|
||||
|
||||
check:
|
||||
@$(SEXC) greet.sex -c -o greet.o
|
||||
|
||||
@@ -7,9 +7,6 @@
|
||||
;;; 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)
|
||||
|
||||
@@ -19,18 +16,4 @@
|
||||
(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))
|
||||
|
||||
@@ -7,47 +7,12 @@
|
||||
|
||||
(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 var greet-count 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."
|
||||
(pub fn greet ((name (* const char))) void
|
||||
(++ 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"))
|
||||
|
||||
@@ -1,14 +1,6 @@
|
||||
(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)
|
||||
@@ -46,57 +38,4 @@
|
||||
(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)")
|
||||
)
|
||||
|
||||
@@ -10,7 +10,6 @@
|
||||
(include "codegen.scm")
|
||||
(include "args.scm")
|
||||
(include "types.scm")
|
||||
(include "infer.scm")
|
||||
|
||||
;;; Should be the last in the test suite
|
||||
(test-exit)
|
||||
|
||||
@@ -1,35 +1,30 @@
|
||||
(import srfi-69
|
||||
semen
|
||||
types)
|
||||
semen)
|
||||
|
||||
(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 '((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? '(extern fn foo () void)))
|
||||
(test 'foo (sex-fn-name '(extern fn foo () void)))
|
||||
(test #f (sex-fn? '(struct point ((x int)))))
|
||||
(test '((int a) (int b)) (sex-fn-arglist sum-fn))
|
||||
(test '(pub fn float sum ((int a) (int b))) (sex-fn-prototype sum-fn))
|
||||
(test '((return (cast float (+ a b)))) (sex-fn-body sum-fn))
|
||||
|
||||
(let ((sex-code
|
||||
'((defmacro (sum-var name a b c)
|
||||
@@ -54,78 +49,9 @@
|
||||
'((defmacro (x10 a)
|
||||
`(* 10 ,a))
|
||||
|
||||
(fn foo ((a int) (b int)) void
|
||||
(fn void foo ((int a) (int b))
|
||||
(return (+ a (x10 b)))))))
|
||||
|
||||
(test '((fn foo ((a int) (b int)) void
|
||||
(test '((fn void foo ((int a) (int b))
|
||||
(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))))
|
||||
)
|
||||
(semen-process sex-code-macro))))
|
||||
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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.
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -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))
|
||||
@@ -1,28 +1,3 @@
|
||||
(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")
|
||||
|
||||
116
tests/types.scm
116
tests/types.scm
@@ -54,74 +54,6 @@
|
||||
#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"
|
||||
@@ -166,55 +98,9 @@
|
||||
#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)))
|
||||
(get-fields 't-never-declared)))
|
||||
|
||||
@@ -1,6 +1,3 @@
|
||||
(module reader (read-from-file
|
||||
read-raw-forms
|
||||
|
||||
current-features
|
||||
platform-features)
|
||||
read-raw-forms)
|
||||
"../../reader.scm")
|
||||
|
||||
@@ -1,5 +1,4 @@
|
||||
(import scheme
|
||||
(scheme base) ; let-values
|
||||
brev-separate
|
||||
(chicken base)
|
||||
(chicken file)
|
||||
@@ -8,91 +7,41 @@
|
||||
(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?
|
||||
srfi-1)
|
||||
|
||||
(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)))))))
|
||||
(let ((contents (read-raw-forms target-path)))
|
||||
(foldl (lambda (acc elt)
|
||||
(case (car elt)
|
||||
((compilation input output return)
|
||||
(cons
|
||||
(append (car acc) (list elt))
|
||||
(cdr acc)))
|
||||
(else
|
||||
(cons
|
||||
(car acc)
|
||||
(append (cdr acc) (list elt))))))
|
||||
(cons (list) (list))
|
||||
contents)))
|
||||
|
||||
(define (compile src compilation sexc)
|
||||
(define (compile src flags 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)
|
||||
@@ -161,7 +110,7 @@
|
||||
(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)))
|
||||
(compiled-file (compile src (assoc 'compile settings) sexc)))
|
||||
(if (not compiled-file)
|
||||
(begin (fmt #t "Failed to compile " path nl)
|
||||
#f)
|
||||
|
||||
@@ -2,8 +2,6 @@
|
||||
(get-env-var
|
||||
set-working-directory
|
||||
to-absolute-pathname
|
||||
comment-form?
|
||||
strip-header-comments
|
||||
list-split
|
||||
list-join
|
||||
recons
|
||||
|
||||
@@ -6,23 +6,9 @@
|
||||
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)
|
||||
get-underlying-type)
|
||||
"types.scm")
|
||||
|
||||
222
types.scm
222
types.scm
@@ -15,17 +15,7 @@
|
||||
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 +type-db+ (make-hash-table))
|
||||
|
||||
(define (strip-pub form)
|
||||
(if (eq? (car form) 'pub) (cdr form) form))
|
||||
@@ -54,17 +44,17 @@
|
||||
(list))))
|
||||
|
||||
(define (add-struct name form)
|
||||
(hash-table-set! +tag-db+ name
|
||||
(hash-table-set! +type-db+ name
|
||||
(list 'struct name (normalize-fields (aggregate-fields form)))))
|
||||
|
||||
(define (add-union name form)
|
||||
(hash-table-set! +tag-db+ name
|
||||
(hash-table-set! +type-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
|
||||
(hash-table-set! +type-db+ name
|
||||
(list 'enum name (if (and (pair? (cddr f)) (list? (caddr f)))
|
||||
(caddr f)
|
||||
(list))))))
|
||||
@@ -80,143 +70,48 @@
|
||||
(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)))
|
||||
(hash-table-ref/default +type-db+ name #f))
|
||||
|
||||
;;; ((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)))
|
||||
(let ((info (get-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.
|
||||
;;; Follow a typedef chain to the name it ultimately stands for. #f if
|
||||
;;; NAME is not a typedef.
|
||||
(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))))
|
||||
(eq? (car info) 'typedef)
|
||||
(let ((target (caddr info)))
|
||||
(or (and (symbol? target) (get-underlying-type target))
|
||||
target)))))
|
||||
|
||||
;;; 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)'.
|
||||
;;; A type is a form, not an atom, so this compares with equal? rather
|
||||
;;; than dispatching like `case'. Patterns are literal types and are not
|
||||
;;; evaluated; `else' is optional and the whole thing is #f when nothing
|
||||
;;; matches and there is no else.
|
||||
(define-syntax type-match
|
||||
(syntax-rules (else)
|
||||
((_ type) #f)
|
||||
((_ type (else body ...)) (begin body ...))
|
||||
((_ type (pattern body ...) clause ...)
|
||||
(if (type-pattern-matches? 'pattern type)
|
||||
(if (equal? type 'pattern)
|
||||
(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
|
||||
@@ -224,92 +119,15 @@
|
||||
;;;
|
||||
;;; Returns #f if nothing of that name was declared
|
||||
(define (map-fields struct-union-enum fn)
|
||||
(let ((info (resolve-type-info struct-union-enum)))
|
||||
(let ((info (get-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.
|
||||
;; An enumerator's type is the enum itself.
|
||||
((enum)
|
||||
(let ((type (list 'enum (cadr info))))
|
||||
(let ((type (list 'enum struct-union-enum)))
|
||||
(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)))))
|
||||
|
||||
@@ -2,8 +2,6 @@
|
||||
(get-env-var
|
||||
set-working-directory
|
||||
to-absolute-pathname
|
||||
comment-form?
|
||||
strip-header-comments
|
||||
list-split
|
||||
list-join
|
||||
recons
|
||||
@@ -15,10 +13,7 @@
|
||||
copy-form-source!
|
||||
stamp-form-source!
|
||||
form-location
|
||||
set-form-type!
|
||||
form-type
|
||||
sex-error
|
||||
sex-warning
|
||||
with-directory
|
||||
)
|
||||
"utils.scm")
|
||||
|
||||
42
utils.scm
42
utils.scm
@@ -42,24 +42,6 @@
|
||||
(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)
|
||||
@@ -101,19 +83,6 @@
|
||||
;;; 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)))
|
||||
|
||||
@@ -151,17 +120,6 @@ wrap a form-building expression."
|
||||
"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
|
||||
|
||||
Reference in New Issue
Block a user