Retropikzel
/
compile-r7rs
1
0
Fork 0
Code Issues 4 Pull Requests Releases Activity

Added support for many more implementations. Moved much more towards SRFI-138 conformity.

This commit is contained in:
retropikzel 2025-04-18 05:53:48 +03:00
parent a05aa0c813
commit b043e2efc8
20 changed files with 1152 additions and 289 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
.gitignore vendored
View File

@ -1,13 +1,12 @@
*.swp *.swp
*.swo
*.link *.link
compile-r7rs compile-r7rs
test/foo test
test/libs/bar/baz
*.c *.c
*.o *.o
*.o* *.o*
*.so *.so
!chicken
!src !src
*.rkt *.rkt
README.txt

12
Dockerfile
View File

@ -1,2 +1,10 @@
FROM schemers/sagittarius ARG COMPILE_R7RS=chibi
RUN apt-get update && apt-get install -y build-essential make 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

182
Jenkinsfile vendored
View File

@ -4,28 +4,178 @@ pipeline {
buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10')) buildDiscarder(logRotator(numToKeepStr: '10', artifactNumToKeepStr: '10'))
} }
stages { 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") { stage("Build") {
agent dockerfile agent {
docker {
image 'schemers/sagittarius'
}
}
steps { steps {
sh 'make' sh 'make'
sh 'make install'
sh 'make SCHEME=sagittarius test-r6rs'
sh 'make SCHEME=sagittarius test-r7rs'
} }
} }
stage("Build exe") { stage("Test chez r6rs") {
agent dockerfile
steps { 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'
}
} }
} }
} }

50
Makefile
View File

@ -2,7 +2,7 @@
PREFIX=/usr/local PREFIX=/usr/local
build: 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: snow:
rm -rf snow rm -rf snow
@ -21,13 +21,55 @@ uninstall:
rm -rf ${PREFIX}/lib/compile-r7rs/snow rm -rf ${PREFIX}/lib/compile-r7rs/snow
rm -rf ${PREFIX}/bin/compile-r7rs 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: clean:
rm -rf test/foo
rm -rf test/libs/bar/baz
find . -name "*.so" -delete find . -name "*.so" -delete
find . -name "*.o*" -delete find . -name "*.o*" -delete
find . -name "*.rkt" -delete find . -name "*.rkt" -delete
find ./test -name "*.c" -delete
find . -name "*.link" -delete find . -name "*.link" -delete
find . -name "*.meta" -delete find . -name "*.meta" -delete
find . -name "*.import.*" -delete find . -name "*.import.*" -delete
rm -rf README.txt
rm -rf dist
rm -rf test
clean-test:
rm -rf test

353
README.md
View File

@ -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). 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
<a name="#notes"></a>
- 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
<a name="#supported-implementations"></a>
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 - chibi
- interpreter
- r7rs
- chicken
- compiler
- r7rs
- cyclone - cyclone
- compiler
- r7rs
- Gambit
- compiler
- r7rs
- foment
- interpreter
- r7rs
- gauche - gauche
- interpreter
- r7rs
- guile - 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 - kawa
- interpreter
- r7rs
- larceny
- interpreter
- r6rs
- r7rs
- loko - loko
- compiler
- r6rs
- r7rs
- mit-scheme
- interpreter
- r7rs
- mosh - mosh
- interpreter
- r6rs
- r7rs
- sagittarius - sagittarius
- interpreter
- r6rs
- r7rs
- skint - skint
- interpreter
- r7rs
- stklos - stklos
- interpreter
- r7rs
- tr7 - tr7
- interpreter
- r7rs
- ypsilon - ypsilon
- interpreter
- r6rs
- r7rs
## Roadmap
<a name="#roadmap"></a>
- 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 ## Dependencies
<a name="#dependencies"></a>
### Linux
<a name="#dependencies-linux"></a>
#### Sagittarius Scheme
## Getting started
### Install Sagittarius scheme
#### Linux
On Debian/Ubuntu/Mint: On Debian/Ubuntu/Mint:
@ -38,53 +161,221 @@ On Debian/Ubuntu/Mint:
make make
make install make install
#### Windows #### libuv
Download the installer from
[https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/](https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/)
and install it.
### Install libuv
#### Linux
On Debian/Ubuntu/Mint run: On Debian/Ubuntu/Mint run:
apt install libuv1 apt install libuv1
#### Windows ### Windows
<a name="#dependencies-windows"></a>
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
<a name="#Installation"></a>
### Linux
<a name="#Installation-linux"></a>
./configure ./configure
make make
make install make install
### Build on Windows ### Windows
<a name="#Installation-windows"></a>
Work in progres Donwload the setup-compile-r7rs.exe from dist directory from this repository.
In command prompt run:
build.bat If you want to compile the installer yourself look into the makefile and
install.bat installer.iss, it is made with innosetup.
## Usage ## Usage
<a name="#usage"></a>
You need to install each Scheme implementation yourself. You need to install each Scheme implementation yourself.
The environment variable SCHEME must be set to the name of the implementation The environment variable COMPILE\_R7RS must be set to the name of the
as specified in the support list. 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=<implementation name> 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=<implementation name> compile-r7rs -I . main.scm COMPILE_R7RS=<implementation name> compile-r7rs -I . -o main main.scm
Which produces file called main, which you can run. Note that when given Scheme 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 is interpreter the file contains commands that run the script, and even when
the file is combiled binary it might need the compiled libraries. 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
<a name="#usage-environment-variables"></a>
- 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
<a name="#usage-with-docker"></a>
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=<your scheme>
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
<a name="#usual-rnrs-projects"></a>
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
<a name="#usual-rnrs-projects-file-structure"></a>
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
<a name="#usual-rnrs-projects-installation-of-your-project"></a>
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
<a name="#development"></a>
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
<a name="#development-adding-new-implementations"></a>
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
<a name="#development-misc-notes"></a>
When developing and testing, run:
make && sudo make uninstall install
without the uninstall the changes to libraries dont seem to update.

2
build.bat
View File

@ -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

3
compile-r7rs.bat
View File

@ -1,2 +1,3 @@
@echo off @echo off
sash.exe -r7 -L C:\Program Files (x86)/compile-r7rs/snow C:\Program Files (x86)compile-r7rs/main.scm %* 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" %*

127
compile-r7rs.scm
View File

@ -13,24 +13,38 @@
(lambda (scheme) (lambda (scheme)
(display scheme) (display scheme)
(newline)) (newline))
'(chibi '(chezscheme
chibi
chicken
cyclone cyclone
gambit
foment
gauche gauche
;guile ;gerbil
guile
;husk
ikarus
ironscheme
kawa kawa
larceny
loko loko
;meevax
mit-scheme
mosh mosh
;picrin
;stak
sagittarius sagittarius
skint skint
stklos stklos
tr7 tr7
;vicare
ypsilon)) ypsilon))
(exit 0)) (exit 0))
(define scheme (if (get-environment-variable "SCHEME") (define scheme (if (get-environment-variable "COMPILE_R7RS")
(string->symbol (get-environment-variable "SCHEME")) (string->symbol (get-environment-variable "COMPILE_R7RS"))
#f)) #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)) (when (not (assoc scheme data))
(error "Unsupported implementation" scheme)) (error "Unsupported implementation" scheme))
(define compilation-target (if (get-environment-variable "TARGET") (define compilation-target (if (get-environment-variable "TARGET")
@ -42,19 +56,22 @@
(let ((input-file #f)) (let ((input-file #f))
(for-each (for-each
(lambda (item) (lambda (item)
(when (and (> (string-length item) 4) (when (or (string-ends-with? item ".scm")
(string=? ".scm" (string-copy item (string-ends-with? item ".sps"))
(- (string-length item) 4)
(string-length item))))
(set! input-file item))) (set! input-file item)))
(list-tail (command-line) 1)) (list-tail (command-line) 1))
input-file)) input-file))
(define r6rs? (if (and input-file
(string-ends-with? input-file ".sps"))
#t
#f))
(define output-file (define output-file
(if (member "-o" (command-line)) (if (member "-o" (command-line))
(cadr (member "-o" (command-line))) (cadr (member "-o" (command-line)))
(if input-file (if input-file
(string-copy input-file 0 (- (string-length input-file) 4)) "a.out"
#f))) #f)))
(define prepend-directories (define prepend-directories
@ -95,7 +112,11 @@
(lambda (file) (lambda (file)
(let* ((path (string-append directory "/" file)) (let* ((path (string-append directory "/" file))
(info (file-info path #f))) (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)))) (set! result (append result (list path))))
(if (file-info-directory? info) (if (file-info-directory? info)
(set! result (append result (search-library-files path)))))) (set! result (append result (search-library-files path))))))
@ -119,12 +140,13 @@
(if output-file output-file "") (if output-file output-file "")
prepend-directories prepend-directories
append-directories append-directories
library-files))) library-files
r6rs?)))
(define scheme-library-command (define scheme-library-command
(lambda (library-file) (lambda (library-file)
(apply (cdr (assoc 'library-command (cdr (assoc scheme data)))) (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 (define list-of-features
@ -144,60 +166,67 @@
(display "Type ") (display "Type ")
(display scheme-type) (display scheme-type)
(newline) (newline)
(display "Command ")
(display scheme-command)
(newline)
(display "Input file ")
(display input-file)
(newline)
(display "Output file ")
(display output-file)
(newline) (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 ; Create executable file
(when (and (equal? scheme-type 'interpreter) input-file) (when (and (equal? scheme-type 'interpreter) input-file)
(when (and output-file (file-exists? output-file)) (when (and output-file (file-exists? output-file))
(delete-file output-file)) (delete-file output-file))
(display "Creating startup script ")
(display output-file)
(newline)
(display "Containing command ")
(display scheme-command)
(newline)
(with-output-to-file (with-output-to-file
(if (string=? compilation-target "windows") (if (string=? compilation-target "windows")
(string-append output-file ".bat") (string-append output-file ".bat")
output-file) output-file)
(lambda () (lambda ()
(when (string=? compilation-target "unix") (cond ((string=? compilation-target "unix")
(display "#!/bin/sh")) (display "#!/bin/sh")
(when (string=? compilation-target "windows") (newline))
(display "@echo off")) ((string=? compilation-target "windows")
(display "@echo off")
(newline) (newline)
(when (string=? compilation-target "windows") (display "start")))
(display "start")) (display scheme-command)))
(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 (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 "Compiling file ")
(display input-file) (display input-file)
(newline) (newline)
(display "With command ") (display "With command ")
(display scheme-command) (display scheme-command)
(newline) (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)))

56
installer.iss Normal file
View File

@ -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')

430
libs/data.sld
View File

@ -3,16 +3,36 @@
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
(scheme file) (scheme file)
(scheme process-context)
(libs util) (libs util)
(srfi 170)) (srfi 170))
(export data) (export data)
(begin (begin
(define data (define data
`((chibi `((chezscheme
(type . interpreter) (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 (apply string-append
`("chibi-scheme" `("chibi-scheme"
" "
,(util-getenv "COMPILE_R7RS_CHIBI")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-I" " " item " ")) (string-append "-I" " " item " "))
@ -24,60 +44,56 @@
,input-file))))) ,input-file)))))
(chicken (chicken
(type . compiler) (type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories) (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(string-append "csc -J " (apply string-append `("csc -R r7rs -X r7rs -s -J"
" " " "
library-file))) ,(util-getenv "COMPILE_R7RS_CHICKEN")
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
(string-append "csc -static " input-file))))
(gambit
(type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories)
(apply string-append
`("gsc -c"
" " " "
"-o" "-o"
" " " "
,(string-append (string-copy library-file ,@(map (lambda (item)
0 (if (string-starts-with? library-file item)
(- (string-length library-file) (string-append (string-replace (string-copy (string-cut-from-end library-file 4)
4)) (+ (string-length item) 1))
".c ") #\/
#\.)
".so")
""))
(append prepend-directories append-directories))
" " " "
,@(map (lambda (item) (string-append item "/ ")) prepend-directories)
,@(map (lambda (item) (string-append item "/ ")) append-directories)
,library-file)))) ,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 (apply string-append `("csc -R r7rs -X r7rs"
`("gsc -nopreload -exe"
" " " "
,@(map (lambda (item) (string-append item "/ ")) prepend-directories) ,(util-getenv "COMPILE_R7RS_CHICKEN")
,@(map (lambda (item) (string-append item "/ ")) append-directories)
" " " "
,input-file "-output-file"
;" " " "
;"&&" ,output-file
;" " " "
;"gsc" ,input-file)))))
;" "
;"-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 (cyclone
(type . compiler) (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?)
(apply string-append (apply string-append
`("cyclone " `("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) ,@(map (lambda (item)
(string-append "-I" " " item " ")) (string-append "-I" " " item " "))
@ -86,12 +102,73 @@
(string-append "-A" " " item " ")) (string-append "-A" " " item " "))
append-directories) append-directories)
" " " "
"-l"
" "
,input-file))))) ,input-file)))))
(gambit
(type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(apply string-append
`("gsc -obj"
" "
,(util-getenv "COMPILE_R7RS_GAMBIT")
" "
,library-file))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append
`("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 (gauche
(type . interpreter) (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 (apply string-append
`("gosh -r7" `("gosh"
" "
,(util-getenv "COMPILE_R7RS_GAUCHE")
" "
"-r7"
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-I" " " item " ")) (string-append "-I" " " item " "))
@ -101,26 +178,39 @@
append-directories) append-directories)
" " " "
,input-file))))) ,input-file)))))
(loko (gerbil
(type . compiler) (type . compiler)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files) (library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(apply string-append (apply string-append
`("LOKO_LIBRARY_PATH=" `("gxc"
,@(map (lambda (item) " "
(string-append item ":")) "-O"
prepend-directories) " "
,@(map (lambda (item) ,(util-getenv "COMPILE_R7RS_GERBIL")
(string-append item ":")) " "
append-directories) ,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)
" " " "
"loko -std=r7rs --compile"
" " " "
,input-file))))) ,input-file)))))
(guile (guile
(type . interpreter) (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 (apply string-append
`("guile --r7rs" `("guile"
" "
,(util-getenv "COMPILE_R7RS_GUILE")
" "
,(if r6rs? "--r6rs" "--r7rs")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-L" " " item " ")) (string-append "-L" " " item " "))
@ -130,11 +220,66 @@
append-directories) append-directories)
" " " "
,input-file))))) ,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 (kawa
(type . interpreter) (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 (apply string-append
`("kawa --r7rs --full-tailcalls" `("kawa"
" "
,(util-getenv "COMPILE_R7RS_KAWA")
" "
"--r7rs"
" " " "
"-Dkawa.import.path=" "-Dkawa.import.path="
,@(map (lambda (item) ,@(map (lambda (item)
@ -145,11 +290,85 @@
append-directories) append-directories)
" " " "
,input-file))))) ,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 (mosh
(type . interpreter) (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 (apply string-append
`("mosh" `("mosh"
" "
,(util-getenv "COMPILE_R7RS_MOSH")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "--loadpath=" item " ")) (string-append "--loadpath=" item " "))
@ -159,9 +378,24 @@
append-directories) append-directories)
" " " "
,input-file))))) ,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 (racket
(type . compiler) (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 "") (let ((rkt-input-file (if (string=? input-file "")
"" ""
(change-file-suffix input-file ".rkt")))) (change-file-suffix input-file ".rkt"))))
@ -197,19 +431,29 @@
(newline))))) (newline)))))
library-files) library-files)
(apply string-append (apply string-append
;; TODO run realpath to each directory
;; as Racket expects static paths
`("PLTCOLLECTS=" `("PLTCOLLECTS="
,(string-join prepend-directories ":") ,(string-join prepend-directories ":")
,(string-join append-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 ,output-file
" " " "
,rkt-input-file)))))) ,rkt-input-file))))))
(sagittarius (sagittarius
(type . interpreter) (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 (apply string-append
`("sash -r7" `("sash"
" "
,(util-getenv "COMPILE_R7RS_SAGITTARIUS")
" "
,(if r6rs? "-r6" "-r7")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-L " item " ")) (string-append "-L " item " "))
@ -221,9 +465,11 @@
,input-file))))) ,input-file)))))
(skint (skint
(type . interpreter) (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 (apply string-append
`("skint" `("skint"
" "
,(util-getenv "COMPILE_R7RS_SKINT")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-I " item "/ ")) (string-append "-I " item "/ "))
@ -233,11 +479,25 @@
append-directories) append-directories)
" " " "
,input-file))))) ,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 (stklos
(type . interpreter) (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 (apply string-append
`("stklos" `("stklos"
" "
,(util-getenv "COMPILE_R7RS_STKLOS")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "-I " item " ")) (string-append "-I " item " "))
@ -249,7 +509,7 @@
,input-file))))) ,input-file)))))
(tr7 (tr7
(type . interpreter) (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 (apply string-append
`("TR7_LIB_PATH=" `("TR7_LIB_PATH="
,@(map (lambda (item) ,@(map (lambda (item)
@ -261,18 +521,42 @@
" " " "
"tr7i" "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))))) ,input-file)))))
(ypsilon (ypsilon
(type . interpreter) (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 (apply string-append
`("ypsilon --r7rs" `("ypsilon"
" "
,(util-getenv "COMPILE_R7RS_YPSILON")
" "
,(if r6rs? "--r6rs" "--r7rs")
" " " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "--sitelib=" item)) (string-append "--sitelib=" item " "))
prepend-directories) prepend-directories)
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "--sitelib=" item)) (string-append "--sitelib=" item " "))
append-directories) append-directories)
" " " "
,input-file))))))))) ,input-file)))))))))

26
libs/util.sld
View File

@ -1,18 +1,31 @@
(define-library (define-library
(libs util) (libs util)
(import (scheme base)) (import (scheme base)
(scheme process-context))
(export string-replace (export string-replace
string-ends-with? string-ends-with?
string-starts-with? string-starts-with?
string-cut-from-end
string-find string-find
string-reverse string-reverse
path->filename path->filename
change-file-suffix change-file-suffix
string-join) string-join
util-getenv)
(begin (begin
(define util-getenv
(lambda (name)
(if (get-environment-variable name)
(get-environment-variable name)
"")))
(define string-replace (define string-replace
(lambda (string-content replace with) (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? (define string-ends-with?
(lambda (string-content end) (lambda (string-content end)
@ -34,6 +47,13 @@
#t #t
#f))) #f)))
(define string-cut-from-end
(lambda (string-content cut-length)
(string-copy string-content
0
(- (string-length string-content) 4))))
(define string-find (define string-find
(lambda (string-content character) (lambda (string-content character)
(letrec* ((string-list (string->list string-content)) (letrec* ((string-list (string->list string-content))

3
snow/retropikzel/pffi.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "pffi.sld")

6
snow/retropikzel/pffi/shared/main.scm
View File

@ -124,6 +124,9 @@
(cond-expand (cond-expand
(windows (windows
(append (append
(if (get-environment-variable "PFFI_LOAD_PATH")
(string-split (get-environment-variable "PFFI_LOAD_PATH") #\;)
(list))
(if (get-environment-variable "SYSTEM") (if (get-environment-variable "SYSTEM")
(list (get-environment-variable "SYSTEM")) (list (get-environment-variable "SYSTEM"))
(list)) (list))
@ -148,6 +151,9 @@
(list)))) (list))))
(else (else
(append (append
(if (get-environment-variable "PFFI_LOAD_PATH")
(string-split (get-environment-variable "PFFI_LOAD_PATH") #\:)
(list))
; Guix ; Guix
(list (if (get-environment-variable "GUIX_ENVIRONMENT") (list (if (get-environment-variable "GUIX_ENVIRONMENT")
(string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib") (string-append (get-environment-variable "GUIX_ENVIRONMENT") slash "lib")

2
snow/retropikzel/pffi/shared/pointer.scm
View File

@ -12,7 +12,7 @@
(chibi #t) ; FIXME (chibi #t) ; FIXME
(else (pffi-define pffi-pointer-allocate pffi-libc-stdlib 'malloc 'pointer '(int)))) (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)) (pffi-define pffi-pointer-allocate-calloc pffi-libc-stdlib 'calloc 'pointer '(int int))
(cond-expand (cond-expand

3
snow/srfi/170.rkt
View File

@ -1,3 +0,0 @@
#lang r7rs
(import (scheme base))
(include "170.sld")

4
snow/srfi/170.scm
View File

@ -8,7 +8,7 @@
(cond-expand (cond-expand
(windows (windows
(pffi-define-library libc '("stdio.h") "ucrtbase")) (pffi-define-library libc '("stdio.h") "ucrtbase" '()))
(else (else
(pffi-define-library libc (pffi-define-library libc
'("stdio.h" "error.h") '("stdio.h" "error.h")
@ -21,7 +21,7 @@
'((additional-versions ("1" "1.0.0")))) '((additional-versions ("1" "1.0.0"))))
(cond-expand (cond-expand
(windows (pffi-define-library libkernel '("windows.h") "kernel32")) (windows (pffi-define-library libkernel '("windows.h") "kernel32" '()))
(else #f)) (else #f))
;(pffi-define c-puts libc 'puts 'int '(string)) ;(pffi-define c-puts libc 'puts 'int '(string))

BIN
snow/srfi/uv-1.dll Executable file
View File

Binary file not shown.

BIN
snow/srfi/uv.dll
View File

Binary file not shown.

5
test/foo.scm
View File

@ -1,5 +0,0 @@
(import (scheme base)
(scheme write)
(bar baz))
(hello)

10
test/libs/bar/baz.sld
View File

@ -1,10 +0,0 @@
(define-library
(bar baz)
(import (scheme base)
(scheme write))
(export hello)
(begin
(define hello
(lambda ()
(display "Hello")
(newline)))))