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

Added support for more implementations

This commit is contained in:
retropikzel 2025-04-13 17:21:10 +03:00
parent 6e0d9efdf1
commit 955f5a7373
14 changed files with 418 additions and 4982 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
.gitignore vendored
View File

@ -1,3 +1,11 @@
*.swp
*.link
compile-r7rs
test/foo
test/libs/bar/baz
*.c
*.o
*.so
!chicken
!src

6
Dockerfile
View File

@ -1,4 +1,2 @@
FROM debian:stable
RUN apt-get update && apt-get install -y build-essential make wget
RUN wget https://ziglang.org/builds/zig-linux-x86_64-0.15.0-dev.300+9e21ba12d.tar.xz && tar -xf *.tar.xz
RUN ls -1
FROM schemers/sagittarius
RUN apt-get update && apt-get install -y build-essential make

12
Jenkinsfile vendored
View File

@ -4,6 +4,18 @@ 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
steps {

25
Makefile
View File

@ -1,4 +1,4 @@
.PHONY: test
.PHONY: snow
PREFIX=/usr/local
CC=gcc
CHICKEN_FLAGS=-optimize-level 3
@ -14,12 +14,19 @@ build:
-Ichicken/include
test-sagittarius:
cd test && sash -r7 -L ${PWD}/snow ../compile-r7rs.scm
cd test && sash -r7 -L ${PWD}/snow ../compile-r7rs.scm -I ./libs
cd test && sash -r7 -L ${PWD}/snow ../compile-r7rs.scm -I ./libs foo.scm
chmod +x test/foo
cd test && ./foo
test-racket:
cd test && racket -I r7rs -S ${PWD}/snow --script ../compile-r7rs.scm
test-guile:
cd test && guile --r7rs -L ${PWD}/snow ../compile-r7rs.scm -I ./libs
cd test && guile --r7rs -L ${PWD}/snow ../compile-r7rs.scm -I ./libs foo.scm
chmod +x test/foo
cd test && ./foo
build-snow:
snow:
rm -rf snow
mkdir -p snow
cp -r ../r7rs-pffi/retropikzel snow/
@ -43,4 +50,10 @@ install:
install compile-r7rs ${PREFIX}/bin/compile-r7rs
clean:
rm -rf src
rm -rf test/foo
rm -rf test/libs/bar/baz
find . -name "*.so" -delete
find . -name "*.o" -delete
find . -name "*.link" -delete
find . -name "*.meta" -delete
find . -name "*.import.*" -delete

100
README.md
View File

@ -1,87 +1,47 @@
compile-r7rs is a tool to compile R7RS Scheme programs, it aims for compability
with [SRFI-138](https://srfi.schemers.org/srfi-138/srfi-138.html).
## Supported implementations
- chibi
- cyclone
- gauche
- guile
- kawa
- mosh
- sagittarius
- skint
- stklos
- tr7
- ypsilon
## Dependencies
For scripts:
C toolchain and libuv, on Debian/Ubuntu/Mint run
apt install sharutils
apt install build-essential libuv1-dev
For binaries:
You need to install each Scheme implementation yourself.
apt install build-essential
## Build and install
For jar:
apt install default-jdk
## Installing
make install
./configure
make
install
## Usage
The environment variable SCMC must be set to the same value as the
implementations command. The command is the first word on the list.
So for example guile for Guile, csi for Chicken interpreter, csc for Chicken
compiler.
The environment variable SCHEME must be set to the name of the implementation
as specified in the support list.
If the command has .exe at it's end cross compilation from Linux to .exe with
Wine is assumed.
First to compile your libraries run the command without the .scm file.
SCHEME=<implementation name> compile-r7rs -I .
Run
Then run it with the .scm file.
SCMC=<SCHEME> compile-r7rs -I <DIR> <file.scm>
SCHEME=<implementation name> compile-r7rs -I . main.scm
So for example to build hello-world.scm with Racket for both Linux and Wine run:
SCMC=racket compile-r7rs -I ./snow hello-world.scm
SCMC=racket.exe compile-r7rs -I ./snow hello-world.scm
Libraries in these commands are assumed to be under snow directory, so library
(foo bar) would be in snow/foo/bar.sld.
## Outputs
### Self contained, self extracting and runnable shell script
Requires the Scheme implementation to be installed to run.
- chibi-scheme
- csi (Chicken)
- icyc (Cyclone)
- gsi (Gambit)
- gosh (Gauche)
- guile
- mosh
- sash
- stklos
- skint
- tr7i (tr7)
- ypsilon
### Static binary executable
Does not require Scheme implementation to be installed to run.
- csc (Chicken)
- racket (Racket)
### Java ARchive (JAR)
Only requires Java to be installed to run.
- kawa
- The build folder needs to contain kawa.jar
### .exe
- racket.exe
- Install Racket and r7rs library with Wine to default locations
## How it works
The scripts searches for .sld files in given paths, compiles them if needed and combines them with
the main script to form something that can be run on it's own. Meaning that the only thing the
person running the things needs, might be, the Scheme implementation, Java, or nothing.
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.

177
compile-r7rs.scm
View File

@ -1,26 +1,177 @@
(import (scheme base)
(scheme file)
(scheme read)
(scheme write)
(scheme process-context)
(retropikzel pffi)
(srfi 170))
(define interpreters '(chibi))
(define compilers '(chicken))
(define implementations (append interpreters compilers))
(include "src/util.scm")
(include "src/data.scm")
(define scheme (get-environment-variable "SCHEME"))
(define scheme (if (get-environment-variable "SCHEME")
(string->symbol (get-environment-variable "SCHEME"))
#f))
(when (not scheme) (error "Environment variable SCHEME not set."))
(define is-interpreter? (if (member (string->symbol scheme) interpreters) #t #f))
(define is-compiler? (if (member (string->symbol scheme) compilers) #t #f))
(when (not (assoc scheme data))
(error "Unsupported implementation" scheme))
(define compilation-target (if (get-environment-variable "TARGET")
(get-environment-variable "TARGET")
(cond-expand (windows "windows")
(else "unix"))))
(define input-file
(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))))
(set! input-file item)))
(list-tail (command-line) 1))
input-file))
(when (not (member (string->symbol scheme) implementations))
(error "Unsupported scheme implementation" scheme))
(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))
#f)))
(define file-to-compile
(if (> (length (command-line)) 1)
(car (reverse (command-line)))
#f))
(define prepend-directories
(letrec ((looper (lambda (rest result)
(if (null? rest)
result
(if (string=? (car rest) "-I")
(looper (cdr (cdr rest))
(append (list (cadr rest)) result))
(looper (cdr rest)
result))))))
(looper (command-line) (list))))
(write file-to-compile)
(define append-directories
(letrec ((looper (lambda (rest result)
(if (null? rest)
result
(if (string=? (car rest) "-A")
(looper (cdr (cdr rest))
(append (list (cadr rest)) result))
(looper (cdr rest)
result))))))
(looper (command-line) (list))))
(cond-expand
(windows (pffi-define-library c-libstd '("libstd.h") "ucrtbase"))
(else (pffi-define-library c-libstd
'("libstd.h")
"c"
'((additional-versions ("6"))))))
(pffi-define c-system c-libstd 'system 'int '(pointer))
(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data)))))
(define scheme-command
(apply (cdr (assoc 'command (cdr (assoc scheme data))))
(list (if input-file input-file "")
(if output-file output-file "")
prepend-directories
append-directories)))
(define scheme-library-command
(lambda (library-file)
(apply (cdr (assoc 'library-command (cdr (assoc scheme data))))
(list library-file prepend-directories append-directories))))
(define search-library-files
(lambda (directory)
(let ((result (list)))
(for-each
(lambda (file)
(let* ((path (string-append directory "/" file))
(info (file-info path #f)))
(when (string-ends-with? path ".sld")
(set! result (append result (list path))))
(if (file-info-directory? info)
(set! result (append result (search-library-files path))))))
(directory-files directory))
result)))
(define list-of-features
(letrec ((looper (lambda (rest result)
(if (null? rest)
result
(if (string=? (car rest) "-D")
(looper (cdr (cdr rest))
(append (list (cadr rest)) result))
(looper (cdr rest)
result))))))
(looper (command-line) (list))))
(display "Scheme ")
(display scheme)
(newline)
(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)
; 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
(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))))
(when (and (equal? scheme-type 'compiler) input-file)
(when (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)))
; 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 (directory)
(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))))
(search-library-files directory)))
(append prepend-directories append-directories)))
((not input-file)
(display "Library compilation requested but no library command found. ")
(display "Skipping...")
(newline)))

50
retropikzel.pffi.import.scm
View File

@ -1,50 +0,0 @@
;;;; retropikzel.pffi.import.scm - GENERATED BY CHICKEN 6.0.0 -*- Scheme -*-
(##sys#with-environment
(lambda ()
(scheme#eval
'(import-syntax
(only scheme.base
begin
cond-expand
export
import
import-for-syntax
include
include-ci
syntax-rules)
(only chicken.module export/rename)
scheme.base
scheme.write
scheme.char
scheme.file
scheme.process-context
chicken.base
chicken.foreign
chicken.locative
chicken.syntax
chicken.memory
chicken.random))
(import
(only scheme.base
begin
cond-expand
export
import
import-for-syntax
include
include-ci
syntax-rules))
(##sys#register-compiled-module
'retropikzel.pffi
'#f
(scheme#list)
'()
(scheme#list
(scheme#cons
'|\x4;r7rsretropikzel.pffi|
(##sys#er-transformer (##core#lambda (x r c) (##core#undefined)))))
(scheme#list)
(scheme#list))))
;; END OF FILE

2
snow/srfi/170.sld
View File

@ -81,4 +81,4 @@
;delete-environment-variable!
;terminal?
)
(include "170.scm"))
(include "170.scm"))

418
src/compile-r7rs.c
View File

@ -1,418 +0,0 @@
/* Generated from compile-r7rs.scm by the CHICKEN compiler
http://www.call-cc.org
Version 6.0.0pre1 ((HEAD detached at 6.0.0pre1)) (rev 05be15d4)
linux-unix-gnu-x86-64 [ 64bit dload ptables ]
command line: compile-r7rs.scm -output-file src/compile-r7rs.c -optimize-level 3
uses: eval r7lib library
*/
#include "chicken.h"
static C_PTABLE_ENTRY *create_ptable(void);
C_noret_decl(C_eval_toplevel)
C_extern void C_ccall C_eval_toplevel(C_word c,C_word *av) C_noret;
C_noret_decl(C_r7lib_toplevel)
C_extern void C_ccall C_r7lib_toplevel(C_word c,C_word *av) C_noret;
C_noret_decl(C_library_toplevel)
C_extern void C_ccall C_library_toplevel(C_word c,C_word *av) C_noret;
static C_word lf[16];
static double C_possibly_force_alignment;
static C_char li0[] C_aligned={C_lihdr(0,0,10),40,116,111,112,108,101,118,101,108,41,0,0,0,0,0,0};
C_noret_decl(f209)
static void C_ccall f209(C_word c,C_word *av) C_noret;
C_noret_decl(f_145)
static void C_ccall f_145(C_word c,C_word *av) C_noret;
C_noret_decl(f_148)
static void C_ccall f_148(C_word c,C_word *av) C_noret;
C_noret_decl(f_151)
static void C_ccall f_151(C_word c,C_word *av) C_noret;
C_noret_decl(f_155)
static void C_ccall f_155(C_word c,C_word *av) C_noret;
C_noret_decl(f_161)
static void C_ccall f_161(C_word c,C_word *av) C_noret;
C_noret_decl(f_172)
static void C_ccall f_172(C_word c,C_word *av) C_noret;
C_noret_decl(f_178)
static void C_ccall f_178(C_word c,C_word *av) C_noret;
C_noret_decl(f_192)
static void C_ccall f_192(C_word c,C_word *av) C_noret;
C_noret_decl(f_199)
static void C_ccall f_199(C_word c,C_word *av) C_noret;
C_noret_decl(f_206)
static void C_ccall f_206(C_word c,C_word *av) C_noret;
C_noret_decl(C_toplevel)
C_extern void C_ccall C_toplevel(C_word c,C_word *av) C_noret;
/* f209 in k190 in k197 in k204 in k159 in k153 in k149 in k146 in k143 */
static void C_ccall f209(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(0,c,1)))){
C_save_and_reclaim((void *)f209,c,av);}
t2=t1;{
C_word *av2=av;
av2[0]=t2;
av2[1]=((C_word*)t0)[2];
((C_proc)(void*)(*((C_word*)t2+1)))(2,av2);}}
/* k143 */
static void C_ccall f_145(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_145,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_148,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_eval_toplevel(2,av2);}}
/* k146 in k143 */
static void C_ccall f_148(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_148,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_151,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_r7lib_toplevel(2,av2);}}
/* k149 in k146 in k143 */
static void C_ccall f_151(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_151,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_155,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
C_trace(C_text("compile-r7rs.scm:5: chicken.process-context#get-environment-variable"));
t3=C_fast_retrieve(lf[14]);{
C_word *av2;
if(c >= 3) {
av2=av;
} else {
av2=C_alloc(3);
}
av2[0]=t3;
av2[1]=t2;
av2[2]=lf[15];
((C_proc)(void*)(*((C_word*)t3+1)))(3,av2);}}
/* k153 in k149 in k146 in k143 */
static void C_ccall f_155(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word t4;
C_word t5;
C_word t6;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,3)))){
C_save_and_reclaim((void *)f_155,c,av);}
a=C_alloc(3);
t2=C_mutate((C_word*)lf[0]+1 /* (set! scheme ...) */,t1);
t3=C_mutate((C_word*)lf[1]+1 /* (set! interpreters ...) */,lf[2]);
t4=C_mutate((C_word*)lf[3]+1 /* (set! compilers ...) */,lf[4]);
t5=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_161,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
C_trace(C_text("compile-r7rs.scm:9: scheme#append"));
t6=*((C_word*)lf[13]+1);{
C_word *av2;
if(c >= 4) {
av2=av;
} else {
av2=C_alloc(4);
}
av2[0]=t6;
av2[1]=t5;
av2[2]=C_fast_retrieve(lf[1]);
av2[3]=C_fast_retrieve(lf[3]);
((C_proc)(void*)(*((C_word*)t6+1)))(4,av2);}}
/* k159 in k153 in k149 in k146 in k143 */
static void C_ccall f_161(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word t4;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_161,c,av);}
a=C_alloc(3);
t2=C_mutate((C_word*)lf[5]+1 /* (set! implementations ...) */,t1);
t3=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_206,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
C_trace(C_text("compile-r7rs.scm:11: scheme#string->symbol"));
t4=*((C_word*)lf[12]+1);{
C_word *av2;
if(c >= 3) {
av2=av;
} else {
av2=C_alloc(3);
}
av2[0]=t4;
av2[1]=t3;
av2[2]=C_fast_retrieve(lf[0]);
((C_proc)(void*)(*((C_word*)t4+1)))(3,av2);}}
/* k170 in k197 in k204 in k159 in k153 in k149 in k146 in k143 */
static void C_ccall f_172(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_172,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_178,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
C_trace(C_text("chicken.base#implicit-exit-handler"));
t3=C_fast_retrieve(lf[8]);{
C_word *av2=av;
av2[0]=t3;
av2[1]=t2;
((C_proc)(void*)(*((C_word*)t3+1)))(2,av2);}}
/* k176 in k170 in k197 in k204 in k159 in k153 in k149 in k146 in k143 */
static void C_ccall f_178(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(0,c,1)))){
C_save_and_reclaim((void *)f_178,c,av);}
t2=t1;{
C_word *av2=av;
av2[0]=t2;
av2[1]=((C_word*)t0)[2];
((C_proc)(void*)(*((C_word*)t2+1)))(2,av2);}}
/* k190 in k197 in k204 in k159 in k153 in k149 in k146 in k143 */
static void C_ccall f_192(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word t4;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,3)))){
C_save_and_reclaim((void *)f_192,c,av);}
a=C_alloc(3);
t2=C_i_member(t1,C_fast_retrieve(lf[9]));
if(C_truep(C_i_not(t2))){
C_trace(C_text("compile-r7rs.scm:15: chicken.base#error"));
t3=*((C_word*)lf[10]+1);{
C_word *av2;
if(c >= 4) {
av2=av;
} else {
av2=C_alloc(4);
}
av2[0]=t3;
av2[1]=((C_word*)t0)[2];
av2[2]=lf[11];
av2[3]=C_fast_retrieve(lf[0]);
((C_proc)(void*)(*((C_word*)t3+1)))(4,av2);}}
else{
t3=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f209,a[2]=((C_word*)t0)[3],tmp=(C_word)a,a+=3,tmp);
C_trace(C_text("chicken.base#implicit-exit-handler"));
t4=C_fast_retrieve(lf[8]);{
C_word *av2=av;
av2[0]=t4;
av2[1]=t3;
((C_proc)(void*)(*((C_word*)t4+1)))(2,av2);}}}
/* k197 in k204 in k159 in k153 in k149 in k146 in k143 */
static void C_ccall f_199(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word t4;
C_word t5;
C_word t6;
C_word t7;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(7,c,2)))){
C_save_and_reclaim((void *)f_199,c,av);}
a=C_alloc(7);
t2=C_i_member(t1,C_fast_retrieve(lf[1]));
t3=(C_truep(t2)?C_SCHEME_TRUE:C_SCHEME_FALSE);
t4=C_set_block_item(lf[7] /* is-compiler? */,0,t3);
t5=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_172,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
t6=(*a=C_CLOSURE_TYPE|3,a[1]=(C_word)f_192,a[2]=t5,a[3]=((C_word*)t0)[2],tmp=(C_word)a,a+=4,tmp);
C_trace(C_text("compile-r7rs.scm:14: scheme#string->symbol"));
t7=*((C_word*)lf[12]+1);{
C_word *av2;
if(c >= 3) {
av2=av;
} else {
av2=C_alloc(3);
}
av2[0]=t7;
av2[1]=t6;
av2[2]=C_fast_retrieve(lf[0]);
((C_proc)(void*)(*((C_word*)t7+1)))(3,av2);}}
/* k204 in k159 in k153 in k149 in k146 in k143 */
static void C_ccall f_206(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word t4;
C_word t5;
C_word t6;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_206,c,av);}
a=C_alloc(3);
t2=C_i_member(t1,C_fast_retrieve(lf[1]));
t3=(C_truep(t2)?C_SCHEME_TRUE:C_SCHEME_FALSE);
t4=C_set_block_item(lf[6] /* is-interpreter? */,0,t3);
t5=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_199,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
C_trace(C_text("compile-r7rs.scm:12: scheme#string->symbol"));
t6=*((C_word*)lf[12]+1);{
C_word *av2;
if(c >= 3) {
av2=av;
} else {
av2=C_alloc(3);
}
av2[0]=t6;
av2[1]=t5;
av2[2]=C_fast_retrieve(lf[0]);
((C_proc)(void*)(*((C_word*)t6+1)))(3,av2);}}
/* toplevel */
static int toplevel_initialized=0;
C_main_entry_point
void C_ccall C_toplevel(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
if(toplevel_initialized) {C_kontinue(t1,C_SCHEME_UNDEFINED);}
else C_toplevel_entry(C_text("toplevel"));
C_check_nursery_minimum(C_calculate_demand(3,c,2));
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void*)C_toplevel,c,av);}
toplevel_initialized=1;
if(C_unlikely(!C_demand_2(104))){
C_save(t1);
C_rereclaim2(104*sizeof(C_word),1);
t1=C_restore;}
a=C_alloc(3);
C_initialize_lf(lf,16);
lf[0]=C_h_intern(&lf[0],6, C_text("scheme"));
lf[1]=C_h_intern(&lf[1],12, C_text("interpreters"));
lf[2]=C_decode_literal(C_heaptop,C_text("\376\003\000\000\002\376\001\000\000\005\001\143\150\151\142\151\376\377\016"));
lf[3]=C_h_intern(&lf[3],9, C_text("compilers"));
lf[4]=C_decode_literal(C_heaptop,C_text("\376\003\000\000\002\376\001\000\000\007\001\143\150\151\143\153\145\156\376\377\016"));
lf[5]=C_h_intern(&lf[5],15, C_text("implementations"));
lf[6]=C_h_intern(&lf[6],15, C_text("is-interpreter?"));
lf[7]=C_h_intern(&lf[7],12, C_text("is-compiler?"));
lf[8]=C_h_intern(&lf[8],34, C_text("chicken.base#implicit-exit-handler"));
lf[9]=C_h_intern(&lf[9],14, C_text("implementation"));
lf[10]=C_h_intern(&lf[10],18, C_text("chicken.base#error"));
lf[11]=C_decode_literal(C_heaptop,C_text("\376\002\000\000\042\125\156\163\165\160\160\157\162\164\145\144\040\163\143\150\145\155\145\040\151\155\160\154\145\155\145\156\164\141\164\151\157\156\000"));
lf[12]=C_h_intern(&lf[12],21, C_text("scheme#string->symbol"));
lf[13]=C_h_intern(&lf[13],13, C_text("scheme#append"));
lf[14]=C_h_intern(&lf[14],48, C_text("chicken.process-context#get-environment-variable"));
lf[15]=C_decode_literal(C_heaptop,C_text("\376\002\000\000\007\123\103\110\105\115\105\000"));
C_register_lf2(lf,16,create_ptable());{}
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_145,a[2]=t1,tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_library_toplevel(2,av2);}}
#ifdef C_ENABLE_PTABLES
static C_PTABLE_ENTRY ptable[13] = {
{C_text("f209:compile_2dr7rs_2escm"),(void*)f209},
{C_text("f_145:compile_2dr7rs_2escm"),(void*)f_145},
{C_text("f_148:compile_2dr7rs_2escm"),(void*)f_148},
{C_text("f_151:compile_2dr7rs_2escm"),(void*)f_151},
{C_text("f_155:compile_2dr7rs_2escm"),(void*)f_155},
{C_text("f_161:compile_2dr7rs_2escm"),(void*)f_161},
{C_text("f_172:compile_2dr7rs_2escm"),(void*)f_172},
{C_text("f_178:compile_2dr7rs_2escm"),(void*)f_178},
{C_text("f_192:compile_2dr7rs_2escm"),(void*)f_192},
{C_text("f_199:compile_2dr7rs_2escm"),(void*)f_199},
{C_text("f_206:compile_2dr7rs_2escm"),(void*)f_206},
{C_text("toplevel:compile_2dr7rs_2escm"),(void*)C_toplevel},
{NULL,NULL}};
#endif
static C_PTABLE_ENTRY *create_ptable(void){
#ifdef C_ENABLE_PTABLES
return ptable;
#else
return NULL;
#endif
}
/*
(o e)|safe calls: 12
(o e)|assignments to immediate values: 2
o|replaced variables: 6
o|removed binding forms: 12
o|removed binding forms: 6
o|inlining procedure: k170
o|removed binding forms: 1
o|simplifications: ((if . 2) (##core#call . 4))
o| call simplifications:
o| scheme#member 3
o| scheme#not
o|contracted procedure: k200
o|contracted procedure: k163
o|contracted procedure: k193
o|contracted procedure: k167
o|contracted procedure: k186
o|contracted procedure: k179
o|simplifications: ((let . 1))
o|removed binding forms: 6
*/
/* end of file */

165
src/data.scm Normal file
View File

@ -0,0 +1,165 @@
(define data
`((chibi
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("chibi-scheme"
" "
,@(map (lambda (item)
(string-append "-I" " " item " "))
prepend-directories)
" "
,@(map (lambda (item)
(string-append "-A" " " item " "))
append-directories)
,input-file)))))
(chicken
(type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories)
(string-append "csc -J "
" "
library-file)))
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(string-append "csc " input-file))))
(cyclone
(type . compiler)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(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)
(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)))))
(guile
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("guile --r7rs"
" "
,@(map (lambda (item)
(string-append "-L" " " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-L" " " item " "))
append-directories)
" "
,input-file)))))
(kawa
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("kawa --r7rs --full-tailcalls"
" "
"-Dkawa.import.path="
,@(map (lambda (item)
(string-append item ":" item "/*.sld:" " "))
prepend-directories)
,@(map (lambda (item)
(string-append item ":" item "/*.sld:" " "))
append-directories)
" "
,input-file)))))
(mosh
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("mosh"
" "
,@(map (lambda (item)
(string-append "--loadpath=" item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "--loadpath=" item " "))
append-directories)
" "
,input-file)))))
(sagittarius
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("sash -r7"
" "
,@(map (lambda (item)
(string-append "-L " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A " item " "))
append-directories)
" "
,input-file)))))
(skint
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("skint"
" "
,@(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)
(apply string-append
`("stklos"
" "
,@(map (lambda (item)
(string-append "-I " item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "-A " item " "))
append-directories)
" "
,input-file)))))
(tr7
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("TR7_LIB_PATH="
,@(map (lambda (item)
(string-append item ":"))
prepend-directories)
,@(map (lambda (item)
(string-append item ":"))
append-directories)
" "
"tr7i"
" "
,input-file)))))
(ypsilon
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories)
(apply string-append
`("ypsilon --r7rs"
" "
,@(map (lambda (item)
(string-append "--sitelib=" item))
prepend-directories)
,@(map (lambda (item)
(string-append "--sitelib=" item))
append-directories)
" "
,input-file)))))))

233
src/retropikzel.pffi.c
View File

@ -1,233 +0,0 @@
/* Generated from snow/retropikzel/pffi.sld by the CHICKEN compiler
http://www.call-cc.org
Version 6.0.0 (rev fbb6ce81)
linux-unix-gnu-x86-64 [ 64bit dload ptables ]
command line: snow/retropikzel/pffi.sld -output-file src/retropikzel.pffi.c -emit-all-import-libraries -optimize-level 3
uses: eval extras expand lolevel r7lib library
*/
#include "chicken.h"
static C_PTABLE_ENTRY *create_ptable(void);
C_noret_decl(C_eval_toplevel)
C_extern void C_ccall C_eval_toplevel(C_word c,C_word *av) C_noret;
C_noret_decl(C_extras_toplevel)
C_extern void C_ccall C_extras_toplevel(C_word c,C_word *av) C_noret;
C_noret_decl(C_expand_toplevel)
C_extern void C_ccall C_expand_toplevel(C_word c,C_word *av) C_noret;
C_noret_decl(C_lolevel_toplevel)
C_extern void C_ccall C_lolevel_toplevel(C_word c,C_word *av) C_noret;
C_noret_decl(C_r7lib_toplevel)
C_extern void C_ccall C_r7lib_toplevel(C_word c,C_word *av) C_noret;
C_noret_decl(C_library_toplevel)
C_extern void C_ccall C_library_toplevel(C_word c,C_word *av) C_noret;
static C_word lf[2];
static double C_possibly_force_alignment;
static C_char li0[] C_aligned={C_lihdr(0,0,10),40,116,111,112,108,101,118,101,108,41,0,0,0,0,0,0};
C_noret_decl(f_149)
static void C_ccall f_149(C_word c,C_word *av) C_noret;
C_noret_decl(f_152)
static void C_ccall f_152(C_word c,C_word *av) C_noret;
C_noret_decl(f_155)
static void C_ccall f_155(C_word c,C_word *av) C_noret;
C_noret_decl(f_158)
static void C_ccall f_158(C_word c,C_word *av) C_noret;
C_noret_decl(f_161)
static void C_ccall f_161(C_word c,C_word *av) C_noret;
C_noret_decl(f_164)
static void C_ccall f_164(C_word c,C_word *av) C_noret;
C_noret_decl(f_170)
static void C_ccall f_170(C_word c,C_word *av) C_noret;
C_noret_decl(C_toplevel)
C_extern void C_ccall C_toplevel(C_word c,C_word *av) C_noret;
/* k147 */
static void C_ccall f_149(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_149,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_152,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_eval_toplevel(2,av2);}}
/* k150 in k147 */
static void C_ccall f_152(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word t4;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(11,c,2)))){
C_save_and_reclaim((void *)f_152,c,av);}
a=C_alloc(11);
t2=C_a_i_provide(&a,1,lf[0]);
t3=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_155,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t3;
C_r7lib_toplevel(2,av2);}}
/* k153 in k150 in k147 */
static void C_ccall f_155(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_155,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_158,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_lolevel_toplevel(2,av2);}}
/* k156 in k153 in k150 in k147 */
static void C_ccall f_158(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_158,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_161,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_expand_toplevel(2,av2);}}
/* k159 in k156 in k153 in k150 in k147 */
static void C_ccall f_161(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_161,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_164,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_extras_toplevel(2,av2);}}
/* k162 in k159 in k156 in k153 in k150 in k147 */
static void C_ccall f_164(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void *)f_164,c,av);}
a=C_alloc(3);
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_170,a[2]=((C_word*)t0)[2],tmp=(C_word)a,a+=3,tmp);
C_trace(C_text("chicken.base#implicit-exit-handler"));
t3=C_fast_retrieve(lf[1]);{
C_word *av2=av;
av2[0]=t3;
av2[1]=t2;
((C_proc)(void*)(*((C_word*)t3+1)))(2,av2);}}
/* k168 in k162 in k159 in k156 in k153 in k150 in k147 */
static void C_ccall f_170(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word *a;
C_check_for_interrupt;
if(C_unlikely(!C_demand(C_calculate_demand(0,c,1)))){
C_save_and_reclaim((void *)f_170,c,av);}
t2=t1;{
C_word *av2=av;
av2[0]=t2;
av2[1]=((C_word*)t0)[2];
((C_proc)(void*)(*((C_word*)t2+1)))(2,av2);}}
/* toplevel */
static int toplevel_initialized=0;
C_main_entry_point
void C_ccall C_toplevel(C_word c,C_word *av){
C_word tmp;
C_word t0=av[0];
C_word t1=av[1];
C_word t2;
C_word t3;
C_word *a;
if(toplevel_initialized) {C_kontinue(t1,C_SCHEME_UNDEFINED);}
else C_toplevel_entry(C_text("toplevel"));
C_check_nursery_minimum(C_calculate_demand(3,c,2));
if(C_unlikely(!C_demand(C_calculate_demand(3,c,2)))){
C_save_and_reclaim((void*)C_toplevel,c,av);}
toplevel_initialized=1;
if(C_unlikely(!C_demand_2(14))){
C_save(t1);
C_rereclaim2(14*sizeof(C_word),1);
t1=C_restore;}
a=C_alloc(3);
C_initialize_lf(lf,2);
lf[0]=C_h_intern(&lf[0],17, C_text("retropikzel.pffi#"));
lf[1]=C_h_intern(&lf[1],34, C_text("chicken.base#implicit-exit-handler"));
C_register_lf2(lf,2,create_ptable());{}
t2=(*a=C_CLOSURE_TYPE|2,a[1]=(C_word)f_149,a[2]=t1,tmp=(C_word)a,a+=3,tmp);{
C_word *av2=av;
av2[0]=C_SCHEME_UNDEFINED;
av2[1]=t2;
C_library_toplevel(2,av2);}}
#ifdef C_ENABLE_PTABLES
static C_PTABLE_ENTRY ptable[9] = {
{C_text("f_149:snow_2fretropikzel_2fpffi_2esld"),(void*)f_149},
{C_text("f_152:snow_2fretropikzel_2fpffi_2esld"),(void*)f_152},
{C_text("f_155:snow_2fretropikzel_2fpffi_2esld"),(void*)f_155},
{C_text("f_158:snow_2fretropikzel_2fpffi_2esld"),(void*)f_158},
{C_text("f_161:snow_2fretropikzel_2fpffi_2esld"),(void*)f_161},
{C_text("f_164:snow_2fretropikzel_2fpffi_2esld"),(void*)f_164},
{C_text("f_170:snow_2fretropikzel_2fpffi_2esld"),(void*)f_170},
{C_text("toplevel:snow_2fretropikzel_2fpffi_2esld"),(void*)C_toplevel},
{NULL,NULL}};
#endif
static C_PTABLE_ENTRY *create_ptable(void){
#ifdef C_ENABLE_PTABLES
return ptable;
#else
return NULL;
#endif
}
/*
(o e)|safe calls: 2
o|replaced variables: 1
o|removed binding forms: 15
o|removed binding forms: 1
*/
/* end of file */

4186
src/srfi.170.c
View File

File diff suppressed because it is too large Load Diff

13
src/util.scm Normal file
View File

@ -0,0 +1,13 @@
(define string-replace
(lambda (strin-content replace with)
(string-map (lambda (c) (char=? c replace) with c))))
(define string-ends-with?
(lambda (string-content end)
(if (and (>= (string-length string-content) (string-length end))
(string=? (string-copy string-content
(- (string-length string-content)
(string-length end)))
end))
#t
#f)))

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

@ -4,4 +4,7 @@
(scheme write))
(export hello)
(begin
(define hello (lambda () (display "Hello") (newline)))))
(define hello
(lambda ()
(display "Hello")
(newline)))))