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

Updated Makefile

This commit is contained in:
retropikzel 2025-04-15 15:08:16 +03:00
parent b0d6757be7
commit 598ac64ba0
12 changed files with 444 additions and 390 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
Makefile
View File

@ -1,30 +1,8 @@
.PHONY: snow .PHONY: snow
PREFIX=/usr/local PREFIX=/usr/local
CC=gcc
CHICKEN_FLAGS=-optimize-level 3
build: build:
${CC} -o compile-r7rs \ printf "#!/bin/sh\nash -r7 -L ${PREFIX}/lib/compile-r7rs/snow ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"\n" > compile-r7rs
-Os \
-fomit-frame-pointer \
-DHAVE_CHICKEN_CONFIG_H \
src/*.c \
chicken/src/*.c \
-lm \
-Ichicken/include
test-sagittarius:
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-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
snow: snow:
rm -rf snow rm -rf snow
@ -32,23 +10,17 @@ snow:
cp -r ../r7rs-pffi/retropikzel snow/ cp -r ../r7rs-pffi/retropikzel snow/
cp -r ../pffi-srfi-170/srfi snow/ cp -r ../pffi-srfi-170/srfi snow/
c-files: src
csc -t snow/retropikzel/pffi.sld -J ${CHICKEN_FLAGS} -output-file src/retropikzel.pffi.c
csc -t snow/srfi/170.sld -J ${CHICKEN_FLAGS} -output-file src/srfi.170.c
csc -t compile-r7rs.scm ${CHICKEN_FLAGS} -output-file src/compile-r7rs.c
test:
cd test && ../compile-r7rs -I ./libs
cd test && ../compile-r7rs -I ./libs foo.scm
cd test && ./foo
src:
mkdir -p src
install: install:
mkdir -p ${PREFIX}/bin mkdir -p ${PREFIX}/lib/compile-r7rs/snow
cp -r snow/* ${PREFIX}/lib/compile-r7rs/snow
cp -r libs ${PREFIX}/lib/compile-r7rs/snow/libs
cp compile-r7rs.scm ${PREFIX}/lib/compile-r7rs/main.scm
install compile-r7rs ${PREFIX}/bin/compile-r7rs install compile-r7rs ${PREFIX}/bin/compile-r7rs
uninstall:
rm -rf ${PREFIX}/lib/compile-r7rs/snow
rm -rf ${PREFIX}/bin/compile-r7rs
clean: clean:
rm -rf test/foo rm -rf test/foo
rm -rf test/libs/bar/baz rm -rf test/libs/bar/baz

51
README.md
View File

@ -18,20 +18,61 @@ with [SRFI-138](https://srfi.schemers.org/srfi-138/srfi-138.html).
## Dependencies ## Dependencies
C toolchain and libuv, on Debian/Ubuntu/Mint run
apt install build-essential libuv1-dev
You need to install each Scheme implementation yourself. ## Getting started
## Build and install ### Install Sagittarius scheme
#### Linux
On Debian/Ubuntu/Mint:
apt-get install -y build-essential cmake libgc-dev zlib1g-dev libffi-dev libssl-dev
wget https://bitbucket.org/ktakashi/sagittarius-scheme/downloads/sagittarius-0.9.12.tar.gz
tar -xf sagittarius-0.9.12.tar.gz
cd sagittarius-0.9.12.tar.gz
mkdir build
cd build
cmake ..
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
On Debian/Ubuntu/Mint run:
apt install libuv1
#### Windows
dll is included, no need to install anything.
### Build on Linux
./configure ./configure
make make
install make install
### Build on Windows
In command prompt run:
build.bat
install.bat
## Usage ## Usage
You need to install each Scheme implementation yourself.
The environment variable SCHEME must be set to the name of the implementation The environment variable SCHEME must be set to the name of the implementation
as specified in the support list. as specified in the support list.

2
build.bat Normal file
View File

@ -0,0 +1,2 @@
echo @echo off > compile-r7rs.bat
echo sash.exe -r7 -L %PROGRAMFILES%/compile-r7rs/snow %PROGRAMFILES%compile-r7rs/main.scm %%^* >> compile-r7rs.bat

2
compile-r7rs.bat Normal file
View File

@ -0,0 +1,2 @@
@echo off
sash.exe -r7 -L C:\Program Files (x86)/compile-r7rs/snow C:\Program Files (x86)compile-r7rs/main.scm %*

26
compile-r7rs.scm
View File

@ -4,10 +4,28 @@
(scheme write) (scheme write)
(scheme process-context) (scheme process-context)
(retropikzel pffi) (retropikzel pffi)
(libs util)
(libs data)
(srfi 170)) (srfi 170))
(include "src/util.scm") (when (member "--list-schemes" (command-line))
(include "src/data.scm") (for-each
(lambda (scheme)
(display scheme)
(newline))
'(chibi
cyclone
gauche
guile
kawa
loko
mosh
sagittarius
skint
stklos
tr7
ypsilon))
(exit 0))
(define scheme (if (get-environment-variable "SCHEME") (define scheme (if (get-environment-variable "SCHEME")
(string->symbol (get-environment-variable "SCHEME")) (string->symbol (get-environment-variable "SCHEME"))
@ -88,7 +106,9 @@
(apply append (apply append
(map (map
(lambda (directory) (lambda (directory)
(search-library-files directory)) (if (file-exists? directory)
(search-library-files directory)
(list)))
(append prepend-directories append-directories)))) (append prepend-directories append-directories))))
(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data))))) (define scheme-type (cdr (assoc 'type (cdr (assoc scheme data)))))

274
libs/data.sld Normal file
View File

@ -0,0 +1,274 @@
(define-library
(libs data)
(import (scheme base))
(export data)
(begin
(define data
`((chibi
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
(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 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"
" "
,(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)
(apply string-append
`("gsc -nopreload -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)
(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 library-files)
(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 library-files)
(apply string-append
`("mosh"
" "
,@(map (lambda (item)
(string-append "--loadpath=" item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "--loadpath=" item " "))
append-directories)
" "
,input-file)))))
(racket
(type . compiler)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
(let ((rkt-input-file (if (string=? input-file "")
""
(change-file-suffix input-file ".rkt"))))
(when (not (string=? rkt-input-file ""))
(if (file-exists? rkt-input-file)
(delete-file rkt-input-file))
(with-output-to-file
rkt-input-file
(lambda ()
(display "#lang r7rs")
(newline)
(display "(import (scheme base))")
(newline)
(display "(include \"")
(display (path->filename input-file))
(display "\")")
(newline))))
(for-each
(lambda (file)
(let ((library-rkt-file (change-file-suffix file ".rkt")))
(if (file-exists? library-rkt-file)
(delete-file library-rkt-file))
(with-output-to-file
library-rkt-file
(lambda ()
(display "#lang r7rs")
(newline)
(display "(import (scheme base))")
(newline)
(display "(include \"")
(display (path->filename file))
(display "\")")
(newline)))))
library-files)
(apply string-append
`("PLTCOLLECTS="
,(string-join prepend-directories ":")
,(string-join append-directories ":")
" "
"raco exe --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)
(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 library-files)
(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 library-files)
(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 library-files)
(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 library-files)
(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)))))))))

81
libs/util.sld Normal file
View File

@ -0,0 +1,81 @@
(define-library
(libs util)
(import (scheme base))
(export string-replace
string-ends-with?
string-starts-with?
string-find
string-reverse
path->filename
change-file-suffix
string-join)
(begin
(define string-replace
(lambda (string-content replace with)
(string-map (lambda (c) (char=? c replace) with c) string-content)))
(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)))
(define string-starts-with?
(lambda (string-content start)
(if (and (>= (string-length string-content) (string-length start))
(string=? (string-copy string-content
0
(string-length start))
start))
#t
#f)))
(define string-find
(lambda (string-content character)
(letrec* ((string-list (string->list string-content))
(looper (lambda (c rest index)
(cond ((null? rest) #f)
((char=? c character) index)
(else (looper (car rest)
(cdr rest)
(+ index 1)))))))
(looper (car string-list)
(cdr string-list)
0))))
(define string-reverse
(lambda (string-content)
(list->string (reverse (string->list string-content)))))
(define path->filename
(lambda (path)
(let ((last-slash-index (string-find (string-reverse path) #\/)))
(cond ((not last-slash-index) path)
(else (string-copy path (- (string-length path)
last-slash-index)))))))
(define change-file-suffix
(lambda (path new-suffix)
(let ((last-dot-index (string-find (string-reverse path) #\.)))
(cond ((not last-dot-index) path)
(else (string-append (string-copy path 0
(- (string-length path)
last-dot-index
1))
new-suffix))))))
(define string-join
(lambda (string-list between)
(apply string-append
(let ((index 0)
(size (length string-list)))
(map
(lambda (item)
(cond ((= index 0) item)
((= index size) item)
(else (string-append item between))))
string-list)))))))

BIN
snow/retropikzel/pffi.o
View File

Binary file not shown.

6
snow/retropikzel/pffi.sld
View File

@ -59,7 +59,8 @@
(scheme process-context) (scheme process-context)
(rnrs bytevectors) (rnrs bytevectors)
(system foreign) (system foreign)
(system foreign-library))) (system foreign-library)
(only (guile) include-from-path)))
(kawa (kawa
(import (scheme base) (import (scheme base)
(scheme write) (scheme write)
@ -133,8 +134,7 @@
(scheme process-context) (scheme process-context)
(ypsilon c-ffi) (ypsilon c-ffi)
(ypsilon c-types) (ypsilon c-types)
(only (core) define-macro syntax-case))) (only (core) define-macro syntax-case))))
(else (error "Unsupported implementation")))
(export pffi-init (export pffi-init
pffi-size-of pffi-size-of
pffi-type? pffi-type?

8
snow/retropikzel/pffi/guile.scm
View File

@ -53,7 +53,7 @@
(native-type (sizeof native-type)) (native-type (sizeof native-type))
(else #f))))) (else #f)))))
(define pffi-pointer-allocate #;(define pffi-pointer-allocate
(lambda (size) (lambda (size)
(bytevector->pointer (make-bytevector size 0)))) (bytevector->pointer (make-bytevector size 0))))
@ -74,10 +74,10 @@
(pointer->string pointer))) (pointer->string pointer)))
(define pffi-shared-object-load (define pffi-shared-object-load
(lambda (header path . options) (lambda (path options)
(load-foreign-library path))) (load-foreign-library path)))
(define pffi-pointer-free #;(define pffi-pointer-free
(lambda (pointer) (lambda (pointer)
#t)) #t))
@ -132,6 +132,6 @@
((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))) ((equal? type 'pointer) (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))
((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type))))))))) ((equal? type 'string) (pffi-pointer->string (make-pointer (bytevector-sint-ref p offset (native-endianness) (size-of-type type)))))))))
(define pffi-struct-dereference #;(define pffi-struct-dereference
(lambda (struct) (lambda (struct)
(dereference-pointer (pffi-struct-pointer struct)))) (dereference-pointer (pffi-struct-pointer struct))))

269
src/data.scm
View File

@ -1,269 +0,0 @@
(define data
`((chibi
(type . interpreter)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
(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 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"
" "
,(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)
(apply string-append
`("gsc -nopreload -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)
(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 library-files)
(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 library-files)
(apply string-append
`("mosh"
" "
,@(map (lambda (item)
(string-append "--loadpath=" item " "))
prepend-directories)
,@(map (lambda (item)
(string-append "--loadpath=" item " "))
append-directories)
" "
,input-file)))))
(racket
(type . compiler)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
(let ((rkt-input-file (if (string=? input-file "")
""
(change-file-suffix input-file ".rkt"))))
(when (not (string=? rkt-input-file ""))
(if (file-exists? rkt-input-file)
(delete-file rkt-input-file))
(with-output-to-file
rkt-input-file
(lambda ()
(display "#lang r7rs")
(newline)
(display "(import (scheme base))")
(newline)
(display "(include \"")
(display (path->filename input-file))
(display "\")")
(newline))))
(for-each
(lambda (file)
(let ((library-rkt-file (change-file-suffix file ".rkt")))
(if (file-exists? library-rkt-file)
(delete-file library-rkt-file))
(with-output-to-file
library-rkt-file
(lambda ()
(display "#lang r7rs")
(newline)
(display "(import (scheme base))")
(newline)
(display "(include \"")
(display (path->filename file))
(display "\")")
(newline)))))
library-files)
(apply string-append
`("PLTCOLLECTS="
,(string-join prepend-directories ":")
,(string-join append-directories ":")
" "
"raco exe --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)
(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 library-files)
(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 library-files)
(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 library-files)
(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 library-files)
(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)))))))

69
src/util.scm
View File

@ -1,69 +0,0 @@
(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)))
(define string-starts-with?
(lambda (string-content start)
(if (and (>= (string-length string-content) (string-length start))
(string=? (string-copy string-content
0
(string-length start))
start))
#t
#f)))
(define string-find
(lambda (string-content character)
(letrec* ((string-list (string->list string-content))
(looper (lambda (c rest index)
(cond ((null? rest) #f)
((char=? c character) index)
(else (looper (car rest)
(cdr rest)
(+ index 1)))))))
(looper (car string-list)
(cdr string-list)
0))))
(define string-reverse
(lambda (string-content)
(list->string (reverse (string->list string-content)))))
(define path->filename
(lambda (path)
(let ((last-slash-index (string-find (string-reverse path) #\/)))
(cond ((not last-slash-index) path)
(else (string-copy path (- (string-length path)
last-slash-index)))))))
(define change-file-suffix
(lambda (path new-suffix)
(let ((last-dot-index (string-find (string-reverse path) #\.)))
(cond ((not last-dot-index) path)
(else (string-append (string-copy path 0
(- (string-length path)
last-dot-index
1))
new-suffix))))))
(define string-join
(lambda (string-list between)
(apply string-append
(let ((index 0)
(size (length string-list)))
(map
(lambda (item)
(cond ((= index 0) item)
((= index size) item)
(else (string-append item between))))
string-list)))))