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
*.c
*.o
*.o*
*.so
!chicken
!src
*.rkt

4
Makefile
View File

@ -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

1
README.md
View File

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

3
compile-r7rs.rkt
View File

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

42
compile-r7rs.scm
View File

@ -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)
@ -157,8 +166,6 @@
(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)))
@ -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...")

130
src/data.scm
View File

@ -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,9 +150,55 @@
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)
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files)
(apply string-append
`("sash -r7"
" "
@ -108,7 +212,7 @@
,input-file)))))
(skint
(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
`("skint"
" "
@ -122,7 +226,7 @@
,input-file)))))
(stklos
(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
`("stklos"
" "
@ -136,7 +240,7 @@
,input-file)))))
(tr7
(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
`("TR7_LIB_PATH="
,@(map (lambda (item)
@ -151,7 +255,7 @@
,input-file)))))
(ypsilon
(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
`("ypsilon --r7rs"
" "

56
src/util.scm
View File

@ -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)))))