Add exception handler fix

* tests/base.scm: add two tests for issue #556

The two tests are adapted from issue #556 (originally from r7rs).
The tests currently fail because errors and raised objects are
treated in the same way.

* Use different tags for raised objects and raised errors

The behaviour for raising an error (error message irritants) and
objects (raise object) are different in r7rs. So tag error objects
differently, and adjust the raised object handling to handle
the raised object instead of a list containing the raised object.

This should resolve issue #556.

* runtime: use the correct string length for comparison

Fix for the pull request adressing issue #556.

* runtime: distinguish exceptions and errors in default handler

* repl: use error-object? to decide whether an error or an exception was raised

This makes error messages a bit more informative.  Also, if error objects become
a distinct type, then the repl implementation will continue to be correct. The
(deleted) second cond clause seemed to be bit redundant - I am not sure what the
original intent was.

* tests/base.scm: revert accidental deletion of else clause

* Display exceptions as errors for consistency

.github/workflows/c-api-docs.yml

@@ -21,7 +21,7 @@ jobs:
             
     - name: upload deb
       if: matrix.arch == '64'
-      uses: actions/upload-artifact@v1
+      uses: actions/upload-artifact@v4
       with:
         name: cyclone-scheme docs
         path: html.tar.bz2

.github/workflows/c-runtime-unit-tests.yml

@@ -0,0 +1,27 @@
+name: C Runtime Unit Tests
+
+#on: [create]
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [64]
+    
+    steps:
+    # Install dependencies
+    - name: Install libck
+      run: sudo apt-get install libck-dev    
+    #- name: Install Cyclone
+    #  run: |
+    #    wget https://github.com/cyclone-scheme/binary-releases/raw/master/ubuntu-18.04-lts/cyclone-scheme_0.30.0_amd64.deb 
+    #    sudo apt install ./cyclone-scheme_0.30.0_amd64.deb
+    - uses: actions/checkout@v1
+
+    # Execute runtime library unit tests
+    - name: make test-lib
+      run: make libcyclone.a && make test-lib && ./test-lib

.github/workflows/ci.yml

@@ -0,0 +1,22 @@
+name: Ubuntu Linux Build
+
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [32, 64]
+    
+    steps:
+    - uses: actions/checkout@v1
+    - name: Install deps
+      run: sudo apt-get install indent
+    - name: Install ck
+      run: sudo apt-get install libck-dev
+    - name: make runtime
+      run: make libcyclone.a
+            

.github/workflows/formatting.yml

@@ -0,0 +1,21 @@
+name: Code Formatting
+
+on: [push]
+
+jobs:
+  build:
+
+    runs-on: ubuntu-latest
+    
+    strategy:    
+      matrix:
+        arch: [64]
+    
+    steps:
+    - uses: actions/checkout@v1
+    - name: Install deps
+      run: sudo apt-get install -y indent
+    - name: formatting
+      run: |
+        make test-format 
+            

Architecture.md

@@ -0,0 +1,71 @@
+** This document is incomplete and a work in progress **
+
+# High level design
+
+Cyclone has a similar architecture to other modern compilers:
+
+<img src="docs/images/compiler.png" alt="flowchart of cyclone compiler">
+
+First, an input file containing Scheme code is received on the command line and loaded into an abstract syntax tree (AST) by Cyclone's parser. From there a series of source-to-source transformations are performed on the AST to expand macros, perform optimizations, and make the code easier to compile to C. These intermediate representations (IR) can be printed out in a readable format to aid debugging. The final AST is then output as a `.c` file and the C compiler is invoked to create the final executable or object file.
+
+Programs are linked with the necessary Scheme libraries and the Cyclone runtime library to create an executable:
+
+<img src="docs/images/runtime.png" alt="Diagram of files linked into a compiled executable">
+
+For more high-level overview of the project a good place to start is [Writing the Cyclone Scheme Compiler](docs/Writing-the-Cyclone-Scheme-Compiler-Revised-2017.md).
+
+# Code Map
+
+This section provides an overview of the code and module layout used by Cyclone. The [API Documentation](docs/API.md) provides more details on individual modules within these directories as well as code-level API documentation.
+
+## `scheme/`
+
+Code for the built-in Scheme standard libraries lives at the top level of this directory. In general all of the code here is written to conform to the Scheme R7RS specification.
+
+## `scheme/cyclone`
+
+Scheme code for the Cyclone compiler itself lives here as a set of libraries.
+
+There are front-end programs at the top-level of the Cyclone repository that use these libraries:
+
+- `cyclone.scm` for the compiler
+- `icyc.scm` for the interpreter
+
+## `srfi/`
+
+Implementations of various Scheme SRFI's that are distributed directly with Cyclone.
+
+In general the recommended way to distribute SRFI's is to use the Winds package manager. At this point there would need to be a very good reason to include a new SRFI here in the main Cyclone repository.
+
+## `runtime.c`
+
+Most of the code for the C runtime lives here including primitives and the minor GC.
+
+Code here is often written in a continuation passing style because Cheney on the MTA is used as the minor garbage collecting mechanism.
+
+TODO: for example
+
+## `gc.c`
+
+Module for the major garbage collector.
+
+For comprehensive design documentation on the major collector see the [Garbage Collector](Garbage-Collector-Revised-2022.md) documentation.
+
+## `mstreams.c`
+
+Code for in-memory streams. Some of this is platform-specific.
+
+# Setting up a Development Environment
+
+See the [Development Guide](docs/Development.md).
+
+This includes instructions on building and debugging the compiler.
+
+# Building
+
+
+# Debugging
+
+TBD: compiler flags, compilation settings, what else?
+TODO: just include in dev guide
+

CHANGELOG.md

@@ -1,6 +1,105 @@
 # Changelog
 
-## 0.31.0 - TBD
+## 0.37.0 - TBD
+
+Bug Fixes
+
+- Yorick Hardy fixed the runtime to return the appropriate types of objects to exception handlers.
+- Yorick Hardy modified the runtime to allow `thread-terminate!` to take a thread object as an argument, per SRFI 18.
+- @nmeum fixed `open_memstream`/`fmemopen` feature detection with GCC >= 14.
+- Fixed a bug in `apply` where an error may be raised when processing quoted sub-expressions. For example the following would throw an error: `(apply cons '(5 (1 2)))`. Thanks to @srgx for the bug report!
+- Fixed a beta expansion optimization bug where code such as the following would cause the compiler to hang. Thanks to Yorick Hardy for the bug report:
+
+      (define (compile-forever x) x (compile-forever x))
+
+- Added a fix from Yorick Hardy to define `*ai-v4mapped*` to zero on platforms where `AI_V4MAPPED` is undefined.
+- Updated `sqrt` to properly handle complex results given non-complex input. EG: `(sqrt -1) ==> 1i`. And updated the parser to properly handle `+i` and `-i`. Thanks to Christopher Hebert for the bug reports!
+- Updated `cond-expand` to raise an error if no clauses match, instead of returning `#t`.
+
+## 0.36.0 - February 14, 2024
+
+Features
+
+- Enhanced the reader to parse rationals and store them as inexact numbers.
+- Add a stub for `(rationalize x y)` to `(scheme base)`.
+
+Bug Fixes
+
+- Yorick Hardy provided a fix to `round` so that Cyclone will round to even when x is halfway between two integers, as required by R7RS.
+- Updated various numeric functions to properly handle numeric type conversions, including `quotient`, `remainder`, `numerator`, `denominator`, `truncate`, `truncate-quotient`, and `/`.
+- Fix `exact` to properly handle complex numbers, including raising an error when passed `nan` or `inf` double values.
+- Ensure the runtime properly differentiates between `+inf.0` and `-inf.0`. Thanks to jpellegrini for the bug report.
+- jpellegrini reported that Cyclone returns `#f` when comparing complex numbers using operators other than `=`. Instead it is better to raise an error in these situations.
+- lassik and jpellegrini reported that `abs` was incorrectly returning the real part of a complex number argument. Modified `abs` to properly handle complex numbers.
+- jpellegrini fixed `(srfi 143)` so that the following are constants instead of procedures: `fx-width`, `fx-greatest`, and `fx-least`.
+- Raise an error if `odd?` or `even?` is passed a decimal number. Thanks to jpellegrini for the bug report.
+- Fix `read-line` to read entire lines that consist of more than 1022 bytes. Previously the function would only return partial data up to this limit. Thanks to Robby Zambito for the bug report.
+- `(include "body.scm")` inside a file `path/to/lib.sld` will look for `path/to/body.scm`, then fallback to the legacy behavior, and look for `$(pwd)/body.scm`.
+- Pass append and prepend directories when compiling dependent libraries of a program. This prevents issues where the directories are not made available to any `include` directives within such libraries.
+- Updated the reader to throw an error if a number cannot be parsed, rather than returning `#f`.
+
+## 0.35.0 - August 25, 2022
+
+Features
+
+- Arthur Maciel added `make-opaque` to `(cyclone foreign)`.
+- Add `memory-streams` to the list of symbols that `(features)` can return, indicating that the current installation supports in-memory streams.
+
+Bug Fixes
+
+- Prevent an error when evaluating a `begin` expression that contains both a macro definition and an application of that macro. For example:
+
+      begin (define-syntax foo (syntax-rules () ((foo) 123))) (foo))
+
+- Fix a regression where `c-compiler-options` was not recognized as a top level form by programs.
+- Enforce a maximum recursion depth when printing an object via `display` or `write`, and when comparing objects via `equal?`. This prevents segmentation faults when working with circular data structures.
+- Added proper implementations of `assv` and `memv`. Both were previously implemented in terms of `assq` and `memq`, respectively.
+
+## 0.34.0 - January 2, 2022
+
+Features
+
+- Separate include/library search directory options from "normal" compiler/linker options and place options passed via the `-COPT`/`-CLNK` command-line flags in-between. This allows overwriting the default search paths, since contrary to all other options, the search paths must be prepend for an `-I`/`-L` option to take precedence over an existing one.
+
+Bug Fixes
+
+- Prevent segmentation faults in the runtime when setting a global variable to itself.
+- Do not throw an error when exporting a primitive that is not defined in the current module, as built-ins are always available in any context.
+
+## 0.33.0 - September 24, 2021
+
+Features
+
+- Allow easier macro debugging from the REPL by using `expand`. Passing a single expression as an argument will return the expanded expression:
+
+      cyclone> (expand '(when #t (+ 1 2 3)))
+      (if #t ((lambda () (+ 1 2 3))) )
+
+- During compilation the compiler will now call itself as a subprocess to perform Scheme-to-C compilation. This allows Cyclone to free all of those resources before calling the C compiler to generate a binary, resulting in more efficient compilation.
+
+Bug Fixes
+
+- Do not inline calls to `system` as it could result in multiple calls of the same command.
+
+## 0.32.0 - August 16, 2021
+
+Features
+
+- Initiate major garbage collections faster after allocating a huge object (larger than 500K). This allows the system to reclaim the memory faster and keep overall memory usage low for certain workloads.
+- Cyclone will no longer memoize pure functions by default.
+- Added build option `CYC_PTHREAD_SET_STACK_SIZE` to allow Cyclone to specify a thread stack size rather than using the OS default. EG:
+
+      make CYC_PTHREAD_SET_STACK_SIZE=1 libcyclone.a
+
+Bug Fixes
+
+- @nmeum fixed `(scheme repl)` to flush the output port prior to writing the prompt, guaranteeing the prompt is written at the correct time. 
+- Fixed `fxbit-set?` to properly handle negative values of `i`.
+- Avoid unnecessary renaming of identifiers when the interpreter performs macro expansion.
+- When allocating a large vector we now guarantee all vector elements are initialized before the major collector can trace those elements. This avoids the potential for a race condition which could lead to a segmentation fault.
+- Ensure atomic objects are properly traced by the major garbage collector.
+
+## 0.31.0 - July 27, 2021
 
 ### Bug Fixes
 

Dockerfile

@@ -4,7 +4,7 @@ MAINTAINER justin.ethier@gmail.com
 
 ARG DEBIAN_FRONTEND=noninteractive
 
-ENV CYCLONE_VERSION v0.31.0
+ENV CYCLONE_VERSION v0.36.0
 RUN apt update -y
 RUN apt install -y build-essential git rsync texinfo libtommath-dev libck-dev make gcc
 

Makefile

@@ -5,9 +5,14 @@
 include Makefile.config
 
 # Commands
-CYCLONE = cyclone -A .
+#
+# Set up Cyclone here to build the compiler itself using a system-installed
+# compiler (EG: from bootstrap or an earlier cyclone version). Everything
+# else can then be built using our local binary.
+CYCLONE_SYSTEM = cyclone -I . -CLNK '-L.'
+CYCLONE_LOCAL = ./cyclone -I . -I libs -COPT '-Iinclude' -CLNK '-L.'
 CCOMP = $(CC) $(CFLAGS)
-INDENT_CMD = indent -linux -l80 -i2 -nut
+FORMAT_CMD = indent -linux -l80 -i2 -nut
 
 # Libraries
 CYC_RT_LIB = libcyclone.a
@@ -31,7 +36,9 @@ COBJECTS = $(SLDFILES:.sld=.o)
 HEADERS = $(HEADER_DIR)/runtime.h $(HEADER_DIR)/types.h
 TEST_SRC = $(TEST_DIR)/unit-tests.scm \
 					 $(TEST_DIR)/base.scm \
+					 $(TEST_DIR)/test.scm \
 					 $(TEST_DIR)/threading.scm \
+					 $(TEST_DIR)/c-compiler-options.scm \
 					 $(TEST_DIR)/test-shared-queue.scm \
 					 $(TEST_DIR)/macro-hygiene.scm \
 					 $(TEST_DIR)/match-tests.scm \
@@ -47,6 +54,7 @@ TESTS = $(basename $(TEST_SRC))
 all : cyclone icyc libs
 
 test : libs $(TESTS)
+	icyc -p "(cond-expand (linux (begin (define-syntax foo (syntax-rules () ((foo) 123))) (foo))))"
 
 example :
 	cd $(EXAMPLE_DIR) ; $(MAKE)
@@ -122,12 +130,31 @@ uninstall :
 tags :
 	ctags -R *
 
-indent : gc.c runtime.c ffi.c mstreams.c $(HEADER_DIR)/*.h
+format : gc.c runtime.c ffi.c hashset.c mstreams.c ck-polyfill.c ck-polyfill.h $(HEADER_DIR)/*.h
-	$(INDENT_CMD) gc.c
+	$(FORMAT_CMD) $(HEADER_DIR)/hashset.h
-	$(INDENT_CMD) runtime.c
+	$(FORMAT_CMD) $(HEADER_DIR)/runtime.h
-	$(INDENT_CMD) ffi.c
+	$(FORMAT_CMD) $(HEADER_DIR)/runtime-main.h
-	$(INDENT_CMD) mstreams.c
+	$(FORMAT_CMD) $(HEADER_DIR)/types.h
-	$(INDENT_CMD) $(HEADER_DIR)/*.h
+	$(FORMAT_CMD) ck-polyfill.c
+	$(FORMAT_CMD) ck-polyfill.h
+	$(FORMAT_CMD) ffi.c
+	$(FORMAT_CMD) gc.c
+	$(FORMAT_CMD) hashset.c
+	$(FORMAT_CMD) mstreams.c
+	$(FORMAT_CMD) runtime.c
+
+test-format :
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/hashset.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/runtime.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/runtime-main.h
+	./scripts/check-c-formatting.sh $(HEADER_DIR)/types.h
+#	./scripts/check-c-formatting.sh ffi.c
+#	./scripts/check-c-formatting.sh gc.c
+	./scripts/check-c-formatting.sh hashset.c
+#	./scripts/check-c-formatting.sh mstreams.c
+#	./scripts/check-c-formatting.sh runtime.c
+#	./scripts/check-c-formatting.sh ck-polyfill.c
+#	./scripts/check-c-formatting.sh ck-polyfill.h
 
 # This is a test directive used to test changes to a SLD file
 # EG: make sld SLDPATH=scheme/cyclone SLD=macros
@@ -140,17 +167,20 @@ debug :
 doc :
 	doxygen Doxyfile
 
+api-doc :
+	./scripts/generate-doc-index.sh && mv api-index.scm docs/api/
+
 # Helper rules (of interest to people hacking on this makefile)
 
-.PHONY: clean full bench bootstrap tags indent debug test doc
+.PHONY: clean full bench bootstrap tags format test-format debug test doc api-doc
 
-$(TESTS) : %: %.scm
+$(TESTS) : %: %.scm cyclone libs
-	$(CYCLONE) -I . $<
+	$(CYCLONE_LOCAL) -I . $<
 	./$@
 	rm -rf $@
 
-$(EXAMPLES) : %: %.scm
+$(EXAMPLES) : %: %.scm cyclone libs
-	$(CYCLONE) $<
+	$(CYCLONE_LOCAL) $<
 
 game-of-life :
 	cd $(EXAMPLE_DIR)/game-of-life ; $(MAKE)
@@ -160,14 +190,14 @@ hello-library/hello :
 
 libs : $(COBJECTS)
 
-$(COBJECTS) : %.o: %.sld
+$(COBJECTS) : %.o: %.sld cyclone
-	$(CYCLONE) $<
+	$(CYCLONE_LOCAL) $<
 
 cyclone : cyclone.scm $(CYC_RT_LIB) $(CYC_BN_LIB)
-	$(CYCLONE) cyclone.scm
+	$(CYCLONE_SYSTEM) cyclone.scm
 
-icyc : icyc.scm $(CYC_RT_LIB) $(CYC_BN_LIB)
+icyc : icyc.scm $(CYC_RT_LIB) $(CYC_BN_LIB) cyclone libs
-	$(CYCLONE) $<
+	$(CYCLONE_LOCAL) $<
 
 $(CYC_RT_LIB) : $(CFILES) $(HEADERS) $(CYC_BN_LIB)
 
@@ -189,8 +219,15 @@ mstreams.o : mstreams.c $(HEADERS)
 					-DCYC_HAVE_FMEMOPEN=$(CYC_PLATFORM_HAS_FMEMOPEN) \
 					$< -o $@
 
+ifdef CYC_PTHREAD_SET_STACK_SIZE
+  DEF_PTHREAD_SET_STACK_SIZE=-DCYC_PTHREAD_SET_STACK_SIZE=$(CYC_PTHREAD_SET_STACK_SIZE)
+else
+  DEF_PTHREAD_SET_STACK_SIZE=
+endif
+
 runtime.o : runtime.c $(HEADERS)
 	$(CCOMP) -c \
+					$(DEF_PTHREAD_SET_STACK_SIZE) \
 					-DCYC_INSTALL_DIR=\"$(PREFIX)\" \
 					-DCYC_INSTALL_LIB=\"$(LIBDIR)\" \
 					-DCYC_INSTALL_BIN=\"$(BINDIR)\" \
@@ -318,3 +355,7 @@ install-bin : cyclone icyc
 	$(MKDIR) $(DESTDIR)$(BINDIR)
 	$(INSTALL) -m0755 cyclone $(DESTDIR)$(BINDIR)/
 	$(INSTALL) -m0755 icyc $(DESTDIR)$(BINDIR)/
+
+# TODO: is this linking in local lcyclone or the system one????
+test-lib: test-lib.c
+	$(CCOMP) -g test-lib.c -o test-lib -L . $(LIBS)

Makefile.config

@@ -13,6 +13,11 @@ CYC_PROFILING ?=
 CYC_GCC_OPT_FLAGS ?= -O2
 #CYC_GCC_OPT_FLAGS ?= -g
 
+# Change this to 1 to use a custom stack size for threads.
+# Required on platforms such as Alpine Linux that use a 
+# very small stack by default.
+CYC_PTHREAD_SET_STACK_SIZE ?=
+
 OS = $(shell uname)
 CC ?= cc
 
@@ -23,24 +28,21 @@ LIBS += -ldl
 endif
 
 # Compiler options
-CFLAGS       ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument -Iinclude
+CFLAGS       += $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument -Iinclude
-BASE_CFLAGS  ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument -I$(PREFIX)/include
+BASE_CFLAGS  ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -fPIC -Wall -Wno-shift-negative-value -Wno-unused-command-line-argument
 # Used by Cyclone to compile programs, no need for PIC there
-BASE_PROG_CFLAGS  ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -Wall -I$(PREFIX)/include
+BASE_PROG_CFLAGS   ?= $(CYC_PROFILING) $(CYC_GCC_OPT_FLAGS) -Wall
-ifeq ($(OS),Darwin)
+COMP_CFLAGS        ?= $(BASE_CFLAGS)
-COMP_CFLAGS  ?= $(BASE_CFLAGS) -L$(PREFIX)/lib
+COMP_LIBDIRS       ?= -L$(PREFIX)/lib
+COMP_INCDIRS       ?= -I$(PREFIX)/include
 COMP_PROG_CFLAGS   ?= $(BASE_PROG_CFLAGS)
-else
-COMP_CFLAGS  ?= $(BASE_CFLAGS) -L$(PREFIX)/lib
-COMP_PROG_CFLAGS  ?= $(BASE_PROG_CFLAGS)
-endif
 
 # Use these lines instead for debugging or profiling
 #CFLAGS = -g -Wall
 #CFLAGS = -g -pg -Wall
 
 # Linker options
-LDFLAGS ?= -L. $(CYC_PROFILING)
+LDFLAGS += -L. $(CYC_PROFILING)
 LIBRARY_OUTPUT_FILE = libcyclone.a
 ifeq ($(OS),Darwin)
 LDFLAGS     += -Wl,-undefined -Wl,dynamic_lookup
@@ -57,15 +59,15 @@ endif
 # concurrencykit was installed via Ports, it won't be picked up without explicitly looking
 # for it here
 ifeq ($(OS),FreeBSD)
-LDFLAGS += -L/usr/local/lib
+COMP_LIBDIRS += -L/usr/local/lib
-CFLAGS  += -I/usr/local/include
+COMP_INCDIRS += -I/usr/local/include
 endif
 
 
 # Commands "baked into" cyclone for invoking the C compiler
-CC_PROG ?= "$(CC) ~src-file~ $(COMP_PROG_CFLAGS) -c -o ~exec-file~.o"
+CC_PROG ?= "$(CC) ~src-file~ $(COMP_PROG_CFLAGS) ~cc-extra~ $(COMP_INCDIRS) -c -o ~exec-file~.o"
-CC_EXEC ?= "$(CC) ~exec-file~.o ~obj-files~ $(LIBS) $(COMP_CFLAGS) -o ~exec-file~"
+CC_EXEC ?= "$(CC) ~exec-file~.o ~obj-files~ $(LIBS) $(COMP_CFLAGS) ~ld-extra~ $(COMP_LIBDIRS) -o ~exec-file~"
-CC_LIB  ?= "$(CC) ~src-file~ $(COMP_CFLAGS) -c -o ~exec-file~.o"
+CC_LIB  ?= "$(CC) ~src-file~ $(COMP_CFLAGS) ~cc-extra~ $(COMP_INCDIRS) -c -o ~exec-file~.o"
 CC_SO   ?= "$(CC) -shared $(LDFLAGS) -o ~exec-file~.so ~exec-file~.o"
 
 AR        ?= ar
@@ -89,8 +91,9 @@ DESTDIR   ?=
 
 # Automatically detect platform-specific flags, instead of using autoconf
 #CYC_PLATFORM_HAS_MEMSTREAM ?= 1
-CYC_PLATFORM_HAS_MEMSTREAM := $(shell echo "main(){char *buf; int len; open_memstream(&buf, &len);}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+HASH := \# # Needed for compatibility with GNU Make < 4.3 <https://lists.gnu.org/archive/html/info-gnu/2020-01/msg00004.html>
-CYC_PLATFORM_HAS_FMEMOPEN := $(shell echo "main(){char *buf; fmemopen(&buf, 0, \"r\");}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+CYC_PLATFORM_HAS_MEMSTREAM := $(shell printf "$(HASH)include <stdio.h>\n%s\n" "int main(void){char *buf; size_t len; open_memstream(&buf, &len); return 0;}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
+CYC_PLATFORM_HAS_FMEMOPEN := $(shell printf "$(HASH)include <stdio.h>\n%s\n" "int main(void){char *buf; fmemopen(&buf, 0, \"r\"); return 0;}" | $(CC) -xc - >/dev/null 2>/dev/null && echo 1 || echo 0)
 
 # code from chibi's makefile to detect platform
 ifndef PLATFORM

Makefile.config.raspberry-pi-2

@@ -20,14 +20,14 @@ CREATE_LIBRARY_COMMAND = $(AR)
 CREATE_LIBRARY_FLAGS = rcs
 
 # Compiler options
-CFLAGS       ?= -O2 -fPIC -Wall -march=armv6k -Iinclude
+CFLAGS       += -O2 -fPIC -Wall -march=armv6k -Iinclude
 COMP_CFLAGS  ?= -O2 -fPIC -Wall -march=armv6k -I$(PREFIX)/include -L$(PREFIX)/lib
 # Use these lines instead for debugging or profiling
 #CFLAGS = -g -Wall
 #CFLAGS = -g -pg -Wall
 
 # Linker options
-LDFLAGS ?= -L.
+LDFLAGS += -L.
 ifeq ($(OS),Darwin)
 LDFLAGS     += -Wl,-export_dynamic -Wl,-undefined -Wl,dynamic_lookup
 COMP_CFLAGS += -Wl,-export_dynamic

README.md

@@ -1,7 +1,5 @@
 ![Cyclone Scheme](docs/images/cyclone-logo-04-header.png "Cyclone Scheme")
 
-[![Travis CI](https://travis-ci.org/justinethier/cyclone.svg?branch=master)](https://travis-ci.org/justinethier/cyclone)
-
 [![Github CI - Linux](https://github.com/justinethier/cyclone-bootstrap/workflows/Ubuntu%20Linux%20Build/badge.svg)](https://github.com/justinethier/cyclone-bootstrap)
 
 [![Github CI - MacOS](https://github.com/justinethier/cyclone-bootstrap/workflows/MacOS%20Build/badge.svg)](https://github.com/justinethier/cyclone-bootstrap)
@@ -69,6 +67,11 @@ Arch Linux users can install using the [AUR](https://aur.archlinux.org/packages/
     cd cyclone-scheme
     makepkg -si
 
+## Gentoo Linux
+![Gentoo Linux](docs/images/gentoo-linux-logo.png "Gentoo Linux")
+
+Cyclone is available from the [official Gentoo package repository](https://packages.gentoo.org/packages/dev-scheme/cyclone).
+
 ## Build from Source
 ![Build from Source](docs/images/build-thumb.png "Build from Source")
 
@@ -147,9 +150,7 @@ Cyclone provides several example programs, including:
 
 - There is a [Development Guide](docs/Development.md) with instructions for common tasks when hacking on the compiler itself.
 
-- Cyclone's [Garbage Collector](docs/Garbage-Collector.md) is documented at a high-level. This document includes details on extending Cheney on the MTA to support multiple stacks and fusing that approach with a tri-color marking collector.
+- Cyclone's [Garbage Collector](docs/Garbage-Collector-Revised-2022.md) is documented at a high-level. This document includes details on extending Cheney on the MTA to support multiple stacks and fusing that approach with a tri-color marking collector.
-
-- The garbage collector was subsequently enhanced to support [Lazy Sweeping](https://github.com/justinethier/cyclone/blob/master/docs/Garbage-Collection-Using-Lazy-Sweeping.md) which improves performance for a wide range of applications.
 
 # License
 

ck-polyfill.c

@@ -27,8 +27,9 @@ void ck_polyfill_init()
 }
 
 // CK Hashset section
-bool ck_hs_init(ck_hs_t *hs, unsigned int mode, ck_hs_hash_cb_t *hash_func,
+bool ck_hs_init(ck_hs_t * hs, unsigned int mode, ck_hs_hash_cb_t * hash_func,
-    ck_hs_compare_cb_t *cmp, struct ck_malloc *alloc, unsigned long capacity, unsigned long seed)
+                ck_hs_compare_cb_t * cmp, struct ck_malloc *alloc,
+                unsigned long capacity, unsigned long seed)
 {
   (*hs).hs = simple_hashset_create();
   if (pthread_mutex_init(&((*hs).lock), NULL) != 0) {
@@ -38,7 +39,7 @@ bool ck_hs_init(ck_hs_t *hs, unsigned int mode, ck_hs_hash_cb_t *hash_func,
   return true;
 }
 
-void *ck_hs_get(ck_hs_t *_hs, unsigned long hash, const void *key)
+void *ck_hs_get(ck_hs_t * _hs, unsigned long hash, const void *key)
 {
   void *result = NULL;
   int index = -1;
@@ -46,7 +47,7 @@ void *ck_hs_get(ck_hs_t *_hs, unsigned long hash, const void *key)
 
   pthread_mutex_lock(&((*_hs).lock));
 
-  index = simple_hashset_is_member(set, (symbol_type *)key);
+  index = simple_hashset_is_member(set, (symbol_type *) key);
   if (index > 0) {
     result = (void *)(set->items[index].item);
   }
@@ -55,7 +56,7 @@ void *ck_hs_get(ck_hs_t *_hs, unsigned long hash, const void *key)
   return result;
 }
 
-bool ck_hs_put(ck_hs_t *_hs, unsigned long hash, const void *key)
+bool ck_hs_put(ck_hs_t * _hs, unsigned long hash, const void *key)
 {
   bool result = false;
   int rv, index;
@@ -65,7 +66,7 @@ bool ck_hs_put(ck_hs_t *_hs, unsigned long hash, const void *key)
 
   //index = simple_hashset_is_member(hs, (symbol_type *)key);
   //if (index == 0) {
-    rv = simple_hashset_add(hs, (symbol_type *)key);
+  rv = simple_hashset_add(hs, (symbol_type *) key);
   if (rv >= 0) {
     result = true;
   }
@@ -77,7 +78,7 @@ bool ck_hs_put(ck_hs_t *_hs, unsigned long hash, const void *key)
 
 // CK Array section
 bool
-ck_array_init(ck_array_t *array, unsigned int mode,
+ck_array_init(ck_array_t * array, unsigned int mode,
               struct ck_malloc *allocator, unsigned int initial_length)
 {
   (*array).hs = hashset_create();
@@ -101,8 +102,7 @@ ck_array_init(ck_array_t *array, unsigned int mode,
 //      This function returns 1 if the pointer already exists in the array.  It
 //      returns 0 if the put operation succeeded. It returns -1 on error due to
 //      internal memory allocation failures.
-int
+int ck_array_put_unique(ck_array_t * array, void *pointer)
-ck_array_put_unique(ck_array_t *array, void *pointer)
 {
   pthread_mutex_lock(&(array->lock));
   hashset_add(array->hs, pointer);
@@ -121,8 +121,8 @@ ck_array_put_unique(ck_array_t *array, void *pointer)
 //      This function returns true if the remove operation succeeded. It will
 //      return false otherwise due to internal allocation failures or because the
 //      value did not exist.
-bool
+bool ck_array_remove(ck_array_t * array, void *pointer)
-ck_array_remove(ck_array_t *array, void *pointer){
+{
   pthread_mutex_lock(&(array->lock));
   hashset_remove(array->hs, pointer);
   pthread_mutex_unlock(&(array->lock));
@@ -138,12 +138,12 @@ ck_array_remove(ck_array_t *array, void *pointer){
 // RETURN VALUES
 //      This function returns true if the commit operation succeeded. It will
 //      return false otherwise, and pending operations will not be applied.
-bool ck_array_commit(ck_array_t *array) {
+bool ck_array_commit(ck_array_t * array)
+{
   // Nothing to do in this polyfill
   return true;
 }
 
-
 // TODO: global pthread mutex lock for this? obviously not ideal but the
 // whole purpose of this module is a minimal interface for compatibility
 // not speed
@@ -164,7 +164,7 @@ bool ck_pr_cas_ptr(void *target, void *old_value, void *new_value)
 {
   bool result = false;
   pthread_mutex_lock(&glock);
-  if ( *(void **)target == old_value ) {
+  if (*(void **)target == old_value) {
     *(void **)target = new_value;
     result = true;
   }
@@ -173,7 +173,7 @@ bool ck_pr_cas_ptr(void *target, void *old_value, void *new_value)
   // *(void **)v = set;                                                             
 }
 
-bool ck_pr_cas_8(uint8_t *target, uint8_t old_value, uint8_t new_value)
+bool ck_pr_cas_8(uint8_t * target, uint8_t old_value, uint8_t new_value)
 {
   bool result = false;
   pthread_mutex_lock(&glock);
@@ -185,36 +185,32 @@ bool ck_pr_cas_8(uint8_t *target, uint8_t old_value, uint8_t new_value)
   return result;
 }
 
-void
+void ck_pr_add_ptr(void *target, uintptr_t delta)
-ck_pr_add_ptr(void *target, uintptr_t delta)
 {
   pthread_mutex_lock(&glock);
-  size_t value = (size_t) target;
+  size_t value = (size_t)target;
-  size_t d = (size_t) delta;
+  size_t d = (size_t)delta;
   size_t result = value + d;
   *(void **)target = (void *)result;
   // *(void **)v = set;                                                             
   pthread_mutex_unlock(&glock);
 }
 
-void
+void ck_pr_add_int(int *target, int delta)
-ck_pr_add_int(int *target, int delta)
 {
   pthread_mutex_lock(&glock);
   (*target) += delta;
   pthread_mutex_unlock(&glock);
 }
 
-void
+void ck_pr_add_8(uint8_t * target, uint8_t delta)
-ck_pr_add_8(uint8_t *target, uint8_t delta)
 {
   pthread_mutex_lock(&glock);
   (*target) += delta;
   pthread_mutex_unlock(&glock);
 }
 
-void *
+void *ck_pr_load_ptr(const void *target)
-ck_pr_load_ptr(const void *target)
 {
   void *result;
   pthread_mutex_lock(&glock);
@@ -223,8 +219,7 @@ ck_pr_load_ptr(const void *target)
   return result;
 }
 
-int
+int ck_pr_load_int(const int *target)
-ck_pr_load_int(const int *target)
 {
   int result;
   pthread_mutex_lock(&glock);
@@ -233,8 +228,7 @@ ck_pr_load_int(const int *target)
   return result;
 }
 
-uint8_t
+uint8_t ck_pr_load_8(const uint8_t * target)
-ck_pr_load_8(const uint8_t *target)
 {
   uint8_t result;
   pthread_mutex_lock(&glock);
@@ -250,13 +244,13 @@ void ck_pr_store_ptr(void *target, void *value)
   pthread_mutex_unlock(&glock);
 }
 
-
 // Simple hashset
 
 static const size_t prime_1 = 73;
 static const size_t prime_2 = 5009;
 
-size_t hash_function(const char* str, size_t len) {
+size_t hash_function(const char *str, size_t len)
+{
   unsigned long hash = 5381;
   int c;
 
@@ -269,7 +263,8 @@ size_t hash_function(const char* str, size_t len) {
 
 simple_hashset_t simple_hashset_create()
 {
-    simple_hashset_t set = (simple_hashset_t)calloc(1, sizeof(struct simple_hashset_st));
+  simple_hashset_t set =
+      (simple_hashset_t) calloc(1, sizeof(struct simple_hashset_st));
 
   if (set == NULL) {
     return NULL;
@@ -279,7 +274,10 @@ simple_hashset_t simple_hashset_create()
   set->nbits = 3;
   set->capacity = (size_t)(1 << set->nbits);
   set->mask = set->capacity - 1;
-    set->items = (struct simple_hashset_item_st*)calloc(set->capacity, sizeof(struct simple_hashset_item_st));
+  set->items =
+      (struct simple_hashset_item_st *)calloc(set->capacity,
+                                              sizeof(struct
+                                                     simple_hashset_item_st));
   if (set->items == NULL) {
     simple_hashset_destroy(set);
     return NULL;
@@ -302,7 +300,8 @@ void simple_hashset_set_hash_function(simple_hashset_t set, hash_func_t func)
   set->hash_func = func;
 }
 
-static int simple_hashset_add_member(simple_hashset_t set, symbol_type* key, size_t hash)
+static int simple_hashset_add_member(simple_hashset_t set, symbol_type * key,
+                                     size_t hash)
 {
   size_t index;
 
@@ -315,8 +314,7 @@ static int simple_hashset_add_member(simple_hashset_t set, symbol_type* key, siz
   while (set->items[index].hash != 0 && set->items[index].hash != 1) {
     if (set->items[index].hash == hash) {
       return 0;
-        }
+    } else {
-        else {
       /* search free slot */
       index = set->mask & (index + prime_2);
     }
@@ -337,25 +335,28 @@ static void set_maybe_rehash(simple_hashset_t set)
   struct simple_hashset_item_st *old_items;
   size_t old_capacity, index;
 
-
   if (set->nitems + set->n_deleted_items >= (double)set->capacity * 0.85) {
     old_items = set->items;
     old_capacity = set->capacity;
     ++set->nbits;
     set->capacity = (size_t)(1 << set->nbits);
     set->mask = set->capacity - 1;
-        set->items = (struct simple_hashset_item_st*)calloc(set->capacity, sizeof(struct simple_hashset_item_st));
+    set->items =
+        (struct simple_hashset_item_st *)calloc(set->capacity,
+                                                sizeof(struct
+                                                       simple_hashset_item_st));
     set->nitems = 0;
     set->n_deleted_items = 0;
     //assert(set->items);
     for (index = 0; index < old_capacity; ++index) {
-            simple_hashset_add_member(set, old_items[index].item, old_items[index].hash);
+      simple_hashset_add_member(set, old_items[index].item,
+                                old_items[index].hash);
     }
     free(old_items);
   }
 }
 
-int simple_hashset_add(simple_hashset_t set, symbol_type* key)
+int simple_hashset_add(simple_hashset_t set, symbol_type * key)
 {
   size_t key_len = strlen(key->desc);
   size_t hash = set->hash_func(key->desc, key_len);
@@ -364,7 +365,7 @@ int simple_hashset_add(simple_hashset_t set, symbol_type* key)
   return rv;
 }
 
-int simple_hashset_is_member(simple_hashset_t set, symbol_type* key)
+int simple_hashset_is_member(simple_hashset_t set, symbol_type * key)
 {
   size_t key_len = strlen(key->desc);
   size_t hash = set->hash_func(key->desc, key_len);
@@ -379,5 +380,3 @@ int simple_hashset_is_member(simple_hashset_t set, symbol_type* key)
   }
   return 0;
 }
-
-

ck-polyfill.h

@@ -17,14 +17,14 @@ struct ck_malloc {
 ///////////////////////////////////////////////////////////////////////////////
 // Simple hashset (hashset with string support)
     /* hash function */
-    typedef size_t(*hash_func_t)(const char*, size_t);
+typedef size_t (*hash_func_t)(const char *, size_t);
 
-    struct simple_hashset_item_st {
+struct simple_hashset_item_st {
   size_t hash;
-        symbol_type* item;
+  symbol_type *item;
-    };
+};
 
-    struct simple_hashset_st {
+struct simple_hashset_st {
   size_t nbits;
   size_t mask;
 
@@ -34,26 +34,25 @@ struct ck_malloc {
   size_t n_deleted_items;
 
   hash_func_t hash_func;
-    };
+};
 //    struct simple_hashset_st;
-    typedef struct simple_hashset_st *simple_hashset_t;
+typedef struct simple_hashset_st *simple_hashset_t;
 
-
+struct hashmap_st;
-    struct hashmap_st;
+typedef struct hashmap_st *hashmap_t;
-    typedef struct hashmap_st *hashmap_t;
 
     /*
      * HASHSET FUNCTIONS
      */
 
     /* create hashset instance */
-    simple_hashset_t simple_hashset_create(void);
+simple_hashset_t simple_hashset_create(void);
 
     /* destroy hashset instance */
-    void simple_hashset_destroy(simple_hashset_t set);
+void simple_hashset_destroy(simple_hashset_t set);
 
     /* set hash function */
-    void simple_hashset_set_hash_function(simple_hashset_t set, hash_func_t func);
+void simple_hashset_set_hash_function(simple_hashset_t set, hash_func_t func);
 
     /* add item into the hashset.
      *
@@ -62,13 +61,13 @@ struct ck_malloc {
      *
      * returns zero if the item already in the set and non-zero otherwise
      */
-    int simple_hashset_add(simple_hashset_t set, symbol_type* key);
+int simple_hashset_add(simple_hashset_t set, symbol_type * key);
 
     /* check if existence of the item
      *
      * returns non-zero if the item exists and zero otherwise
      */
-    int simple_hashset_is_member(simple_hashset_t set, symbol_type* key);
+int simple_hashset_is_member(simple_hashset_t set, symbol_type * key);
 
 static inline uint64_t MurmurHash64A(const void *key, int len, uint64_t seed)
 {
@@ -101,7 +100,8 @@ typedef bool ck_hs_compare_cb_t(const void *, const void *);
 #define CK_HS_HASH(hs, hs_hash, value) 0
 
 bool ck_hs_init(ck_hs_t *, unsigned int, ck_hs_hash_cb_t *,
-    ck_hs_compare_cb_t *, struct ck_malloc *, unsigned long, unsigned long);     
+                ck_hs_compare_cb_t *, struct ck_malloc *, unsigned long,
+                unsigned long);
 
 void *ck_hs_get(ck_hs_t *, unsigned long, const void *);
 bool ck_hs_put(ck_hs_t *, unsigned long, const void *);
@@ -150,7 +150,7 @@ typedef struct ck_array_iterator ck_array_iterator_t;
 //      returns false if the creation failed. Failure may occur due to internal
 //      memory allocation failures or invalid arguments.
 bool
-ck_array_init(ck_array_t *array, unsigned int mode,
+ck_array_init(ck_array_t * array, unsigned int mode,
               struct ck_malloc *allocator, unsigned int initial_length);
 
 // DESCRIPTION
@@ -166,8 +166,7 @@ ck_array_init(ck_array_t *array, unsigned int mode,
 //      This function returns 1 if the pointer already exists in the array.  It
 //      returns 0 if the put operation succeeded. It returns -1 on error due to
 //      internal memory allocation failures.
-int
+int ck_array_put_unique(ck_array_t * array, void *pointer);
-ck_array_put_unique(ck_array_t *array, void *pointer);
 
 // DESCRIPTION
 //      The ck_array_remove(3) function will attempt to remove the value of
@@ -180,9 +179,7 @@ ck_array_put_unique(ck_array_t *array, void *pointer);
 //      This function returns true if the remove operation succeeded. It will
 //      return false otherwise due to internal allocation failures or because the
 //      value did not exist.
-bool
+bool ck_array_remove(ck_array_t * array, void *pointer);
-ck_array_remove(ck_array_t *array, void *pointer);
-
 
 // DESCRIPTION
 //      The ck_array_commit(3) function will commit any pending put or remove
@@ -193,9 +190,7 @@ ck_array_remove(ck_array_t *array, void *pointer);
 // RETURN VALUES
 //      This function returns true if the commit operation succeeded. It will
 //      return false otherwise, and pending operations will not be applied.
-bool
+bool ck_array_commit(ck_array_t * array);
-ck_array_commit(ck_array_t *array);
-
 
   // TODO:
 
@@ -213,33 +208,23 @@ ck_array_commit(ck_array_t *array);
 
 ///////////////////////////////////////////////////////////////////////////////
 // CK PR section
-bool
+bool ck_pr_cas_ptr(void *target, void *old_value, void *new_value);
-ck_pr_cas_ptr(void *target, void *old_value, void *new_value);
 
-bool
+bool ck_pr_cas_int(int *target, int old_value, int new_value);
-ck_pr_cas_int(int *target, int old_value, int new_value);
 
-bool
+bool ck_pr_cas_8(uint8_t * target, uint8_t old_value, uint8_t new_value);
-ck_pr_cas_8(uint8_t *target, uint8_t old_value, uint8_t new_value);
 
+void ck_pr_add_ptr(void *target, uintptr_t delta);
 
-void
+void ck_pr_add_int(int *target, int delta);
-ck_pr_add_ptr(void *target, uintptr_t delta);
 
-void
+void ck_pr_add_8(uint8_t * target, uint8_t delta);
-ck_pr_add_int(int *target, int delta);
 
-void
+void *ck_pr_load_ptr(const void *target);
-ck_pr_add_8(uint8_t *target, uint8_t delta);
 
-void *
+int ck_pr_load_int(const int *target);
-ck_pr_load_ptr(const void *target);
 
-int
+uint8_t ck_pr_load_8(const uint8_t * target);
-ck_pr_load_int(const int *target);
-
-uint8_t
-ck_pr_load_8(const uint8_t *target);
 
 void ck_pr_store_ptr(void *target, void *value);
 #endif                          /* CYCLONE_CK_POLYFILL_H */

cyclone.scm

@@ -21,11 +21,12 @@
         (scheme cyclone primitives)
         (scheme cyclone transforms)
         (scheme cyclone cps-optimizations)
-        (scheme cyclone libraries))
+        (scheme cyclone libraries)
+        (srfi 18))
 
 (define *fe:batch-compile* #t) ;; Batch compilation. TODO: default to false or true??
 (define *optimization-level* 2) ;; Default level
-(define *optimize:memoize-pure-functions* #t) ;; Memoize pure funcs by default
+(define *optimize:memoize-pure-functions* #f) ;; Memoize pure function
 (define *optimize:beta-expand-threshold* #f) ;; BE threshold or #f to use default
 (define *optimize:inline-unsafe* #f) ;; Inline primitives even if generated code may be unsafe
 (define *cgen:track-call-history* #t)
@@ -79,6 +80,11 @@
     Cyc_check_str(data, filename);
     double_value(&box) = Cyc_file_last_modified_time(string_str(filename));
     return_closcall1(data, k, &box); ")
+
+(define-c calling-program
+  "(void *data, int argc, closure _, object k)"
+  " make_utf8_string(data, s, _cyc_argv[0]);
+    return_closcall1(data, k, &s); ")
 ;; END batch compilation
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -287,7 +293,10 @@
         (for-each 
           (lambda (lib-dep)
             (when (recompile? lib-dep append-dirs prepend-dirs)
-              (let ((result (system (string-append "cyclone " 
+              (let ((result (system (string-append 
+                                      (calling-program) " " 
+                                      (dirs->args "-A" append-dirs) " "
+                                      (dirs->args "-I" prepend-dirs) " "
                                       (lib:import->filename lib-dep ".sld" append-dirs prepend-dirs)))))
                 (when (> result 0)
                   (error "Unable to compile library" lib-dep)))))
@@ -340,7 +349,8 @@
               (cond
                 ((eq? e 'call/cc) #f) ;; Special case
                 ((and (not module-global?)
-                      (not imported-var?))
+                      (not imported-var?)
+                      (not (prim? e)))
                  (error "Identifier is exported but not defined" e))
                 (else
                   ;; Pass throughs are not defined in this module,
@@ -715,9 +725,7 @@
     in-prog))
 
 ;; Compile and emit:
-(define (run-compiler args cc? cc-prog cc-exec cc-lib cc-so 
+(define (run-compiler args append-dirs prepend-dirs change-cc-opts!)
-                      cc-opts cc-prog-linker-opts cc-prog-linker-objs 
-                      append-dirs prepend-dirs)
   (let* ((in-file (car args))
          (expander (base-expander))
          (in-prog-raw (read-file in-file))
@@ -730,7 +738,7 @@
               in-prog-raw)
             (else
               ;; Account for any cond-expand declarations in the library
-              (list (lib:cond-expand (car in-prog-raw) expander)))))
+              (list (lib:cond-expand in-file (car in-prog-raw) expander)))))
           ;; expand in-prog, if a library, using lib:cond-expand.
           ;; TODO: will also need to do below in lib:get-all-import-deps, after reading each library
          (program:imports/code (if program? (import-reduction in-prog expander) '()))
@@ -739,6 +747,20 @@
                     (not (null? (car program:imports/code))))
              (lib:get-all-import-deps (car program:imports/code) append-dirs prepend-dirs expander)
             '()))
+        ;; Read C compiler options
+         (cc-opts
+          (cond
+            (program? 
+              (let ((opts (program-c-compiler-opts! in-prog)))
+                (when (not (null? opts))
+                  (change-cc-opts! opts))
+                (string-join ;; Check current program for options
+                  opts
+                  " ")))
+            (else
+              (string-join 
+                (lib:c-compiler-options (car in-prog)) 
+                " "))))
          ;; Read all linker options from dependent libs
          (c-linker-options
            (let ((lib-options (lib:get-all-c-linker-options lib-deps append-dirs prepend-dirs expander)))
@@ -748,17 +770,6 @@
                    " "
                    lib-options)
                  lib-options)))
-         ;; Only read C compiler options from module being compiled
-         (cc-opts*
-          (cond
-            (program? 
-              (string-join ;; Check current program for options
-                (program-c-compiler-opts! in-prog)
-                " "))
-            (else
-              (string-join 
-                (lib:c-compiler-options (car in-prog)) 
-                " "))))
          (exec-file (basename in-file))
          (src-file (string-append exec-file ".c"))
          (meta-file (string-append exec-file ".meta"))
@@ -797,13 +808,85 @@
                      lib-deps)
                    in-file 
                    append-dirs 
-                   prepend-dirs)))))
+                   prepend-dirs))))))
-         (result (create-c-file in-prog)))
+    (create-c-file in-prog)
+    (cond
+     (program?
+      ;; Use .meta file to store information for C compiler phase
+      (save-program-metadata meta-file lib-deps c-linker-options))
+     (else
+      ;; Emit .meta file
+      (with-output-to-file
+        meta-file
+        (lambda ()
+          (display ";; This file was automatically generated by the Cyclone Scheme compiler")
+          (newline)
+          (write (macro:get-defined-macros))))))))
 
+(define (save-program-metadata filename lib-deps c-linker-options)
+  (with-output-to-file
+    filename
+    (lambda ()
+      (display ";; This file was automatically generated by the Cyclone Scheme compiler")
+      (newline)
+      (write `(lib-deps . ,lib-deps))
+      (newline)
+      (write `(c-linker-options . ,c-linker-options)))))
+
+(define (load-program-metadata filename)
+  (let ((data (call-with-input-file filename  read-all)))
+    (delete-file filename)
+    data))
+
+(define (get-meta meta symbol default)
+  (if (assoc symbol meta)
+      (cdr (assoc symbol meta))
+      default))
+
+(define (run-external-compiler 
+           args append-dirs prepend-dirs
+           cc? cc-prog cc-exec cc-lib cc-so 
+           cc-opts cc-prog-linker-opts cc-prog-linker-objs)
+  (let* ((in-file (car args))
+         (expander (base-expander))
+         (in-prog-raw (read-file in-file))
+         (program? (not (library? (car in-prog-raw))))
+         (in-prog
+          (cond
+            (program? 
+              (Cyc-add-feature! 'program) ;; Load special feature
+              ;; TODO: what about top-level cond-expands in the program?
+              in-prog-raw)
+            (else
+              ;; Account for any cond-expand declarations in the library
+              (list (lib:cond-expand in-file (car in-prog-raw) expander)))))
+         ;; Only read C compiler options from module being compiled
+         (cc-opts*
+          (cond
+            (program? 
+              (string-join ;; Check current program for options
+                (program-c-compiler-opts! in-prog)
+                " "))
+            (else
+              (string-join 
+                (lib:c-compiler-options (car in-prog)) 
+                " "))))
+         (exec-file (basename in-file))
+         (src-file (string-append exec-file ".c"))
+         (meta-file (string-append exec-file ".meta"))
+         (get-comp-env 
+           (lambda (sym str)
+             (if (> (string-length str) 0)
+                 str
+                 (Cyc-compilation-environment sym)))) 
+        )
     ;; Compile the generated C file
     (cond
       (program?
-        (letrec ((objs-str 
+        (letrec ((metadata (load-program-metadata meta-file))
+                 (c-linker-options (get-meta metadata 'c-linker-options '()))
+                 (lib-deps (get-meta metadata 'lib-deps '()))
+                 (objs-str 
                   (string-append
                     cc-prog-linker-objs
                     (apply
@@ -814,29 +897,29 @@
                         lib-deps))))
                  (comp-prog-cmd 
                    (string-append
+                     (string-replace-all 
                        (string-replace-all 
                          (string-replace-all 
                            ;(Cyc-compilation-environment 'cc-prog) 
                            (get-comp-env 'cc-prog cc-prog)
                            "~src-file~" src-file)
+                         "~cc-extra~" cc-opts)
                        "~exec-file~" exec-file)
                      " "
-                     cc-opts
-                     " "
                      cc-opts*))
                  (comp-objs-cmd 
                   (string-append
                    (string-replace-all
+                     (string-replace-all
                        (string-replace-all
                          (string-replace-all
                            ;(Cyc-compilation-environment 'cc-exec)
                            (get-comp-env 'cc-exec cc-exec)
                            "~exec-file~" exec-file)
+                         "~ld-extra~" cc-prog-linker-opts)
                        "~obj-files~" objs-str)
                      "~exec-file~" exec-file)
                    " "
-                   cc-prog-linker-opts
-                   " "
                    c-linker-options
                    )))
           ;(write `(DEBUG all imports ,lib-deps objs ,objs-str))
@@ -851,24 +934,17 @@
               (display comp-objs-cmd)
               (newline)))))
       (else
-        ;; Emit .meta file
-        (with-output-to-file
-          meta-file
-          (lambda ()
-            (display ";; This file was automatically generated by the Cyclone Scheme compiler")
-            (newline)
-            (write (macro:get-defined-macros))))
         ;; Compile library
         (let ((comp-lib-cmd
                (string-append
+                (string-replace-all 
                   (string-replace-all 
                     (string-replace-all 
                       (get-comp-env 'cc-lib cc-lib)
                       "~src-file~" src-file)
+                    "~cc-extra~" cc-opts)
                   "~exec-file~" exec-file)
                 " "
-                cc-opts
-                " "
                 cc-opts*))
               (comp-so-cmd
                (string-append
@@ -912,6 +988,17 @@
       (list #f)
       args)))
 
+;; Convert a list of directories to a string of arguments.
+;; EG: (dirs->args "-I" '("dir-1" "dir-2")) =>
+;;     " -I dir-1 -I dir-2 "
+(define (dirs->args prefix dirs)
+  (apply 
+    string-append
+    (map
+      (lambda (dir)
+        (string-append " " prefix " " dir " "))
+      dirs)))
+
 ;; Handle command line arguments
 (let* ((args (command-line-arguments))
        (non-opts 
@@ -924,6 +1011,8 @@
                 ;               (equal? #\- (string-ref arg 0)))))
                 ;   args))
        (compile? #t)
+       (run-scm-compiler? (member "-run-scm-compiler" args))
+       (no-compiler-subprocess (member "-no-compiler-subprocess" args))
        (cc-prog (apply string-append (collect-opt-values args "-CP")))
        (cc-exec (apply string-append (collect-opt-values args "-CE")))
        (cc-lib  (apply string-append (collect-opt-values args "-CL")))
@@ -1067,7 +1156,34 @@ Debug options:
             (cdr err))
           (newline)
           (exit 1)))
-      (run-compiler non-opts compile? cc-prog cc-exec cc-lib cc-so 
+      (cond
-                    cc-opts cc-linker-opts cc-linker-extra-objects 
+        (run-scm-compiler? 
-                    append-dirs prepend-dirs)))))
+          ;; Compile Scheme code into a C file
+          (run-compiler non-opts append-dirs prepend-dirs
+            (lambda (opts) 
+              (set! cc-opts opts))))
+        (else
+          ;; Generate the C file
+          (cond
+           (no-compiler-subprocess
+            ;; Special case, we can generate .C file within this process
+            (run-compiler non-opts append-dirs prepend-dirs
+              (lambda (opts) (set! cc-opts opts)))
+
+            )
+           (else
+            ;; Normal path is to run another instance of cyclone to generate
+            ;; the .C file. This lets us immediately free those resources once
+            ;; the Scheme compilation is done.
+            (when (not (zero? (system
+                                (string-append 
+                                  (calling-program) " -run-scm-compiler "
+                                  (string-join args " ")))))
+              (exit 1))))
+          ;; Call the C compiler
+          (run-external-compiler
+            non-opts append-dirs prepend-dirs
+            compile? cc-prog cc-exec cc-lib cc-so 
+            cc-opts cc-linker-opts cc-linker-extra-objects)))
+      ))))
 

docs/Garbage-Collector-Revised-2022.md

@@ -0,0 +1,639 @@
+[<img src="images/cyclone-logo-04-header.png" alt="cyclone-scheme">](http://github.com/justinethier/cyclone)
+
+# Garbage Collector
+
+- [Introduction](#introduction)
+- [Minor Collection](#minor-collection)
+  - [Cheney on the MTA](#cheney-on-the-mta)
+  - [Our Implementation](#our-implementation)
+  - [Write Barriers](#write-barriers)
+- [Major Collection](#major-collection)
+  - [Lazy Sweeping](#lazy-sweeping)
+  - [Object Marking](#object-marking)
+  - [Handshakes](#handshakes)
+  - [Collection Cycle](#collection-cycle)
+  - [Mutator Functions](#mutator-functions)
+  - [Collector Functions](#collector-functions)
+  - [Cooperation by the Collector](#cooperation-by-the-collector)
+  - [Running the Collector](#running-the-collector)
+  - [Performance Measurements](#performance-measurements)
+- [Conclusion](#conclusion)
+- [Further Reading](#further-reading)
+- [Appendix](#appendix)
+  - [Terms](#terms)
+  - [Code](#code)
+  - [Data Structures](#data-structures)
+    - [Heap](#heap)
+    - [Thread Data](#thread-data)
+    - [Object Header](#object-header)
+    - [Mark Buffers](#mark-buffers)
+
+# Introduction
+
+This article provides a high-level overview of Cyclone's garbage collector, including recent work on lazy sweeping and automatic relocation of shared objects. This overview would be a good starting point for understanding the corresponding code in Cyclone's runtime and may also be of interest to anyone wanting to implement - or just peek under the hood of - a modern, real-world collector.
+
+The collector has the following requirements:
+
+- Efficiently free allocated memory.
+- Allow the language implementation to support tail calls and continuations.
+- Allow the language to support native multithreading.
+
+Cyclone uses generational garbage collection (GC) to automatically free allocated memory using two types of collection. In practice, most allocations consist of short-lived objects such as temporary variables. Minor GC is done frequently to clean up most of these short-lived objects. A major collection runs less often to free longer-lived objects that are no longer being used by the application.
+
+Cheney on the MTA, a technique introduced by Henry Baker, is used to implement the minor collector. Objects are allocated directly on the stack using `alloca` so allocations are very fast, do not cause fragmentation, and do not require a special pass to free unused objects. 
+
+A concurrent mark-sweep collector is used to manage heap memory and perform major collections without [stopping the world](https://en.wikipedia.org/wiki/Tracing_garbage_collection#Stop-the-world_vs._incremental_vs._concurrent).
+
+For more background there are introductory articles on garbage collection in the [further reading](#further-reading) section that discuss underlying concepts.
+
+# Minor Collection
+
+## Cheney on the MTA
+
+A runtime based on Henry Baker's paper [CONS Should Not CONS Its Arguments, Part II: Cheney on the M.T.A.](research-papers/CheneyMTA.pdf) was used as it allows for fast code that meets all of the fundamental requirements for a Scheme runtime: tail calls, garbage collection, and continuations.
+
+Baker explains how it works:
+
+> We propose to compile Scheme by converting it into continuation-passing style (CPS), and then compile the resulting lambda expressions into individual C functions. Arguments are passed as normal C arguments, and function calls are normal C calls. Continuation closures and closure environments are passed as extra C arguments. Such a Scheme never executes a C return, so the stack will grow and grow ... eventually, the C "stack" will overflow the space assigned to it, and we must perform garbage collection. 
+
+Cheney on the M.T.A. uses a copying garbage collector. By using static roots and the current continuation closure, the GC is able to copy objects from the stack to a pre-allocated heap without having to know the format of C stack frames. To quote Baker:
+
+> the entire C "stack" is effectively the youngest generation in a generational garbage collector!
+
+After GC is finished, the C stack pointer is reset using [`longjmp`](http://man7.org/linux/man-pages/man3/longjmp.3.html) and the GC calls its continuation. 
+
+Here is a snippet demonstrating how C functions may be written using Baker's approach:
+
+    object Cyc_make_vector(object cont, object len, object fill) {
+      object v = NULL;
+      int i;
+      Cyc_check_int(len);
+
+      // Memory for vector can be allocated directly on the stack
+      v = alloca(sizeof(vector_type));
+
+      // Populate vector object
+      ((vector)v)->tag = vector_tag;
+      ... 
+
+      // Check if GC is needed, then call into continuation with the new vector
+      return_closcall1(cont, v);
+    }
+
+[CHICKEN](http://www.call-cc.org/) was the first Scheme compiler to use Baker's approach.
+
+## Our Implementation
+
+Minor GC is always performed for a single mutator thread. Each thread uses local stack storage for its own objects so there is no need for minor GC to synchronize with other mutator threads.
+
+As described in Baker's paper, Cyclone converts the original program to continuation passing style (CPS) and compiles it as a series of C functions that never return. At runtime each mutator periodically checks to see if its stack has exceeded a certain size. When this happens a minor GC is started and all live stack objects are copied to the heap.
+
+The following root objects are used as a starting point to find all live objects:
+
+- The current continuation
+- Arguments to the current continuation
+- Mutations contained in the write barrier
+- Closures from the exception stack
+- Global variables
+
+The collection algorithm itself operates as follows:
+
+- Move any root objects on the stack to the heap. 
+- For each object moved: 
+  - Replace the stack object with a forwarding pointer. The forwarding pointer ensures all references to a stack object refer to the same heap object, and allows minor GC to handle cycles.
+  - Record each moved object in a buffer to serve as the Cheney to-space.
+- Loop over the to-space buffer and check each object moved to the heap. Move any child objects that are still on the stack. This loop continues until all live objects are moved.
+- [Cooperate](#cooperate) with the major GC's collection thread.
+- Perform a `longjmp` to reset the stack and call into the current continuation.
+
+Any objects left on the stack after `longjmp` are considered garbage. There is no need to clean them up because the stack will just re-use the memory as it grows.
+
+## Write Barriers
+
+### Heap Object References
+
+Baker's paper does not mention one important detail. A heap object can be modified to contain a reference to a stack object. For example, by using a `set-car!` to change the head of a list.
+
+This is problematic since stack references are no longer valid after a minor GC and the GC does not check heap objects. We account for these mutations by using a write barrier to maintain a list of each modified object. During GC these modified objects are treated as roots to avoid dangling references.
+
+The write barrier must be called by each primitive in the runtime that modifies object pointers - `set-car!`, `set-cdr!`, `vector-set!`, etc. Fortunately there are only a handful of these functions.
+
+### Relocating Shared Objects
+
+Cyclone must guarantee the objects located on each mutator thread's stack are only used by that thread. 
+
+This requirement is critical as any existing references to a stack object will become invalid when that object is moved to the heap by minor GC. Without the proper safety measures in place this would lead to the potential for memory safety issues - segmentation faults, undefined behavior, etc.
+
+Thus Cyclone ensures memory safety by automatically relocating objects to the heap before they can be accessed by more than one thread. Each write barrier checks to see if a heap variable is being changed to point to a variable on the stack. When such a change is detected Cyclone will move only that object to the heap if possible. However for objects with many children - such as a list or vector - it may be necessary for Cyclone to trigger a minor collection in order to ensure all objects are relocated to the heap before they can be accessed by multiple threads. 
+
+The following function does the heavy lifting:
+
+    object transport_stack_value(gc_thread_data *data, object var, object value, int *run_gc) 
+    {
+      char tmp;
+      int inttmp, *heap_grown = &inttmp;
+      gc_heap_root *heap = data->heap;
+    
+      // Nothing needs to be done unless we are mutating
+      // a heap variable to point to a stack var.
+      if (!gc_is_stack_obj(&tmp, data, var) && gc_is_stack_obj(&tmp, data, value)) {
+        // Must move `value` to the heap to allow use by other threads
+        switch(type_of(value)) {
+          case string_tag:
+          case bytevector_tag:
+            if (immutable(value)) {
+              // Safe to transport now
+              object hp = gc_alloc(heap, gc_allocated_bytes(value, NULL, NULL), value, data, heap_grown);
+              return hp;
+            }
+            // Need to GC if obj is mutable, EG: a string could be mutated so we can't
+            // have multiple copies of the object running around
+            *run_gc = 1;
+            return value;
+          case double_tag:
+          case port_tag:
+          case c_opaque_tag:
+          case complex_num_tag: {
+            // These objects are immutable, transport now
+            object hp = gc_alloc(heap, gc_allocated_bytes(value, NULL, NULL), value, data, heap_grown);
+            return hp;
+          }
+          // Objs w/children force minor GC to guarantee everything is relocated:
+          case cvar_tag:
+          case closure0_tag:
+          case closure1_tag:
+          case closureN_tag:
+          case pair_tag:
+          case vector_tag:
+            *run_gc = 1;
+            return value;
+          default:
+            // Other object types are not stack-allocated so should never get here
+            printf("Invalid shared object type %d\n", type_of(value));
+            exit(1);
+        }
+      }
+    
+      return value;
+    }
+
+Then, `transport_stack_value` is called from each write barrier in a manner similar to the below for `set-car!`:
+
+    int do_gc = 0;
+    val = transport_stack_value(data, l, val, &do_gc);
+    ...
+    if (do_gc) { // GC and then do assignment
+      mclosure0(clo, (function_type)Cyc_set_car_cps_gc_return);
+      object buf[3]; buf[0] = l; buf[1] = val; buf[2] = cont;
+      GC(data, &clo, buf, 3);
+      return NULL;
+    }
+
+It is still necessary for application code to use the appropriate concurrency constructs - such as locks, atomics, etc - to ensure that a shared object is safely accessed by only one thread at a time.
+
+# Major Collection
+
+Baker's technique uses a copying collector for both the minor and major generations of collection. One of the drawbacks of using a copying collector for major GC is that it relocates all the live objects during collection. This is problematic for supporting native threads because an object can be relocated at any time, invalidating any references to the object. To prevent this either all threads must be stopped while major GC is running or a read barrier must be used each time an object is accessed. Both options add a potentially significant overhead so instead Cyclone uses a tracing collector based on the Doligez-Leroy-Gonthier (DLG) algorithm for major collections. 
+
+An advantage of this approach is that major GC executes asynchronously so threads can continue to run concurrently even during collections. A collector thread is used to perform a major GC with cooperation from the mutator threads.
+
+## Lazy Sweeping
+
+A fundamental mark-sweep optimization suggested by the [Garbage Collection Handbook](#further-reading) is lazy sweeping.
+
+In a simple mark-sweep collector the entire heap is swept at once when tracing is finished. Instead with lazy sweeping each mutator thread will sweep its own heap incrementally as part of allocation. When no more free space is available to meet a request the allocator will check to see if there are unswept heap pages, and if so, the mutator will pick a page and sweep it to free up space. This amortizes the cost of sweeping.
+
+Performance is improved in several ways:
+
+- Better Locality - Heap slots tend to be used soon after they are swept and sweep only needs to visit a small part of the heap. This allows programs to make better use of the processor cache.
+- Thread-Local Data - There is no need to lock the heap for allocation or sweeping since both operations are performed by the same thread.
+- Reduced Complexity - The algorithmic complexity of mark-sweep is reduced to be proportional to the size of the live data in the heap instead of the whole heap, similar to a copying collector. Lazy sweeping will perform best when most of the heap is empty.
+
+Lazy sweeping is discussed here in the first major GC section as it impacts most of the other components of the collector.
+
+## Object Marking
+
+An object can be marked using any of the following colors to indicate the status of its memory:
+
+  - :large_blue_circle: - Blue - Unallocated memory.
+  - :red_circle: - Red - An object on the stack.
+  - :white_circle: - White - Heap memory that has not been scanned by the collector. 
+  - :radio_button: - Gray - Objects marked by the collector that may still have child objects that must be marked.
+  - :black_circle: - Black - Objects marked by the collector whose immediate child objects have also been marked.
+  - :purple_circle: - Purple - Garbage objects on the heap that have not yet been reclaimed due to lazy sweeping.
+
+### Tri-Color Invariant
+
+Only objects marked as white, gray, or black participate in major collections. 
+
+White objects are freed during the sweep state. White is sometimes also referred to as the clear color.
+
+Black objects survive the collection cycle. Black is sometimes referred to as the mark color as live objects are ultimately marked black.
+
+Our collector must guarantee that a black object never has any children that are white objects. This satisfies the so-called tri-color invariant and guarantees that all white objects can be collected once the gray objects are marked. This is the reason our collector must use a gray color instead of transitioning white objects directly to black.
+
+Finally, a [mark buffer](#mark-buffers) is used to store the list of gray objects. This improves performance by avoiding repeated passes over the heap to search for gray objects.
+
+## Deferred Collection
+
+A set of three heap colors is insufficient for lazy sweeping because parts of the heap may not be swept during a collection cycle. Thus an object that is really garbage could accidentally be assigned the black color.
+
+For example, suppose a heap page consists entirely of white objects after a GC is finished. All of the objects are garbage and would be freed if the page is swept. However if this page is not swept before the next collection starts, the collector will [swap the values of white/black](#clear) and during the subsequent cycle all of the objects will appear as if they have the black color. Thus a sweep during this most recent GC cycle would not be able to free any of the objects!
+
+The solution is to add a new color (purple) to indicate garbage objects on the heap. Garbage can then be swept while the collector is busy doing other work such as mark/trace. In order to account for multiple generations of objects the object colors are incremented each cycle instead of being swapped. For example, the collector starts in the following state:
+
+    static unsigned char gc_color_mark = 5;   // Black, is swapped during GC
+    static unsigned char gc_color_clear = 3;  // White, is swapped during GC
+    static unsigned char gc_color_purple = 1;  // There are many "shades" of purple, this is the most recent one
+
+We can assign a new purple color after tracing is finished. At this point the clear color and the purple color are (essentially) the same, and any new objects are allocated using the mark color. When GC starts back up, the clear and mark colors are each incremented by 2:
+
+    // We now increment both so that clear becomes the old mark color and a
+    // new value is used for the mark color. The old clear color becomes
+    // purple, indicating any of these objects are garbage
+    ck_pr_add_8(&gc_color_purple, 2);
+    ck_pr_add_8(&gc_color_clear, 2);
+    ck_pr_add_8(&gc_color_mark, 2);
+
+So we now have purple (assigned the previous clear color), clear (assigned the previous mark color), and mark (assigned a new number). All of these numbers must be odd so they will never conflict with the red or blue colors. Effectively any odd numbered colors not part of this set represent other "shades" of purple.
+
+## Handshakes
+
+Instead of stopping the world and pausing all threads, when the collector needs to coordinate with the mutators it performs a handshake.
+
+Each of the mutator threads, and the collector itself, has a status variable:
+
+     typedef enum { STATUS_ASYNC 
+                  , STATUS_SYNC1 
+                  , STATUS_SYNC2 
+                  } gc_status_type;
+
+The collector will update its status variable and then wait for all of the collectors to change their status before continuing. The mutators periodically call a cooperate function to check in and update their status to match the collectors. A handshake is complete once all mutators have updated their status.
+
+## Collection Cycle
+
+During a GC cycle the collector thread transitions through the following states.
+
+### Clear
+The collector swaps the values of the clear color (white) and the mark color (black). This is more efficient than modifying the color on each object in the heap. The collector then transitions to sync 1. At this point no heap objects are marked, as demonstrated below:
+
+<img src="images/gc-graph-clear.png" alt="Initial object graph">
+
+### Mark
+The collector transitions to sync 2 and then async. At this point it marks the global variables and waits for the mutators to also transition to async. When a mutator transitions it will mark its roots and use black as the allocation color to prevent any new objects from being collected during this cycle:
+
+<img src="images/gc-graph-mark.png" alt="Initial object graph">
+
+### Trace
+The collector finds all live objects using a breadth-first search and marks them black:
+
+<img src="images/gc-graph-trace.png" alt="Initial object graph">
+
+The collector thread performs the bulk of its work during this phase. For more details see the [Collector Trace](#collector-trace) section.
+
+### Sweep
+This function is included here for completeness but is actually performed much later due to [lazy sweeping](#lazy-sweeping).
+
+When the time comes to reclaim memory a mutator scans a heap page and frees memory used by any of the white objects:
+
+<img src="images/gc-graph-sweep.png" alt="Initial object graph">
+
+### Resting
+The collector cycle is complete and it rests until it is triggered again.
+
+## Mutator Functions
+
+Each mutator calls the following functions to coordinate with the collector.
+
+### Allocate
+
+This function is called by a mutator to allocate memory on the heap for an object. This is generally only done during a minor GC when each object is relocated to the heap.
+
+There is no need for the mutator to directly coordinate with the collector during allocation as each thread uses its own set of heap pages.
+
+The main allocation function takes a fast or slow path depending upon whether a free slot is found on the current heap page. 
+
+The logic in simplified form is:
+
+    result = try_alloc();
+    if (result)
+      return result;
+
+    result = try_alloc_slow();
+    if (result) 
+      return result;
+
+    grow_heap(); // malloc more heap space
+    result = try_alloc_slow();
+    if (result) 
+      return result;
+
+    out_of_memory_error();
+  
+A heap page uses a "free list" of available slots to quickly find the next available slot. The `try_alloc` function simply finds the first slot on the free list and returns it, or `NULL` if there is no free slot.
+
+On the other hand, `try_alloc_slow` has to do more work to find the next available heap page, sweep it, and then call `try_alloc` to perform an allocation.
+
+If there is not enough free memory to fulfill a `try_alloc_slow` request a new page is allocated and added to the heap. This is the only choice, unfortunately. The collection process is asynchronous so memory cannot be freed immediately to make room.
+
+### Sweep
+
+Sweep walks an entire heap page, freeing all unused slots along the way. 
+
+To identify an unused object the algorithm must check for two colors:
+
+- Objects that are either newly-allocated or recently traced are given the allocation color; we need to keep them.
+- If the collector is currently tracing, objects not traced yet will have the trace/clear color. We need to keep any of those to make sure the collector has a chance to trace the entire heap.
+
+The code is as follows:
+
+      if (mark(p) != thd->gc_alloc_color && 
+          mark(p) != thd->gc_trace_color) {
+        ... // Free slot p
+      }
+
+### Update
+
+A write barrier is used to ensure any modified objects are properly marked for the current collection cycle. There are two cases:
+
+- Gray the object's new and old values if the mutator is in a synchronous status. 
+- Gray the object's old value if the collector is in the tracing stage.
+
+Because updates can occur at any time a modified object may still live on the stack. In this case the object is tagged to be grayed when it is relocated to the heap.
+
+### Cooperate
+
+Each mutator is required to periodically call this function to cooperate with the collector. During cooperation a mutator will update its status to match the collector's status, to handshake with the collector. 
+
+In addition when a mutator transitions to async it will:
+
+- Mark all of its roots gray
+- Use black as the allocation color for any new objects to prevent them from being collected during this cycle.
+
+Cyclone's mutators cooperate after each minor GC, for two reasons. Minor GC's are frequent and immediately afterwards all of the mutator's live objects can be marked because they are on the heap.
+
+Finally, at the end of a collection cycle the main thread must clean up heap data for any terminated threads.
+
+### Mark Gray
+
+Mutators call this function to add an object to their mark buffer.
+
+    mark_gray(m, obj):
+      if obj != clear_color:
+        m->mark_buffer[m->last_write] = obj
+        m->last_write++
+
+## Collector Functions
+
+### Collector Mark Gray
+
+The collector calls this function to add an object to the mark stack.
+
+    collector_mark_gray(obj):
+      if obj != clear_color:
+        mark_stack->push(obj)
+
+### Mark Black
+
+The collector calls this function to mark an object black and mark all of the object's children gray using Collector Mark Gray.
+
+    mark_black(obj):
+      if mark(obj) != mark_color:
+        for each child(c):
+          collector_mark_gray(c)
+        mark(obj) = mark_color
+
+
+### Empty Collector Mark Stack
+
+This function removes and marks each object on the collector's mark stack.
+
+    empty_collector_mark_stack():
+      while not mark_stack->empty():
+        mark_black(mark_stack->pop())
+
+### Collector Trace
+
+This function performs tracing for the collector by looping over all of the mutator mark buffers. All of the remaining objects in each buffer are marked black, as well as all the remaining objects on the collector's mark stack. This function continues looping until there are no more objects to mark:
+
+    collector_trace():
+      clean = 0
+      while not clean:
+        clean = 1
+        for each mutator(m):
+          while m->last_read < m->last_write:
+            clean = 0
+            mark_black(m->mark_buffer[m->last_read])
+            empty_collector_mark_stack()
+            m->last_read++
+
+The primary job of the collector thread is tracing. 
+
+While tracing the collector visits all live objects and marks them as being in use. Since these objects are stored all across the heap the tracing algorithm cannot take advantage of object locality and tends to demonstrate unusual memory access patterns, leading to inefficient use of the processor cache and poor performance. This makes tracing an excellent task to be done in parallel with the mutator threads so it does not slow down application code.
+
+Note that during tracing some synchronization is required between the collector and the mutator threads. When an object is changed (EG via: `set!`, `vector-set!`, etc) the mutator needs to add this object to the mark stack, which requires a mutex lock to safely update shared resources.
+
+## Cooperation by the Collector
+
+In practice a mutator will not always be able to cooperate in a timely manner. For example, a thread can block indefinitely waiting for user input or reading from a network port. In the meantime the collector will never be able to complete a handshake with this mutator and major GC will never be performed.
+
+Cyclone solves this problem by requiring that a mutator keep track of its thread state. With this information the collector can cooperate on behalf of a blocked mutator and do the work itself instead of waiting for the mutator. 
+
+The possible thread states are:
+
+- `CYC_THREAD_STATE_NEW` - A new thread not yet running.
+- `CYC_THREAD_STATE_RUNNABLE` - A thread that can be scheduled to run by the OS.
+- `CYC_THREAD_STATE_BLOCKED` - A thread that could be blocked.
+- `CYC_THREAD_STATE_BLOCKED_COOPERATING` - A blocked thread that the collector is cooperating with on behalf of the mutator.
+- `CYC_THREAD_STATE_TERMINATED` - A thread that has been terminated by the application but its resources have not been freed up yet.
+
+Before entering a C function that could block the mutator must call a function to update its thread state to `CYC_THREAD_STATE_BLOCKED`. This indicates to the collector that the thread may be blocked.
+
+When the collector handshakes it will check each mutator to see if it is blocked. Normally in this case the collector can just update the blocked mutator's status and move on to the next one. But if the mutator is transitioning to async all of its objects need to be relocated from the stack so they can be marked. In this case the collector changes the thread's state to `CYC_THREAD_STATE_BLOCKED_COOPERATING`, locks the mutator's mutex, and performs a minor collection for the thread. The mutator's objects can then be marked gray and its allocation color can be flipped. When it is finished cooperating for the mutator the collector releases its mutex.
+
+When a mutator exits a (potentially) blocking section of code, it must call another function to update its thread state to `CYC_THREAD_STATE_RUNNABLE`. In addition, the function will detect if the collector cooperated for this mutator by checking if its status is `CYC_THREAD_STATE_BLOCKED_COOPERATING`. If so, the mutator waits for its mutex to be released to ensure the collector has finished cooperating. The mutator then performs a minor GC again to ensure any additional objects - such as results from the blocking code - are moved to the heap before calling `longjmp` to jump back to the beginning of its stack. Either way, the mutator now calls into its continuation and resumes normal operations.
+
+## Running the Collector
+
+Cyclone checks the amount of free memory as part of its cooperation code. A major GC cycle is started if the amount of free memory dips below a threshold. Additionally, during a slow allocation the mutator checks how many heap pages are still free. If that number is too low we trigger a new GC cycle.
+
+The goal is to run major collections infrequently while at the same time minimizing the allocation of new heap pages.
+
+# Performance Measurements
+
+A [benchmark suite](#further-reading) was used to compare performance between the previous version of Cyclone (0.8.1) and the new version with lazy sweeping.
+
+The following table lists the differences in elapsed time (seconds) between versions:
+
+Benchmark | Baseline | Lazy Sweeping | Improvement
+--------- | -------- | ------------- | ------------
+browse | 25.34 | 22.21 | 12.35%
+deriv | 17.17 | 10.83 | 36.90%
+destruc | 38.00 | 30.94 | 18.59%
+diviter | 8.57 | 6.05 | 29.35%
+divrec | 17.98 | 14.49 | 19.46%
+puzzle | 46.97 | 44.97 | 4.25%
+triangl | 26.20 | 25.35 | 3.23%
+tak | 18.73 | 18.36 | 1.99%
+takl | 14.42 | 11.30 | 21.64%
+ntakl | 15.32 | 11.22 | 26.74%
+cpstak | 21.09 | 20.92 | 0.80%
+ctak | 2.78 | 2.77 | 0.28%
+fib | 41.26 | 41.05 | 0.51%
+fibc | 3.52 | 3.47 | 1.37%
+fibfp | 9.56 | 9.57 | -0.12%
+sum | 30.28 | 30.29 | -0.02%
+sumfp | 11.55 | 11.53 | 0.23%
+fft | 21.19 | 17.25 | 18.57%
+mbrot | 16.84 | 15.27 | 9.34%
+mbrotZ | 23.35 | 22.88 | 2.01%
+nucleic | 8.29 | 7.91 | 4.56%
+pi | 0.13 | 0.13 | 1.90%
+pnpoly | 43.64 | 41.80 | 4.22%
+ray | 9.13 | 9.12 | 0.05%
+simplex | 53.26 | 42.60 | 20.02%
+ack | 75.78 | 50.64 | 33.18%
+array1 | 30.84 | 30.65 | 0.60%
+string | 0.28 | 0.26 | 6.91%
+sum1 | 1.01 | 1.00 | 1.23%
+cat | 22.05 | 22.42 | -1.69%
+tail | 1.04 | 0.99 | 4.56%
+wc | 14.46 | 14.75 | -2.07%
+read1 | 3.61 | 3.20 | 11.31%
+conform | 40.67 | 34.00 | 16.40%
+dynamic | 33.84 | 27.61 | 18.41%
+earley | 31.49 | 26.84 | 14.78%
+graphs | 64.84 | 55.22 | 14.84%
+lattice | 84.57 | 68.93 | 18.50%
+matrix | 61.07 | 48.46 | 20.64%
+maze | 23.02 | 18.46 | 19.79%
+mazefun | 23.73 | 20.74 | 12.61%
+nqueens | 47.92 | 45.18 | 5.71%
+paraffins | 15.21 | 10.76 | 29.28%
+parsing | 39.50 | 38.55 | 2.41%
+peval | 32.11 | 27.72 | 13.67%
+primes | 18.79 | 12.83 | 31.74%
+quicksort | 56.64 | 48.13 | 15.03%
+scheme | 23.32 | 21.39 | 8.30%
+slatex | 9.74 | 8.14 | 16.37%
+chudnovsky | 0.09 | 0.09 | 1.79%
+nboyer | 13.80 | 11.84 | 14.24%
+sboyer | 11.90 | 12.09 | -1.60%
+gcbench | 37.12 | 32.37 | 12.79%
+mperm | 49.94 | 39.97 | 19.95%
+equal | 0.74 | 0.70 | 4.43%
+bv2string | 7.54 | 7.62 | -1.00%
+
+This data is illustrated in the following chart:
+
+<img src="images/benchmarks/lazy-sweep-benchmark-times.png" alt="Chart of Results">
+
+Here is an overall summary:
+
+Statistic | Benchmark | Result
+--------- | --------- | ------
+Overall Improvement | N/A |  13.36%
+Average Speedup     | N/A |  10.74%
+Maximum Speedup     | deriv |  36.90%
+Minimum Speedup     | wc |  -2.07%
+
+Overall we achieve an average speedup of 10.74% with lazy sweeping. That said there are a wide range of performance impacts across the whole benchmark suite. 
+
+Those benchmarks with the biggest speedups are likely those that are generating the most garbage. For example `ack` frequently invokes GC and most of the heap is freed during each GC cycle - this benchmark benefits greatly from lazy sweeping. Alternatively `wc` - which did not realize a speedup - spends most of its time running in a tight loop, invokes GC infrequently, and after a GC cycle there are many live objects left on the heap. 
+
+By all accounts lazy sweeping is a great win for Cyclone and has exceeded performance expectations. Though there is a slight performance overhead that affects some programs the overall performance improvement across a wide range of programs more than compensates. 
+
+# Conclusion
+
+[<img src="images/campfire.jpg" alt="Campfire">](#conclusion)
+
+The garbage collector is by far the most complex component of Cyclone. The primary motivation in developing it was to extend Baker's approach to support multiple native threads, which had never been done before prior to this project. Cyclone demonstrates the viability of this approach.
+
+Our GC is also positioned to potentially support state of the art GC's built on top of DLG such as Stopless, Chicken, and Clover.
+
+That said, heap memory fragmentation has not been addressed and could be an issue for long-running programs. Traditionally a compaction process is used to defragment a heap. An alternative strategy has also been suggested by Pizlo:
+
+> instead of copying objects to evacuate fragmented regions of the heap, fragmentation is instead embraced. A fragmented heap is allowed to stay fragmented, but the collector ensures that it can still satisfy allocation requests even if no large enough contiguous free region of space exists.
+
+Ultimately, a garbage collector is tricky to implement and the focus must primarily be on correctness first, with an eye towards performance.
+
+# Further Reading
+
+- [Baby's First Garbage Collector](http://journal.stuffwithstuff.com/2013/12/08/babys-first-garbage-collector/), by Bob Nystrom
+- [Chibi-Scheme](https://github.com/ashinn/chibi-scheme)
+- [CHICKEN internals: the garbage collector](http://www.more-magic.net/posts/internals-gc.html), by Peter Bex
+- [CONS Should Not CONS Its Arguments, Part II: Cheney on the M.T.A.](https://github.com/justinethier/cyclone/raw/master/docs/research-papers/CheneyMTA.pdf), by Henry Baker
+- Fragmentation Tolerant Real Time Garbage Collection (PhD Dissertation), by Filip Pizlo
+- [The Garbage Collection Handbook: The Art of Automatic Memory Management](http://gchandbook.org/), by Antony Hosking, Eliot Moss, and Richard Jones
+- Implementing an on-the-fly garbage collector for Java, by Domani et al
+- Incremental Parallel Garbage Collection, by Paul Thomas
+- Portable, Unobtrusive Garbage Collection for Multiprocessor Systems, by Damien Doligez and Georges Gonthier
+- [Introducing Riptide: WebKit's Retreating Wavefront Concurrent Garbage Collector](https://webkit.org/blog/7122/introducing-riptide-webkits-retreating-wavefront-concurrent-garbage-collector/), by Filip Pizlo
+- [Scheme Benchmarks](https://ecraven.github.io/r7rs-benchmarks/), by [ecraven](https://github.com/ecraven)
+- [The Ramsey sweep](http://people.csail.mit.edu/gregs/ll1-discuss-archive-html/msg00761.html), by Olin Shivers
+
+
+# Appendix
+
+## Terms
+- Collector - A thread running the garbage collection code. The collector is responsible for coordinating and performing most of the work for major garbage collections.
+- Continuation - With respect to the collectors, this is a function that is called to resume execution of application code. For more information see [this article on continuation passing style](https://en.wikipedia.org/wiki/Continuation-passing_style).
+- Forwarding Pointer - When a copying collector relocates an object it leaves one of these pointers behind with the object's new address.
+- Garbage Collector (GC) - A form of automatic memory management that frees memory allocated by objects that are no longer used by the program.
+- Heap - A section of memory used to store longer-lived variables. In C, heap memory is allocated using built-in functions such as `malloc`, and memory must be explicitly deallocated using `free`.
+- Mutation - A modification to an object. For example, changing a vector (array) entry.
+- Mutator - A thread running user (or "application") code; there may be more than one mutator running concurrently.
+- Read Barrier - Code that is executed before reading an object. Read barriers have a larger overhead than write barriers because object reads are much more common.
+- Root - During tracing the collector uses these objects as the starting point to find all reachable data.
+- Stack - The C call stack, where local variables are allocated and freed automatically when a function returns. Stack variables only exist until the function that created them returns, at which point the memory may be overwritten. The stack has a very limited size and undefined behavior (usually a crash) will result if that size is exceeded.
+- Sweep - A phase of garbage collection where the heap - either the whole heap or a subset - is scanned and any unused slots are made available for new allocations.
+- Tracing - A phase of garbage collection that visits and marks all live objects on the heap. This is done by starting from a set of "root" objects and iteratively following references to child objects.
+- Write Barrier - Code that is executed before writing to an object.
+
+## Code
+
+The implementation code is available here:
+
+- [`runtime.c`](../runtime.c) contains most of the runtime system, including code to perform minor GC. A good place to start would be the `GC` and `gc_minor` functions.
+- [`gc.c`](../gc.c) contains the major GC code.
+
+## Data Structures
+
+### Heap
+
+The heap is used to store all objects that survive minor GC, and consists of a linked list of pages. Each page contains a contiguous block of memory and a linked list of free chunks. When a new chunk is requested the first free chunk large enough to meet the request is found and either returned directly or carved up into a smaller chunk to return to the caller.
+
+Memory is always allocated in multiples of 32 bytes. On the one hand this helps prevent external fragmentation by allocating many objects of the same size. But on the other it incurs internal fragmentation because an object will not always fill all of its allocated memory.
+
+A separate set of heap pages is maintained by each mutator thread. Thus there is no need to lock during allocation or sweep operations.
+
+### Thread Data
+
+At runtime Cyclone passes the current continuation, number of arguments, and a thread data parameter to each compiled C function. The continuation and arguments are used by the application code to call into its next function with a result. Thread data is a structure that contains all of the necessary information to perform collections, including:
+
+- Thread state
+- Stack boundaries
+- Jump buffer
+- List of mutated objects detected by the minor GC write barrier
+- Major GC parameters - mark buffer, last read/write, etc (see next sections)
+- Call history buffer
+- Exception handler stack
+
+Each thread has its own instance of the thread data structure and its own stack (assigned by the C runtime/compiler).
+
+### Object Header
+
+Each object contains a header with the following information:
+
+- Tag - A number indicating the object type: cons, vector, string, etc.
+- Mark - The status of the object's memory.
+- Grayed - A field indicating the object has been grayed but has not been added to a mark buffer yet (see major GC sections below). This is only applicable for objects on the stack.
+
+### Mark Buffers
+
+Mark buffers are used to hold gray objects instead of explicitly marking objects gray. These mark buffers consist of fixed-size pointer arrays that are increased in size as necessary using `realloc`.  Each mutator has a reference to a mark buffer holding their gray objects. A last write variable is used to keep track of the buffer size.
+
+The collector updates the mutator's last read variable each time it marks an object from the mark buffer. Marking is finished when last read and last write are equal. The collector also maintains a single mark stack of objects that the collector has marked gray.
+
+An object on the stack cannot be added to a mark buffer because the reference may become invalid before it can be processed by the collector.
+

docs/Release-Checklist.md

@@ -7,6 +7,7 @@ Steps for making a release of Cyclone:
   - `Dockerfile`
   - `DEBIAN/control` in cyclone-bootstrap
   - `.github/workflows/Release.yml` job in cyclone-bootstrap
+  - `libs/common.sld` in cyclone winds repo
 - Update documentation, if applicable
 - Tag releases and push to Github
 - Upload release notes to `gh-pages` branch
@@ -14,3 +15,8 @@ Steps for making a release of Cyclone:
 - Update release on Homebrew (automated)
 - Update release on Dockerhub (push to bitbucket)
 - Upload new binary from cyclone-bootstrap release build to the cyclone-scheme "packages" repo
+- Update WASM hosted Cyclone
+  - Trigger CI action on the WASM repo to recompile the WASM binary: https://github.com/cyclone-scheme/wasm-terminal
+  - Download the generated `.zip` artifact
+  - Extract `terminal.js` and `terminal.wasm` and copy to the `_site` directory in the repo to update the build
+  - Optionally update year in the `terminal.html` file

docs/User-Manual.md

@@ -12,6 +12,10 @@
   - [Generated Files](#generated-files)
   - [Interpreter](#interpreter)
 - [Language Details](#language-details)
+- [Macros](#macros)
+  - [Syntax Rules](#syntax-rules)
+  - [Explicit Renaming](#explicit-renaming)
+  - [Debugging](#debugging)
 - [Multithreaded Programming](#multithreaded-programming)
   - [Thread Safety](#thread-safety)
 - [Foreign Function Interface](#foreign-function-interface)
@@ -160,6 +164,51 @@ A [R<sup>7</sup>RS Compliance Chart](Scheme-Language-Compliance.md) lists differ
 
 [API Documentation](API.md) is available for the libraries provided by Cyclone.
 
+# Macros
+
+## Syntax Rules
+
+High-level hygienic macros may be created using `syntax-rules`. This system is based on a template language specified by R<sup>7</sup>RS. The specification goes into more detail on how to work with these macros:
+
+    (define-syntax when
+      (syntax-rules  ()
+        ((when test result1 result2 ...)
+         (if test
+             (begin result1 result2 ...)))))
+
+## Explicit Renaming
+
+Alternatively a low-level explicit renaming (ER) system is provided that allows defining macros using Scheme code, in a similar manner as `defmacro`. 
+
+This macro system provides the convenience functions `(rename identifier)` to hygienically rename an identifier and `(compare identifier1 identifier2)` to compare two identifiers:
+
+    (define-syntax when
+      (er-macro-transformer
+        (lambda (exp rename compare)
+          (if (null? (cdr exp)) (error/loc "empty when" exp))
+          (if (null? (cddr exp)) (error/loc "no when body" exp))
+          `(if ,(cadr exp)
+               ((lambda () ,@(cddr exp)))))))
+
+## Debugging
+
+- From the interpreter one can use `expand` to perform macro expansion on the given expression:
+
+      cyclone> (expand '(when #t (+ 1 2 3)))
+      (if #t ((lambda () (+ 1 2 3))) )
+
+- Alternatively when developing an ER macro, since its just a Scheme function, the macro can be defined as a `lambda` and passed a quoted expression to debug:
+
+      (pretty-print
+        ((lambda (exp rename compare)
+           (if (null? (cdr exp)) (error/loc "empty when" exp))
+           (if (null? (cddr exp)) (error/loc "no when body" exp))
+           `(if ,(cadr exp)
+                ((lambda () ,@(cddr exp)))))
+        '(when #t  (write 1) (write 2)) #f #f))
+
+- Finally, a Scheme file may be compiled with the `-t` option to write all of the intermediate transformations - including macro expansions - out to the corresponding `.c` file.
+
 # Multithreaded Programming
 
 ## Overview

docs/api/cyclone/foreign.md

@@ -2,12 +2,15 @@
 
 The `(cyclone foreign)` provides a convenient interface for integrating with C code. It is based in concept on the `(chicken foreign)` module from CHICKEN Scheme. Similarly to that module, this library manipulates the C code directly before it is compiled to a native binary. It is not possible to call these forms at runtime.
 
-# Overview
+# API
 
 - [`c-code`](#c-code)
 - [`c-value`](#c-value)
 - [`c-define`](#c-define)
 - [`c-define-type`](#c-define-type)
+- [`opaque?`](#opaque)
+- [`opaque-null?`](#opaque-null)
+- [`make-opaque`](#make-opaque)
 
 ## c-code
 
@@ -51,6 +54,23 @@ EG, to define a type that consists of integers in Scheme and strings in C:
 
     (c-define-type string-as-integer string number->string string->number)
 
+## opaque?
+
+    (opaque? obj)
+
+Predicate to determine if `obj` is a C Opaque object.
+
+## opaque-null?
+
+    (opaque-null? obj)
+
+Predicate to determine if `obj` is a C Opaque object that contains `NULL`.
+
+## make-opaque
+
+    (make-opaque)
+
+Create a C Opaque object containing `NULL`.
 
 # Type Specifiers
 

docs/api/scheme/cyclone/libraries.md

@@ -182,7 +182,24 @@ libraries can be initialized properly in sequence.
 
     (lib:get-dep-list imports)
 
-Given a list of alists `(library-name . imports)`, resolve all of the dependencies and return an ordered list of library names such that each library is encounted after the libraries it imports (IE, it's dependencies).
+Given a list of alists `(library-name . imports)`, resolve all of the dependencies and return an ordered list of library names such that each library is encounted after the libraries it imports (IE, it's dependencies). For example:
+
+    (lib:get-dep-list `(
+      ((srfi 69) (scheme base) (scheme char))
+      ((scheme base) (scheme cyclone common))
+      ((scheme cyclone common))
+      ((scheme char) (scheme base))
+      ((scheme cyclone hashset) (scheme base) (scheme write))
+      ((scheme write) (scheme base))
+      ((scheme cyclone primitives) (scheme base) (scheme cyclone hashset) (srfi 69))
+      ((scheme process-context))
+      ((scheme cyclone libraries) (scheme base) (scheme read) (scheme process-context) (scheme cyclone util))
+      ((scheme read) (scheme base) (scheme cyclone common) (scheme cyclone util) (scheme char))
+      ((scheme cyclone util) (scheme base) (scheme char))
+      ((scheme eval) (scheme cyclone util) (scheme cyclone libraries) (scheme cyclone primitives) (scheme base) (scheme file) (scheme read))
+      ((scheme file) (scheme base))
+      ((scheme lazy) (scheme base))
+    ))
 
 # lib:imports->idb
 

docs/api/scheme/cyclone/primitives.md

@@ -15,7 +15,7 @@ The `(scheme cyclone primitives)` library contains information about Cyclone's s
 - [`prim:cont?`](#primcont)
 - [`prim:cont/no-args?`](#primcontno-args)
 - [`prim:arg-count?`](#primarg-count)
-- [`prim:allocates-object?)`](#primallocates-object)
+- [`prim:allocates-object?`](#primallocates-object)
 
 # prim?
 
@@ -85,7 +85,7 @@ Is `sym` a primitive function that passes a continuation or thread data but has
 
 Should the compiler pass an integer arg count as the function's first parameter?
 
-# prim:allocates-object?)
+# prim:allocates-object?
 
     (prim:allocates-object? sym use-alloca?)
 

docs/api/scheme/cyclone/transforms.md

@@ -43,8 +43,6 @@ The `(scheme cyclone transforms)` library performs Scheme-to-Scheme transformati
 - [`env-make->id              `](#env-make-id)
 - [`env-make->values          `](#env-make-values)
 - [`env-make?                 `](#env-make)
-- [`expand                    `](#expand)
-- [`expand-lambda-body        `](#expand-lambda-body)
 - [`filter-unused-variables   `](#filter-unused-variables)
 - [`free-vars                 `](#free-vars)
 - [`get-macros                `](#get-macros)
@@ -163,10 +161,6 @@ The `(scheme cyclone transforms)` library performs Scheme-to-Scheme transformati
 
 # env-make? 
 
-# expand 
-
-# expand-lambda-body
-
 # filter-unused-variables 
 
 # free-vars 

docs/api/scheme/eval.md

@@ -7,6 +7,7 @@ For more information see the [R<sup>7</sup>RS Scheme Specification](../../r7rs.p
 - [`eval`](#eval)
 - [`create-environment`](#create-environment)
 - [`setup-environment`](#setup-environment)
+- [`expand`](#expand)
 
 # eval
 
@@ -30,3 +31,14 @@ A non-standard function to create a new environment on top of the default one.
     (setup-environment)
 
 A non-standard function to initialize a new global environment.
+
+# expand
+
+    (expand expr [[environment] [rename-environment]])
+
+Perform macro expansion on `expr` and return the resulting expression.
+
+`environment` may be optionally passed as the current environment. 
+
+`rename-environment` is an optional argument of an environment containing variables renamed directly by macros. This would generally be an empty environment when using this function for macro debugging.
+

docs/api/srfi/18.md

@@ -92,9 +92,9 @@ The current thread exits the running state as if its quantum had expired.
 
 # thread-terminate!
 
-    (thread-terminate!)
+    (thread-terminate! thread)
 
-Immediately abort the current thread.
+Immediately abort the given thread.
 
 # thread-join!
 

ffi.c

@@ -13,14 +13,15 @@
 #include <ck_pr.h>
 #include <unistd.h>
 
-void *Cyc_init_thread(object thread_and_thunk, int argc, object *args);
+void *Cyc_init_thread(object thread_and_thunk, int argc, object * args);
 
 /**
  * After the Scheme call finishes, we wind down the GC / Heap used
  * for the call and perform a minor GC to ensure any returned object
  * is on the heap and safe to use.
  */
-static void Cyc_return_from_scm_call(void *data, object _, int argc, object *args)
+static void Cyc_return_from_scm_call(void *data, object _, int argc,
+                                     object * args)
 {
   gc_thread_data *thd = data;
   object result = args[0];
@@ -41,12 +42,13 @@ static void Cyc_return_from_scm_call(void *data, object _, int argc, object *arg
  * We store results and longjmp back to where we started, at the
  * bottom of the trampoline (we only jump once).
  */
-static void Cyc_after_scm_call(void *data, object _, int argc, object *args)
+static void Cyc_after_scm_call(void *data, object _, int argc, object * args)
 {
   gc_thread_data *thd = data;
   object result = args[0];
   mclosure0(clo, Cyc_return_from_scm_call);
-  object buf[1]; buf[0] = result;
+  object buf[1];
+  buf[0] = result;
   GC(thd, &clo, buf, 1);
 }
 
@@ -58,7 +60,8 @@ static void Cyc_after_scm_call(void *data, object _, int argc, object *args)
  * can do anything "normal" Scheme code does, and any returned
  * objects will be on the heap and available for use by the caller.
  */
-object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *args)
+object Cyc_scm_call(gc_thread_data * parent_thd, object fnc, int argc,
+                    object * args)
 {
   jmp_buf l;
   gc_thread_data local;
@@ -72,7 +75,7 @@ object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *ar
 
   make_c_opaque(co_parent_thd, parent_thd);
   make_c_opaque(co_this_thd, &local);
-  mclosure0(after, (function_type)Cyc_after_scm_call); 
+  mclosure0(after, (function_type) Cyc_after_scm_call);
 
   make_empty_vector(vec);
   vec.num_elements = 7;
@@ -105,7 +108,8 @@ object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *ar
  * We store results and longjmp back to where we started, at the
  * bottom of the trampoline (we only jump once).
  */
-static void no_gc_after_call_scm(gc_thread_data *thd, object _, int argc, object *args)
+static void no_gc_after_call_scm(gc_thread_data * thd, object _, int argc,
+                                 object * args)
 {
   object result = args[0];
   thd->gc_cont = result;
@@ -115,11 +119,11 @@ static void no_gc_after_call_scm(gc_thread_data *thd, object _, int argc, object
 /**
  * Call into Scheme function
  */
-static void no_gc_call_scm(gc_thread_data *thd, object fnc, object obj)
+static void no_gc_call_scm(gc_thread_data * thd, object fnc, object obj)
 {
-  mclosure0(after, (function_type)no_gc_after_call_scm); 
+  mclosure0(after, (function_type) no_gc_after_call_scm);
-  object buf[2] = {&after, obj};
+  object buf[2] = { &after, obj };
-  ((closure)fnc)->fn(thd, fnc, 2, buf);
+  ((closure) fnc)->fn(thd, fnc, 2, buf);
 }
 
 /**
@@ -134,12 +138,12 @@ static void no_gc_call_scm(gc_thread_data *thd, object fnc, object obj)
  * or re-allocated (EG: malloc) before returning it
  * to the C layer.
  */
-object Cyc_scm_call_no_gc(gc_thread_data *parent_thd, object fnc, object arg)
+object Cyc_scm_call_no_gc(gc_thread_data * parent_thd, object fnc, object arg)
 {
   long stack_size = 100000;
   char *stack_base = (char *)&stack_size;
   char *stack_traces[MAX_STACK_TRACES];
-  gc_thread_data thd = {0};
+  gc_thread_data thd = { 0 };
   jmp_buf jmp;
   thd.jmp_start = &jmp;
   thd.stack_start = stack_base;
@@ -184,5 +188,5 @@ object Cyc_scm_call_no_gc(gc_thread_data *parent_thd, object fnc, object arg)
     no_gc_call_scm(&thd, fnc, arg);
   }
 
-  return(thd.gc_cont);
+  return (thd.gc_cont);
 }

guix/cyclone.scm

@@ -0,0 +1,87 @@
+;; cyclone.scm
+(use-modules
+ (gnu packages)
+ (gnu packages multiprecision)
+ ((guix licenses)
+  #:select (gpl2 gpl2+ lgpl2.0+ lgpl2.1 lgpl2.1+ lgpl3+ asl2.0
+                 bsd-0 bsd-3 cc-by-sa4.0 non-copyleft expat
+                 public-domain))
+ (guix gexp)
+ (guix packages)
+ (guix download)
+ (guix git-download)
+ (guix utils)
+ (guix build-system gnu)
+ (gnu packages c))
+
+(define-public cyclone
+  (package
+    (name "cyclone")
+    (version "0.36.0")
+    (source (origin
+              (method git-fetch)
+              (uri (git-reference
+                    (url "https://github.com/justinethier/cyclone-bootstrap")
+                    (commit (string-append "v" version))))
+              (sha256
+               (base32
+                "0fv0mnrn5shbx77383f4mbkvc4i9yyj1bjm3dfyhipnaqapbhqpi"))
+              (file-name (git-file-name name version))))
+    (build-system gnu-build-system)
+    (arguments
+     (list
+      #:test-target "test"
+      #:make-flags #~(list (string-append
+                            "CC=" #$(this-package-input "gcc-toolchain")
+                            "/bin/gcc")
+                           (string-append "PREFIX=" #$output)
+                           (string-append "COMP_INCDIRS=-I$(PREFIX)/include -I"
+                                          #$(this-package-input "gcc-toolchain")
+                                          "/include")
+                           (string-append
+                            "COMP_LIBDIRS=-L$(PREFIX)/lib "
+                            "-Wl,-rpath=" #$(this-package-input "ck") "/lib "
+                            "-L" #$(this-package-input "ck") "/lib "
+                            "-Wl,-rpath=" #$(this-package-input "libtommath")
+                            "/lib "
+                            "-L" #$(this-package-input "libtommath") "/lib "
+                            "-Wl,-rpath="
+                            #$(this-package-input "gcc-toolchain") "/lib "
+                            "-L" #$(this-package-input "gcc-toolchain")
+                            "/lib"))
+      #:phases #~(modify-phases %standard-phases
+                   (delete 'configure) ; no configure script
+                   (add-before 'build 'replace-cyclonebn
+                     (lambda* (#:key outputs #:allow-other-keys)
+                       (substitute* "Makefile"
+                         (("-lcyclonebn")
+                          "-ltommath")
+                         (("^[$][(]CYC_BN_LIB[)] :")
+                          "dont-build-cyclonebn :")
+                         (("^	[$][(]INSTALL[)] .* [$][(]CYC_BN_LIB[)].*$")
+                          "#dont-install-cyclonebn\n")
+                         (("[$][(]CYC_BN_LIB[)]")
+                          ""))
+                       (substitute* "Makefile.config"
+                         (("-lcyclonebn")
+                          "-ltommath"))))
+                   (add-after 'install 'wrap
+                     (lambda _
+                       (wrap-program (string-append #$output "/bin/cyclone")
+                         `("LIBRARY_PATH" ":" prefix
+                           ,(list (string-append
+                                   #$(this-package-input "gcc-toolchain")
+                                   "/lib")))))))))
+    (inputs (list ck libtommath (module-ref (resolve-interface
+                                             '(gnu packages commencement))
+                                            'gcc-toolchain)))
+    (home-page "https://justinethier.github.io/cyclone/")
+    (synopsis "R7RS Scheme to C compiler")
+    (description
+     "Cyclone Scheme is a R7RS Scheme-to-C compiler that uses a variant of
+Cheney on the MTA to implement full tail recursion, continuations, and
+generational garbage collection.  It also includes the Winds package manager
+for installing Cyclone libraries.")
+    (license expat)))
+
+cyclone

hashset.c

@@ -86,7 +86,6 @@ static void maybe_rehash(hashset_t set)
   size_t *old_items;
   size_t old_capacity, ii;
 
-
   if (set->nitems + set->n_deleted_items >= (double)set->capacity * 0.85) {
     old_items = set->items;
     old_capacity = set->capacity;
@@ -154,4 +153,3 @@ void hashset_to_array(hashset_t set, void **items)
     }
   }
 }
-

include/cyclone/bignum.h

@@ -9,20 +9,20 @@
 #include <limits.h>
 
 #ifdef LTM_NO_FILE
-#  warning LTM_NO_FILE has been deprecated, use MP_NO_FILE.
+#warning LTM_NO_FILE has been deprecated, use MP_NO_FILE.
-#  define MP_NO_FILE
+#define MP_NO_FILE
 #endif
 
 #ifndef MP_NO_FILE
-#  include <stdio.h>
+#include <stdio.h>
 #endif
 
 #ifdef MP_8BIT
-#  ifdef _MSC_VER
+#ifdef _MSC_VER
-#    pragma message("8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version.")
+#pragma message("8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version.")
-#  else
+#else
-#    warning "8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version."
+#warning "8-bit (MP_8BIT) support is deprecated and will be dropped completely in the next version."
-#  endif
+#endif
 #endif
 
 #ifdef __cplusplus
@@ -31,7 +31,7 @@ extern "C" {
 
 /* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
 #if (defined(_MSC_VER) || defined(__LLP64__) || defined(__e2k__) || defined(__LCC__)) && !defined(MP_64BIT)
-#   define MP_32BIT
+#define MP_32BIT
 #endif
 
 /* detect 64-bit mode if possible */
@@ -41,19 +41,19 @@ extern "C" {
     defined(__sparcv9) || defined(__sparc_v9__) || defined(__sparc64__) || \
     defined(__ia64) || defined(__ia64__) || defined(__itanium__) || defined(_M_IA64) || \
     defined(__LP64__) || defined(_LP64) || defined(__64BIT__)
-#   if !(defined(MP_64BIT) || defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
+#if !(defined(MP_64BIT) || defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
-#      if defined(__GNUC__) && !defined(__hppa)
+#if defined(__GNUC__) && !defined(__hppa)
 /* we support 128bit integers only via: __attribute__((mode(TI))) */
-#         define MP_64BIT
+#define MP_64BIT
-#      else
+#else
 /* otherwise we fall back to MP_32BIT even on 64bit platforms */
-#         define MP_32BIT
+#define MP_32BIT
-#      endif
+#endif
-#   endif
+#endif
 #endif
 
 #ifdef MP_DIGIT_BIT
-#   error Defining MP_DIGIT_BIT is disallowed, use MP_8/16/31/32/64BIT
+#error Defining MP_DIGIT_BIT is disallowed, use MP_8/16/31/32/64BIT
 #endif
 
 /* some default configurations.
@@ -66,36 +66,36 @@ extern "C" {
  */
 
 #ifdef MP_8BIT
-typedef uint8_t              mp_digit;
+  typedef uint8_t mp_digit;
-typedef uint16_t             private_mp_word;
+  typedef uint16_t private_mp_word;
-#   define MP_DIGIT_BIT 7
+#define MP_DIGIT_BIT 7
 #elif defined(MP_16BIT)
-typedef uint16_t             mp_digit;
+  typedef uint16_t mp_digit;
-typedef uint32_t             private_mp_word;
+  typedef uint32_t private_mp_word;
-#   define MP_DIGIT_BIT 15
+#define MP_DIGIT_BIT 15
 #elif defined(MP_64BIT)
 /* for GCC only on supported platforms */
-typedef uint64_t mp_digit;
+  typedef uint64_t mp_digit;
 #if defined(__GNUC__)
-typedef unsigned long        private_mp_word __attribute__((mode(TI)));
+  typedef unsigned long private_mp_word __attribute__((mode(TI)));
 #endif
-#   define MP_DIGIT_BIT 60
+#define MP_DIGIT_BIT 60
 #else
-typedef uint32_t             mp_digit;
+  typedef uint32_t mp_digit;
-typedef uint64_t             private_mp_word;
+  typedef uint64_t private_mp_word;
-#   ifdef MP_31BIT
+#ifdef MP_31BIT
 /*
  * This is an extension that uses 31-bit digits.
  * Please be aware that not all functions support this size, especially s_mp_mul_digs_fast
  * will be reduced to work on small numbers only:
  * Up to 8 limbs, 248 bits instead of up to 512 limbs, 15872 bits with MP_28BIT.
  */
-#      define MP_DIGIT_BIT 31
+#define MP_DIGIT_BIT 31
-#   else
+#else
 /* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
-#      define MP_DIGIT_BIT 28
+#define MP_DIGIT_BIT 28
-#      define MP_28BIT
+#define MP_28BIT
-#   endif
+#endif
 #endif
 
 /* mp_word is a private type */
@@ -116,48 +116,48 @@ typedef uint64_t             private_mp_word;
 #define LTM_PRIME_2MSB_ON  (MP_DEPRECATED_PRAGMA("LTM_PRIME_2MSB_ON has been deprecated, use MP_PRIME_2MSB_ON") MP_PRIME_2MSB_ON)
 
 #ifdef MP_USE_ENUMS
-typedef enum {
+  typedef enum {
     MP_ZPOS = 0,                /* positive */
     MP_NEG = 1                  /* negative */
-} mp_sign;
+  } mp_sign;
-typedef enum {
+  typedef enum {
     MP_LT = -1,                 /* less than */
     MP_EQ = 0,                  /* equal */
     MP_GT = 1                   /* greater than */
-} mp_ord;
+  } mp_ord;
-typedef enum {
+  typedef enum {
     MP_NO = 0,
     MP_YES = 1
-} mp_bool;
+  } mp_bool;
-typedef enum {
+  typedef enum {
     MP_OKAY = 0,                /* no error */
     MP_ERR = -1,                /* unknown error */
     MP_MEM = -2,                /* out of mem */
     MP_VAL = -3,                /* invalid input */
     MP_ITER = -4,               /* maximum iterations reached */
     MP_BUF = -5                 /* buffer overflow, supplied buffer too small */
-} mp_err;
+  } mp_err;
-typedef enum {
+  typedef enum {
     MP_LSB_FIRST = -1,
     MP_MSB_FIRST = 1
-} mp_order;
+  } mp_order;
-typedef enum {
+  typedef enum {
     MP_LITTLE_ENDIAN = -1,
     MP_NATIVE_ENDIAN = 0,
     MP_BIG_ENDIAN = 1
-} mp_endian;
+  } mp_endian;
 #else
-typedef int mp_sign;
+  typedef int mp_sign;
 #define MP_ZPOS       0         /* positive integer */
 #define MP_NEG        1         /* negative */
-typedef int mp_ord;
+  typedef int mp_ord;
 #define MP_LT        -1         /* less than */
 #define MP_EQ         0         /* equal to */
 #define MP_GT         1         /* greater than */
-typedef int mp_bool;
+  typedef int mp_bool;
 #define MP_YES        1
 #define MP_NO         0
-typedef int mp_err;
+  typedef int mp_err;
 #define MP_OKAY       0         /* no error */
 #define MP_ERR        -1        /* unknown error */
 #define MP_MEM        -2        /* out of mem */
@@ -165,10 +165,10 @@ typedef int mp_err;
 #define MP_RANGE      (MP_DEPRECATED_PRAGMA("MP_RANGE has been deprecated in favor of MP_VAL") MP_VAL)
 #define MP_ITER       -4        /* maximum iterations reached */
 #define MP_BUF        -5        /* buffer overflow, supplied buffer too small */
-typedef int mp_order;
+  typedef int mp_order;
 #define MP_LSB_FIRST -1
 #define MP_MSB_FIRST  1
-typedef int mp_endian;
+  typedef int mp_endian;
 #define MP_LITTLE_ENDIAN  -1
 #define MP_NATIVE_ENDIAN  0
 #define MP_BIG_ENDIAN     1
@@ -177,11 +177,8 @@ typedef int mp_endian;
 /* tunable cutoffs */
 
 #ifndef MP_FIXED_CUTOFFS
-extern int
+  extern int
-KARATSUBA_MUL_CUTOFF,
+   KARATSUBA_MUL_CUTOFF, KARATSUBA_SQR_CUTOFF, TOOM_MUL_CUTOFF, TOOM_SQR_CUTOFF;
-KARATSUBA_SQR_CUTOFF,
-TOOM_MUL_CUTOFF,
-TOOM_SQR_CUTOFF;
 #endif
 
 /* define this to use lower memory usage routines (exptmods mostly) */
@@ -189,14 +186,14 @@ TOOM_SQR_CUTOFF;
 
 /* default precision */
 #ifndef MP_PREC
-#   ifndef MP_LOW_MEM
+#ifndef MP_LOW_MEM
-#      define PRIVATE_MP_PREC 32        /* default digits of precision */
+#define PRIVATE_MP_PREC 32      /* default digits of precision */
-#   elif defined(MP_8BIT)
+#elif defined(MP_8BIT)
-#      define PRIVATE_MP_PREC 16        /* default digits of precision */
+#define PRIVATE_MP_PREC 16      /* default digits of precision */
-#   else
+#else
-#      define PRIVATE_MP_PREC 8         /* default digits of precision */
+#define PRIVATE_MP_PREC 8       /* default digits of precision */
-#   endif
+#endif
-#   define MP_PREC (MP_DEPRECATED_PRAGMA("MP_PREC is an internal macro") PRIVATE_MP_PREC)
+#define MP_PREC (MP_DEPRECATED_PRAGMA("MP_PREC is an internal macro") PRIVATE_MP_PREC)
 #endif
 
 /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
@@ -204,9 +201,9 @@ TOOM_SQR_CUTOFF;
 #define MP_WARRAY (MP_DEPRECATED_PRAGMA("MP_WARRAY is an internal macro") PRIVATE_MP_WARRAY)
 
 #if defined(__GNUC__) && __GNUC__ >= 4
-#   define MP_NULL_TERMINATED __attribute__((sentinel))
+#define MP_NULL_TERMINATED __attribute__((sentinel))
 #else
-#   define MP_NULL_TERMINATED
+#define MP_NULL_TERMINATED
 #endif
 
 /*
@@ -225,23 +222,23 @@ TOOM_SQR_CUTOFF;
  * tommath.h, disabling the warnings.
  */
 #ifndef MP_WUR
-#  if defined(__GNUC__) && __GNUC__ >= 4
+#if defined(__GNUC__) && __GNUC__ >= 4
-#     define MP_WUR __attribute__((warn_unused_result))
+#define MP_WUR __attribute__((warn_unused_result))
-#  else
+#else
-#     define MP_WUR
+#define MP_WUR
-#  endif
+#endif
 #endif
 
 #if defined(__GNUC__) && (__GNUC__ * 100 + __GNUC_MINOR__ >= 405)
-#  define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
+#define MP_DEPRECATED(x) __attribute__((deprecated("replaced by " #x)))
-#  define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
+#define PRIVATE_MP_DEPRECATED_PRAGMA(s) _Pragma(#s)
-#  define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
+#define MP_DEPRECATED_PRAGMA(s) PRIVATE_MP_DEPRECATED_PRAGMA(GCC warning s)
 #elif defined(_MSC_VER) && _MSC_VER >= 1500
-#  define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
+#define MP_DEPRECATED(x) __declspec(deprecated("replaced by " #x))
-#  define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
+#define MP_DEPRECATED_PRAGMA(s) __pragma(message(s))
 #else
-#  define MP_DEPRECATED(s)
+#define MP_DEPRECATED(s)
-#  define MP_DEPRECATED_PRAGMA(s)
+#define MP_DEPRECATED_PRAGMA(s)
 #endif
 
 #define DIGIT_BIT   (MP_DEPRECATED_PRAGMA("DIGIT_BIT macro is deprecated, MP_DIGIT_BIT instead") MP_DIGIT_BIT)
@@ -250,193 +247,204 @@ TOOM_SQR_CUTOFF;
 #define SIGN(m)     (MP_DEPRECATED_PRAGMA("SIGN macro is deprecated, use z->sign instead") (m)->sign)
 
 /* the infamous mp_int structure */
-typedef struct  {
+  typedef struct {
     int used, alloc;
     mp_sign sign;
     mp_digit *dp;
-} mp_int;
+  } mp_int;
 
 /* callback for mp_prime_random, should fill dst with random bytes and return how many read [upto len] */
-typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat);
+  typedef int private_mp_prime_callback(unsigned char *dst, int len, void *dat);
-typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source) ltm_prime_callback;
+  typedef private_mp_prime_callback MP_DEPRECATED(mp_rand_source)
+   ltm_prime_callback;
 
 /* error code to char* string */
-const char *mp_error_to_string(mp_err code) MP_WUR;
+  const char *mp_error_to_string(mp_err code) MP_WUR;
 
 /* ---> init and deinit bignum functions <--- */
 /* init a bignum */
-mp_err mp_init(mp_int *a) MP_WUR;
+  mp_err mp_init(mp_int * a) MP_WUR;
 
 /* free a bignum */
-void mp_clear(mp_int *a);
+  void mp_clear(mp_int * a);
 
 /* init a null terminated series of arguments */
-mp_err mp_init_multi(mp_int *mp, ...) MP_NULL_TERMINATED MP_WUR;
+  mp_err mp_init_multi(mp_int * mp, ...) MP_NULL_TERMINATED MP_WUR;
 
 /* clear a null terminated series of arguments */
-void mp_clear_multi(mp_int *mp, ...) MP_NULL_TERMINATED;
+  void mp_clear_multi(mp_int * mp, ...) MP_NULL_TERMINATED;
 
 /* exchange two ints */
-void mp_exch(mp_int *a, mp_int *b);
+  void mp_exch(mp_int * a, mp_int * b);
 
 /* shrink ram required for a bignum */
-mp_err mp_shrink(mp_int *a) MP_WUR;
+  mp_err mp_shrink(mp_int * a) MP_WUR;
 
 /* grow an int to a given size */
-mp_err mp_grow(mp_int *a, int size) MP_WUR;
+  mp_err mp_grow(mp_int * a, int size) MP_WUR;
 
 /* init to a given number of digits */
-mp_err mp_init_size(mp_int *a, int size) MP_WUR;
+  mp_err mp_init_size(mp_int * a, int size) MP_WUR;
 
 /* ---> Basic Manipulations <--- */
 #define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
-mp_bool mp_iseven(const mp_int *a) MP_WUR;
+  mp_bool mp_iseven(const mp_int * a) MP_WUR;
-mp_bool mp_isodd(const mp_int *a) MP_WUR;
+  mp_bool mp_isodd(const mp_int * a) MP_WUR;
 #define mp_isneg(a)  (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)
 
 /* set to zero */
-void mp_zero(mp_int *a);
+  void mp_zero(mp_int * a);
 
 /* get and set doubles */
-double mp_get_double(const mp_int *a) MP_WUR;
+  double mp_get_double(const mp_int * a) MP_WUR;
-mp_err mp_set_double(mp_int *a, double b) MP_WUR;
+  mp_err mp_set_double(mp_int * a, double b) MP_WUR;
 
 /* get integer, set integer and init with integer (int32_t) */
-int32_t mp_get_i32(const mp_int *a) MP_WUR;
+  int32_t mp_get_i32(const mp_int * a) MP_WUR;
-void mp_set_i32(mp_int *a, int32_t b);
+  void mp_set_i32(mp_int * a, int32_t b);
-mp_err mp_init_i32(mp_int *a, int32_t b) MP_WUR;
+  mp_err mp_init_i32(mp_int * a, int32_t b) MP_WUR;
 
 /* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint32_t) */
 #define mp_get_u32(a) ((uint32_t)mp_get_i32(a))
-void mp_set_u32(mp_int *a, uint32_t b);
+  void mp_set_u32(mp_int * a, uint32_t b);
-mp_err mp_init_u32(mp_int *a, uint32_t b) MP_WUR;
+  mp_err mp_init_u32(mp_int * a, uint32_t b) MP_WUR;
 
 /* get integer, set integer and init with integer (int64_t) */
-int64_t mp_get_i64(const mp_int *a) MP_WUR;
+  int64_t mp_get_i64(const mp_int * a) MP_WUR;
-void mp_set_i64(mp_int *a, int64_t b);
+  void mp_set_i64(mp_int * a, int64_t b);
-mp_err mp_init_i64(mp_int *a, int64_t b) MP_WUR;
+  mp_err mp_init_i64(mp_int * a, int64_t b) MP_WUR;
 
 /* get integer, set integer and init with integer, behaves like two complement for negative numbers (uint64_t) */
 #define mp_get_u64(a) ((uint64_t)mp_get_i64(a))
-void mp_set_u64(mp_int *a, uint64_t b);
+  void mp_set_u64(mp_int * a, uint64_t b);
-mp_err mp_init_u64(mp_int *a, uint64_t b) MP_WUR;
+  mp_err mp_init_u64(mp_int * a, uint64_t b) MP_WUR;
 
 /* get magnitude */
-uint32_t mp_get_mag_u32(const mp_int *a) MP_WUR;
+  uint32_t mp_get_mag_u32(const mp_int * a) MP_WUR;
-uint64_t mp_get_mag_u64(const mp_int *a) MP_WUR;
+  uint64_t mp_get_mag_u64(const mp_int * a) MP_WUR;
-unsigned long mp_get_mag_ul(const mp_int *a) MP_WUR;
+  unsigned long mp_get_mag_ul(const mp_int * a) MP_WUR;
-unsigned long long mp_get_mag_ull(const mp_int *a) MP_WUR;
+  unsigned long long mp_get_mag_ull(const mp_int * a) MP_WUR;
 
 /* get integer, set integer (long) */
-long mp_get_l(const mp_int *a) MP_WUR;
+  long mp_get_l(const mp_int * a) MP_WUR;
-void mp_set_l(mp_int *a, long b);
+  void mp_set_l(mp_int * a, long b);
-mp_err mp_init_l(mp_int *a, long b) MP_WUR;
+  mp_err mp_init_l(mp_int * a, long b) MP_WUR;
 
 /* get integer, set integer (unsigned long) */
 #define mp_get_ul(a) ((unsigned long)mp_get_l(a))
-void mp_set_ul(mp_int *a, unsigned long b);
+  void mp_set_ul(mp_int * a, unsigned long b);
-mp_err mp_init_ul(mp_int *a, unsigned long b) MP_WUR;
+  mp_err mp_init_ul(mp_int * a, unsigned long b) MP_WUR;
 
 /* get integer, set integer (long long) */
-long long mp_get_ll(const mp_int *a) MP_WUR;
+  long long mp_get_ll(const mp_int * a) MP_WUR;
-void mp_set_ll(mp_int *a, long long b);
+  void mp_set_ll(mp_int * a, long long b);
-mp_err mp_init_ll(mp_int *a, long long b) MP_WUR;
+  mp_err mp_init_ll(mp_int * a, long long b) MP_WUR;
 
 /* get integer, set integer (unsigned long long) */
 #define mp_get_ull(a) ((unsigned long long)mp_get_ll(a))
-void mp_set_ull(mp_int *a, unsigned long long b);
+  void mp_set_ull(mp_int * a, unsigned long long b);
-mp_err mp_init_ull(mp_int *a, unsigned long long b) MP_WUR;
+  mp_err mp_init_ull(mp_int * a, unsigned long long b) MP_WUR;
 
 /* set to single unsigned digit, up to MP_DIGIT_MAX */
-void mp_set(mp_int *a, mp_digit b);
+  void mp_set(mp_int * a, mp_digit b);
-mp_err mp_init_set(mp_int *a, mp_digit b) MP_WUR;
+  mp_err mp_init_set(mp_int * a, mp_digit b) MP_WUR;
 
 /* get integer, set integer and init with integer (deprecated) */
-MP_DEPRECATED(mp_get_mag_u32/mp_get_u32) unsigned long mp_get_int(const mp_int *a) MP_WUR;
+   MP_DEPRECATED(mp_get_mag_u32 /
-MP_DEPRECATED(mp_get_mag_ul/mp_get_ul) unsigned long mp_get_long(const mp_int *a) MP_WUR;
+                 mp_get_u32) unsigned long mp_get_int(const mp_int * a) MP_WUR;
-MP_DEPRECATED(mp_get_mag_ull/mp_get_ull) unsigned long long mp_get_long_long(const mp_int *a) MP_WUR;
+   MP_DEPRECATED(mp_get_mag_ul /
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int *a, unsigned long b);
+                 mp_get_ul) unsigned long mp_get_long(const mp_int * a) MP_WUR;
-MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int *a, unsigned long b);
+   MP_DEPRECATED(mp_get_mag_ull /
-MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int *a, unsigned long long b);
+                 mp_get_ull) unsigned long long mp_get_long_long(const mp_int *
-MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int *a, unsigned long b) MP_WUR;
+                                                                 a) MP_WUR;
+   MP_DEPRECATED(mp_set_ul) mp_err mp_set_int(mp_int * a, unsigned long b);
+   MP_DEPRECATED(mp_set_ul) mp_err mp_set_long(mp_int * a, unsigned long b);
+   MP_DEPRECATED(mp_set_ull) mp_err mp_set_long_long(mp_int * a,
+                                                     unsigned long long b);
+   MP_DEPRECATED(mp_init_ul) mp_err mp_init_set_int(mp_int * a,
+                                                    unsigned long b) MP_WUR;
 
 /* copy, b = a */
-mp_err mp_copy(const mp_int *a, mp_int *b) MP_WUR;
+  mp_err mp_copy(const mp_int * a, mp_int * b) MP_WUR;
 
 /* inits and copies, a = b */
-mp_err mp_init_copy(mp_int *a, const mp_int *b) MP_WUR;
+  mp_err mp_init_copy(mp_int * a, const mp_int * b) MP_WUR;
 
 /* trim unused digits */
-void mp_clamp(mp_int *a);
+  void mp_clamp(mp_int * a);
-
 
 /* export binary data */
-MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order, size_t size,
+   MP_DEPRECATED(mp_pack) mp_err mp_export(void *rop, size_t *countp, int order,
-                                        int endian, size_t nails, const mp_int *op) MP_WUR;
+                                           size_t size, int endian,
+                                           size_t nails,
+                                           const mp_int * op) MP_WUR;
 
 /* import binary data */
-MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int *rop, size_t count, int order,
+   MP_DEPRECATED(mp_unpack) mp_err mp_import(mp_int * rop, size_t count,
-      size_t size, int endian, size_t nails,
+                                             int order, size_t size, int endian,
+                                             size_t nails,
                                              const void *op) MP_WUR;
 
 /* unpack binary data */
-mp_err mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian,
+  mp_err mp_unpack(mp_int * rop, size_t count, mp_order order, size_t size,
-                 size_t nails, const void *op) MP_WUR;
+                   mp_endian endian, size_t nails, const void *op) MP_WUR;
 
 /* pack binary data */
-size_t mp_pack_count(const mp_int *a, size_t nails, size_t size) MP_WUR;
+  size_t mp_pack_count(const mp_int * a, size_t nails, size_t size) MP_WUR;
-mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size,
+  mp_err mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order,
-               mp_endian endian, size_t nails, const mp_int *op) MP_WUR;
+                 size_t size, mp_endian endian, size_t nails,
+                 const mp_int * op) MP_WUR;
 
 /* ---> digit manipulation <--- */
 
 /* right shift by "b" digits */
-void mp_rshd(mp_int *a, int b);
+  void mp_rshd(mp_int * a, int b);
 
 /* left shift by "b" digits */
-mp_err mp_lshd(mp_int *a, int b) MP_WUR;
+  mp_err mp_lshd(mp_int * a, int b) MP_WUR;
 
 /* c = a / 2**b, implemented as c = a >> b */
-mp_err mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_div_2d(const mp_int * a, int b, mp_int * c, mp_int * d) MP_WUR;
 
 /* b = a/2 */
-mp_err mp_div_2(const mp_int *a, mp_int *b) MP_WUR;
+  mp_err mp_div_2(const mp_int * a, mp_int * b) MP_WUR;
 
 /* a/3 => 3c + d == a */
-mp_err mp_div_3(const mp_int *a, mp_int *c, mp_digit *d) MP_WUR;
+  mp_err mp_div_3(const mp_int * a, mp_int * c, mp_digit * d) MP_WUR;
 
 /* c = a * 2**b, implemented as c = a << b */
-mp_err mp_mul_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
+  mp_err mp_mul_2d(const mp_int * a, int b, mp_int * c) MP_WUR;
 
 /* b = a*2 */
-mp_err mp_mul_2(const mp_int *a, mp_int *b) MP_WUR;
+  mp_err mp_mul_2(const mp_int * a, mp_int * b) MP_WUR;
 
 /* c = a mod 2**b */
-mp_err mp_mod_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
+  mp_err mp_mod_2d(const mp_int * a, int b, mp_int * c) MP_WUR;
 
 /* computes a = 2**b */
-mp_err mp_2expt(mp_int *a, int b) MP_WUR;
+  mp_err mp_2expt(mp_int * a, int b) MP_WUR;
 
 /* Counts the number of lsbs which are zero before the first zero bit */
-int mp_cnt_lsb(const mp_int *a) MP_WUR;
+  int mp_cnt_lsb(const mp_int * a) MP_WUR;
 
 /* I Love Earth! */
 
 /* makes a pseudo-random mp_int of a given size */
-mp_err mp_rand(mp_int *a, int digits) MP_WUR;
+  mp_err mp_rand(mp_int * a, int digits) MP_WUR;
 /* makes a pseudo-random small int of a given size */
-MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit *r) MP_WUR;
+   MP_DEPRECATED(mp_rand) mp_err mp_rand_digit(mp_digit * r) MP_WUR;
 /* use custom random data source instead of source provided the platform */
-void mp_rand_source(mp_err(*source)(void *out, size_t size));
+  void mp_rand_source(mp_err(*source) (void *out, size_t size));
 
 #ifdef MP_PRNG_ENABLE_LTM_RNG
-#  warning MP_PRNG_ENABLE_LTM_RNG has been deprecated, use mp_rand_source instead.
+#warning MP_PRNG_ENABLE_LTM_RNG has been deprecated, use mp_rand_source instead.
 /* A last resort to provide random data on systems without any of the other
  * implemented ways to gather entropy.
  * It is compatible with `rng_get_bytes()` from libtomcrypt so you could
  * provide that one and then set `ltm_rng = rng_get_bytes;` */
-extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen, void (*callback)(void));
+  extern unsigned long (*ltm_rng)(unsigned char *out, unsigned long outlen,
-extern void (*ltm_rng_callback)(void);
+                                  void(*callback)(void));
+  extern void (*ltm_rng_callback)(void);
 #endif
 
 /* ---> binary operations <--- */
@@ -445,225 +453,250 @@ extern void (*ltm_rng_callback)(void);
  * if the bit is 1, MP_NO if it is 0 and MP_VAL
  * in case of error
  */
-MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int *a, int b) MP_WUR;
+   MP_DEPRECATED(s_mp_get_bit) int mp_get_bit(const mp_int * a, int b) MP_WUR;
 
 /* c = a XOR b (two complement) */
-MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_xor) mp_err mp_tc_xor(const mp_int * a, const mp_int * b,
-mp_err mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+                                          mp_int * c) MP_WUR;
+  mp_err mp_xor(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = a OR b (two complement) */
-MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_or) mp_err mp_tc_or(const mp_int * a, const mp_int * b,
-mp_err mp_or(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+                                        mp_int * c) MP_WUR;
+  mp_err mp_or(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = a AND b (two complement) */
-MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_and) mp_err mp_tc_and(const mp_int * a, const mp_int * b,
-mp_err mp_and(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+                                          mp_int * c) MP_WUR;
+  mp_err mp_and(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* b = ~a (bitwise not, two complement) */
-mp_err mp_complement(const mp_int *a, mp_int *b) MP_WUR;
+  mp_err mp_complement(const mp_int * a, mp_int * b) MP_WUR;
 
 /* right shift with sign extension */
-MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int *a, int b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_signed_rsh) mp_err mp_tc_div_2d(const mp_int * a, int b,
-mp_err mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR;
+                                                    mp_int * c) MP_WUR;
+  mp_err mp_signed_rsh(const mp_int * a, int b, mp_int * c) MP_WUR;
 
 /* ---> Basic arithmetic <--- */
 
 /* b = -a */
-mp_err mp_neg(const mp_int *a, mp_int *b) MP_WUR;
+  mp_err mp_neg(const mp_int * a, mp_int * b) MP_WUR;
 
 /* b = |a| */
-mp_err mp_abs(const mp_int *a, mp_int *b) MP_WUR;
+  mp_err mp_abs(const mp_int * a, mp_int * b) MP_WUR;
 
 /* compare a to b */
-mp_ord mp_cmp(const mp_int *a, const mp_int *b) MP_WUR;
+  mp_ord mp_cmp(const mp_int * a, const mp_int * b) MP_WUR;
 
 /* compare |a| to |b| */
-mp_ord mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR;
+  mp_ord mp_cmp_mag(const mp_int * a, const mp_int * b) MP_WUR;
 
 /* c = a + b */
-mp_err mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_add(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = a - b */
-mp_err mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_sub(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = a * b */
-mp_err mp_mul(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_mul(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* b = a*a  */
-mp_err mp_sqr(const mp_int *a, mp_int *b) MP_WUR;
+  mp_err mp_sqr(const mp_int * a, mp_int * b) MP_WUR;
 
 /* a/b => cb + d == a */
-mp_err mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_div(const mp_int * a, const mp_int * b, mp_int * c,
+                mp_int * d) MP_WUR;
 
 /* c = a mod b, 0 <= c < b  */
-mp_err mp_mod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_mod(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* Increment "a" by one like "a++". Changes input! */
-mp_err mp_incr(mp_int *a) MP_WUR;
+  mp_err mp_incr(mp_int * a) MP_WUR;
 
 /* Decrement "a" by one like "a--". Changes input! */
-mp_err mp_decr(mp_int *a) MP_WUR;
+  mp_err mp_decr(mp_int * a) MP_WUR;
 
 /* ---> single digit functions <--- */
 
 /* compare against a single digit */
-mp_ord mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR;
+  mp_ord mp_cmp_d(const mp_int * a, mp_digit b) MP_WUR;
 
 /* c = a + b */
-mp_err mp_add_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
+  mp_err mp_add_d(const mp_int * a, mp_digit b, mp_int * c) MP_WUR;
 
 /* c = a - b */
-mp_err mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
+  mp_err mp_sub_d(const mp_int * a, mp_digit b, mp_int * c) MP_WUR;
 
 /* c = a * b */
-mp_err mp_mul_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
+  mp_err mp_mul_d(const mp_int * a, mp_digit b, mp_int * c) MP_WUR;
 
 /* a/b => cb + d == a */
-mp_err mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d) MP_WUR;
+  mp_err mp_div_d(const mp_int * a, mp_digit b, mp_int * c,
+                  mp_digit * d) MP_WUR;
 
 /* c = a mod b, 0 <= c < b  */
-mp_err mp_mod_d(const mp_int *a, mp_digit b, mp_digit *c) MP_WUR;
+  mp_err mp_mod_d(const mp_int * a, mp_digit b, mp_digit * c) MP_WUR;
 
 /* ---> number theory <--- */
 
 /* d = a + b (mod c) */
-mp_err mp_addmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_addmod(const mp_int * a, const mp_int * b, const mp_int * c,
+                   mp_int * d) MP_WUR;
 
 /* d = a - b (mod c) */
-mp_err mp_submod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_submod(const mp_int * a, const mp_int * b, const mp_int * c,
+                   mp_int * d) MP_WUR;
 
 /* d = a * b (mod c) */
-mp_err mp_mulmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d) MP_WUR;
+  mp_err mp_mulmod(const mp_int * a, const mp_int * b, const mp_int * c,
+                   mp_int * d) MP_WUR;
 
 /* c = a * a (mod b) */
-mp_err mp_sqrmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_sqrmod(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = 1/a (mod b) */
-mp_err mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_invmod(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* c = (a, b) */
-mp_err mp_gcd(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_gcd(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* produces value such that U1*a + U2*b = U3 */
-mp_err mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_int *U3) MP_WUR;
+  mp_err mp_exteuclid(const mp_int * a, const mp_int * b, mp_int * U1,
+                      mp_int * U2, mp_int * U3) MP_WUR;
 
 /* c = [a, b] or (a*b)/(a, b) */
-mp_err mp_lcm(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR;
+  mp_err mp_lcm(const mp_int * a, const mp_int * b, mp_int * c) MP_WUR;
 
 /* finds one of the b'th root of a, such that |c|**b <= |a|
  *
  * returns error if a < 0 and b is even
  */
-mp_err mp_root_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR;
+  mp_err mp_root_u32(const mp_int * a, uint32_t b, mp_int * c) MP_WUR;
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_root_u32) mp_err mp_n_root(const mp_int * a, mp_digit b,
-MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
+                                               mp_int * c) MP_WUR;
+   MP_DEPRECATED(mp_root_u32) mp_err mp_n_root_ex(const mp_int * a, mp_digit b,
+                                                  mp_int * c, int fast) MP_WUR;
 
 /* special sqrt algo */
-mp_err mp_sqrt(const mp_int *arg, mp_int *ret) MP_WUR;
+  mp_err mp_sqrt(const mp_int * arg, mp_int * ret) MP_WUR;
 
 /* special sqrt (mod prime) */
-mp_err mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) MP_WUR;
+  mp_err mp_sqrtmod_prime(const mp_int * n, const mp_int * prime,
+                          mp_int * ret) MP_WUR;
 
 /* is number a square? */
-mp_err mp_is_square(const mp_int *arg, mp_bool *ret) MP_WUR;
+  mp_err mp_is_square(const mp_int * arg, mp_bool * ret) MP_WUR;
 
 /* computes the jacobi c = (a | n) (or Legendre if b is prime)  */
-MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int *a, const mp_int *n, int *c) MP_WUR;
+   MP_DEPRECATED(mp_kronecker) mp_err mp_jacobi(const mp_int * a,
+                                                const mp_int * n,
+                                                int *c) MP_WUR;
 
 /* computes the Kronecker symbol c = (a | p) (like jacobi() but with {a,p} in Z */
-mp_err mp_kronecker(const mp_int *a, const mp_int *p, int *c) MP_WUR;
+  mp_err mp_kronecker(const mp_int * a, const mp_int * p, int *c) MP_WUR;
 
 /* used to setup the Barrett reduction for a given modulus b */
-mp_err mp_reduce_setup(mp_int *a, const mp_int *b) MP_WUR;
+  mp_err mp_reduce_setup(mp_int * a, const mp_int * b) MP_WUR;
 
 /* Barrett Reduction, computes a (mod b) with a precomputed value c
  *
  * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
  * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code].
  */
-mp_err mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu) MP_WUR;
+  mp_err mp_reduce(mp_int * x, const mp_int * m, const mp_int * mu) MP_WUR;
 
 /* setups the montgomery reduction */
-mp_err mp_montgomery_setup(const mp_int *n, mp_digit *rho) MP_WUR;
+  mp_err mp_montgomery_setup(const mp_int * n, mp_digit * rho) MP_WUR;
 
 /* computes a = B**n mod b without division or multiplication useful for
  * normalizing numbers in a Montgomery system.
  */
-mp_err mp_montgomery_calc_normalization(mp_int *a, const mp_int *b) MP_WUR;
+  mp_err mp_montgomery_calc_normalization(mp_int * a, const mp_int * b) MP_WUR;
 
 /* computes x/R == x (mod N) via Montgomery Reduction */
-mp_err mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) MP_WUR;
+  mp_err mp_montgomery_reduce(mp_int * x, const mp_int * n,
+                              mp_digit rho) MP_WUR;
 
 /* returns 1 if a is a valid DR modulus */
-mp_bool mp_dr_is_modulus(const mp_int *a) MP_WUR;
+  mp_bool mp_dr_is_modulus(const mp_int * a) MP_WUR;
 
 /* sets the value of "d" required for mp_dr_reduce */
-void mp_dr_setup(const mp_int *a, mp_digit *d);
+  void mp_dr_setup(const mp_int * a, mp_digit * d);
 
 /* reduces a modulo n using the Diminished Radix method */
-mp_err mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k) MP_WUR;
+  mp_err mp_dr_reduce(mp_int * x, const mp_int * n, mp_digit k) MP_WUR;
 
 /* returns true if a can be reduced with mp_reduce_2k */
-mp_bool mp_reduce_is_2k(const mp_int *a) MP_WUR;
+  mp_bool mp_reduce_is_2k(const mp_int * a) MP_WUR;
 
 /* determines k value for 2k reduction */
-mp_err mp_reduce_2k_setup(const mp_int *a, mp_digit *d) MP_WUR;
+  mp_err mp_reduce_2k_setup(const mp_int * a, mp_digit * d) MP_WUR;
 
 /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-mp_err mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d) MP_WUR;
+  mp_err mp_reduce_2k(mp_int * a, const mp_int * n, mp_digit d) MP_WUR;
 
 /* returns true if a can be reduced with mp_reduce_2k_l */
-mp_bool mp_reduce_is_2k_l(const mp_int *a) MP_WUR;
+  mp_bool mp_reduce_is_2k_l(const mp_int * a) MP_WUR;
 
 /* determines k value for 2k reduction */
-mp_err mp_reduce_2k_setup_l(const mp_int *a, mp_int *d) MP_WUR;
+  mp_err mp_reduce_2k_setup_l(const mp_int * a, mp_int * d) MP_WUR;
 
 /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
-mp_err mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d) MP_WUR;
+  mp_err mp_reduce_2k_l(mp_int * a, const mp_int * n, const mp_int * d) MP_WUR;
 
 /* Y = G**X (mod P) */
-mp_err mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y) MP_WUR;
+  mp_err mp_exptmod(const mp_int * G, const mp_int * X, const mp_int * P,
+                    mp_int * Y) MP_WUR;
 
 /* ---> Primes <--- */
 
 /* number of primes */
 #ifdef MP_8BIT
-#  define PRIVATE_MP_PRIME_TAB_SIZE 31
+#define PRIVATE_MP_PRIME_TAB_SIZE 31
 #else
-#  define PRIVATE_MP_PRIME_TAB_SIZE 256
+#define PRIVATE_MP_PRIME_TAB_SIZE 256
 #endif
 #define PRIME_SIZE (MP_DEPRECATED_PRAGMA("PRIME_SIZE has been made internal") PRIVATE_MP_PRIME_TAB_SIZE)
 
 /* table of first PRIME_SIZE primes */
-MP_DEPRECATED(internal) extern const mp_digit ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
+   MP_DEPRECATED(internal) extern const mp_digit
+      ltm_prime_tab[PRIVATE_MP_PRIME_TAB_SIZE];
 
 /* result=1 if a is divisible by one of the first PRIME_SIZE primes */
-MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *a, mp_bool *result) MP_WUR;
+   MP_DEPRECATED(mp_prime_is_prime) mp_err mp_prime_is_divisible(const mp_int *
+                                                                 a,
+                                                                 mp_bool *
+                                                                 result) MP_WUR;
 
 /* performs one Fermat test of "a" using base "b".
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_fermat(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
+  mp_err mp_prime_fermat(const mp_int * a, const mp_int * b,
+                         mp_bool * result) MP_WUR;
 
 /* performs one Miller-Rabin test of "a" using base "b".
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_miller_rabin(const mp_int *a, const mp_int *b, mp_bool *result) MP_WUR;
+  mp_err mp_prime_miller_rabin(const mp_int * a, const mp_int * b,
+                               mp_bool * result) MP_WUR;
 
 /* This gives [for a given bit size] the number of trials required
  * such that Miller-Rabin gives a prob of failure lower than 2^-96
  */
-int mp_prime_rabin_miller_trials(int size) MP_WUR;
+  int mp_prime_rabin_miller_trials(int size) MP_WUR;
 
 /* performs one strong Lucas-Selfridge test of "a".
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_strong_lucas_selfridge(const mp_int *a, mp_bool *result) MP_WUR;
+  mp_err mp_prime_strong_lucas_selfridge(const mp_int * a,
+                                         mp_bool * result) MP_WUR;
 
 /* performs one Frobenius test of "a" as described by Paul Underwood.
  * Sets result to 0 if composite or 1 if probable prime
  */
-mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR;
+  mp_err mp_prime_frobenius_underwood(const mp_int * N,
+                                      mp_bool * result) MP_WUR;
 
 /* performs t random rounds of Miller-Rabin on "a" additional to
  * bases 2 and 3.  Also performs an initial sieve of trial
@@ -679,14 +712,14 @@ mp_err mp_prime_frobenius_underwood(const mp_int *N, mp_bool *result) MP_WUR;
  *
  * Sets result to 1 if probably prime, 0 otherwise
  */
-mp_err mp_prime_is_prime(const mp_int *a, int t, mp_bool *result) MP_WUR;
+  mp_err mp_prime_is_prime(const mp_int * a, int t, mp_bool * result) MP_WUR;
 
 /* finds the next prime after the number "a" using "t" trials
  * of Miller-Rabin.
  *
  * bbs_style = 1 means the prime must be congruent to 3 mod 4
  */
-mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR;
+  mp_err mp_prime_next_prime(mp_int * a, int t, int bbs_style) MP_WUR;
 
 /* makes a truly random prime of a given size (bytes),
  * call with bbs = 1 if you want it to be congruent to 3 mod 4
@@ -712,49 +745,69 @@ mp_err mp_prime_next_prime(mp_int *a, int t, int bbs_style) MP_WUR;
  * so it can be NULL
  *
  */
-MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int *a, int t, int size, int flags,
+   MP_DEPRECATED(mp_prime_rand) mp_err mp_prime_random_ex(mp_int * a, int t,
-      private_mp_prime_callback cb, void *dat) MP_WUR;
+                                                          int size, int flags,
-mp_err mp_prime_rand(mp_int *a, int t, int size, int flags) MP_WUR;
+                                                          private_mp_prime_callback
+                                                          cb, void *dat) MP_WUR;
+  mp_err mp_prime_rand(mp_int * a, int t, int size, int flags) MP_WUR;
 
 /* Integer logarithm to integer base */
-mp_err mp_log_u32(const mp_int *a, uint32_t base, uint32_t *c) MP_WUR;
+  mp_err mp_log_u32(const mp_int * a, uint32_t base, uint32_t * c) MP_WUR;
 
 /* c = a**b */
-mp_err mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c) MP_WUR;
+  mp_err mp_expt_u32(const mp_int * a, uint32_t b, mp_int * c) MP_WUR;
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int *a, mp_digit b, mp_int *c) MP_WUR;
+   MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d(const mp_int * a, mp_digit b,
-MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) MP_WUR;
+                                               mp_int * c) MP_WUR;
+   MP_DEPRECATED(mp_expt_u32) mp_err mp_expt_d_ex(const mp_int * a, mp_digit b,
+                                                  mp_int * c, int fast) MP_WUR;
 
 /* ---> radix conversion <--- */
-int mp_count_bits(const mp_int *a) MP_WUR;
+  int mp_count_bits(const mp_int * a) MP_WUR;
 
+   MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *
+                                                        a) MP_WUR;
+   MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int * a, const unsigned char
+                                                           *b, int c) MP_WUR;
+   MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int * a,
+                                                       unsigned char *b) MP_WUR;
+   MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int * a,
+                                                         unsigned char *b,
+                                                         unsigned long *outlen)
+   MP_WUR;
 
-MP_DEPRECATED(mp_ubin_size) int mp_unsigned_bin_size(const mp_int *a) MP_WUR;
+   MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int * a) MP_WUR;
-MP_DEPRECATED(mp_from_ubin) mp_err mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
+   MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int * a,
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin(const mp_int *a, unsigned char *b) MP_WUR;
+                                                         const unsigned char *b,
-MP_DEPRECATED(mp_to_ubin) mp_err mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
+                                                         int c) MP_WUR;
+   MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int * a,
+                                                     unsigned char *b) MP_WUR;
+   MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int * a,
+                                                       unsigned char *b,
+                                                       unsigned long *outlen)
+   MP_WUR;
 
-MP_DEPRECATED(mp_sbin_size) int mp_signed_bin_size(const mp_int *a) MP_WUR;
+  size_t mp_ubin_size(const mp_int * a) MP_WUR;
-MP_DEPRECATED(mp_from_sbin) mp_err mp_read_signed_bin(mp_int *a, const unsigned char *b, int c) MP_WUR;
+  mp_err mp_from_ubin(mp_int * a, const unsigned char *buf, size_t size) MP_WUR;
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin(const mp_int *a,  unsigned char *b) MP_WUR;
+  mp_err mp_to_ubin(const mp_int * a, unsigned char *buf, size_t maxlen,
-MP_DEPRECATED(mp_to_sbin) mp_err mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) MP_WUR;
+                    size_t *written) MP_WUR;
 
-size_t mp_ubin_size(const mp_int *a) MP_WUR;
+  size_t mp_sbin_size(const mp_int * a) MP_WUR;
-mp_err mp_from_ubin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
+  mp_err mp_from_sbin(mp_int * a, const unsigned char *buf, size_t size) MP_WUR;
-mp_err mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
+  mp_err mp_to_sbin(const mp_int * a, unsigned char *buf, size_t maxlen,
+                    size_t *written) MP_WUR;
 
-size_t mp_sbin_size(const mp_int *a) MP_WUR;
+  mp_err mp_read_radix(mp_int * a, const char *str, int radix) MP_WUR;
-mp_err mp_from_sbin(mp_int *a, const unsigned char *buf, size_t size) MP_WUR;
+   MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int * a, char *str,
-mp_err mp_to_sbin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR;
+                                                int radix) MP_WUR;
-
+   MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int * a, char *str,
-mp_err mp_read_radix(mp_int *a, const char *str, int radix) MP_WUR;
+                                                  int radix, int maxlen) MP_WUR;
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix(const mp_int *a, char *str, int radix) MP_WUR;
+  mp_err mp_to_radix(const mp_int * a, char *str, size_t maxlen,
-MP_DEPRECATED(mp_to_radix) mp_err mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) MP_WUR;
+                     size_t *written, int radix) MP_WUR;
-mp_err mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR;
+  mp_err mp_radix_size(const mp_int * a, int radix, int *size) MP_WUR;
-mp_err mp_radix_size(const mp_int *a, int radix, int *size) MP_WUR;
 
 #ifndef MP_NO_FILE
-mp_err mp_fread(mp_int *a, int radix, FILE *stream) MP_WUR;
+  mp_err mp_fread(mp_int * a, int radix, FILE * stream) MP_WUR;
-mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR;
+  mp_err mp_fwrite(const mp_int * a, int radix, FILE * stream) MP_WUR;
 #endif
 
 #define mp_read_raw(mp, str, len) (MP_DEPRECATED_PRAGMA("replaced by mp_read_signed_bin") mp_read_signed_bin((mp), (str), (len)))
@@ -777,5 +830,4 @@ mp_err mp_fwrite(const mp_int *a, int radix, FILE *stream) MP_WUR;
 #ifdef __cplusplus
 }
 #endif
-
 #endif

include/cyclone/hashset.h

@@ -71,5 +71,4 @@ extern "C" {
 #ifdef __cplusplus
 }
 #endif
-
 #endif

include/cyclone/runtime-main.h

@@ -12,7 +12,7 @@
 long global_stack_size = 0;
 long global_heap_size = 0;
 
-static void c_entry_pt(void *data, object clo, int argc, object *args);
+static void c_entry_pt(void *data, object clo, int argc, object * args);
 static void Cyc_heap_init(long heap_size);
 
 static void Cyc_heap_init(long heap_size)

include/cyclone/runtime.h

@@ -9,7 +9,6 @@
 #ifndef CYCLONE_RUNTIME_H
 #define CYCLONE_RUNTIME_H
 
-
 /**
  * The boolean True value.
  * \ingroup objects
@@ -231,7 +230,8 @@ object Cyc_global_set(void *thd, object sym, object * glo, object value);
 
 #define global_set_cps(thd,k,glo,value) Cyc_global_set_cps(thd, k, NULL, (object *)&glo, value)
 #define global_set_cps_id(thd,k,id,glo,value) Cyc_global_set_cps(thd, k, id, (object *)&glo, value)
-object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo, object value);
+object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo,
+                          object value);
 
 /**
  * Variable argument count support 
@@ -274,8 +274,8 @@ object Cyc_global_set_cps(void *thd, object cont, object sym, object * glo, obje
 
 /**@{*/
 object apply(void *data, object cont, object func, object args);
-void Cyc_apply(void *data, object cont, int argc, object *args);
+void Cyc_apply(void *data, object cont, int argc, object * args);
-void dispatch_apply_va(void *data, object clo, int argc, object *args);
+void dispatch_apply_va(void *data, object clo, int argc, object * args);
 object apply_va(void *data, object cont, int argc, object func, ...);
 void dispatch(void *data, int argc, function_type func, object clo, object cont,
               object args);
@@ -288,7 +288,7 @@ void dispatch(void *data, int argc, function_type func, object clo, object cont,
  */
 /**@{*/
 object Cyc_string_cmp(void *data, object str1, object str2);
-void dispatch_string_91append(void *data, object clo, int _argc, object *args);
+void dispatch_string_91append(void *data, object clo, int _argc, object * args);
 object Cyc_string2number_(void *d, object cont, object str);
 object Cyc_string2number2_(void *data, object cont, int argc, object str, ...);
 int binstr2int(const char *str);
@@ -342,12 +342,12 @@ object Cyc_set_cvar(object var, object value);
  */
 /**@{*/
 object Cyc_display(void *data, object, FILE * port);
-void dispatch_display_va(void *data, object clo, int argc, object *args);
+void dispatch_display_va(void *data, object clo, int argc, object * args);
 object Cyc_display_va(void *data, int argc, object x, ...);
 object Cyc_display_va_list(void *data, object x, object opts);
 object Cyc_write_char(void *data, object c, object port);
 object Cyc_write(void *data, object, FILE * port);
-void dispatch_write_va(void *data, object clo, int argc, object *args);
+void dispatch_write_va(void *data, object clo, int argc, object * args);
 object Cyc_write_va(void *data, int argc, object x, ...);
 object Cyc_write_va_list(void *data, object x, object opts);
 port_type Cyc_stdout(void);
@@ -372,18 +372,59 @@ object Cyc_io_char_ready(void *data, object port);
 object Cyc_write_u8(void *data, object c, object port);
 object Cyc_io_read_u8(void *data, object cont, object port);
 object Cyc_io_peek_u8(void *data, object cont, object port);
-object Cyc_write_bytevector(void *data, object bvec, object port, object start, object end);
+object Cyc_write_bytevector(void *data, object bvec, object port, object start,
+                            object end);
 object Cyc_io_read_line(void *data, object cont, object port);
 void Cyc_io_read_token(void *data, object cont, object port);
+int Cyc_have_mstreams();
 /**@}*/
 
-
 /**
  * \defgroup prim_num Numbers
  * @brief Number functions
  */
 /**@{*/
 
+/**
+ * Extract result of OP and pass it in a call to continuation `cont`
+ */
+#define return_double_op(data, cont, OP, z) \
+  int i = 0; \
+  Cyc_check_num(data, z); \
+  if (obj_is_int(z)) { \
+    i = obj_obj2int(z); \
+  } else if (type_of(z) == integer_tag) { \
+    i = (int)OP(((integer_type *)z)->value); \
+  } else if (type_of(z) == bignum_tag) { \
+    return_closcall1(data, cont, z); \
+  } else if (type_of(z) == double_tag) { \
+    make_double(d, OP(((double_type *)z)->value)); \
+    return_closcall1(data, cont, &d); \
+  } else { \
+    Cyc_rt_raise2(data, "Expected number but received", z); \
+  } \
+  return_closcall1(data, cont, obj_int2obj(i));
+
+/**
+ * Directly return result of OP to caller
+ */
+#define return_double_op_no_cps(data, ptr, OP, z) \
+  int i = 0; \
+  Cyc_check_num(data, z); \
+  if (obj_is_int(z)) { \
+    i = obj_obj2int(z); \
+  } else if (type_of(z) == integer_tag) { \
+    i = (int)OP(((integer_type *)z)->value); \
+  } else if (type_of(z) == bignum_tag) { \
+    return z; \
+  } else if (type_of(z) == double_tag) { \
+    assign_double(ptr, OP(((double_type *)z)->value)); \
+    return ptr; \
+  } else { \
+    Cyc_rt_raise2(data, "Expected number but received", z); \
+  } \
+  return obj_int2obj(i);
+
 /**
  * Extract double and return it to caller
  */
@@ -463,39 +504,9 @@ void Cyc_io_read_token(void *data, object cont, object port);
   } \
   return_closcall1(data, cont, &d)
 
-/**
+double round_to_nearest_even(double);
- * Extract exact or double number and pass it in a call to continuation `cont`
+void Cyc_exact(void *data, object cont, object z);
- */
+object Cyc_exact_no_cps(void *data, object ptr, object z);
-#define return_exact_double_op(data, cont, OP, z) \
-  int i = 0; \
-  Cyc_check_num(data, z); \
-  if (obj_is_int(z)) { \
-    i = obj_obj2int(z); \
-  } else if (type_of(z) == integer_tag) { \
-    i = (int)OP(((integer_type *)z)->value); \
-  } else if (type_of(z) == bignum_tag) { \
-    return_closcall1(data, cont, z); \
-  } else { \
-    i = (int)OP(((double_type *)z)->value); \
-  } \
-  return_closcall1(data, cont, obj_int2obj(i))
-
-/**
- * Directly return exact or double number to caller
- */
-#define return_exact_double_op_no_cps(data, ptr, OP, z) \
-  int i = 0; \
-  Cyc_check_num(data, z); \
-  if (obj_is_int(z)) { \
-    i = obj_obj2int(z); \
-  } else if (type_of(z) == integer_tag) { \
-    i = (int)OP(((integer_type *)z)->value); \
-  } else if (type_of(z) == bignum_tag) { \
-    return z; \
-  } else { \
-    i = (int)OP(((double_type *)z)->value); \
-  } \
-  return obj_int2obj(i);
 
 /**
  * Take Scheme object that is a number and return the number as a C type
@@ -548,8 +559,10 @@ object Cyc_fast_list_3(object ptr, object a1, object a2, object a3);
 object Cyc_fast_list_4(object ptr, object a1, object a2, object a3, object a4);
 object Cyc_fast_vector_2(object ptr, object a1, object a2);
 object Cyc_fast_vector_3(object ptr, object a1, object a2, object a3);
-object Cyc_fast_vector_4(object ptr, object a1, object a2, object a3, object a4);
+object Cyc_fast_vector_4(object ptr, object a1, object a2, object a3,
-object Cyc_fast_vector_5(object ptr, object a1, object a2, object a3, object a4, object a5);
+                         object a4);
+object Cyc_fast_vector_5(object ptr, object a1, object a2, object a3, object a4,
+                         object a5);
 object Cyc_bit_unset(void *data, object n1, object n2);
 object Cyc_bit_set(void *data, object n1, object n2);
 object Cyc_num_op_va_list(void *data, int argc,
@@ -559,13 +572,12 @@ object Cyc_num_op_va_list(void *data, int argc,
 object Cyc_num_op_args(void *data, int argc,
                        object(fn_op(void *, common_type *, object)),
                        int default_no_args, int default_one_arg,
-                       object *args,
+                       object * args, common_type * buf);
-                       common_type * buf);
+void Cyc_int2bignum(int n, mp_int * bn);
-void Cyc_int2bignum(int n, mp_int *bn);
 object Cyc_bignum_normalize(void *data, object n);
 int Cyc_bignum_cmp(bn_cmp_type type, object x, int tx, object y, int ty);
 void Cyc_make_rectangular(void *data, object k, object r, object i);
-double MRG32k3a (double seed);
+double MRG32k3a(double seed);
 /**@}*/
 /**
  * \defgroup prim_eq Equality and type predicates
@@ -574,7 +586,6 @@ double MRG32k3a (double seed);
 //object Cyc_eq(object x, object y);
 object Cyc_eqv(object x, object y);
 #define Cyc_eq(x, y) (make_boolean(x == y))
-int equal(object, object);
 object equalp(object, object);
 object Cyc_has_cycle(object lst);
 object Cyc_is_list(object lst);
@@ -642,7 +653,8 @@ object Cyc_vector_ref(void *d, object v, object k);
 object Cyc_vector_set(void *d, object v, object k, object obj);
 object Cyc_vector_set_unsafe(void *d, object v, object k, object obj);
 object Cyc_vector_set_cps(void *d, object cont, object v, object k, object obj);
-object Cyc_vector_set_unsafe_cps(void *d, object cont, object v, object k, object obj);
+object Cyc_vector_set_unsafe_cps(void *d, object cont, object v, object k,
+                                 object obj);
 object Cyc_make_vector(void *data, object cont, int argc, object len, ...);
 /**@}*/
 
@@ -677,7 +689,7 @@ object Cyc_installation_dir(void *data, object cont, object type);
 object Cyc_compilation_environment(void *data, object cont, object var);
 object Cyc_command_line_arguments(void *data, object cont);
 object Cyc_system(object cmd);
-void Cyc_halt(void *data, object clo, int argc, object *args);
+void Cyc_halt(void *data, object clo, int argc, object * args);
 object __halt(object obj);
 object Cyc_io_delete_file(void *data, object filename);
 object Cyc_io_file_exists(void *data, object filename);
@@ -695,7 +707,7 @@ time_t Cyc_file_last_modified_time(char *path);
 object Cyc_spawn_thread(object thunk);
 void Cyc_start_trampoline(gc_thread_data * thd);
 void Cyc_end_thread(gc_thread_data * thd);
-void Cyc_exit_thread(void *data, object _, int argc, object *args);
+void Cyc_exit_thread(void *data, object _, int argc, object * args);
 object Cyc_thread_sleep(void *data, object timeout);
 /**@}*/
 
@@ -898,7 +910,8 @@ extern object Cyc_glo_call_cc;
  * @brief Raise and handle Scheme exceptions
  */
 /**@{*/
-object Cyc_default_exception_handler(void *data, object _, int argc, object *args);
+object Cyc_default_exception_handler(void *data, object _, int argc,
+                                     object * args);
 
 object Cyc_current_exception_handler(void *data);
 void Cyc_rt_raise(void *data, object err);
@@ -939,7 +952,7 @@ object register_library(const char *name);
 /**@{*/
 extern list global_table;
 void add_global(const char *identifier, object * glo);
-void Cyc_set_globals_changed(gc_thread_data *thd);
+void Cyc_set_globals_changed(gc_thread_data * thd);
 /**@}*/
 
 /**
@@ -961,9 +974,9 @@ void Cyc_set_globals_changed(gc_thread_data *thd);
 #define Cyc_utf8_encode_char(dest, dest_size, char_value) \
   Cyc_utf8_encode(dest, dest_size, &char_value, 1)
 
-int Cyc_utf8_encode(char *dest, int sz, uint32_t *src, int srcsz);
+int Cyc_utf8_encode(char *dest, int sz, uint32_t * src, int srcsz);
-int Cyc_utf8_count_code_points(uint8_t* s);
+int Cyc_utf8_count_code_points(uint8_t * s);
-uint32_t Cyc_utf8_validate_stream(uint32_t *state, char *str, size_t len); 
+uint32_t Cyc_utf8_validate_stream(uint32_t * state, char *str, size_t len);
 uint32_t Cyc_utf8_validate(char *str, size_t len);
 /**@}*/
 
@@ -985,6 +998,7 @@ static inline object Cyc_cdr(void *data, object lis)
   Cyc_check_pair(data, lis);
   return cdr(lis);
 }
+
 // Unsafe car/cdr
 #define Cyc_car_unsafe(d, lis) car(lis)
 #define Cyc_cdr_unsafe(d, lis) cdr(lis)
@@ -1000,8 +1014,10 @@ object Cyc_length_unsafe(void *d, object l);
 object Cyc_list2vector(void *data, object cont, object l);
 object Cyc_list2string(void *d, object cont, object lst);
 object memberp(void *data, object x, list l);
+object memvp(void *data, object x, list l);
 object memqp(void *data, object x, list l);
 list assq(void *data, object x, list l);
+list assv(void *data, object x, list l);
 list assoc(void *data, object x, list l);
 list assoc_cdr(void *data, object x, list l);
 /**@}*/

include/cyclone/types.h

@@ -46,31 +46,13 @@ typedef void *object;
  *\ingroup objects
  */
 enum object_tag {
-        closure0_tag    = 0
+  closure0_tag = 0, closure1_tag = 1, closureN_tag = 2, macro_tag = 3   // Keep closures here for quick type checking
-      , closure1_tag    = 1
+  , boolean_tag = 4, bytevector_tag = 5, c_opaque_tag = 6, cond_var_tag =
-      , closureN_tag    = 2
+      7, cvar_tag = 8, double_tag = 9, eof_tag = 10, forward_tag =
-      , macro_tag       = 3 // Keep closures here for quick type checking
+      11, integer_tag = 12, bignum_tag = 13, mutex_tag = 14, pair_tag =
-      , boolean_tag     = 4
+      15, port_tag = 16, primitive_tag = 17, string_tag = 18, symbol_tag =
-      , bytevector_tag  = 5
+      19, vector_tag = 20, complex_num_tag = 21, atomic_tag = 22, void_tag =
-      , c_opaque_tag    = 6
+      23, record_tag = 24
-      , cond_var_tag    = 7
-      , cvar_tag        = 8
-      , double_tag      = 9
-      , eof_tag         = 10
-      , forward_tag     = 11
-      , integer_tag     = 12
-      , bignum_tag      = 13
-      , mutex_tag       = 14
-      , pair_tag        = 15
-      , port_tag        = 16 
-      , primitive_tag   = 17
-      , string_tag      = 18
-      , symbol_tag      = 19
-      , vector_tag      = 20
-      , complex_num_tag = 21
-      , atomic_tag      = 22
-      , void_tag        = 23
-      , record_tag      = 24
 };
 
 /**
@@ -176,28 +158,24 @@ typedef unsigned char tag_type;
  heaps (128, 160) are also added.
 
  32 bit x86 is starting to have trouble with just a 96 byte heap added.
-
- In the future, a better solution might be to allocate arrays (closureN's, vectors, bytevectors, and strings)
- as fixed-size chunks to prevent heap fragmentation. The advantage is then we have no fragmentation directly.
- But, an array will no longer be contiguous so they may cause other problems, and the runtime has to change
- to work with non-contiguous arrays. This would also cause a lot of problems for strings since the built-in
- functions would no longer work (EG: strlen, etc).
  */
-typedef enum { 
+
-    HEAP_SM = 0  // 32 byte objects (min gc_heap_align)
+// Type starts at 0 and ends at LAST_FIXED_SIZE_HEAP_TYPE
-  , HEAP_64
+// Presently each type contains buckets of a multiple of 32 bytes
-  , HEAP_96
+// EG: 0 ==> 32
-  , HEAP_REST    // Everything else
+//     1 ==> 64, etc
-  , HEAP_HUGE    // Huge objects, 1 per page
+typedef int gc_heap_type;
-} gc_heap_type;
 
 /** The first heap type that is not fixed-size */
 #if INTPTR_MAX == INT64_MAX
-#define LAST_FIXED_SIZE_HEAP_TYPE HEAP_96
+#define LAST_FIXED_SIZE_HEAP_TYPE 2
 #else
-#define LAST_FIXED_SIZE_HEAP_TYPE HEAP_64
+#define LAST_FIXED_SIZE_HEAP_TYPE 1
 #endif
 
+#define HEAP_REST (LAST_FIXED_SIZE_HEAP_TYPE + 1)
+#define HEAP_HUGE (HEAP_REST + 1)
+
 /** The number of `gc_heap_type`'s */
 #define NUM_HEAP_TYPES (HEAP_HUGE + 1)
 
@@ -225,7 +203,7 @@ struct gc_heap_t {
   /** Size of the heap page in bytes */
   unsigned int size;
   /** Keep empty page alive this many times before freeing */
-  unsigned int ttl; 
+  unsigned char ttl;
   /** Bump: Track remaining space; this is useful for bump&pop style allocation */
   unsigned int remaining;
   /** For fixed-size heaps, only allocate blocks of this size */
@@ -402,29 +380,31 @@ void gc_initialize(void);
 void gc_add_new_unrunning_mutator(gc_thread_data * thd);
 void gc_add_mutator(gc_thread_data * thd);
 void gc_remove_mutator(gc_thread_data * thd);
-int gc_is_mutator_active(gc_thread_data *thd);
+int gc_is_mutator_active(gc_thread_data * thd);
-int gc_is_mutator_new(gc_thread_data *thd);
+int gc_is_mutator_new(gc_thread_data * thd);
 void gc_sleep_ms(int ms);
-gc_heap *gc_heap_create(int heap_type, size_t size, gc_thread_data *thd);
+gc_heap *gc_heap_create(int heap_type, size_t size, gc_thread_data * thd);
-gc_heap *gc_heap_free(gc_heap *page, gc_heap *prev_page);
+gc_heap *gc_heap_free(gc_heap * page, gc_heap * prev_page);
-void gc_heap_merge(gc_heap *hdest, gc_heap *hsrc);
+int gc_heap_merge(gc_heap * hdest, gc_heap * hsrc);
-void gc_merge_all_heaps(gc_thread_data *dest, gc_thread_data *src);
+void gc_merge_all_heaps(gc_thread_data * dest, gc_thread_data * src);
 void gc_print_stats(gc_heap * h);
-gc_heap *gc_grow_heap(gc_heap * h, size_t size, gc_thread_data *thd);
+gc_heap *gc_grow_heap(gc_heap * h, size_t size, gc_thread_data * thd);
 char *gc_copy_obj(object hp, char *obj, gc_thread_data * thd);
-void *gc_try_alloc(gc_heap * h, size_t size, char *obj,
+void *gc_try_alloc(gc_heap * h, size_t size, char *obj, gc_thread_data * thd);
+void *gc_try_alloc_slow(gc_heap * h_passed, gc_heap * h, size_t size, char *obj,
                         gc_thread_data * thd);
-void *gc_try_alloc_slow(gc_heap *h_passed, gc_heap *h, size_t size, char *obj, gc_thread_data *thd);
 void *gc_alloc(gc_heap_root * h, size_t size, char *obj, gc_thread_data * thd,
                int *heap_grown);
-void *gc_alloc_bignum(gc_thread_data *data);
+void *gc_alloc_bignum(gc_thread_data * data);
 size_t gc_allocated_bytes(object obj, gc_free_list * q, gc_free_list * r);
 gc_heap *gc_heap_last(gc_heap * h);
 
-void gc_heap_create_rest(gc_heap *h, gc_thread_data *thd);
+void gc_heap_create_rest(gc_heap * h, gc_thread_data * thd);
-void *gc_try_alloc_rest(gc_heap * h, size_t size, char *obj, gc_thread_data * thd);
+void *gc_try_alloc_rest(gc_heap * h, size_t size, char *obj,
-void *gc_alloc_rest(gc_heap_root * hrt, size_t size, char *obj, gc_thread_data * thd, int *heap_grown);
+                        gc_thread_data * thd);
-void gc_init_fixed_size_free_list(gc_heap *h);
+void *gc_alloc_rest(gc_heap_root * hrt, size_t size, char *obj,
+                    gc_thread_data * thd, int *heap_grown);
+void gc_init_fixed_size_free_list(gc_heap * h);
 
 //size_t gc_heap_total_size(gc_heap * h);
 //size_t gc_heap_total_free_size(gc_heap *h);
@@ -433,7 +413,7 @@ void gc_init_fixed_size_free_list(gc_heap *h);
 void gc_request_mark_globals(void);
 void gc_mark_globals(object globals, object global_table);
 //size_t gc_sweep(gc_heap * h, size_t * sum_freed_ptr, gc_thread_data *thd);
-gc_heap *gc_sweep(gc_heap * h, gc_thread_data *thd);
+gc_heap *gc_sweep(gc_heap * h, gc_thread_data * thd);
 void gc_thr_grow_move_buffer(gc_thread_data * d);
 void gc_thread_data_init(gc_thread_data * thd, int mut_num, char *stack_base,
                          long stack_size);
@@ -460,7 +440,8 @@ void gc_post_handshake(gc_status_type s);
 void gc_wait_handshake();
 void gc_start_collector();
 void gc_mutator_thread_blocked(gc_thread_data * thd, object cont);
-void gc_mutator_thread_runnable(gc_thread_data * thd, object result, object maybe_copied);
+void gc_mutator_thread_runnable(gc_thread_data * thd, object result,
+                                object maybe_copied);
 void Cyc_make_shared_object(void *data, object k, object obj);
 #define set_thread_blocked(d, c) \
   gc_mutator_thread_blocked(((gc_thread_data *)d), (c))
@@ -527,7 +508,6 @@ void Cyc_make_shared_object(void *data, object k, object obj);
  */
 #define forward(obj) (((pair_type *) obj)->pair_car)
 
-
 /**
  * \defgroup gc_minor_mut Mutation table
  * @brief Mutation table to support the minor GC write barrier
@@ -542,7 +522,8 @@ void clear_mutations(void *data);
  * @brief Minor GC write barrier to ensure there are no references to stack objects from the heap.
  */
 /**@{*/
-object transport_stack_value(gc_thread_data *data, object var, object value, int *run_gc);
+object transport_stack_value(gc_thread_data * data, object var, object value,
+                             int *run_gc);
 /**@}*/
 
 /**@}*/
@@ -554,8 +535,9 @@ object transport_stack_value(gc_thread_data *data, object var, object value, int
  * \defgroup ffi Foreign Function Interface
  */
 /**@{*/
-object Cyc_scm_call(gc_thread_data *parent_thd, object fnc, int argc, object *args);
+object Cyc_scm_call(gc_thread_data * parent_thd, object fnc, int argc,
-object Cyc_scm_call_no_gc(gc_thread_data *parent_thd, object fnc, object arg);
+                    object * args);
+object Cyc_scm_call_no_gc(gc_thread_data * parent_thd, object fnc, object arg);
 /**@}*/
 
 /**
@@ -663,10 +645,10 @@ typedef uint32_t char_type;
 /**@{*/
 
 /** Function type */
-typedef void (*function_type) (void *data, object clo, int argc, object *args);
+typedef void (*function_type)(void *data, object clo, int argc, object * args);
 
 /** Non-CPS function type */
-typedef object (*inline_function_type) ();
+typedef object(*inline_function_type) ();
 
 /**
  * @brief C-variable integration type - wrapper around a Cyclone object pointer
@@ -917,11 +899,8 @@ typedef struct {
  * and provides constants for each of the comparison operators.
  */
 typedef enum {
-    CYC_BN_LTE = -2
+  CYC_BN_LTE = -2, CYC_BN_LT = MP_LT, CYC_BN_EQ = MP_EQ, CYC_BN_GT =
-  , CYC_BN_LT = MP_LT
+      MP_GT, CYC_BN_GTE = 2
-  , CYC_BN_EQ = MP_EQ
-  , CYC_BN_GT = MP_GT
-  , CYC_BN_GTE = 2
 } bn_cmp_type;
 
 /** 
@@ -1172,10 +1151,22 @@ typedef struct {
 } vector_type;
 typedef vector_type *vector;
 
-typedef struct { vector_type v; object arr[2]; } vector_2_type;
+typedef struct {
-typedef struct { vector_type v; object arr[3]; } vector_3_type;
+  vector_type v;
-typedef struct { vector_type v; object arr[4]; } vector_4_type;
+  object arr[2];
-typedef struct { vector_type v; object arr[5]; } vector_5_type;
+} vector_2_type;
+typedef struct {
+  vector_type v;
+  object arr[3];
+} vector_3_type;
+typedef struct {
+  vector_type v;
+  object arr[4];
+} vector_4_type;
+typedef struct {
+  vector_type v;
+  object arr[5];
+} vector_5_type;
 
 /** Create a new vector in the nursery */
 #define make_empty_vector(v) \
@@ -1270,6 +1261,9 @@ typedef pair_type *pair;
   n->pair_car = a; \
   n->pair_cdr = d;
 
+/** Create a new pair in the thread's heap */
+void *gc_alloc_pair(gc_thread_data * data, object head, object tail);
+
 /**
  * Set members of the given pair 
  * @param n - Pointer to a pair object
@@ -1300,9 +1294,21 @@ typedef pair_type *pair;
   (n))
 
 //typedef list_1_type pair_type;
-typedef struct { pair_type a; pair_type b; } list_2_type;
+typedef struct {
-typedef struct { pair_type a; pair_type b; pair_type c;} list_3_type;
+  pair_type a;
-typedef struct { pair_type a; pair_type b; pair_type c; pair_type d;} list_4_type;
+  pair_type b;
+} list_2_type;
+typedef struct {
+  pair_type a;
+  pair_type b;
+  pair_type c;
+} list_3_type;
+typedef struct {
+  pair_type a;
+  pair_type b;
+  pair_type c;
+  pair_type d;
+} list_4_type;
 
 /**
  * Create a pair with a single value. 
@@ -1531,7 +1537,7 @@ struct vpbuffer_t {
 };
 
 vpbuffer *vp_create(void);
-void vp_add(vpbuffer *v, void *obj);
+void vp_add(vpbuffer * v, void *obj);
 
 /* Utility functions */
 void **vpbuffer_realloc(void **buf, int *len);
@@ -1540,10 +1546,10 @@ void vpbuffer_free(void **buf);
 
 /* Bignum utility functions */
 int Cyc_bignum_cmp(bn_cmp_type type, object x, int tx, object y, int ty);
-void Cyc_int2bignum(int n, mp_int *bn);
+void Cyc_int2bignum(int n, mp_int * bn);
 
 /* Remaining GC prototypes that require objects to be defined */
-void *gc_alloc_from_bignum(gc_thread_data *data, bignum_type *src);
+void *gc_alloc_from_bignum(gc_thread_data * data, bignum_type * src);
 
 /**
  * Do a minor GC
@@ -1552,5 +1558,6 @@ void *gc_alloc_from_bignum(gc_thread_data *data, bignum_type *src);
 int gc_minor(void *data, object low_limit, object high_limit, closure cont,
              object * args, int num_args);
 
-void Cyc_import_shared_object(void *data, object cont, object filename, object entry_pt_fnc);
+void Cyc_import_shared_object(void *data, object cont, object filename,
+                              object entry_pt_fnc);
 #endif                          /* CYCLONE_TYPES_H */

libs/cyclone/foreign.sld

@@ -14,6 +14,7 @@
   (export
    opaque?
    opaque-null?
+   make-opaque
    
    c-code
    c-value
@@ -31,6 +32,11 @@
       "Cyc_check_opaque(data, p);
        return_closcall1(data, k, make_boolean(opaque_ptr(p) == NULL));")
 
+    (define-c make-opaque
+      "(void *data, int argc, closure _, object k)"
+      "make_c_opaque(opq, NULL);
+       return_closcall1(data, k, &opq);")
+
     ;; (c-define-type name type (pack (unpack)))
     (define-syntax c-define-type
       (er-macro-transformer
@@ -83,7 +89,6 @@
     ;;  - type - Data type of the Scheme object
     ;; Returns:
     ;;  - C code used to unbox the data
-                                        ;(define (scm->c code type)
     (define-syntax scm->c
       (er-macro-transformer
        (lambda (expr rename compare)

mstreams.c

@@ -32,7 +32,16 @@ if (obj_is_not_closure(clo)) { \
  } \
 }
 
-object Cyc_heap_alloc_port(void *data, port_type *p);
+int Cyc_have_mstreams()
+{
+#if CYC_HAVE_FMEMOPEN && CYC_HAVE_OPEN_MEMSTREAM
+  return 1;
+#else
+  return 0;
+#endif
+}
+
+object Cyc_heap_alloc_port(void *data, port_type * p);
 port_type *Cyc_io_open_input_string(void *data, object str)
 {
   // Allocate port on the heap so the location of mem_buf does not change
@@ -40,7 +49,7 @@ port_type *Cyc_io_open_input_string(void *data, object str)
   make_input_port(sp, NULL, CYC_IO_BUF_LEN);
 
   Cyc_check_str(data, str);
-  p = (port_type *)Cyc_heap_alloc_port(data, &sp);
+  p = (port_type *) Cyc_heap_alloc_port(data, &sp);
   errno = 0;
 #if CYC_HAVE_FMEMOPEN
   p->str_bv_in_mem_buf = malloc(sizeof(char) * (string_len(str) + 1));
@@ -48,8 +57,9 @@ port_type *Cyc_io_open_input_string(void *data, object str)
   memcpy(p->str_bv_in_mem_buf, string_str(str), string_len(str));
   p->fp = fmemopen(p->str_bv_in_mem_buf, string_len(str), "r");
 #endif
-  if (p->fp == NULL){
+  if (p->fp == NULL) {
-    Cyc_rt_raise2(data, "Unable to open input memory stream", obj_int2obj(errno));
+    Cyc_rt_raise2(data, "Unable to open input memory stream",
+                  obj_int2obj(errno));
   }
   return p;
 }
@@ -61,16 +71,17 @@ port_type *Cyc_io_open_input_bytevector(void *data, object bv)
   make_input_port(sp, NULL, CYC_IO_BUF_LEN);
 
   Cyc_check_bvec(data, bv);
-  p = (port_type *)Cyc_heap_alloc_port(data, &sp);
+  p = (port_type *) Cyc_heap_alloc_port(data, &sp);
   errno = 0;
 #if CYC_HAVE_FMEMOPEN
-  p->str_bv_in_mem_buf = malloc(sizeof(char) * ((bytevector)bv)->len);
+  p->str_bv_in_mem_buf = malloc(sizeof(char) * ((bytevector) bv)->len);
-  p->str_bv_in_mem_buf_len = ((bytevector)bv)->len;
+  p->str_bv_in_mem_buf_len = ((bytevector) bv)->len;
-  memcpy(p->str_bv_in_mem_buf, ((bytevector)bv)->data, ((bytevector)bv)->len);
+  memcpy(p->str_bv_in_mem_buf, ((bytevector) bv)->data, ((bytevector) bv)->len);
-  p->fp = fmemopen(p->str_bv_in_mem_buf, ((bytevector)bv)->len, "r");
+  p->fp = fmemopen(p->str_bv_in_mem_buf, ((bytevector) bv)->len, "r");
 #endif
-  if (p->fp == NULL){
+  if (p->fp == NULL) {
-    Cyc_rt_raise2(data, "Unable to open input memory stream", obj_int2obj(errno));
+    Cyc_rt_raise2(data, "Unable to open input memory stream",
+                  obj_int2obj(errno));
   }
   return p;
 }
@@ -80,20 +91,21 @@ port_type *Cyc_io_open_output_string(void *data)
   // Allocate port on the heap so the location of mem_buf does not change
   port_type *p;
   make_port(sp, NULL, 0);
-  p = (port_type *)Cyc_heap_alloc_port(data, &sp);
+  p = (port_type *) Cyc_heap_alloc_port(data, &sp);
   errno = 0;
 #if CYC_HAVE_OPEN_MEMSTREAM
   p->fp = open_memstream(&(p->str_bv_in_mem_buf), &(p->str_bv_in_mem_buf_len));
 #endif
-  if (p->fp == NULL){
+  if (p->fp == NULL) {
-    Cyc_rt_raise2(data, "Unable to open output memory stream", obj_int2obj(errno));
+    Cyc_rt_raise2(data, "Unable to open output memory stream",
+                  obj_int2obj(errno));
   }
   return p;
 }
 
 void Cyc_io_get_output_string(void *data, object cont, object port)
 {
-  port_type *p = (port_type *)port;
+  port_type *p = (port_type *) port;
   Cyc_check_port(data, port);
   if (p->fp) {
     fflush(p->fp);
@@ -103,14 +115,14 @@ void Cyc_io_get_output_string(void *data, object cont, object port)
   }
   {
     make_string_with_len(s, p->str_bv_in_mem_buf, p->str_bv_in_mem_buf_len);
-    s.num_cp = Cyc_utf8_count_code_points((uint8_t *)string_str(&s));
+    s.num_cp = Cyc_utf8_count_code_points((uint8_t *) string_str(&s));
     return_closcall1(data, cont, &s);
   }
 }
 
 void Cyc_io_get_output_bytevector(void *data, object cont, object port)
 {
-  port_type *p = (port_type *)port;
+  port_type *p = (port_type *) port;
   Cyc_check_port(data, port);
   if (p->fp) {
     fflush(p->fp);
@@ -121,8 +133,8 @@ void Cyc_io_get_output_bytevector(void *data, object cont, object port)
   {
     object bv;
     alloc_bytevector(data, bv, p->str_bv_in_mem_buf_len);
-    memcpy(((bytevector)bv)->data, p->str_bv_in_mem_buf, p->str_bv_in_mem_buf_len);
+    memcpy(((bytevector) bv)->data, p->str_bv_in_mem_buf,
+           p->str_bv_in_mem_buf_len);
     return_closcall1(data, cont, bv);
   }
 }
-

scheme/base.sld

@@ -205,15 +205,10 @@
     write-u8
     binary-port?
     textual-port?
-
+    rationalize
 ;;;;
 ; Possibly missing functions:
-;
 ;    u8-ready?
-;
-;    ; No complex or rational numbers at this time
-;    rationalize
-;
 ;    ;; syntax-rules
 ;;;;
   )
@@ -235,6 +230,9 @@
   (begin
     ;; Features implemented by this Scheme
     (define (features) 
+      (let ((feats *other-features*))
+        (if (> (string-length (Cyc-compilation-environment 'memory-streams)) 0)
+          (set! feats (cons 'memory-streams feats)))
         (cons 
           'cyclone
           (cons
@@ -242,7 +240,7 @@
               (string-append "version-" *version-number*))
             (cons
               (string->symbol (Cyc-compilation-environment 'platform))
-            *other-features*))))
+              feats)))))
 
     (define *other-features* 
             '(r7rs 
@@ -409,7 +407,7 @@
                   (else (error "cond-expand: bad feature" x)))
                 (memq x (features))))
           (let expand ((ls (cdr expr)))
-            (cond ((null? ls))  ; (error "cond-expand: no expansions" expr)
+            (cond ((null? ls)  (error "cond-expand: no expansions" expr))
                   ((not (pair? (car ls))) (error "cond-expand: bad clause" (car ls)))
                   ((eq? 'else (caar ls)) ;(identifier->symbol (caar ls)))
                    (if (pair? (cdr ls))
@@ -691,10 +689,27 @@
       (if (null? port)
         (Cyc-read-char (current-input-port))
         (Cyc-read-char (car port))))
-    (define (read-line . port)
+    (define (read-line . o)
-      (if (null? port)
+      (let* ((port (if (null? o)
-        (Cyc-read-line (current-input-port))
+                       (current-input-port)
-        (Cyc-read-line (car port))))
+                       (car o)))
+             (str (Cyc-read-line port)))
+        (cond
+          ((eof-object? str) str)
+          ((< (string-length str) 1022) str)
+          (else (_read-line str port)))))
+    ;; Helper function to handle case where a line is too
+    ;; long to be read by a single runtime I/O call
+    (define (_read-line str port)
+      (let loop ((lis (list str))
+                 (str (Cyc-read-line port)))
+        (cond
+          ((eof-object? str)
+           (apply string-append (reverse lis)))
+          ((< (string-length str) 1022)
+           (apply string-append (reverse (cons str lis))))
+          (else
+            (loop (cons str lis) (Cyc-read-line port))))))
     (define (read-string k . opts)
       (let ((port (if (null? opts)
                       (current-input-port)
@@ -1236,13 +1251,16 @@
     (define error-object-message car)
     (define error-object-irritants cdr)
     (define (error msg . args)
-      (raise (cons msg args)))
+      (raise-error (cons msg args)))
     (define (raise obj)
       ((Cyc-current-exception-handler) 
-        (cons 'raised (if (pair? obj) obj (list obj)))))
+        (cons 'raised obj)))
     (define (raise-continuable obj)
       ((Cyc-current-exception-handler) 
-        (cons 'continuable (if (pair? obj) obj (list obj)))))
+        (cons 'continuable obj)))
+    (define (raise-error obj)
+      ((Cyc-current-exception-handler) 
+        (cons 'error obj)))
     ;; A simpler exception handler based on the one from Bigloo:
     ;; https://www-sop.inria.fr/indes/fp/Bigloo/doc/bigloo-17.html#g20889
     ;(define (with-handler handler body)
@@ -1342,25 +1360,29 @@
 
   (define-c floor
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, floor, z); "
+    " return_double_op(data, k, floor, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, floor, z);")
+    " return_double_op_no_cps(data, ptr, floor, z);")
   (define-c ceiling
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, ceil, z); "
+    " return_double_op(data, k, ceil, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, ceil, z);")
+    " return_double_op_no_cps(data, ptr, ceil, z);")
   (define-c truncate
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, (int), z); "
+    " return_double_op(data, k, trunc, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, (int), z);")
+    " return_double_op_no_cps(data, ptr, trunc, z);")
   (define-c round
     "(void *data, int argc, closure _, object k, object z)"
-    " return_exact_double_op(data, k, round, z); "
+    " return_double_op(data, k, round_to_nearest_even, z); "
     "(void *data, object ptr, object z)"
-    " return_exact_double_op_no_cps(data, ptr, round, z);")
+    " return_double_op_no_cps(data, ptr, round_to_nearest_even, z);")
-  (define exact truncate)
+  (define-c exact
+    "(void *data, int argc, closure _, object k, object z)"
+    " Cyc_exact(data, k, z); "
+    "(void *data, object ptr, object z)"
+    " return Cyc_exact_no_cps(data, ptr, z);")
   (define-c inexact
     "(void *data, int argc, closure _, object k, object z)"
     " return_inexact_double_or_cplx_op(data, k, (double), (double complex), z); "
@@ -1375,6 +1397,9 @@
         alloc_bignum(data, bn);
         BIGNUM_CALL(mp_abs(&bignum_value(num), &bignum_value(bn)));
         return_closcall1(data, k, bn);
+      } else if (is_object_type(num) && type_of(num) == complex_num_tag){
+        make_double(d, cabs(((complex_num_type *)num)->value));
+        return_closcall1(data, k, &d);
       } else {
         make_double(d, fabs(((double_type *)num)->value));
         return_closcall1(data, k, &d);
@@ -1389,8 +1414,14 @@
       (if (< b 0)
         (if (<= res 0) res (+ res b))
         (if (>= res 0) res (+ res b)))))
-  (define (odd? num)   (= (modulo num 2) 1))
+  (define (odd? num)
-  (define (even? num)  (= (modulo num 2) 0))
+    (if (integer? num)
+        (= (modulo num 2) 1)
+        (error "Not an integer" num)))
+  (define (even? num) 
+    (if (integer? num)
+        (= (modulo num 2) 0)
+        (error "Not an integer" num)))
   (define-c bignum?
     "(void *data, int argc, closure _, object k, object obj)"
     " return_closcall1(data, k, Cyc_is_bignum(obj)); ")
@@ -1409,10 +1440,10 @@
       (error "exact non-negative integer required" k))
     (let* ((s (if (bignum? k)
                   (bignum-sqrt k)
-                  (exact (truncate (sqrt k)))))
+                  (exact (truncate (_sqrt k)))))
            (r (- k (* s s))))
       (values s r)))
-  (define-c sqrt
+  (define-c _sqrt
     "(void *data, int argc, closure _, object k, object z)"
     " return_inexact_double_op(data, k, sqrt, z);"
     "(void *data, object ptr, object z)"
@@ -1450,6 +1481,9 @@
     "(void *data, object ptr, object z)"
     " return Cyc_is_complex(z); ")
   (define rational? number?)
+  ;; Stub, doesn't do much now because rationals are not supported
+  (define (rationalize x y)
+    (/ x y))
   (define (max first . rest) (foldl (lambda (old new) (if (> old new) old new)) first rest))
   (define (min first . rest) (foldl (lambda (old new) (if (< old new) old new)) first rest))
   ; Implementations of gcd and lcm using Euclid's algorithm
@@ -1492,8 +1526,17 @@
     "(void *data, int argc, closure _, object k, object n)"
     " Cyc_get_ratio(data, k, n, 0);")
 
+  (define-c fixnum?
+    "(void *data, int argc, closure _, object k, object obj)"
+    " return_closcall1(data, k, 
+        obj_is_int(obj) ? boolean_t : boolean_f); "
+    "(void *data, object ptr, object obj)"
+    " return obj_is_int(obj) ? boolean_t : boolean_f; ")
+
   (define (quotient x y)
-    (truncate (/ x y)))
+    (if (and (fixnum? x) (fixnum? y))
+        (exact (truncate (/ x y)))
+        (truncate (/ x y))))
 
   (define truncate-quotient quotient)
   (define truncate-remainder remainder)

scheme/cyclone/common.sld

@@ -18,7 +18,7 @@
     memloc
   )
   (begin
-(define *version-number* "0.31.0")
+(define *version-number* "0.37.0")
 (define *version-name* "")
 (define *version* (string-append *version-number* " " *version-name* ""))
 
@@ -32,7 +32,7 @@
        @@     @@     Cyclone Scheme->C compiler
       ,@             http://justinethier.github.io/cyclone/
       '@        
-      .@             (c) 2014-2021 Justin Ethier
+      .@             (c) 2014-2025 Justin Ethier
        @@     #@     Version " *version* "
        `@@@#@@@.
         #@@@@@   
@@ -49,7 +49,7 @@
  ** This file was automatically generated by the Cyclone scheme compiler
  ** http://justinethier.github.io/cyclone/
  **
- ** (c) 2014-2021 Justin Ethier
+ ** (c) 2014-2024 Justin Ethier
  ** Version " *version* "
  **
  **/

scheme/cyclone/cps-opt-analyze-call-graph.scm

@@ -20,7 +20,8 @@
             (srfi 2)
             (srfi 69)
             )
-    ))
+    )
+  (else #f))
 
 ;; symbol -> hash-table -> boolean
 ;; Is it OK to inline code replacing ref, based on call graph data from lookup table?
@@ -261,4 +262,5 @@
     ;  (ast:ast->pp-sexp
     ;    (opt:local-var-reduction (ast:sexp->ast sexp)))
     ;)
-))
+)
+(else #f))

scheme/cyclone/cps-opt-local-var-redux.scm

@@ -14,7 +14,9 @@
             (scheme cyclone ast) 
             (scheme cyclone primitives)
             (scheme cyclone util) 
-            (scheme cyclone pretty-print))))
+            (scheme cyclone pretty-print)))
+  (else
+    #f))
 
 ;; Local variable reduction:
 ;; Reduce given sexp by replacing certain lambda calls with a let containing
@@ -434,4 +436,5 @@
       (ast:ast->pp-sexp
         (opt:local-var-reduction (ast:sexp->ast sexp)))
     )
-    ))
+    )
+  (else #f))

scheme/cyclone/cps-opt-memoize-pure-fncs.scm

@@ -18,9 +18,9 @@
             (scheme cyclone util) 
             (scheme cyclone pretty-print)
             (srfi 2)
-            (srfi 69)
+            (srfi 69)))
-            )
+  (else
-    ))
+    #f))
 
 ;; Predicate to determine if a function can be memoized
 ;; var - symbol - global name of the function
@@ -371,4 +371,5 @@
 ;;    ;  (ast:ast->pp-sexp
 ;;    ;    (opt:local-var-reduction (ast:sexp->ast sexp)))
 ;;    ;)
-))
+)
+(else #f))

scheme/cyclone/cps-optimizations.sld

@@ -1057,7 +1057,8 @@
                     (lambda (arg)
                       (and (prim-call? arg)
                            ;; Do not inline functions that are looping over lists, seems counter-productive
-                           (not (member (car arg) '( member assoc Cyc-fast-member Cyc-fast-assoc assq assv memq memv)))
+                           ;; Or functions that may be harmful to call more than once such as system
+                           (not (member (car arg) '( member assoc Cyc-fast-member Cyc-fast-assoc assq assv memq memv system)))
                            (not (prim:cont? (car arg)))))
                     (cdr exp))
                   ;; Disallow primitives that allocate a new obj,
@@ -1664,7 +1665,7 @@
 
     ;; Full beta expansion phase, make a pass over all of the program's AST
     (define (opt:beta-expand exp)
-;(write `(DEBUG opt:beta-expand ,exp)) (newline)
+      ;(trace:info `(opt:beta-expand ,exp)) (flush-output-port)
       (cond
        ((ast:lambda? exp)
         (ast:%make-lambda
@@ -1693,6 +1694,7 @@
        (else exp)))
 
     (define (analyze-cps exp)
+      ;(trace:info `(analyze-cps ,exp))
       (analyze:find-named-lets exp)
       (analyze:find-direct-recursive-calls exp)
       (analyze:find-recursive-calls exp)
@@ -2229,11 +2231,17 @@
       (scan (if->then exp) def-sym)
       (scan (if->else exp) def-sym))
      ((app? exp)
-      (when (equal? (car exp) def-sym)
+      ;(trace:info `(analyze:find-recursive-calls scan app ,exp))
+      (cond
+        ((equal? (car exp) def-sym)
          (trace:info `("recursive call" ,exp))
          (with-var! def-sym (lambda (var)
-          (adbv:set-self-rec-call! var #t)))
+           (adbv:set-self-rec-call! var #t))))
-        ))
+        (else
+          (for-each
+            (lambda (e)
+              (scan e def-sym))
+            exp))))
      (else #f)))
 
   ;; TODO: probably not good enough, what about recursive functions that are not top-level??

scheme/cyclone/libraries.sld

@@ -286,10 +286,13 @@
 ;obviously also need to expand cond-expand in cases where the code reads sld files to track down library dependencies
 
 ;; Take given define-library expression and cond-expand all declarations
-(define (lib:cond-expand expr expander)
+(define (lib:cond-expand filepath expr expander)
+  ;; parametrize include, and include-ci during expand, inside
+  ;; expander.
+  (parameterize ((current-expand-filepath filepath))
     (let ((name (cadr expr))
           (decls (lib:cond-expand-decls (cddr expr) expander)))
-    `(define-library ,name ,@decls)))
+      `(define-library ,name ,@decls))))
 
 (define (lib:cond-expand-decls decls expander)
   (reverse
@@ -462,7 +465,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (imports (lib:imports (car lib*))))
     (close-input-port fp)
@@ -485,7 +488,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (options (lib:c-linker-options (car lib*))))
     (close-input-port fp)
@@ -505,7 +508,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (options (lib:c-compiler-options (car lib*))))
     (close-input-port fp)
@@ -526,7 +529,7 @@
          (fp (open-input-file dir))
          (lib (read-all fp))
          (lib* (if expander
-                   (list (lib:cond-expand (car lib) expander))
+                   (list (lib:cond-expand dir (car lib) expander))
                    lib))
          (exports (lib:exports (car lib*))))
     (close-input-port fp)

scheme/cyclone/pass-validate-syntax.scm

@@ -14,7 +14,8 @@
       (scheme base)
       (scheme read)
       (scheme cyclone pretty-print)
-      (scheme cyclone util))))
+      (scheme cyclone util)))
+   (else #f))
 ;;
 ;; TODO: call this from cyclone.scm after it works, probably after "resolve macros"
 
@@ -59,7 +60,9 @@
   (define (search exp vars)
     (cond-expand
       (program
-        (pretty-print `(search ,exp ,vars))(newline))) ;; Debugging
+        (pretty-print `(search ,exp ,vars))(newline)) ;; Debugging
+      (else
+        #f))
     (cond
       ;((ast:lambda? exp) 'TODO)
       ((const? exp) #f)
@@ -111,4 +114,5 @@
     ;(if 1 2 3 4)
     
      (let ((sexp (read-all (open-input-file "validation.scm"))))
-      (validate-keyword-syntax sexp))))
+      (validate-keyword-syntax sexp)))
+  (else #f))

scheme/cyclone/primitives.sld

@@ -665,9 +665,9 @@
          ((eq? p 'Cyc-fast-member)  "memberp")
          ((eq? p 'Cyc-fast-assoc)   "assoc")
          ((eq? p 'assq)          "assq")
-         ((eq? p 'assv)          "assq")
+         ((eq? p 'assv)          "assv")
          ((eq? p 'memq)          "memqp")
-         ((eq? p 'memv)          "memqp")
+         ((eq? p 'memv)          "memvp")
          ((eq? p 'boolean?)      "Cyc_is_boolean")
          ((eq? p 'char?)         "Cyc_is_char")
          ((eq? p 'null?)         "Cyc_is_null")

scheme/cyclone/util.sld

@@ -93,7 +93,8 @@
     string-replace-all
     take
     drop
-    filter)
+    filter
+    current-expand-filepath)
   (inline
     env:frame-values
     env:frame-variables
@@ -113,6 +114,8 @@
   )
   (begin
 
+(define current-expand-filepath (make-parameter #f))
+
 (define (tagged-list? tag exp)
   (if (pair? exp)
       (equal? (car exp) tag)

scheme/eval.sld

@@ -89,17 +89,26 @@
       ((analyze exp *global-environment* rename-env '()) *global-environment*)
       ((analyze exp (car env) rename-env '()) (car env))))
 
+;; Called from the C runtime to support apply
 (define (eval-from-c exp . _env)
   (let ((env (if (null? _env) *global-environment* (car _env))))
     (eval (wrapc exp) env)))
 
-;; Expressions received from C code are already evaluated, but sometimes too much so.
+;; Helper function for eval-from-c
-;; Try to wrap 
+;; 
+;; Expressions received from C code are already evaluated, 
+;; however any quoted expressions will have the quotes
+;; stripped off. This is a problem for expressions that
+;; aren't self evaluating - like (1 2) - so we re-quote
+;; the expressions here so a subsequent eval will work.
+;;
 (define (wrapc exp)
   (cond 
     ((application? exp)
      (cond
-       ((compound-procedure? (car exp))
+       ((or (primitive-procedure? (car exp)) 
+            (compound-procedure? (car exp))
+            (procedure? (car exp)))
         (cons 
           (car exp)
           (map 
@@ -611,19 +620,19 @@
                   #f))
          (expand 
            (lambda (macro-op)
-             ;(define use-env (env:extend-environment '() '() '()))
              (if (Cyc-macro? macro-op)
                ;; Compiled macro, call directly
-               (let ((expanded
+               (let* ((expanded (_expand exp a-env rename-env '() local-renamed))
-                        (macro:expand exp (list 'macro macro-op) a-env rename-env local-renamed)))
+                      (cleaned (macro:cleanup expanded rename-env)))
-                 (analyze expanded 
+                 (analyze cleaned
                           a-env
                           rename-env
                           local-renamed))
                ;; Interpreted macro, build expression and eval
-               (let* ((expanded (macro:expand exp (list 'macro macro-op) a-env rename-env local-renamed)))
+               (let* ((expanded (_expand exp a-env rename-env '() local-renamed))
+                      (cleaned (macro:cleanup expanded rename-env)))
                  (analyze
-                   expanded
+                   cleaned
                    a-env
                    rename-env
                    local-renamed))))))
@@ -636,14 +645,9 @@
 ;(display "/* ")
 ;(write (list exp))
 ;(display "*/ ")
-       (let ((fncs 
+       (let ((fncs (Cyc-map-loop-1 (lambda (expr) 
-               ;; Our map starts from the end, we reverse
-               ;; so everything is evaluated in order, then
-               ;; reverse again so results are in order
-               (reverse
-                 (map (lambda (expr) 
                                       (analyze expr a-env rename-env local-renamed))
-                      (reverse (cdr exp))))))
+                                   (cdr exp))))
          (lambda (env)
            (foldl (lambda (fnc _) (fnc env)) #f fncs))))
       ;; compiled macro
@@ -917,6 +921,10 @@
 ;(newline)
 ;(display "*/ ")
          (cond 
+           ((and (pair? expr) ;; Improper list
+                 (not (list? expr)))
+            (cons (clean (car expr) bv)
+                  (clean (cdr expr) bv)))
            ((const? expr)      expr)
            ((null? expr)       expr)
            ((quote? expr)      
@@ -978,8 +986,14 @@
 ;TODO: modify this whole section to use macros:get-env instead of *defined-macros*. macro:get-env becomes the mac-env. any new scopes need to extend that env, and an env parameter needs to be added to (expand). any macros defined with define-syntax use that env as their mac-env (how to store that)?
 ; expand : exp -> exp
 
-(define (expand exp env rename-env)
+(define (expand exp . opts)
-  (_expand exp env rename-env '() '()))
+  (let ((env (if (> (length opts) 0) 
+                 (car opts)
+                 *global-environment*))
+        (rename-env (if (> (length opts) 1) 
+                        (cadr opts) 
+                        (env:extend-environment '() '() '()))))
+    (_expand exp env rename-env '() '())))
 
 ;; Internal implementation of expand
 ;; exp - Expression to expand

scheme/inexact.sld

@@ -69,7 +69,6 @@
             (/ (c-log z1) (c-log z2*)))))
     (define-inexact-op c-log "log"   "clog")
     (define-inexact-op exp   "exp"   "cexp")
-    (define-inexact-op sqrt  "sqrt"  "csqrt")
     (define-inexact-op sin   "sin"   "csin")
     (define-inexact-op cos   "cos"   "ccos")
     (define-inexact-op tan   "tan"   "ctan")
@@ -93,4 +92,58 @@
                         (* (if (eqv? y -0.0) -1 1)
                            (if (eqv? x -0.0) 3.141592653589793 x))
                         (atan1 (/ y x))))))))
+
+ (define-c
+   sqrt
+   "(void *data, int argc, closure _, object k, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+   
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return_closcall1(data, k, obj_int2obj(creal(result)));
+       }
+       make_double(d, creal(result));
+       return_closcall1(data, k, &d);
+     } else {
+       complex_num_type cn;
+       assign_complex_num((&cn), result);
+       return_closcall1(data, k, &cn);
+     } "
+   "(void *data, object ptr, object z)"
+   " double complex result;
+     Cyc_check_num(data, z);
+     if (obj_is_int(z)) {
+       result = csqrt(obj_obj2int(z));
+     } else if (type_of(z) == integer_tag) {
+       result = csqrt(((integer_type *)z)->value);
+     } else if (type_of(z) == bignum_tag) {
+       result = csqrt(mp_get_double(&bignum_value(z)));
+     } else if (type_of(z) == complex_num_tag) {
+       result = csqrt(complex_num_value(z));
+     } else {
+       result = csqrt(((double_type *)z)->value);
+     }
+  
+     if (cimag(result) == 0.0) {
+       if (obj_is_int(z) && creal(result) == round(creal(result))) {
+         return obj_int2obj(creal(result));
+       }
+       assign_double(ptr, creal(result));
+     } else {
+       assign_complex_num(ptr, result);
+     }
+     return ptr;
+     ")
 ))

scheme/read.sld

@@ -9,6 +9,7 @@
 (define-library (scheme read)
   (import (scheme base)
           (scheme cyclone common)
+          (scheme cyclone util)
           ;(scheme write)
           (scheme char))
   (export
@@ -31,17 +32,37 @@
 (define-syntax include
   (er-macro-transformer
    (lambda (expr rename compare)
-     (apply
+
-      append
+     (define (dirname filename)
-      (cons
+       (let loop ((index (string-length filename)))
-        '(begin)
+         (if (zero? index)
-         (map
+             ""
-          (lambda (filename)
+             (let ((index (- index 1)))
+               (if (char=? (string-ref filename index) #\/)
+                   (substring filename 0 index)
+                   (loop index))))))
+
+     (define (massage filename)
+       (cond
+        ;; may happen in the REPL
+        ((not (current-expand-filepath)) filename)
+        ;; absolute filename
+        ((char=? (string-ref filename 0) #\/) filename)
+        ;; otherwise, open the file relative to the library that is
+        ;; expanded
+        (else (let ((target (string-append (dirname (current-expand-filepath)) "/" filename)))
+                ;; if the target exists use, otherwise fallback to the
+                ;; backward compatible behavior.
+                (if (file-exists? target)
+                    target
+                    filename)))))
+
+     `(begin
+        ,@(let ((filename (massage (cadr expr))))
             (call-with-port
               (open-input-file filename)
               (lambda (port)
-                (read-all/source port filename))))
+                (read-all/source port filename))))))))
-          (cdr expr)))))))
 
 (define-syntax include-ci
   (er-macro-transformer
@@ -158,6 +179,12 @@
   "(void *data, object ptr, object opq)"
   " return(Cyc_is_string(opaque_ptr(opq)));")
 
+(define-c Cyc-opaque->string
+  "(void *data, int argc, closure _, object k, object opq)"
+  " return_closcall1(data, k, opaque_ptr(opq));"
+  "(void *data, object ptr, object opq)"
+  " return(opaque_ptr(opq));")
+
 (define-c Cyc-opaque-unsafe-string->number
   "(void *data, int argc, closure _, object k, object opq)"
   " Cyc_string2number_(data, k, opaque_ptr(opq));")
@@ -205,7 +232,10 @@
       ((Cyc-opaque? token)
        (cond
          ((Cyc-opaque-unsafe-string? token)
-          (Cyc-opaque-unsafe-string->number token))
+          (let ((rv (Cyc-opaque-unsafe-string->number token)))
+            (if rv
+                rv
+                (error "Invalid numeric syntax" (Cyc-opaque->string token)))))
          ;; Open paren, start read loop
          ((Cyc-opaque-unsafe-eq? token #\()
           (let ((line-num (get-line-num fp))
@@ -264,7 +294,10 @@
                                    (substring t 0 end)
                                    (substring t end (- len 1))))
                      (real (string->number real-str))
-                     (imag (string->number imag-str))
+                     (imag (cond
+                             ((equal? "+" imag-str) 1)  ;; Special case, +i w/no number
+                             ((equal? "-" imag-str) -1) ;; Special case, -i
+                             (else (string->number imag-str))))
                     )
                 (Cyc-make-rect real imag)))
              (else

scheme/repl.sld

@@ -20,9 +20,9 @@
     (define (repl)
       (with-handler
         (lambda (obj)
-          (display "Error: ")
           (cond
             ((error-object? obj)
+             (display "Error: ")
              (display (error-object-message obj))
              (if (not (null? (error-object-irritants obj)))
                  (display ": "))
@@ -31,22 +31,13 @@
                  (write o)
                  (display " "))
                (error-object-irritants obj)))
-            ((pair? obj)
-             (when (string? (car obj))
-               (display (car obj))
-               (if (not (null? (cdr obj)))
-                   (display ": "))
-               (set! obj (cdr obj)))
-             (for-each
-               (lambda (o)
-                 (write o)
-                 (display " "))
-               obj))
             (else
+              (display "Error: ")
               (display obj)))
           (newline)
           (repl))
         (display "cyclone> ")
+        (flush-output-port)
         (let ((obj (read)))
           (if (eof-object? obj)
               (newline) ;; Quick way to exit REPL

scripts/check-c-formatting.sh

@@ -0,0 +1,16 @@
+#!/bin/bash
+
+FORMAT_CMD="indent -linux -l80 -i2 -nut"
+FILE=$1
+TMP=$(mktemp)
+
+$FORMAT_CMD $FILE -o $TMP
+
+diff $FILE $TMP > /dev/null
+#ret=$?
+#
+#if [[ $ret -eq 0 ]]; then
+#    echo "passed."
+#else
+#    echo "failed."
+#fi

scripts/convert-doc-index.scm

@@ -48,7 +48,7 @@
   (when (not (eof-object? line))
     (with-handler
       (lambda (obj)
-        (display `(Error processing line ,line details ,obj)))
+        (display `(Error processing line ,line details ,obj) (current-error-port)))
       (display (convert-line line))
       (newline))
         

scripts/generate-doc-index.sh

@@ -2,7 +2,7 @@
 # Cyclone Scheme
 # https://github.com/justinethier/cyclone
 #
-# Copyright (c) 2014-2016, Justin Ethier
+# Copyright (c) 2014-2022, Justin Ethier
 # All rights reserved.
 #
 # Generate a sorted list of functions/variables from the API documentation.
@@ -18,3 +18,30 @@ grep -r "^- \[" docs/api/srfi/* | ./scripts/convert-doc-index >> $TMP
 grep -r "^\[" docs/api/srfi/* | ./scripts/convert-doc-index >> $TMP
 grep -r "^\[" docs/api/cyclone/* | ./scripts/convert-doc-index >> $TMP
 sort $TMP | ./scripts/alphabetize > $API
+
+# --------------------------------------------------------------------------------
+# Index with SEXP format (needed by Winds)
+# The sed command bellow transforms...
+
+#                                        ; newline
+#- - -                                   ; hyphens used as sections divs
+#[`abs`](api/scheme/base.md#abs)         ; Markdown link
+#[`acos`](api/scheme/inexact.md#acos)    ; Markdown link
+
+# ...into...
+
+#((abs (scheme base))                     ; ((definition1 library-that-contains-it)
+# (acos (scheme inexact)))                ;  (definition2 library-that-contains-it))
+
+API_SEXP=api-index.scm
+sed -e '/^-\|^$/d'           \
+    -e 's/\[`/(/'            \
+    -e 's/`\](api\// (/'     \
+    -e 's/.md.*$/))/'        \
+    -e 's/\// /g'            \
+    -e 's/[[:space:]]\+/ /g' $API > $API_SEXP
+
+# Add extra opening and closing parentheses
+sed -e '1s/^/(/'             \
+    -e '$s/$/)/'             \
+    -i $API_SEXP

srfi/106.sld

@@ -388,7 +388,7 @@
 #ifdef AI_V4MAPPED
       return_closcall1(data, k, obj_int2obj(AI_V4MAPPED)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_V4MAPPED is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (define *ai-all* (ai-all))
@@ -398,7 +398,7 @@
 #ifdef AI_ALL
       return_closcall1(data, k, obj_int2obj(AI_ALL)); 
 #else
-      Cyc_rt_raise_msg(data, \"AI_ALL is not available on this platform\");
+      return_closcall1(data, k, obj_int2obj(0)); 
 #endif
       ")
     (make-const ai-addrconfig  "AI_ADDRCONFIG" )

srfi/143.sld

@@ -36,9 +36,6 @@
     fxbit-field-rotate fxbit-field-reverse
   )
   (inline
-    fx-width
-    fx-greatest
-    fx-least
     fixnum?
     fx=?  fx<? fx>? fx<=? fx>=?
     fxzero? fxpositive? fxnegative? fxodd? fxeven?
@@ -50,15 +47,15 @@
     fxarithmetic-shift 
     fxarithmetic-shift-left fxarithmetic-shift-right
     fxbit-count 
-    fxif fxbit-set? fxcopy-bit
+    fxif fxcopy-bit
     fxfirst-set-bit 
     fxbit-field
     mask
   )
   (begin
-    (define (fx-width) 31)
+    (define fx-width 31)
-    (define (fx-greatest) 1073741823)
+    (define fx-greatest 1073741823)
-    (define (fx-least)   -1073741824)
+    (define fx-least   -1073741824)
 
     (define-syntax bin-num-op
       (er-macro-transformer
@@ -161,16 +158,22 @@
          return_closcall1(data, k, obj_int2obj(count));")
 
     (define (fxlength  i)
+      (exact 
         (ceiling (/ (log (if (fxnegative? i)
                              (fxneg i)
                              (fx+ 1 i)))
-                  (log 2))))
+                    (log 2)))))
 
     (define (fxif mask n0 n1)
       (fxior (fxand mask n0)
              (fxand (fxnot mask) n1)))
 
-    (define-c fxbit-set?
+    (define (fxbit-set? index i)
+      (or (%fxbit-set? index i)
+          (and (negative? i)
+               (>= index (fxlength i)))))
+
+    (define-c %fxbit-set?
        "(void* data, int argc, closure _, object k, object index, object i)"
        " Cyc_check_fixnum(data, index);
          Cyc_check_fixnum(data, i);

srfi/18.sld

@@ -74,6 +74,7 @@
         ;; - internal
         ;; - end of thread cont (or #f for default)
         ;; - end-result - Result of thread that terminates successfully
+        ;; - internal thread context at termination, e.g. parameterised objects
         (vector 
           'cyc-thread-obj 
           thunk 
@@ -82,6 +83,7 @@
           #f 
           #f
           #f
+          #f
           #f)))
 
     (define (thread-name t) (vector-ref t 3))
@@ -98,7 +100,7 @@
       (%get-thread-data))
 
     (define *primordial-thread*
-      (vector 'cyc-thread-obj #f #f "main thread" #f #f))
+      (vector 'cyc-thread-obj #f #f "main thread" #f #f #f #f))
 
     (define-c %current-thread
       "(void *data, int argc, closure _, object k)"
@@ -118,13 +120,21 @@
         make_c_opaque(co, td);
         return_closcall1(data, k, &co); ")
 
+    (define-c %end-thread!
+      "(void *data, int argc, closure _, object k, object ret)"
+      " gc_thread_data *d = data;
+        vector_type *v = d->scm_thread_obj;
+        v->elements[7] = ret;     // Store thread result
+        Cyc_end_thread(d);
+        return_closcall1(data, k, boolean_f);")
+
     (define (thread-start! t)
       ;; Initiate a GC prior to running the thread, in case
       ;; it contains any closures on the "parent" thread's stack
       (let* ((thunk (vector-ref t 1)) 
              (thread-params (cons t (lambda ()
                                       (vector-set! t 5 #f)
-                                      (thunk)))))
+                                      (let ((r (thunk))) (%end-thread! r))))))
         (vector-set! t 5 (%get-thread-data)) ;; Temporarily make parent thread
                                              ;; data available for child init
         (Cyc-minor-gc)
@@ -132,9 +142,33 @@
         t))
 
     (define (thread-yield!) (thread-sleep! 1))
-    (define-c thread-terminate!
+
-      "(void *data, object _, int argc, object *args)"
+    (define-c %thread-terminate!
-      " Cyc_end_thread(data); ")
+      "(void *data, int argc, closure _, object k, object thread_data_opaque)"
+      " gc_thread_data *td;
+        if (thread_data_opaque == boolean_f) {
+          /* primordial thread */
+          __halt(boolean_f);
+        } else {
+          td = (gc_thread_data *)(opaque_ptr(thread_data_opaque));
+          if (td == data) {
+            Cyc_end_thread(td);
+          } else {
+            pthread_cancel(td->thread_id);
+          }
+        }
+        return_closcall1(data, k, boolean_t);")
+    (define (thread-terminate! t)
+      (cond
+       ((and (thread? t)
+             (or (Cyc-opaque? (vector-ref t 2)) (equal? *primordial-thread* t)))
+        (begin
+         (Cyc-minor-gc)
+         (vector-set! t 5 (%get-thread-data)) ;; remember calling thread
+         (%thread-terminate! (vector-ref t 2))
+         #t))
+       (else
+        #f))) ;; TODO: raise an error instead?
 
     ;; TODO: not good enough, need to return value from thread
     ;; TODO: perhaps not an ideal solution using a loop/polling below, but good
@@ -156,6 +190,7 @@
       (cond
        ((and (thread? t) (Cyc-opaque? (vector-ref t 2)))
         (%thread-join! (vector-ref t 2))
+        (Cyc-minor-gc)
         (vector-ref t 7))
        (else
         #f))) ;; TODO: raise an error instead?

test-lib.c

@@ -0,0 +1,51 @@
+#include <stdio.h>
+#include <assert.h>
+#include "include/cyclone/types.h"
+#include "include/cyclone/runtime.h"
+#include "include/cyclone/runtime-main.h"
+
+/* Future considerations:
+int main(int argc, char **argv, char **envp)
+{gc_thread_data *thd;
+ long stack_size = global_stack_size = STACK_SIZE;
+ long heap_size = global_heap_size = HEAP_SIZE;
+ init_polyfills();
+ mclosure0(clos_halt,&Cyc_halt);  // Halt if final closure is reached
+ mclosure0(entry_pt,&c_entry_pt); // First function to execute
+ _cyc_argc = argc;
+ _cyc_argv = argv;
+ set_env_variables(envp);
+ gc_initialize();
+ thd = malloc(sizeof(gc_thread_data));
+ gc_thread_data_init(thd, 0, (char *) &stack_size, stack_size);
+ thd->gc_cont = &entry_pt;
+ thd->gc_args[0] = &clos_halt;
+ thd->gc_num_args = 1;
+ thd->thread_id = pthread_self();
+ gc_add_mutator(thd);
+ Cyc_heap_init(heap_size);
+ thd->thread_state = CYC_THREAD_STATE_RUNNABLE;
+ Cyc_start_trampoline(thd);
+ return 0;}
+ */
+
+void test_exact() {
+  common_type ptr;
+  make_double(d, 42.5);
+  assert(obj_int2obj(42) == Cyc_exact_no_cps(NULL, &ptr, obj_int2obj(42)));
+  object result = Cyc_exact_no_cps(NULL, &ptr, &d);
+  assert( result == obj_int2obj(43));
+
+  // TODO: unit tests for below as examples:
+  //void Cyc_exact(void *data, object cont, object z)
+}
+
+int main(){
+  assert(boolean_t == boolean_t);
+  assert(boolean_t != boolean_f);
+
+  test_exact();
+
+  printf("All tests passed successfully!\n");
+  return 0;
+}

tests/base.scm

@@ -9,6 +9,9 @@
 
 (import 
   (scheme base)
+  (scheme eval)
+  (scheme inexact)
+  (scheme write)
   (cyclone test))
 
 
@@ -31,6 +34,14 @@
 )
 
 (test-group
+  "apply"
+  (test '(5 1 2) (eval '(apply cons '(5 (1 2)))))
+  (test '(5 1 2) (apply cons '(5 (1 2))))
+)
+
+(cond-expand
+  (memory streams
+    (test-group
       "I/O"
       (define p (open-input-string "one\ntwo\n"))
       (test #\o (read-char p))
@@ -42,12 +53,87 @@
       (test #\t (read-char p))
       (test #\w (read-char p))
       (test "o" (read-line p))
+    )
+  )
+  (else #f)
 )
 
 (test-group
   "rationals"
   (test 3.0 (numerator (/ 6 4)))
   (test 2.0 (denominator (/ 6 4)))
+  (test 3.0 (expt 81 1/4))
+  (test #t
+    (< 1.0e+40 
+       (/ 33333333333333333333333333333333333333333 3.0)
+       1.2e+40))
+)
+
+(test-group
+  "numeric operations - floor, truncate, "
+  (test -1 (truncate -1))
+  (test -1.0 (truncate -1.0))
+  (test -1.0 (truncate -1.1))
+  (test -1.0 (truncate -1.1))
+  (test +inf.0 (truncate +inf.0))
+
+  (test (values 2 1) (floor/ 5 2))
+  (test (values -3 1) (floor/ -5 2))
+  (test (values -3 -1) (floor/ 5 -2))
+  (test (values 2 -1) (floor/ -5 -2))
+  (test (values 2 1) (truncate/ 5 2))
+  (test (values -2 -1) (truncate/ -5 2))
+  (test (values -2 1) (truncate/ 5 -2))
+  (test (values 2 -1) (truncate/ -5 -2))
+  (test (values 2.0 -1.0) (truncate/ -5.0 -2))
+
+  (test 4 (gcd 32 -36))
+  (test 0 (gcd))
+  (test 288 (lcm 32 -36))
+  (test 288.0 (lcm 32.0 -36))
+  (test 1 (lcm))
+
+  (test -5.0 (floor -4.3))
+  (test -4.0 (ceiling -4.3))
+  (test -4.0 (truncate -4.3))
+  (test -4.0 (round -4.3))
+  (test 3.0  (floor 3.5))
+  (test 4.0  (ceiling 3.5))
+  (test 3.0  (truncate 3.5))
+  (test 4.0  (round 3.5))
+  (test 2.0  (round 2.5))
+  (test -4.0 (round -3.5))
+  (test -2.0 (round -2.5))
+  (test 4.0  (round 7/2)) ;; Rationals not supported, so result is inexact
+  (test 7    (round 7))
+
+  (test 3.0 (numerator (/ 6 4))) ;; Inexact because we don't support rationals yet
+  (test 2.0 (denominator (/ 6 4))) ;; Inexact because we don't support rationals yet
+  (test 2.0 (denominator (inexact (/ 6 4))))
+)
+
+(test-group
+  "sqrt"
+  (test 1i (sqrt -1))
+  (test 1i (sqrt -1.0))
+  (test +i (sqrt -1.0))
+  (test 2 (sqrt 4))
+  (test 2.0 (sqrt 4.0))
+  (test 2i (sqrt -4.0))
+  (test #t (complex? (sqrt -1)))
+  (test #t (complex? (sqrt -i)))
+)
+
+(test-group
+  "exact"
+  (test -1 (exact -1))
+  (test -1 (exact -1.0))
+  (test -1 (exact -1.1))
+  (test -1 (exact -1.1))
+  (test 1.0+1.0i (exact 1.1+1.2i))
+  ;(test #t (bignum? (exact 111111111111111111111111111.0)))
+  ;(test #t (bignum? (exact -111111111111111111111111111.0)))
+  ;(test +inf.0 (exact +inf.0))
 )
 
 (test-group
@@ -65,5 +151,67 @@
   (test 'test-field (get-test e))
 )
 
+(test-group
+  "assoc"
+  (define a 0.0)
+  (test '(0.0) (assoc a (list (list a))))
+  (test '(0.0) (assoc 0.0 (list (list a))))
+  (test '(0.0) (assv a (list (list a))))
+  (test '(0.0) (assv 0.0 (list (list a))))
+  (test '(0.0) (assq a (list (list a))))
+  (test #f (assq 0.0 (list (list a))))
+)
+
+(test-group
+  "member"
+  (define m 0.0)
+  (test '(0.0) (member m (list m)))
+  (test '(0.0) (member 0.0 (list m)))
+  (test '(0.0) (memv m (list m)))
+  (test '(0.0) (memv 0.0 (list m)))
+  (test '(0.0) (memq m (list m)))
+  (test #f (memq 0.0 (list m)))
+)
+
+(test-group
+  "exception handling"
+  (define (capture-output thunk)
+    (let ((output-string (open-output-string)))
+      (parameterize ((current-output-port output-string))
+        (thunk))
+      (let ((result (get-output-string output-string)))
+       (close-output-port output-string)
+       result)))
+  (test
+    "should be a number65"
+    (capture-output
+      (lambda ()
+        (with-exception-handler
+          (lambda (con)
+            (cond
+              ((string? con)
+               (display con))
+              (else
+               (display "a warning has been issued")))
+            42)
+          (lambda ()
+            (display
+              (+ (raise-continuable "should be a number")
+                 23)))))))
+  (test
+    "condition: an-error"
+    (capture-output
+      (lambda ()
+        (call-with-current-continuation
+          (lambda (k)
+            (with-exception-handler
+              (lambda (x)
+                (display "condition: ")
+                (write x)
+                (k "exception"))
+              (lambda ()
+                (+ 1 (raise 'an-error)))))))))
+)
+
 (test-exit)
 

tests/c-compiler-options.scm

@@ -0,0 +1,9 @@
+;; Simple test to prevent regressions of top-level c-compiler-options 
+(import (scheme base)
+        (scheme write)
+        (cyclone foreign))
+
+(c-compiler-options "-I/tmp")
+
+(display "hello")
+

tests/test.scm

@@ -0,0 +1,26 @@
+;;;; Cyclone Scheme
+;;;; https://github.com/justinethier/cyclone
+;;;;
+;;;; Copyright (c) 2014-2021, Justin Ethier
+;;;; All rights reserved.
+;;;;
+;;;; This module contains unit tests for (cyclone test)
+;;;;
+
+(import 
+  (scheme base)
+  (cyclone test))
+
+(test-group
+  "assert"
+  (test-assert #t)
+)
+
+(test-group
+  "not"
+  (test-not #f)
+)
+
+(test-exit)
+
+

tests/unit-tests.scm

@@ -35,6 +35,49 @@
 (set-cdr! l '(c b)) ; Above seems to break if it replaces this line
 (assert:equal "list? on circular list" (list? l) #t)
 
+;; Circular data structures
+(define v1 (vector #f))
+(define v2 (vector v1))
+(vector-set! v1 0 v2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (display v1 fp)
+     (assert:equal "display circular vector" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular vectors" (equal? v1 v2) #t)
+(newline)
+
+(define v1 (vector 1 2 3))
+(define v2 (vector 1 v1 3))
+(vector-set! v1 1 v2)
+(cond-expand
+ (memory-streams
+  (let ((fp (open-output-string)))
+    (write v1 fp)
+    (assert:equal "display circular vector" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular vectors, test 2" (equal? v1 v2) #t)
+(newline)
+
+(define l1 (list #f))
+(define l2 (list l1))
+(set-cdr! l1 l2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (display l1 fp)
+     (assert:equal "display circular list" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular lists" (equal? l1 l2) #f)
+
+(define l1 (list 1 2 3))
+(define l2 (list 1 l1 3))
+(set-cdr! (cdr l1) l2)
+(cond-expand
+  (memory-streams
+   (let ((fp (open-output-string)))
+     (write l1 fp)
+     (assert:equal "display circular list" (> (string-length (get-output-string fp)) 0) #t))))
+(assert:equal "equality on circular lists, test 2" (equal? l1 l2) #f)
+
 ;; Adder example
 (define (make-adder x)
   (lambda (y) (+ x  y)))