diff --git a/.gitignore b/.gitignore
index b92e679..a800178 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,13 +1,12 @@
*.swp
+*.swo
*.link
compile-r7rs
-test/foo
-test/libs/bar/baz
+test
*.c
*.o
*.o*
*.so
-!chicken
!src
*.rkt
-
+README.txt
diff --git a/Dockerfile b/Dockerfile
index cb4d56a..b9ae116 100644
--- a/Dockerfile
+++ b/Dockerfile
@@ -1,2 +1,10 @@
-FROM schemers/sagittarius
-RUN apt-get update && apt-get install -y build-essential make
+ARG COMPILE_R7RS=chibi
+FROM debian:bookworm AS build
+RUN apt-get update && apt-get install -y build-essential wget make cmake libgc-dev zlib1g-dev libffi-dev libssl-dev
+RUN wget https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.12.tar.gz && tar -xf sagittarius-0.9.12.tar.gz
+RUN cd sagittarius-0.9.12 && mkdir build && cd build && cmake -DCMAKE_INSTALL_PREFIX=/usr/local-other .. && make && make install
+
+FROM schemers/${COMPILE_R7RS}
+RUN apt-get update && apt-get install -y make libffi8 libgc1 libssl3 libuv1
+COPY --from=build /usr/local-other/ /usr/local-other/
+ENV PATH=${PATH}:/usr/local-other/bin
diff --git a/Jenkinsfile b/Jenkinsfile
index f99a889..5d711a8 100644
--- a/Jenkinsfile
+++ b/Jenkinsfile
@@ -4,28 +4,178 @@ pipeline {
buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
}
stages {
- stage("Test chibi") {
- agent dockerfile
- steps {
- sh 'make SCHEME=chibi test-sagittarius'
- }
- }
- stage("Test guile") {
- agent dockerfile
- steps {
- sh 'make SCHEME=guile test-sagittarius'
- }
- }
stage("Build") {
- agent dockerfile
+ agent {
+ docker {
+ image 'schemers/sagittarius'
+ }
+ }
steps {
sh 'make'
+ sh 'make install'
+ sh 'make SCHEME=sagittarius test-r6rs'
+ sh 'make SCHEME=sagittarius test-r7rs'
}
}
- stage("Build exe") {
- agent dockerfile
+ stage("Test chez r6rs") {
steps {
- sh 'make build-exe'
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=chibi test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test chibi r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=chibi test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test cyclone r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=cyclone test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test foment r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=foment test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test gauche r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=gauche test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test guile r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=guile test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test guile r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=guile test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test ikarus r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=ikarus test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test ironscheme r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=ironscheme test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test kawa r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=kawa test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test larceny r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=larceny test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test larceny r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=larceny test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test loko r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=loko test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test loko r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=loko test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test mit-scheme r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=mit-scheme test-r7rs'
+ }
+ }
+ }
+ stage("Test mosh r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=mosh test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test mosh r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=mosh test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test sagittarius r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=sagittarius test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test sagittarius r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=sagittarius test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test skint r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=skint test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test tr7 r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=tr7 test-r7rs-docker'
+ }
+ }
+ }
+ stage("Test ypsilon r6rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=ypsilon test-r6rs-docker'
+ }
+ }
+ }
+ stage("Test ypsilon r7rs") {
+ steps {
+ catchError(buildResult: 'SUCCESS', stageResult: 'FAILURE') {
+ sh 'make SCHEME=ypsilon test-r7rs-docker'
+ }
}
}
}
diff --git a/Makefile b/Makefile
index af94c41..7c15718 100644
--- a/Makefile
+++ b/Makefile
@@ -2,7 +2,7 @@
PREFIX=/usr/local
build:
- printf "#!/bin/sh\nsash -r7 -L ${PREFIX}/lib/compile-r7rs/snow ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"\n" > compile-r7rs
+ printf "#!/bin/sh\nsash --disable-cache -r7 -L ${PREFIX}/lib/compile-r7rs/snow ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"\n" > compile-r7rs
snow:
rm -rf snow
@@ -21,13 +21,55 @@ uninstall:
rm -rf ${PREFIX}/lib/compile-r7rs/snow
rm -rf ${PREFIX}/bin/compile-r7rs
+dist:
+ mkdir -p dist
+
+# Uses wine and innosetup
+installer-exe: dist
+ cp README.md README.txt
+ wine "${HOME}/.wine/drive_c/Program Files (x86)/Inno Setup 6./Compil32.exe" /cc installer.iss
+
+test-r6rs:
+ rm -rf /tmp/compile-r7rs-test-result.txt
+ mkdir -p test
+ mkdir -p test/snow
+ mkdir -p test/snow/foo
+ echo "(library (foo bar) (export baz) (import (rnrs)) (define baz (lambda () (display \"Test successfull\") (newline))))" > test/snow/foo/bar.sls
+ echo "(import (rnrs) (foo bar)) (baz)" > test/main.sps
+ cd test && COMPILE_R7RS=${COMPILE_R7RS} compile-r7rs -I ./snow -o main main.sps
+ -cd test && ./main > /tmp/compile-r7rs-test-result.txt 2>&1
+ @grep "Test successfull" /tmp/compile-r7rs-test-result.txt || (echo "Test failed, output: " && cat /tmp/compile-r7rs-test-result.txt && exit 1)
+
+test-r6rs-docker:
+ docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=compile-r7rs-test-${COMPILE_R7RS} .
+ docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${COMPILE_R7RS} sh -c "make && make install && make clean-test COMPILE_R7RS=${COMPILE_R7RS} test-r6rs"
+
+test-r7rs:
+ rm -rf /tmp/compile-r7rs-test-result.txt
+ mkdir -p test
+ mkdir -p test/snow
+ mkdir -p test/snow/foo
+ echo "(import (scheme base) (foo bar)) (baz)" > test/main.scm
+ echo "(define baz (lambda () (display \"Test successfull\") (newline)))" > test/snow/foo/bar.scm
+ echo "(define-library (foo bar) (import (scheme base) (scheme write)) (export baz) (include \"bar.scm\"))" > test/snow/foo/bar.sld
+ cd test && COMPILE_R7RS=${COMPILE_R7RS} compile-r7rs -I ./snow -o main main.scm
+ -cd test && ./main > /tmp/compile-r7rs-test-result.txt 2>&1
+ @grep "Test successfull" /tmp/compile-r7rs-test-result.txt || (echo "Test failed, output: " && cat /tmp/compile-r7rs-test-result.txt && exit 1)
+
+test-r7rs-docker:
+ docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=compile-r7rs-test-${COMPILE_R7RS} .
+ docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-test-${COMPILE_R7RS} sh -c "make && make install && make clean-test COMPILE_R7RS=${COMPILE_R7RS} test-r7rs"
+
clean:
- rm -rf test/foo
- rm -rf test/libs/bar/baz
find . -name "*.so" -delete
find . -name "*.o*" -delete
find . -name "*.rkt" -delete
- find ./test -name "*.c" -delete
find . -name "*.link" -delete
find . -name "*.meta" -delete
find . -name "*.import.*" -delete
+ rm -rf README.txt
+ rm -rf dist
+ rm -rf test
+
+clean-test:
+ rm -rf test
diff --git a/README.md b/README.md
index acc9ff8..97842d0 100644
--- a/README.md
+++ b/README.md
@@ -1,30 +1,153 @@
-compile-r7rs is a tool to compile R7RS Scheme programs, it aims for compability
+compile-r7rs is a tool to compile Scheme programs, it aims for compability
with [SRFI-138](https://srfi.schemers.org/srfi-138/srfi-138.html).
-## Supported implementations
+Despite it's name it also supports R6RS implementations and compilation.
+Schemers, unite! <3
+- [Notes](#notes)
+- [Supported implementations](#supported-implementations)
+- [Roadmap](#roadmap)
+- [Dependencies](#dependencies)
+ - [Linux](#dependencies-linux)
+ - [Windows](#dependencies-windows)
+- [Installation](#installation)
+ - [Linux](#installation-linux)
+ - [Windows](#installation-windows)
+- [Usage](#usage)
+ - [Environment variables](#usage-environment-variables)
+- [Usage with docker](#usage-with-docker)
+- [Usual RnRS project](#usual-rnrs-project)
+ - [File structure](#usual-rnrs-project-file-structure)
+ - [Installation of your project](#usual-rnrs-project-installation-of-your-project)
+- [Development](#development)
+ - [Adding new implementations](#development-adding-new-implementations)
+ - [Misc notes](#development-misc-notes)
+
+## Notes
+
+
+- No support for -D flag yet.
+- Not all implementations support adding to beginning or end o load path so
+-I and -A might work the same
+
+## Supported implementations
+
+
+Some implementations support both compiling and interpreting, in that
+case only the compiler functionality is used and the implementation is marked
+as compiler.
+
+- chezscheme
+ - interpreter
+ - r6rs
- chibi
+ - interpreter
+ - r7rs
+- chicken
+ - compiler
+ - r7rs
- cyclone
+ - compiler
+ - r7rs
+- Gambit
+ - compiler
+ - r7rs
+- foment
+ - interpreter
+ - r7rs
- gauche
+ - interpreter
+ - r7rs
- guile
+ - interpreter
+ - r6rs
+ - r7rs
+ - Has include bug https://debbugs.gnu.org/cgi/bugreport.cgi?bug=66046
+ but for some reason it seems to work for me atleast sometimes
+- ikarus
+ - interpreter
+ - r6rs
+- ironscheme
+ - interpreter
+ - r6rs
- kawa
+ - interpreter
+ - r7rs
+- larceny
+ - interpreter
+ - r6rs
+ - r7rs
- loko
+ - compiler
+ - r6rs
+ - r7rs
+- mit-scheme
+ - interpreter
+ - r7rs
- mosh
+ - interpreter
+ - r6rs
+ - r7rs
- sagittarius
+ - interpreter
+ - r6rs
+ - r7rs
- skint
+ - interpreter
+ - r7rs
- stklos
+ - interpreter
+ - r7rs
- tr7
+ - interpreter
+ - r7rs
- ypsilon
+ - interpreter
+ - r6rs
+ - r7rs
+
+## Roadmap
+
+
+- Support for more implementations
+ - Gerbil
+ - Dont know how to run this thing yet :D
+ - Husk
+ - Dont know how to add directories to load path yet
+ - Meevax
+ - Asked how to add directory to load path
+ https://github.com/yamacir-kit/meevax/issues/494, might not be
+ implemented yet
+ - Picrin
+ - Might not be possible, seems to not have (include...) that works like
+ others
+ - Stak
+ - Asked how to add directoy to load path
+ https://github.com/raviqqe/stak/issues/2355, migth not be implemented
+ yet
+ - Vicare
+ - So old that I have problems compiling it in Docker, so testing is
+ hard but I expect it to work once I get it to compile as it is R6RS
+ implementation
+- Better and tested support for Windows
+ - Right now there is support for running this but I can not quarantee it
+ works on all if any cases
+- Support for -D
+ - Most implementations dont have this or equivalent flag, but it would be
+ really nice feature to have so filing issues and implementing it myself is
+ something I would like to do
+- Ask implementations to support adding to the front and back of load path, or
+ implement this onto implementations myself
+ - This might not be as important, but it would be nice to go towards SRFI-138
+ conformaty
## Dependencies
+
+### Linux
+
-
-## Getting started
-
-### Install Sagittarius scheme
-
-#### Linux
+#### Sagittarius Scheme
On Debian/Ubuntu/Mint:
@@ -38,53 +161,221 @@ On Debian/Ubuntu/Mint:
make
make install
-#### Windows
-
-Download the installer from
-[https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/](https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/)
-and install it.
-
-### Install libuv
-
-#### Linux
+#### libuv
On Debian/Ubuntu/Mint run:
apt install libuv1
-#### Windows
+### Windows
+
-dll is included, no need to install anything.
+### Sagittarius Scheme
+Download the installer from
+[https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/](https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/)
+and install it into **default location**.
-### Build on Linux
+### libuv
+
+Libuv is distributed with compile-r7rs on Windows.
+
+## Installation
+
+
+### Linux
+
./configure
make
make install
-### Build on Windows
+### Windows
+
-Work in progres
-In command prompt run:
+Donwload the setup-compile-r7rs.exe from dist directory from this repository.
- build.bat
- install.bat
+If you want to compile the installer yourself look into the makefile and
+installer.iss, it is made with innosetup.
## Usage
+
You need to install each Scheme implementation yourself.
-The environment variable SCHEME must be set to the name of the implementation
-as specified in the support list.
+The environment variable COMPILE\_R7RS must be set to the name of the
+implementation as specified in the support list.
+**This differs from the SRFI** as it excepts a path.
-First to compile your libraries run the command without the .scm file.
+To get the list of supported implementations run:
- SCHEME= compile-r7rs -I .
+ compile-r7rs --list-schemes
-Then run it with the .scm file.
+Then run it with the .scm file for r7rs, or .sps file for r6rs.
- SCHEME= compile-r7rs -I . main.scm
+ COMPILE_R7RS= compile-r7rs -I . -o main main.scm
Which produces file called main, which you can run. Note that when given Scheme
is interpreter the file contains commands that run the script, and even when
the file is combiled binary it might need the compiled libraries.
+
+No other file suffixes are supported at the moment.
+
+Setting value of COMPILE\_R7RS to implementation name that supports only r7rs
+and input file to .sps file and other way around is undefined behaviour.
+
+### Environment variables
+
+
+- COMPILE\_R7RS
+ - **Name** of the implementation you want to compile with
+ - **This differs from the SRFI** as it excepts a path
+- COMPILE\_R7RS\_SCHEME_NAME
+ - Additional string to insert right after the command and it's arguments
+ can be used for example to pass C compiler flags on implementations that
+ compile to C
+ - For example for Chicken to link with libcurl you would set
+ COMPILE\_R7RS\_CHICKEN="-L -lcurl"
+ - If implementation has - it is changed to \_, for example mit-scheme ->
+ MIT\_SCHEME
+ - **This differs from the SRFI** as it's not in there
+
+## Usage with Docker
+
+
+Here is a sample Dockerfile to get you started.
+
+ ARG COMPILE_R7RS=chibi
+ FROM debian:bookworm AS build
+ RUN apt-get update && apt-get install -y build-essential wget make cmake libgc-dev zlib1g-dev libffi-dev libssl-dev
+ RUN wget https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.12.tar.gz && tar -xf sagittarius-0.9.12.tar.gz
+ RUN cd sagittarius-0.9.12 && mkdir build && cd build && cmake -DCMAKE_INSTALL_PREFIX=/usr/local-other .. && make && make install
+
+ FROM schemers/${COMPILE_R7RS}
+ RUN apt-get update && apt-get install -y make libffi8 libgc1 libssl3 libuv1 git
+ COPY --from=build /usr/local-other/ /usr/local-other/
+ ENV PATH=${PATH}:/usr/local-other/bin
+ ENV COMPILE_R7RS=${COMPILE_R7RS}
+ RUN git clone https://git.sr.ht/~retropikzel/compile-r7rs && cd compile-r7rs && make && make install
+
+To use this run:
+
+ export COMPILE_R7RS=
+ docker build --build-arg COMPILE_R7RS=${COMPILE_R7RS} --tag=compile-r7rs-${COMPILE_R7RS} .
+ docker run -v "${PWD}":/workdir -w /workdir -t compile-r7rs-${COMPILE_R7RS} sh -c "compile-r7rs -I -o main ./snow main.scm"
+
+## Usual RnRS projects
+
+
+The reports do not say much, if anything, about the file structure of your
+project. However in practice certain patterns will repeat a lot. Here we use
+R7RS .sld and .scm files as example but for R6RS .sld = .sld and .scm = .sps.
+
+### File structure
+
+
+The implementations most often expect library named (foo bar) to be in file
+foo/bar.sld. Some implementations add the current directory to the load path
+implicitly, some do not. If you store your libraries directly in your projects
+root it's propably best to always pass . as load path to compile-r7rs.
+
+For example if your projects file structure is:
+
+ foo/bar.sld
+ main.scm
+
+The command to compile and run this project is:
+
+ compile-r7rs -I . -o myproject main.scm
+ ./main
+
+If your project has more than one library then you propably want to store the
+libraries in one directory. For example:
+
+ snow/foo/bar.sld
+ main.scm
+
+This is the case the compile-r7rs is tested against, main.scm imports (foo bar).
+The command to compile and run this project is:
+
+ compile-r7rs -I ./snow -o myproject main.scm
+ ./main
+
+### Installation of your project
+
+
+compile-r7rs (that is, this project) does not install your project files
+anywhere, that is left for you to do. I will update this section as I use this
+project more but here are some ideas. Basically each implementation might need
+it's own specific way and is outside of scope of this project.
+
+#### Interpreters
+
+The interpreters, that is for example Sagittarius, Gauche, Chibi and STklos,
+produce an executable that contains the command to run the main .scm file
+and add given paths to the implementations load paths. So if you run this:
+
+ compile-r7rs -I ./snow -o main main.scm
+
+the resulting main file will only work in this directory, as the load path is
+relative. For system wide installation the paths would need to be more like this:
+
+ compile-r7rs -I /usr/local/lib/myproject/snow -o myproject main.scm
+
+and then in makefile you would have:
+
+ install:
+ mkdir -p /usr/local/lib/myproject
+ cp -r snow /usr/local/lib/myproject/
+ install myproject /usr/local/bin/
+
+#### Compilers
+
+Compilers, that is for example Chicken, Gambit, Cyclone either produce static
+executable or shared libraries. Cyclone produces static executable so
+if you run this:
+
+ compile-r7rs -I /usr/local/lib/myproject/snow -o myproject main.scm
+
+and then in makefile you would have:
+
+ install:
+ install myproject /usr/local/bin/
+
+Chicken compiles shared object files and is different from that, like I said I
+hope to update this section when I get more experience with installing stuff
+compiled by using this project. :)
+
+## Development
+
+
+The program relies on two projects,
+[r7rs-pffi](https://sr.ht/~retropikzel/r7rs-pffi/) and
+[pffi-srfi-170](https://git.sr.ht/~retropikzel/pffi-srfi-170). They both are
+stil work in progress so best way to help this project is to help on those
+projects. That said bug fixes for this projects are also welcome. Pull requests
+that add more SRFI-138 support are also welcome, but lets keep the scope on
+that.
+
+The program itself is a quite simple transformer of inputs to implementation
+specific inputs. It stands on the shoulders of giants and relies on the
+implementations to have all the needed features, then unifies the interface to
+use them.
+
+### Adding new implementations
+
+
+The main program reads the flags and other inputs and passes them to a
+transformer functions. So to add support for new implementations you need
+to add the transformer functions and other data for it in libs/data.scm. You
+should be able to decuct how they work from other transformers. If you need to
+make utility functions add them into libs/util.scm and export them in
+libs/util.sld.
+
+### Misc notes
+
+
+When developing and testing, run:
+
+ make && sudo make uninstall install
+
+without the uninstall the changes to libraries dont seem to update.
diff --git a/build.bat b/build.bat
deleted file mode 100644
index a358d1a..0000000
--- a/build.bat
+++ /dev/null
@@ -1,2 +0,0 @@
-echo @echo off > compile-r7rs.bat
-echo sash.exe -r7 -L %PROGRAMFILES%/compile-r7rs/snow %PROGRAMFILES%compile-r7rs/main.scm %%^* >> compile-r7rs.bat
diff --git a/compile-r7rs.bat b/compile-r7rs.bat
index 271912e..523608c 100644
--- a/compile-r7rs.bat
+++ b/compile-r7rs.bat
@@ -1,2 +1,3 @@
-@echo off
-sash.exe -r7 -L C:\Program Files (x86)/compile-r7rs/snow C:\Program Files (x86)compile-r7rs/main.scm %*
+@echo off
+set "PFFI_LOAD_PATH=%PROGRAMFILES%/compile-r7rs/snow/srfi"
+sash.exe -r7 -L "%PROGRAMFILES%/compile-r7rs/snow" -L "%PROGRAMFILES%/compile-r7rs" "%PROGRAMFILES%/compile-r7rs/main.scm" %*
diff --git a/compile-r7rs.scm b/compile-r7rs.scm
index 33e2d90..619a2eb 100644
--- a/compile-r7rs.scm
+++ b/compile-r7rs.scm
@@ -13,24 +13,38 @@
(lambda (scheme)
(display scheme)
(newline))
- '(chibi
+ '(chezscheme
+ chibi
+ chicken
cyclone
+ gambit
+ foment
gauche
- ;guile
+ ;gerbil
+ guile
+ ;husk
+ ikarus
+ ironscheme
kawa
+ larceny
loko
+ ;meevax
+ mit-scheme
mosh
+ ;picrin
+ ;stak
sagittarius
skint
stklos
tr7
+ ;vicare
ypsilon))
(exit 0))
-(define scheme (if (get-environment-variable "SCHEME")
- (string->symbol (get-environment-variable "SCHEME"))
+(define scheme (if (get-environment-variable "COMPILE_R7RS")
+ (string->symbol (get-environment-variable "COMPILE_R7RS"))
#f))
-(when (not scheme) (error "Environment variable SCHEME not set."))
+(when (not scheme) (error "Environment variable COMPILE_R7RS not set."))
(when (not (assoc scheme data))
(error "Unsupported implementation" scheme))
(define compilation-target (if (get-environment-variable "TARGET")
@@ -42,19 +56,22 @@
(let ((input-file #f))
(for-each
(lambda (item)
- (when (and (> (string-length item) 4)
- (string=? ".scm" (string-copy item
- (- (string-length item) 4)
- (string-length item))))
+ (when (or (string-ends-with? item ".scm")
+ (string-ends-with? item ".sps"))
(set! input-file item)))
(list-tail (command-line) 1))
input-file))
+(define r6rs? (if (and input-file
+ (string-ends-with? input-file ".sps"))
+ #t
+ #f))
+
(define output-file
(if (member "-o" (command-line))
(cadr (member "-o" (command-line)))
(if input-file
- (string-copy input-file 0 (- (string-length input-file) 4))
+ "a.out"
#f)))
(define prepend-directories
@@ -95,7 +112,11 @@
(lambda (file)
(let* ((path (string-append directory "/" file))
(info (file-info path #f)))
- (when (string-ends-with? path ".sld")
+ (when (and (not r6rs?)
+ (string-ends-with? path ".sld"))
+ (set! result (append result (list path))))
+ (when (and r6rs?
+ (string-ends-with? path ".sls"))
(set! result (append result (list path))))
(if (file-info-directory? info)
(set! result (append result (search-library-files path))))))
@@ -119,12 +140,13 @@
(if output-file output-file "")
prepend-directories
append-directories
- library-files)))
+ library-files
+ r6rs?)))
(define scheme-library-command
(lambda (library-file)
(apply (cdr (assoc 'library-command (cdr (assoc scheme data))))
- (list library-file prepend-directories append-directories))))
+ (list library-file prepend-directories append-directories r6rs?))))
(define list-of-features
@@ -144,60 +166,67 @@
(display "Type ")
(display scheme-type)
(newline)
-(display "Command ")
-(display scheme-command)
-(newline)
-(display "Input file ")
-(display input-file)
-(newline)
-(display "Output file ")
-(display output-file)
(newline)
+; Compile libraries
+(cond ((assoc 'library-command (cdr (assoc scheme data)))
+ (for-each
+ (lambda (file)
+ (let* ((library-command (scheme-library-command file)))
+ (display "Compiling library ")
+ (display file)
+ (newline)
+ (display "With command ")
+ (display library-command)
+ (newline)
+ (display "Exit code ")
+ (let ((output (c-system (pffi-string->pointer library-command))))
+ (when (not (= output 0))
+ (error "Problem compiling libraries, exiting" output))
+ (display output))
+ (newline)
+ (newline)))
+ library-files))
+ (else
+ (display "Implementation has no library build command, skipping library compilation.")
+ (newline)))
+
; Create executable file
(when (and (equal? scheme-type 'interpreter) input-file)
(when (and output-file (file-exists? output-file))
(delete-file output-file))
- (with-output-to-file
+ (display "Creating startup script ")
+ (display output-file)
+ (newline)
+ (display "Containing command ")
+ (display scheme-command)
+ (newline)
+ (with-output-to-file
(if (string=? compilation-target "windows")
(string-append output-file ".bat")
output-file)
(lambda ()
- (when (string=? compilation-target "unix")
- (display "#!/bin/sh"))
- (when (string=? compilation-target "windows")
- (display "@echo off"))
- (newline)
- (when (string=? compilation-target "windows")
- (display "start"))
- (display scheme-command))))
+ (cond ((string=? compilation-target "unix")
+ (display "#!/bin/sh")
+ (newline))
+ ((string=? compilation-target "windows")
+ (display "@echo off")
+ (newline)
+ (display "start")))
+ (display scheme-command)))
+ (cond ((string=? compilation-target "unix")
+ (c-system (pffi-string->pointer (string-append "chmod +x " output-file))))))
(when (and (equal? scheme-type 'compiler) input-file)
- (when (file-exists? output-file) (delete-file output-file))
+ (when (and output-file (file-exists? output-file))
+ (delete-file output-file))
(display "Compiling file ")
(display input-file)
(newline)
(display "With command ")
(display scheme-command)
(newline)
- (c-system (pffi-string->pointer scheme-command)))
+ (display "Exit code ")
+ (display (c-system (pffi-string->pointer scheme-command)))
+ (newline))
-; Compile libraries
-(cond ((and (not input-file) (assoc 'library-command (cdr (assoc scheme data))))
- (when (and output-file (file-exists? output-file))
- (delete-file output-file))
- (for-each
- (lambda (file)
- (let* ((command (scheme-library-command file)))
- (display "Compiling library ")
- (display file)
- (newline)
- (display "With command ")
- (display command)
- (newline)
- (c-system (pffi-string->pointer command))))
- library-files))
- ((not input-file)
- (display "Library compilation requested but no library command found. ")
- (display "Skipping...")
- (newline)))
diff --git a/installer.iss b/installer.iss
new file mode 100644
index 0000000..f5816ec
--- /dev/null
+++ b/installer.iss
@@ -0,0 +1,56 @@
+; -- Example1.iss --
+; Demonstrates copying 3 files and creating an icon.
+
+; SEE THE DOCUMENTATION FOR DETAILS ON CREATING .ISS SCRIPT FILES!
+
+[Setup]
+AppName=compile-r7rs
+AppVersion=0.1
+WizardStyle=modern
+DefaultDirName={autopf}\compile-r7rs
+DefaultGroupName=compile-r7rs
+UninstallDisplayIcon={app}\compile-r7rs.bat
+Compression=lzma2
+SolidCompression=yes
+OutputBaseFilename=setup-compile-r7rs
+OutputDir=dist
+
+[Files]
+Source: "compile-r7rs.bat"; DestDir: "{app}"
+Source: "compile-r7rs.scm"; DestDir: "{app}"; DestName: "main.scm"
+Source: "snow/*"; DestDir: "{app}/snow"; Flags: recursesubdirs
+Source: "libs/*"; DestDir: "{app}/libs"; Flags: recursesubdirs
+Source: "README.txt"; DestDir: "{app}"; Flags: isreadme
+
+[Icons]
+Name: "{group}\compile-r7rs"; Filename: "{app}\compile-r7rs.bat"
+
+[UninstallDelete]
+Name: {app}; Type: filesandordirs
+
+[Code]
+
+function NeedsAddPath(Param: string): boolean;
+var
+OrigPath: string;
+begin
+if not RegQueryStringValue(HKEY_LOCAL_MACHINE,
+ 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment',
+ 'Path', OrigPath)
+then begin
+Result := True;
+exit;
+end;
+{ look for the path with leading and trailing semicolon }
+{ Pos() returns 0 if not found }
+Result := Pos(';' + Param + ';', ';' + OrigPath + ';') = 0;
+end;
+
+[Registry]
+Root: HKLM; Subkey: "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"; \
+ ValueType: expandsz; ValueName: "Path"; ValueData: "{olddata};{app}"; \
+ Check: NeedsAddPath('{app}')
+Root: HKLM; Subkey: "SYSTEM\CurrentControlSet\Control\Session Manager\Environment"; \
+ ValueType: expandsz; ValueName: "Path"; ValueData: "{olddata};C:\Program Files\Sagittarius"; \
+ Check: NeedsAddPath('C:\Program Files\Sagittarius')
+
diff --git a/libs/data.sld b/libs/data.sld
index c4a9cc8..04afd91 100644
--- a/libs/data.sld
+++ b/libs/data.sld
@@ -3,16 +3,36 @@
(import (scheme base)
(scheme write)
(scheme file)
+ (scheme process-context)
(libs util)
(srfi 170))
(export data)
(begin
(define data
- `((chibi
+ `((chezscheme
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("scheme"
+ " "
+ ,(util-getenv "COMPILE_R7RS_CHEZSCHEME")
+ " "
+ "--quiet"
+ " "
+ ,@(map (lambda (item)
+ (string-append "--libdirs " " " item ":"))
+ (append prepend-directories append-directories))
+ " "
+ "--program"
+ " "
+ ,input-file)))))
+ (chibi
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("chibi-scheme"
+ " "
+ ,(util-getenv "COMPILE_R7RS_CHIBI")
" "
,@(map (lambda (item)
(string-append "-I" " " item " "))
@@ -24,103 +44,173 @@
,input-file)))))
(chicken
(type . compiler)
- (library-command . ,(lambda (library-file prepend-directories append-directories)
- (string-append "csc -J "
+ (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
+ (apply string-append `("csc -R r7rs -X r7rs -s -J"
+ " "
+ ,(util-getenv "COMPILE_R7RS_CHICKEN")
+ " "
+ "-o"
+ " "
+ ,@(map (lambda (item)
+ (if (string-starts-with? library-file item)
+ (string-append (string-replace (string-copy (string-cut-from-end library-file 4)
+ (+ (string-length item) 1))
+ #\/
+ #\.)
+ ".so")
+ ""))
+ (append prepend-directories append-directories))
+ " "
+ ,library-file))))
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append `("csc -R r7rs -X r7rs"
" "
- library-file)))
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
- (string-append "csc -static " input-file))))
+ ,(util-getenv "COMPILE_R7RS_CHICKEN")
+ " "
+ "-output-file"
+ " "
+ ,output-file
+ " "
+ ,input-file)))))
+ (cyclone
+ (type . compiler)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("cyclone"
+ " "
+ ,(util-getenv "COMPILE_R7RS_CYCLONE")
+ " "
+ "-o"
+ " "
+ ,output-file
+ " "
+ ,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories)
+ ,@(map (lambda (item) (string-append "-A " item " ")) append-directories)
+ ,input-file)))))
+ (foment
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("foment"
+ " "
+ ,(util-getenv "COMPILE_R7RS_FOMENT")
+ " "
+ ,@(map (lambda (item)
+ (string-append "-I" " " item " "))
+ prepend-directories)
+ ,@(map (lambda (item)
+ (string-append "-A" " " item " "))
+ append-directories)
+ " "
+ "-l"
+ " "
+ ,input-file)))))
(gambit
(type . compiler)
- (library-command . ,(lambda (library-file prepend-directories append-directories)
+ (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(apply string-append
- `("gsc -c"
+ `("gsc -obj"
" "
- "-o"
+ ,(util-getenv "COMPILE_R7RS_GAMBIT")
" "
- ,(string-append (string-copy library-file
- 0
- (- (string-length library-file)
- 4))
- ".c ")
- " "
- ,@(map (lambda (item) (string-append item "/ ")) prepend-directories)
- ,@(map (lambda (item) (string-append item "/ ")) append-directories)
,library-file))))
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
- `("gsc -nopreload -exe"
+ `("echo '#!/usr/bin/env -S gsi-script -f -:search="
+ ,@(map (lambda (item)
+ (string-append item "/"))
+ (append prepend-directories append-directories))
+ "'"
+ " "
+ ">"
+ " "
+ ,(string-append (string-cut-from-end input-file 4) ".tmp")
+ " "
+ "&&"
+ " "
+ "cat"
+ " "
+ ,input-file
+ " "
+ ">>"
+ " "
+ ,(string-append (string-cut-from-end input-file 4) ".tmp")
+ " "
+ "&&"
+ " "
+ "gsc"
+ " "
+ ,(util-getenv "COMPILE_R7RS_GAMBIT")
+ " "
+ "-:search="
+ ,@(map (lambda (item)
+ (string-append item "/"))
+ (append prepend-directories append-directories))
+ " "
+ "-o"
+ " "
+ ,output-file
+ " "
+ "-exe -nopreload"
+ " "
+ ,@(map (lambda (item) (string-append item "/ ")) prepend-directories)
+ " "
+ ,@(map (lambda (item) (string-append item "/ ")) append-directories)
+ " "
+ ,(string-append (string-cut-from-end input-file 4) ".tmp")
+ ;,input-file
+ )))))
+ (gauche
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("gosh"
+ " "
+ ,(util-getenv "COMPILE_R7RS_GAUCHE")
+ " "
+ "-r7"
+ " "
+ ,@(map (lambda (item)
+ (string-append "-I" " " item " "))
+ prepend-directories)
+ ,@(map (lambda (item)
+ (string-append "-A" " " item " "))
+ append-directories)
+ " "
+ ,input-file)))))
+ (gerbil
+ (type . compiler)
+ (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
+ (apply string-append
+ `("gxc"
+ " "
+ "-O"
+ " "
+ ,(util-getenv "COMPILE_R7RS_GERBIL")
+ " "
+ ,library-file))))
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("gxc"
+ " "
+ ,(util-getenv "COMPILE_R7RS_GERBIL")
+ " "
+ "-exe"
" "
,@(map (lambda (item) (string-append item "/ ")) prepend-directories)
,@(map (lambda (item) (string-append item "/ ")) append-directories)
" "
- ,input-file
- ;" "
- ;"&&"
- ;" "
- ;"gsc"
- ;" "
- ;"-o"
- ;" "
- ;,output-file
- ;" "
- ;"-exe"
- ;,@(map (lambda (item) (string-append item "/ ")) prepend-directories)
- ;,@(map (lambda (item) (string-append item "/ ")) append-directories)
- ;" "
- ;,@(map (lambda (item) (string-append (string-copy item 0 (- (string-length item) 4)) ".c")) library-files)
- ;" "
- ;,(string-copy input-file 0 (- (string-length input-file) 4))
- ;".c"
- )))))
- (cyclone
- (type . compiler)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
- (apply string-append
- `("cyclone "
- " "
- ,@(map (lambda (item)
- (string-append "-I" " " item " "))
- prepend-directories)
- ,@(map (lambda (item)
- (string-append "-A" " " item " "))
- append-directories)
- " "
- ,input-file)))))
- (gauche
- (type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
- (apply string-append
- `("gosh -r7"
- " "
- ,@(map (lambda (item)
- (string-append "-I" " " item " "))
- prepend-directories)
- ,@(map (lambda (item)
- (string-append "-A" " " item " "))
- append-directories)
- " "
- ,input-file)))))
- (loko
- (type . compiler)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
- (apply string-append
- `("LOKO_LIBRARY_PATH="
- ,@(map (lambda (item)
- (string-append item ":"))
- prepend-directories)
- ,@(map (lambda (item)
- (string-append item ":"))
- append-directories)
- " "
- "loko -std=r7rs --compile"
" "
,input-file)))))
(guile
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
- `("guile --r7rs"
+ `("guile"
+ " "
+ ,(util-getenv "COMPILE_R7RS_GUILE")
+ " "
+ ,(if r6rs? "--r6rs" "--r7rs")
" "
,@(map (lambda (item)
(string-append "-L" " " item " "))
@@ -130,11 +220,66 @@
append-directories)
" "
,input-file)))))
+ (husk
+ (type . compiler)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("huskc"
+ " "
+ ,(util-getenv "COMPILE_R7RS_HUSK")
+ " "
+ "-o"
+ " "
+ ,output-file
+ " "
+ ;,@(map (lambda (item) (string-append "-L" " " item " ")) prepend-directories)
+ ;,@(map (lambda (item) (string-append "-L" " " item " ")) append-directories)
+ " "
+ ,input-file)))))
+ (ikarus
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("IKARUS_LIBRARY_PATH="
+ ,@(map (lambda (item)
+ (string-append item ":"))
+ prepend-directories)
+ ,@(map (lambda (item)
+ (string-append item ":"))
+ append-directories)
+ " "
+ "ikarus"
+ " "
+ ,(util-getenv "COMPILE_R7RS_IKARUS")
+ " "
+ "--r6rs-script"
+ " "
+ ,input-file)))))
+ (ironscheme
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("ironscheme"
+ " "
+ ,(util-getenv "COMPILE_R7RS_IRONSCHEME")
+ " "
+ ,@(map (lambda (item)
+ (string-append "-I \"" item "\" "))
+ prepend-directories)
+ ,@(map (lambda (item)
+ (string-append "-I \"" item "\" "))
+ append-directories)
+ " "
+ ,input-file)))))
(kawa
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
- `("kawa --r7rs --full-tailcalls"
+ `("kawa"
+ " "
+ ,(util-getenv "COMPILE_R7RS_KAWA")
+ " "
+ "--r7rs"
" "
"-Dkawa.import.path="
,@(map (lambda (item)
@@ -145,11 +290,85 @@
append-directories)
" "
,input-file)))))
+ (larceny
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("larceny"
+ ,(util-getenv "COMPILE_R7RS_LARCENY")
+ " "
+ "-nobanner"
+ " "
+ ,(if r6rs? "-r6rs" "-r7rs")
+ " "
+ ,@(map (lambda (item)
+ (string-append "-I " item " "))
+ prepend-directories)
+ ,@(map (lambda (item)
+ (string-append "-A " item " "))
+ append-directories)
+ " "
+ ,input-file)))))
+ (loko
+ (type . compiler)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("LOKO_LIBRARY_PATH="
+ ,@(map (lambda (item)
+ (string-append item ":"))
+ prepend-directories)
+ ,@(map (lambda (item)
+ (string-append item ":"))
+ append-directories)
+ " "
+ "loko "
+ " "
+ ,(util-getenv "COMPILE_R7RS_LOKO")
+ " "
+ ,(if r6rs? "-std=r6rs" "-std=r7rs")
+ " "
+ "--compile"
+ " "
+ ,input-file)))))
+ (meevax
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("meevax"
+ " "
+ ,(util-getenv "COMPILE_R7RS_MEEVAX")
+ " "
+ ;,@(map (lambda (item) (string-append "--load " item " ")) library-files)
+ ;,@(map (lambda (item) (string-append " " item " ")) prepend-directories)
+ ;,@(map (lambda (item) (string-append " " item " ")) append-directories)
+ " "
+ ,input-file)))))
+ (mit-scheme
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("mit-scheme"
+ " "
+ ,(util-getenv "COMPILE_R7RS_MIT_SCHEME")
+ " "
+ "--batch-mode"
+ " "
+ ,@(map (lambda (item)
+ (string-append "--load " item " "))
+ library-files)
+ " "
+ "--load"
+ " "
+ ,input-file
+ " "
+ "--eval \"(exit 0)\"")))))
(mosh
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("mosh"
+ " "
+ ,(util-getenv "COMPILE_R7RS_MOSH")
" "
,@(map (lambda (item)
(string-append "--loadpath=" item " "))
@@ -159,9 +378,24 @@
append-directories)
" "
,input-file)))))
+ (picrin
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("picrin"
+ " "
+ ,(util-getenv "COMPILE_R7RS_PICRIN")
+ " "
+ ,@(map (lambda (item)
+ (string-append "-l " item " "))
+ library-files)
+ " "
+ "-e"
+ " "
+ ,input-file)))))
(racket
(type . compiler)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(let ((rkt-input-file (if (string=? input-file "")
""
(change-file-suffix input-file ".rkt"))))
@@ -197,19 +431,29 @@
(newline)))))
library-files)
(apply string-append
+ ;; TODO run realpath to each directory
+ ;; as Racket expects static paths
`("PLTCOLLECTS="
,(string-join prepend-directories ":")
,(string-join append-directories ":")
" "
- "raco exe --orig-exe ++lang r7rs -o "
+ "raco exe"
+ " "
+ ,(util-getenv "COMPILE_R7RS_RACKET")
+ " "
+ "--orig-exe ++lang r7rs -o "
,output-file
" "
,rkt-input-file))))))
(sagittarius
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
- `("sash -r7"
+ `("sash"
+ " "
+ ,(util-getenv "COMPILE_R7RS_SAGITTARIUS")
+ " "
+ ,(if r6rs? "-r6" "-r7")
" "
,@(map (lambda (item)
(string-append "-L " item " "))
@@ -221,9 +465,11 @@
,input-file)))))
(skint
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("skint"
+ " "
+ ,(util-getenv "COMPILE_R7RS_SKINT")
" "
,@(map (lambda (item)
(string-append "-I " item "/ "))
@@ -233,11 +479,25 @@
append-directories)
" "
,input-file)))))
+ (stak
+ (type . interpreter)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("stak"
+ " "
+ ,(util-getenv "COMPILE_R7RS_STAK")
+ " "
+ ;,@(map (lambda (item) (string-append "-I " item " ")) prepend-directories)
+ ;,@(map (lambda (item) (string-append "-A " item " ")) append-directories)
+ " "
+ ,input-file)))))
(stklos
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("stklos"
+ " "
+ ,(util-getenv "COMPILE_R7RS_STKLOS")
" "
,@(map (lambda (item)
(string-append "-I " item " "))
@@ -249,7 +509,7 @@
,input-file)))))
(tr7
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("TR7_LIB_PATH="
,@(map (lambda (item)
@@ -261,18 +521,42 @@
" "
"tr7i"
" "
+ ,(util-getenv "COMPILE_R7RS_TR7")
+ " "
+ ,input-file)))))
+ (vicare
+ (type . compiler)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
+ (apply string-append
+ `("vicare"
+ " "
+ ,(util-getenv "COMPILE_R7RS_VICARE")
+ " "
+ ,@(map (lambda (item)
+ (string-append "-I " item " "))
+ prepend-directories)
+ ,@(map (lambda (item)
+ (string-append "-A " item " "))
+ append-directories)
+ " "
+ "--compile-program"
+ " "
,input-file)))))
(ypsilon
(type . interpreter)
- (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
+ (command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
- `("ypsilon --r7rs"
+ `("ypsilon"
+ " "
+ ,(util-getenv "COMPILE_R7RS_YPSILON")
+ " "
+ ,(if r6rs? "--r6rs" "--r7rs")
" "
,@(map (lambda (item)
- (string-append "--sitelib=" item))
+ (string-append "--sitelib=" item " "))
prepend-directories)
,@(map (lambda (item)
- (string-append "--sitelib=" item))
+ (string-append "--sitelib=" item " "))
append-directories)
" "
,input-file)))))))))
diff --git a/libs/util.sld b/libs/util.sld
index 4c396c9..e679fb7 100644
--- a/libs/util.sld
+++ b/libs/util.sld
@@ -1,18 +1,31 @@
(define-library
(libs util)
- (import (scheme base))
+ (import (scheme base)
+ (scheme process-context))
(export string-replace
string-ends-with?
string-starts-with?
+ string-cut-from-end
string-find
string-reverse
path->filename
change-file-suffix
- string-join)
+ string-join
+ util-getenv)
(begin
+
+ (define util-getenv
+ (lambda (name)
+ (if (get-environment-variable name)
+ (get-environment-variable name)
+ "")))
+
(define string-replace
(lambda (string-content replace with)
- (string-map (lambda (c) (char=? c replace) with c) string-content)))
+ (string-map (lambda (c)
+ (if (char=? c replace)
+ with c))
+ string-content)))
(define string-ends-with?
(lambda (string-content end)
@@ -34,6 +47,13 @@
#t
#f)))
+ (define string-cut-from-end
+ (lambda (string-content cut-length)
+ (string-copy string-content
+ 0
+ (- (string-length string-content) 4))))
+
+
(define string-find
(lambda (string-content character)
(letrec* ((string-list (string->list string-content))
diff --git a/snow/retropikzel/pffi.rkt b/snow/retropikzel/pffi.rkt
deleted file mode 100644
index 4498eda..0000000
--- a/snow/retropikzel/pffi.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "pffi.sld")
diff --git a/snow/retropikzel/pffi/shared/main.scm b/snow/retropikzel/pffi/shared/main.scm
index aae7e79..986ce39 100644
--- a/snow/retropikzel/pffi/shared/main.scm
+++ b/snow/retropikzel/pffi/shared/main.scm
@@ -121,61 +121,67 @@
(list)))
(slash (cond-expand (windows (string #\\)) (else "/")))
(auto-load-paths
- (cond-expand
- (windows
- (append
- (if (get-environment-variable "SYSTEM")
- (list (get-environment-variable "SYSTEM"))
- (list))
- (if (get-environment-variable "WINDIR")
- (list (get-environment-variable "WINDIR"))
- (list))
- (if (get-environment-variable "WINEDLLDIR0")
- (list (get-environment-variable "WINEDLLDIR0"))
- (list))
- (if (get-environment-variable "SystemRoot")
- (list (string-append
- (get-environment-variable "SystemRoot")
- slash
- "system32"))
- (list))
- (list ".")
- (if (get-environment-variable "PATH")
- (string-split (get-environment-variable "PATH") #\;)
- (list))
- (if (get-environment-variable "PWD")
- (list (get-environment-variable "PWD"))
- (list))))
- (else
- (append
- ; Guix
- (list (if (get-environment-variable "GUIX_ENVIRONMENT")
- (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
- "")
- "/run/current-system/profile/lib")
- ; Debian
- (if (get-environment-variable "LD_LIBRARY_PATH")
- (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
- (list))
- (list
- ;;; x86-64
+ (cond-expand
+ (windows
+ (append
+ (if (get-environment-variable "PFFI_LOAD_PATH")
+ (string-split (get-environment-variable "PFFI_LOAD_PATH") #\;)
+ (list))
+ (if (get-environment-variable "SYSTEM")
+ (list (get-environment-variable "SYSTEM"))
+ (list))
+ (if (get-environment-variable "WINDIR")
+ (list (get-environment-variable "WINDIR"))
+ (list))
+ (if (get-environment-variable "WINEDLLDIR0")
+ (list (get-environment-variable "WINEDLLDIR0"))
+ (list))
+ (if (get-environment-variable "SystemRoot")
+ (list (string-append
+ (get-environment-variable "SystemRoot")
+ slash
+ "system32"))
+ (list))
+ (list ".")
+ (if (get-environment-variable "PATH")
+ (string-split (get-environment-variable "PATH") #\;)
+ (list))
+ (if (get-environment-variable "PWD")
+ (list (get-environment-variable "PWD"))
+ (list))))
+ (else
+ (append
+ (if (get-environment-variable "PFFI_LOAD_PATH")
+ (string-split (get-environment-variable "PFFI_LOAD_PATH") #\:)
+ (list))
+ ; Guix
+ (list (if (get-environment-variable "GUIX_ENVIRONMENT")
+ (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")
+ "")
+ "/run/current-system/profile/lib")
; Debian
- "/lib/x86_64-linux-gnu"
- "/usr/lib/x86_64-linux-gnu"
- "/usr/local/lib"
- ; Fedora/Alpine
- "/usr/lib"
- "/usr/lib64"
- ;;; aarch64
- ; Debian
- "/lib/aarch64-linux-gnu"
- "/usr/lib/aarch64-linux-gnu"
- "/usr/local/lib"
- ; Fedora/Alpine
- "/usr/lib"
- "/usr/lib64"
- ; NetBSD
- "/usr/pkg/lib")))))
+ (if (get-environment-variable "LD_LIBRARY_PATH")
+ (string-split (get-environment-variable "LD_LIBRARY_PATH") #\:)
+ (list))
+ (list
+ ;;; x86-64
+ ; Debian
+ "/lib/x86_64-linux-gnu"
+ "/usr/lib/x86_64-linux-gnu"
+ "/usr/local/lib"
+ ; Fedora/Alpine
+ "/usr/lib"
+ "/usr/lib64"
+ ;;; aarch64
+ ; Debian
+ "/lib/aarch64-linux-gnu"
+ "/usr/lib/aarch64-linux-gnu"
+ "/usr/local/lib"
+ ; Fedora/Alpine
+ "/usr/lib"
+ "/usr/lib64"
+ ; NetBSD
+ "/usr/pkg/lib")))))
(auto-load-versions (list ""))
(paths (append auto-load-paths additional-paths))
(versions (append additional-versions auto-load-versions))
diff --git a/snow/retropikzel/pffi/shared/pointer.scm b/snow/retropikzel/pffi/shared/pointer.scm
index 5e490e7..069fa83 100644
--- a/snow/retropikzel/pffi/shared/pointer.scm
+++ b/snow/retropikzel/pffi/shared/pointer.scm
@@ -12,7 +12,7 @@
(chibi #t) ; FIXME
(else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int))))
-(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int))
+;(pffi-define pffi-pointer-allocate-aligned pffi-libc-stdlib 'aligned_alloc 'pointer '(int int))
(pffi-define pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
(cond-expand
diff --git a/snow/srfi/170.rkt b/snow/srfi/170.rkt
deleted file mode 100644
index abf5fa4..0000000
--- a/snow/srfi/170.rkt
+++ /dev/null
@@ -1,3 +0,0 @@
-#lang r7rs
-(import (scheme base))
-(include "170.sld")
diff --git a/snow/srfi/170.scm b/snow/srfi/170.scm
index 75885af..af93f85 100644
--- a/snow/srfi/170.scm
+++ b/snow/srfi/170.scm
@@ -8,7 +8,7 @@
(cond-expand
(windows
- (pffi-define-library libc '("stdio.h") "ucrtbase"))
+ (pffi-define-library libc '("stdio.h") "ucrtbase" '()))
(else
(pffi-define-library libc
'("stdio.h" "error.h")
@@ -21,7 +21,7 @@
'((additional-versions ("1" "1.0.0"))))
(cond-expand
- (windows (pffi-define-library libkernel '("windows.h") "kernel32"))
+ (windows (pffi-define-library libkernel '("windows.h") "kernel32" '()))
(else #f))
;(pffi-define c-puts libc 'puts 'int '(string))
diff --git a/snow/srfi/uv-1.dll b/snow/srfi/uv-1.dll
new file mode 100755
index 0000000..d791657
Binary files /dev/null and b/snow/srfi/uv-1.dll differ
diff --git a/snow/srfi/uv.dll b/snow/srfi/uv.dll
deleted file mode 100755
index 13e0c05..0000000
Binary files a/snow/srfi/uv.dll and /dev/null differ
diff --git a/test/foo.scm b/test/foo.scm
deleted file mode 100644
index d0623cb..0000000
--- a/test/foo.scm
+++ /dev/null
@@ -1,5 +0,0 @@
-(import (scheme base)
- (scheme write)
- (bar baz))
-
-(hello)
diff --git a/test/libs/bar/baz.sld b/test/libs/bar/baz.sld
deleted file mode 100644
index da8ba45..0000000
--- a/test/libs/bar/baz.sld
+++ /dev/null
@@ -1,10 +0,0 @@
-(define-library
- (bar baz)
- (import (scheme base)
- (scheme write))
- (export hello)
- (begin
- (define hello
- (lambda ()
- (display "Hello")
- (newline)))))