1
0
Fork 0

Compare commits

..

2 Commits

Author SHA1 Message Date
retropikzel 6e15d3768f Trying to make more silent 2025-10-25 19:21:25 +03:00
retropikzel e27346413c Make the tool silent 2025-10-24 18:39:37 +03:00
4 changed files with 60 additions and 47 deletions

2
.gitignore vendored
View File

@ -15,3 +15,5 @@ README.html
*.import.* *.import.*
deps deps
tmp tmp
deb
*.deb

View File

@ -1,5 +1,6 @@
PREFIX=/usr/local PREFIX=/usr/local
SCHEME=chibi SCHEME=chibi
VERSION=1.0.0
R6RSTMP=tmp/${SCHEME}-r6rs R6RSTMP=tmp/${SCHEME}-r6rs
R7RSTMP=tmp/${SCHEME}-r7rs R7RSTMP=tmp/${SCHEME}-r7rs
DOCKERIMG=${SCHEME}:head DOCKERIMG=${SCHEME}:head
@ -34,6 +35,14 @@ build-chicken:
-uses srfi-170 \ -uses srfi-170 \
compile-r7rs.scm compile-r7rs.scm
deb: build-chicken
mkdir -p deb/bin
cp compile-r7rs deb/bin/
mkdir -p deb/DEBIAN
printf "Package: compile-r7rs\nArchitecture: amd64\nVersion: ${VERSION}\nSection: misc\nMaintainer: Retropikzel <retropikzel@iki.fi>\nDescription: SRFI 138: Compiling Scheme programs to executables - Implementation" \
> deb/DEBIAN/control
dpkg-deb -b deb
# FIXME # FIXME
#build-gauche: #build-gauche:
#echo "#!/bin/sh" > compile-r7rs #echo "#!/bin/sh" > compile-r7rs
@ -42,7 +51,7 @@ build-chicken:
build-guile: build-guile:
echo "#!/bin/sh" > compile-r7rs echo "#!/bin/sh" > compile-r7rs
echo "guile --r7rs --auto-compile -I -q -L ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\" 2> /dev/null" >> compile-r7rs echo "guile --r7rs --auto-compile -I -q -L ${PREFIX}/lib/compile-r7rs ${PREFIX}/lib/compile-r7rs/compile-r7rs.scm \"\$$@\"" >> compile-r7rs
chmod +x compile-r7rs chmod +x compile-r7rs
# FIXME # FIXME

View File

@ -176,44 +176,41 @@
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)
(newline) ;(newline)
; Compile libraries ; Compile libraries
(when (not (null? library-files)) (when (not (null? library-files))
(if single-library-input-file #;(if single-library-input-file
(display "Given library file: ") (display "Given library file: ")
(display "Found library files: ")) (display "Found library files: "))
(display library-files) ;(display library-files)
(newline) ;(newline)
(cond ((assoc 'library-command (cdr (assoc scheme data))) (when (assoc 'library-command (cdr (assoc scheme data)))
(for-each (for-each
(lambda (file) (lambda (file)
(let* ((library-command (scheme-library-command file))) (let* ((library-command (scheme-library-command file)))
(display "Compiling library ") ;(display "Compiling library ")
(display file) ;(display file)
(newline) ;(newline)
(for-each (for-each
(lambda (command) (lambda (command)
(display "Running ") ;(display "Running ")
(write command) ;(write command)
(newline) ;(newline)
(display "Exit code ") ;(display "Exit code ")
(let ((exit-code (c-system (string->c-utf8 command)))) (let ((exit-code (c-system (string->c-utf8 command))))
(display exit-code) ;(display exit-code)
(newline) ;(newline)
(when (not (= exit-code 0)) (when (not (= exit-code 0))
(exit exit-code)))) (exit exit-code))))
library-command))) library-command)))
library-files)) library-files)))
(else
(display "Implementation has no library build command, skipping library compilation.")
(newline))))
; Create executable file ; Create executable file
(when (and (equal? scheme-type 'interpreter) input-file) (when (and (equal? scheme-type 'interpreter) input-file)
@ -224,9 +221,11 @@
(string-append (string-append
"#!/bin/sh" "#!/bin/sh"
(string #\newline) (string #\newline)
"#|"
(string #\newline)
"tmpfile=$(mktemp)" "tmpfile=$(mktemp)"
(string #\newline) (string #\newline)
"tail -n+7 \"$0\" > ${tmpfile}" "tail -n+9 \"$0\" > ${tmpfile}"
(string #\newline))) (string #\newline)))
((string=? compilation-target "windows") ((string=? compilation-target "windows")
(string-append (string-append
@ -241,16 +240,18 @@
"rm -rf ${tmpfile}" "rm -rf ${tmpfile}"
(string #\newline) (string #\newline)
"exit" "exit"
(string #\newline)
"|#"
(string #\newline))) (string #\newline)))
((string=? compilation-target "windows") ((string=? compilation-target "windows")
"")))) ""))))
(scheme-program (slurp input-file))) (scheme-program (slurp input-file)))
(display "Creating startup script ") ;(display "Creating startup script ")
(display output-file) ;(display output-file)
(newline) ;(newline)
(display "Starting with ") ;(display "Starting with ")
(display shebang-line) ;(display shebang-line)
(newline) ;(newline)
(with-output-to-file (with-output-to-file
(if (string=? compilation-target "windows") (if (string=? compilation-target "windows")
(string-append output-file ".bat") (string-append output-file ".bat")
@ -266,20 +267,21 @@
(when (and (equal? scheme-type 'compiler) input-file) (when (and (equal? scheme-type 'compiler) input-file)
(when (and output-file (file-exists? output-file)) (when (and output-file (file-exists? output-file))
(delete-file output-file)) (delete-file output-file))
(display "Compiling file ") ;(display "Compiling file ")
(display input-file) ;(display input-file)
(newline) ;(newline)
(for-each (for-each
(lambda (command) (lambda (command)
(display "Running ") ;(display "Running ")
(write command) ;(write command)
(newline) ;(newline)
(display "Exit code ") ;(display "Exit code ")
(let ((exit-code (c-system (string->c-utf8 command)))) (let ((exit-code (c-system (string->c-utf8 command))))
(display exit-code) ;(display exit-code)
(newline) ;(newline)
(when (not (= exit-code 0)) (when (not (= exit-code 0))
(exit exit-code)))) (exit exit-code))))
scheme-command) scheme-command)
(newline)) ;(newline)
)

View File

@ -100,14 +100,14 @@
(define library-dependencies (define library-dependencies
(lambda (implementation directories path previous-indent indent) (lambda (implementation directories path previous-indent indent)
(for-each (lambda (item) (display " ")) indent) ;(for-each (lambda (item) (display " ")) indent)
(display path) ;(display path)
(let ((full-path (search-library-file directories path))) (let ((full-path (search-library-file directories path)))
(if (not (file-exists? full-path)) (if (not (file-exists? full-path))
(begin (begin
(display #\space) ;(display #\space)
(display "not found, ignoring") ;(display "not found, ignoring")
(newline) ;(newline)
(list)) (list))
(begin (begin
(newline) (newline)