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

Adding support for more implementations

This commit is contained in:
retropikzel 2025-04-13 20:51:34 +03:00
parent 955f5a7373
commit b0d6757be7
7 changed files with 277 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -5,7 +5,9 @@ test/foo
test/libs/bar/baz test/libs/bar/baz
*.c *.c
*.o *.o
*.o*
*.so *.so
!chicken !chicken
!src !src
*.rkt

4
Makefile
View File

@ -53,7 +53,9 @@ clean:
rm -rf test/foo rm -rf test/foo
rm -rf test/libs/bar/baz rm -rf test/libs/bar/baz
find . -name "*.so" -delete find . -name "*.so" -delete
find . -name "*.o" -delete find . -name "*.o*" -delete
find . -name "*.rkt" -delete
find ./test -name "*.c" -delete
find . -name "*.link" -delete find . -name "*.link" -delete
find . -name "*.meta" -delete find . -name "*.meta" -delete
find . -name "*.import.*" -delete find . -name "*.import.*" -delete

1
README.md
View File

@ -8,6 +8,7 @@ with [SRFI-138](https://srfi.schemers.org/srfi-138/srfi-138.html).
- gauche - gauche
- guile - guile
- kawa - kawa
- loko
- mosh - mosh
- sagittarius - sagittarius
- skint - skint

3
compile-r7rs.rkt
View File

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

58
compile-r7rs.scm
View File

@ -70,20 +70,6 @@
(pffi-define c-system c-libstd 'system 'int '(pointer)) (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 (define search-library-files
(lambda (directory) (lambda (directory)
(let ((result (list))) (let ((result (list)))
@ -98,6 +84,29 @@
(directory-files directory)) (directory-files directory))
result))) 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 (define list-of-features
(letrec ((looper (lambda (rest result) (letrec ((looper (lambda (rest result)
(if (null? rest) (if (null? rest)
@ -109,19 +118,19 @@
result)))))) result))))))
(looper (command-line) (list)))) (looper (command-line) (list))))
(display "Scheme ") (display "Scheme ")
(display scheme) (display scheme)
(newline) (newline)
(display "Type ") (display "Type ")
(display scheme-type) (display scheme-type)
(newline) (newline)
(display "Command ") (display "Command ")
(display scheme-command) (display scheme-command)
(newline) (newline)
(display "Input file ") (display "Input file ")
(display input-file) (display input-file)
(newline) (newline)
(display "Output file ") (display "Output file ")
(display output-file) (display output-file)
(newline) (newline)
@ -145,10 +154,10 @@
(when (and (equal? scheme-type 'compiler) input-file) (when (and (equal? scheme-type 'compiler) input-file)
(when (file-exists? output-file) (delete-file output-file)) (when (file-exists? output-file) (delete-file output-file))
(display "Compiling file ") (display "Compiling file ")
(display input-file) (display input-file)
(newline) (newline)
(display "With command ") (display "With command ")
(display scheme-command) (display scheme-command)
(newline) (newline)
(c-system (pffi-string->pointer scheme-command))) (c-system (pffi-string->pointer scheme-command)))
@ -157,9 +166,7 @@
(cond ((and (not input-file) (assoc 'library-command (cdr (assoc scheme data)))) (cond ((and (not input-file) (assoc 'library-command (cdr (assoc scheme data))))
(when (and output-file (file-exists? output-file)) (when (and output-file (file-exists? output-file))
(delete-file output-file)) (delete-file output-file))
(for-each (for-each
(lambda (directory)
(for-each
(lambda (file) (lambda (file)
(let* ((command (scheme-library-command file))) (let* ((command (scheme-library-command file)))
(display "Compiling library ") (display "Compiling library ")
@ -169,8 +176,7 @@
(display command) (display command)
(newline) (newline)
(c-system (pffi-string->pointer command)))) (c-system (pffi-string->pointer command))))
(search-library-files directory))) library-files))
(append prepend-directories append-directories)))
((not input-file) ((not input-file)
(display "Library compilation requested but no library command found. ") (display "Library compilation requested but no library command found. ")
(display "Skipping...") (display "Skipping...")

262
src/data.scm
View File

@ -1,7 +1,7 @@
(define data (define data
`((chibi `((chibi
(type . interpreter) (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 (apply string-append
`("chibi-scheme" `("chibi-scheme"
" " " "
@ -19,11 +19,54 @@
(string-append "csc -J " (string-append "csc -J "
" " " "
library-file))) library-file)))
(command . ,(lambda (input-file output-file prepend-directories append-directories) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
(string-append "csc " input-file)))) (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 (cyclone
(type . compiler) (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 (apply string-append
`("cyclone " `("cyclone "
" " " "
@ -37,7 +80,7 @@
,input-file))))) ,input-file)))))
(gauche (gauche
(type . interpreter) (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 (apply string-append
`("gosh -r7" `("gosh -r7"
" " " "
@ -49,9 +92,24 @@
append-directories) append-directories)
" " " "
,input-file))))) ,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 (guile
(type . interpreter) (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 (apply string-append
`("guile --r7rs" `("guile --r7rs"
" " " "
@ -65,7 +123,7 @@
,input-file))))) ,input-file)))))
(kawa (kawa
(type . interpreter) (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 (apply string-append
`("kawa --r7rs --full-tailcalls" `("kawa --r7rs --full-tailcalls"
" " " "
@ -80,7 +138,7 @@
,input-file))))) ,input-file)))))
(mosh (mosh
(type . interpreter) (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 (apply string-append
`("mosh" `("mosh"
" " " "
@ -92,74 +150,120 @@
append-directories) append-directories)
" " " "
,input-file))))) ,input-file)))))
(sagittarius (racket
(type . interpreter) (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 (let ((rkt-input-file (if (string=? input-file "")
`("sash -r7" ""
" " (change-file-suffix input-file ".rkt"))))
,@(map (lambda (item) (when (not (string=? rkt-input-file ""))
(string-append "-L " item " ")) (if (file-exists? rkt-input-file)
prepend-directories) (delete-file rkt-input-file))
,@(map (lambda (item) (with-output-to-file
(string-append "-A " item " ")) rkt-input-file
append-directories) (lambda ()
" " (display "#lang r7rs")
,input-file))))) (newline)
(skint (display "(import (scheme base))")
(type . interpreter) (newline)
(command . ,(lambda (input-file output-file prepend-directories append-directories) (display "(include \"")
(apply string-append (display (path->filename input-file))
`("skint" (display "\")")
" " (newline))))
,@(map (lambda (item) (for-each
(string-append "-I " item "/ ")) (lambda (file)
prepend-directories) (let ((library-rkt-file (change-file-suffix file ".rkt")))
,@(map (lambda (item) (if (file-exists? library-rkt-file)
(string-append "-A " item "/ ")) (delete-file library-rkt-file))
append-directories) (with-output-to-file
" " library-rkt-file
,input-file))))) (lambda ()
(stklos (display "#lang r7rs")
(type . interpreter) (newline)
(command . ,(lambda (input-file output-file prepend-directories append-directories) (display "(import (scheme base))")
(apply string-append (newline)
`("stklos" (display "(include \"")
" " (display (path->filename file))
,@(map (lambda (item) (display "\")")
(string-append "-I " item " ")) (newline)))))
prepend-directories) library-files)
,@(map (lambda (item) (apply string-append
(string-append "-A " item " ")) `("PLTCOLLECTS="
append-directories) ,(string-join prepend-directories ":")
" " ,(string-join append-directories ":")
,input-file))))) " "
(tr7 "raco exe --orig-exe ++lang r7rs -o "
(type . interpreter) ,output-file
(command . ,(lambda (input-file output-file prepend-directories append-directories) " "
(apply string-append ,rkt-input-file))))))
`("TR7_LIB_PATH=" (sagittarius
,@(map (lambda (item) (type . interpreter)
(string-append item ":")) (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
prepend-directories) (apply string-append
,@(map (lambda (item) `("sash -r7"
(string-append item ":")) " "
append-directories) ,@(map (lambda (item)
" " (string-append "-L " item " "))
"tr7i" prepend-directories)
" " ,@(map (lambda (item)
,input-file))))) (string-append "-A " item " "))
(ypsilon append-directories)
(type . interpreter) " "
(command . ,(lambda (input-file output-file prepend-directories append-directories) ,input-file)))))
(apply string-append (skint
`("ypsilon --r7rs" (type . interpreter)
" " (command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
,@(map (lambda (item) (apply string-append
(string-append "--sitelib=" item)) `("skint"
prepend-directories) " "
,@(map (lambda (item) ,@(map (lambda (item)
(string-append "--sitelib=" item)) (string-append "-I " item "/ "))
append-directories) prepend-directories)
" " ,@(map (lambda (item)
,input-file))))))) (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)))))))

56
src/util.scm
View File

@ -11,3 +11,59 @@
end)) end))
#t #t
#f))) #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)))))