diff --git a/.gitignore b/.gitignore index 6a10068..b92e679 100644 --- a/.gitignore +++ b/.gitignore @@ -5,7 +5,9 @@ test/foo test/libs/bar/baz *.c *.o +*.o* *.so !chicken !src +*.rkt diff --git a/Makefile b/Makefile index a7530d0..b975d75 100644 --- a/Makefile +++ b/Makefile @@ -53,7 +53,9 @@ clean: rm -rf test/foo rm -rf test/libs/bar/baz find . -name "*.so" -delete - find . -name "*.o" -delete + find . -name "*.o*" -delete + find . -name "*.rkt" -delete + find ./test -name "*.c" -delete find . -name "*.link" -delete find . -name "*.meta" -delete find . -name "*.import.*" -delete diff --git a/README.md b/README.md index e5f3808..8f519c3 100644 --- a/README.md +++ b/README.md @@ -8,6 +8,7 @@ with [SRFI-138](https://srfi.schemers.org/srfi-138/srfi-138.html). - gauche - guile - kawa +- loko - mosh - sagittarius - skint diff --git a/compile-r7rs.rkt b/compile-r7rs.rkt deleted file mode 100644 index 32bab69..0000000 --- a/compile-r7rs.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang r7rs -(import (scheme base)) -(include "compile-r7rs.scm") diff --git a/compile-r7rs.scm b/compile-r7rs.scm index 24d4cf0..3c51d12 100644 --- a/compile-r7rs.scm +++ b/compile-r7rs.scm @@ -70,20 +70,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))) @@ -98,6 +84,29 @@ (directory-files directory)) result))) +(define library-files + (apply append + (map + (lambda (directory) + (search-library-files directory)) + (append prepend-directories append-directories)))) + +(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 + library-files))) + +(define scheme-library-command + (lambda (library-file) + (apply (cdr (assoc 'library-command (cdr (assoc scheme data)))) + (list library-file prepend-directories append-directories)))) + + (define list-of-features (letrec ((looper (lambda (rest result) (if (null? rest) @@ -109,19 +118,19 @@ result)))))) (looper (command-line) (list)))) -(display "Scheme ") +(display "Scheme ") (display scheme) (newline) -(display "Type ") +(display "Type ") (display scheme-type) (newline) -(display "Command ") +(display "Command ") (display scheme-command) (newline) -(display "Input file ") +(display "Input file ") (display input-file) (newline) -(display "Output file ") +(display "Output file ") (display output-file) (newline) @@ -145,10 +154,10 @@ (when (and (equal? scheme-type 'compiler) input-file) (when (file-exists? output-file) (delete-file output-file)) - (display "Compiling file ") + (display "Compiling file ") (display input-file) (newline) - (display "With command ") + (display "With command ") (display scheme-command) (newline) (c-system (pffi-string->pointer scheme-command))) @@ -157,9 +166,7 @@ (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 + (for-each (lambda (file) (let* ((command (scheme-library-command file))) (display "Compiling library ") @@ -169,8 +176,7 @@ (display command) (newline) (c-system (pffi-string->pointer command)))) - (search-library-files directory))) - (append prepend-directories append-directories))) + library-files)) ((not input-file) (display "Library compilation requested but no library command found. ") (display "Skipping...") diff --git a/src/data.scm b/src/data.scm index 499333f..eafebfc 100644 --- a/src/data.scm +++ b/src/data.scm @@ -1,7 +1,7 @@ (define data `((chibi (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files) (apply string-append `("chibi-scheme" " " @@ -19,11 +19,54 @@ (string-append "csc -J " " " library-file))) - (command . ,(lambda (input-file output-file prepend-directories append-directories) - (string-append "csc " input-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) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files) (apply string-append `("cyclone " " " @@ -37,7 +80,7 @@ ,input-file))))) (gauche (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files) (apply string-append `("gosh -r7" " " @@ -49,9 +92,24 @@ 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) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files) (apply string-append `("guile --r7rs" " " @@ -65,7 +123,7 @@ ,input-file))))) (kawa (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files) (apply string-append `("kawa --r7rs --full-tailcalls" " " @@ -80,7 +138,7 @@ ,input-file))))) (mosh (type . interpreter) - (command . ,(lambda (input-file output-file prepend-directories append-directories) + (command . ,(lambda (input-file output-file prepend-directories append-directories library-files) (apply string-append `("mosh" " " @@ -92,74 +150,120 @@ 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))))))) + (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 index d41578b..d89e6db 100644 --- a/src/util.scm +++ b/src/util.scm @@ -11,3 +11,59 @@ 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)))))