From 598ac64ba082c82945df3f28b02ecf71c38d94d4 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Tue, 15 Apr 2025 15:08:16 +0300 Subject: [PATCH] Updated Makefile --- Makefile | 46 ++---- README.md | 51 +++++- build.bat | 2 + compile-r7rs.bat | 2 + compile-r7rs.scm | 26 ++- libs/data.sld | 274 ++++++++++++++++++++++++++++++++ libs/util.sld | 81 ++++++++++ snow/retropikzel/pffi.o | Bin 6952 -> 0 bytes snow/retropikzel/pffi.sld | 6 +- snow/retropikzel/pffi/guile.scm | 8 +- src/data.scm | 269 ------------------------------- src/util.scm | 69 -------- 12 files changed, 444 insertions(+), 390 deletions(-) create mode 100644 build.bat create mode 100644 compile-r7rs.bat create mode 100644 libs/data.sld create mode 100644 libs/util.sld delete mode 100644 snow/retropikzel/pffi.o delete mode 100644 src/data.scm delete mode 100644 src/util.scm diff --git a/Makefile b/Makefile index b975d75..39f421f 100644 --- a/Makefile +++ b/Makefile @@ -1,30 +1,8 @@ .PHONY: snow PREFIX=/usr/local -CC=gcc -CHICKEN_FLAGS=-optimize-level 3 build: - ${CC} -o 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 - + printf "#!/bin/sh\nash -r7 -L ${PREFIX}/lib/compile-r7rs/snow ${PREFIX}/lib/compile-r7rs/main.scm \"\$$@\"\n" > compile-r7rs snow: rm -rf snow @@ -32,23 +10,17 @@ snow: cp -r ../r7rs-pffi/retropikzel 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: - 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 +uninstall: + rm -rf ${PREFIX}/lib/compile-r7rs/snow + rm -rf ${PREFIX}/bin/compile-r7rs + clean: rm -rf test/foo rm -rf test/libs/bar/baz diff --git a/README.md b/README.md index 8f519c3..a096718 100644 --- a/README.md +++ b/README.md @@ -18,20 +18,61 @@ with [SRFI-138](https://srfi.schemers.org/srfi-138/srfi-138.html). ## 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 make - install + make install + +### Build on Windows + +In command prompt run: + + build.bat + install.bat ## Usage +You need to install each Scheme implementation yourself. + The environment variable SCHEME must be set to the name of the implementation as specified in the support list. diff --git a/build.bat b/build.bat new file mode 100644 index 0000000..a358d1a --- /dev/null +++ b/build.bat @@ -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 diff --git a/compile-r7rs.bat b/compile-r7rs.bat new file mode 100644 index 0000000..271912e --- /dev/null +++ b/compile-r7rs.bat @@ -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 %* diff --git a/compile-r7rs.scm b/compile-r7rs.scm index 3c51d12..80d2aa5 100644 --- a/compile-r7rs.scm +++ b/compile-r7rs.scm @@ -4,10 +4,28 @@ (scheme write) (scheme process-context) (retropikzel pffi) + (libs util) + (libs data) (srfi 170)) -(include "src/util.scm") -(include "src/data.scm") +(when (member "--list-schemes" (command-line)) + (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") (string->symbol (get-environment-variable "SCHEME")) @@ -88,7 +106,9 @@ (apply append (map (lambda (directory) - (search-library-files directory)) + (if (file-exists? directory) + (search-library-files directory) + (list))) (append prepend-directories append-directories)))) (define scheme-type (cdr (assoc 'type (cdr (assoc scheme data))))) diff --git a/libs/data.sld b/libs/data.sld new file mode 100644 index 0000000..02fb9b5 --- /dev/null +++ b/libs/data.sld @@ -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))))))))) diff --git a/libs/util.sld b/libs/util.sld new file mode 100644 index 0000000..4c396c9 --- /dev/null +++ b/libs/util.sld @@ -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))))))) diff --git a/snow/retropikzel/pffi.o b/snow/retropikzel/pffi.o deleted file mode 100644 index 6dbae4a4782c95f15fc5da38c667a9f3864edc8b..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 6952 zcmdUye{38_7035{iF1@XcGChbq4a33ZBUwP&eWz3DxC3;jK!w4T1-JmT-N7xeDuzD zy<0~~L>gCDTCJQb6|}1IPpMP{{RdG3)czdW)%LO@C~?p4HW?)oJat#+Cou zfd>b^GB7^yvV#@L$jKSDLj_K&Yg7ond;O%Z2$L*T>%U{G_=RX>xhju9w9gS`=j-DE^9q|P=TFMYt>=@Td6MP z|2oLnkMSvzlv<7>b)){alxl2$T33fs3ER&nbT>T>GzCa#eYMMs)1FVO<^|(keS7Kj zu5(T5s{GlNAkO*O73Kd%?bG3Amei~Nh>zB<#5$i_QgI!!>VFMceveXow%Ke_vUSJN z`Qa`zry~gjru_EiSmNIrMH`}M3|aAwp*$@@q2VTjP+n;zt1*=7RQ0zmD?gzc9iPzg zsl@2~c$Zpk55gUzB#&&!-2=25v52Gcca6?pkh_g}o>h(xtO?BG-?}EUGFPa$&RuUF0=?ojbNGn9O#v2Tu#yU@mMn_7H*QbFt#=6b= zQT`w;#__=S|NU%z@RiOp_Mcp1|3guqf4|vOe)KPc7E;yqs^v=Ip_6X$&dStOL4q{E z9&0L>={;~z80LDWpvm>Pwc?~!e`afS-`48>E!BNJTdRAc)n2($bdR~kXbZ}~e_0L< z4jxSI9daiM&P+1XlkQ0$*q^!U)23?OV8V-?yx)o)?~3idc1PkV+AWgAvGGBk!0s`y zv+MD;!H)LB--$oDt+D+~dwmD=S$ZIkni<<1hrzq zo_pS;tv1?sQ$VoCH37oqExNVc!c{@a?bL`_?JYECYH2FlNYh~sJDpQvcNwndn(BH! zsXS=-PmR5vCt_K{e-ft(3HuqLI{ZIu2E^Pp{B|=m=I9$2aiR^mpPpUhhlS(9rHjYT zI+Tw_@Us#8M-lwx2>yBmzZAh&Bltff_=jnzn~iIC1ivkU_eO9P!6zcP7r`Hk;NOkl zFGTQ{BKU;}Zs9~o=PllHbA_3LS8$4jlkTLIwg(U3m9Z+GGf{MdBL(li-r)Su?>_zR z*SyCX%x!YyuzS*SHRsNF)e{8r({BEu+{|pX=2lPSN)$k8wnV(^FFFNun5vdbwThE>@r|q6?8I|Rm2%ag&uHglQ*}*$1in7@ zTycup(?mSCI-~857HU){1uTn&3GIdlL&z(XNUb|mXDePVU!Fy0^mPg~cU?ooJ?0c! ziJ-QVE95HG^0C4shF1M7xtHoJV`FWd2P+68OQH$NXVH5^!9VnLhzY0*<|v`58bG z`2Q$9%)bXn0(<<`Wsdy^0*-O5nfMm~Nx-}5Vfz;WNx*NUhxvIxk}&^8fOR|{r#jpJ z((thT+Y$T^f+NmrO`HGPW4ycRVgJ|B?-T-#GnhHfDG0ucGmiOQ!KMF9grBUi$G*sZ z4harFe1EZpADp3VUl$zz+?byger^{0hY|c0;U_8VmxaAtSHBWmuB-QiAGv;RM#4x? z$awCE;9oEt`A^cr<2o$tWjs@Y%Xm%+KQbQupOE~*|EGliH-sM<=erU7ufl&)_-P7z z8D}>pl>}-T=beTl9vSC7!X8y#w_g|bw-D$2OoZ%t{gfl@Ulx3i@bh!wN9N&D1plM( zlN5g57xpp_H(;P7;XLd!Je-G;;3?|Iru>>W#IAJCu~H zX}oFHJL_O81!q6zGbpyOOnwBE^9EvRIv*erjS%>guK zK7{;XNa6gA6N3r=-l?kPdGr0GX>-AGbNLNYaGh;XE}8z4p&qua876R46 z1DT;`v+-xK>5?o2g+9Npp*r^u?~}%?RV*391v4=nq{03Y?*AcT;kkp8X>(z?6pBC8 S)IK-szhdG)1!qFS{r?3_hMuAT diff --git a/snow/retropikzel/pffi.sld b/snow/retropikzel/pffi.sld index 77e8c15..13b871d 100644 --- a/snow/retropikzel/pffi.sld +++ b/snow/retropikzel/pffi.sld @@ -59,7 +59,8 @@ (scheme process-context) (rnrs bytevectors) (system foreign) - (system foreign-library))) + (system foreign-library) + (only (guile) include-from-path))) (kawa (import (scheme base) (scheme write) @@ -133,8 +134,7 @@ (scheme process-context) (ypsilon c-ffi) (ypsilon c-types) - (only (core) define-macro syntax-case))) - (else (error "Unsupported implementation"))) + (only (core) define-macro syntax-case)))) (export pffi-init pffi-size-of pffi-type? diff --git a/snow/retropikzel/pffi/guile.scm b/snow/retropikzel/pffi/guile.scm index 68eb76c..e6927c4 100644 --- a/snow/retropikzel/pffi/guile.scm +++ b/snow/retropikzel/pffi/guile.scm @@ -53,7 +53,7 @@ (native-type (sizeof native-type)) (else #f))))) -(define pffi-pointer-allocate +#;(define pffi-pointer-allocate (lambda (size) (bytevector->pointer (make-bytevector size 0)))) @@ -74,10 +74,10 @@ (pointer->string pointer))) (define pffi-shared-object-load - (lambda (header path . options) + (lambda (path options) (load-foreign-library path))) -(define pffi-pointer-free +#;(define pffi-pointer-free (lambda (pointer) #t)) @@ -132,6 +132,6 @@ ((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))))))))) -(define pffi-struct-dereference +#;(define pffi-struct-dereference (lambda (struct) (dereference-pointer (pffi-struct-pointer struct)))) diff --git a/src/data.scm b/src/data.scm deleted file mode 100644 index eafebfc..0000000 --- a/src/data.scm +++ /dev/null @@ -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))))))) diff --git a/src/util.scm b/src/util.scm deleted file mode 100644 index d89e6db..0000000 --- a/src/util.scm +++ /dev/null @@ -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)))))