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

Added proper dependency resolution system

This commit is contained in:
retropikzel 2025-05-08 19:44:59 +03:00
parent 311eefc961
commit 29a161ff6a
5 changed files with 174 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
compile-r7rs.scm
View File

@ -6,6 +6,7 @@
(retropikzel pffi)
(libs util)
(libs data)
(libs library-util)
(srfi 170))
(when (member "--list-schemes" (command-line))
@ -110,6 +111,17 @@
result))))))
(looper (command-line) (list))))
(when (member "--library-dependencies" (command-line))
(write (library-dependencies scheme
(append prepend-directories append-directories)
(if input-file
input-file
single-library-input-file)
(list)
(list)))
(newline)
(exit 0))
(cond-expand
(windows (pffi-define-library c-stdlib '("stdlib.h") "ucrtbase"))
(else (pffi-define-library c-stdlib
@ -119,7 +131,7 @@
(pffi-define c-system c-stdlib 'system 'int '(pointer))
(define search-library-files
#;(define search-library-files
(lambda (directory)
(let ((result (list)))
(for-each
@ -137,7 +149,7 @@
(directory-files directory))
result)))
(define library-files
#;(define library-files
(cond (single-library-input-file (list single-library-input-file))
(else
(apply append
@ -148,6 +160,14 @@
(list)))
(append prepend-directories append-directories))))))
(define library-files (library-dependencies scheme
(append prepend-directories append-directories)
(if input-file
input-file
single-library-input-file)
(list)
(list)))
(define scheme-type (cdr (assoc 'type (cdr (assoc scheme data)))))
(define scheme-command

39
libs/data.sld
View File

@ -45,30 +45,21 @@
(chicken
(type . compiler)
(library-command . ,(lambda (library-file prepend-directories append-directories r6rs?)
(apply string-append `("csc -R r7rs -X r7rs -s -J"
" "
,(util-getenv "COMPILE_R7RS_CHICKEN")
" "
"-o"
" "
,(let ((result #f))
(map (lambda (item)
(when (and (not result)
(string-starts-with? (real-path library-file)
(real-path item)))
(set! result (string-append (string-replace (string-copy (string-cut-from-end library-file 4)
(+ (string-length item) 1))
#\/
#\.)
".so"))))
(append prepend-directories append-directories))
(write result)
(newline)
(if result
result
(error "Could not deduct library output path" library-file)))
" "
,library-file))))
(let* ((out (string-append (if (string-starts-with? library-file "srfi")
(string-replace (string-cut-from-end library-file 4) #\/ #\-)
(string-replace (string-cut-from-end library-file 4) #\/ #\.))
".so")))
(apply string-append `("csc -R r7rs -X r7rs -s -J"
" "
,(util-getenv "COMPILE_R7RS_CHICKEN")
" "
"-o"
" "
,out
" "
,(search-library-file (append prepend-directories
append-directories)
library-file))))))
(command . ,(lambda (input-file output-file prepend-directories append-directories library-files r6rs?)
(apply string-append `("csc -R r7rs -X r7rs"
" "

102
libs/library-util.scm Normal file
View File

@ -0,0 +1,102 @@
(define filter-out-scheme-dependencies
(lambda (dependencies)
(let ((result (list)))
(for-each
(lambda (dependency)
(when (not (equal? (car dependency) 'scheme))
(set! result (append result (list dependency)))))
dependencies)
result)))
(define flatten-dependencies
(lambda (result dependencies)
(if (null? dependencies)
result
(flatten-dependencies (append result
(list
(if (or (equal? (car (car dependencies)) 'only)
(equal? (car (car dependencies)) 'except)
(equal? (car (car dependencies)) 'prefix)
(equal? (car (car dependencies)) 'rename))
(car (cdr (car dependencies)))
(car dependencies))))
(cdr dependencies)))))
(define library-name->path
(lambda (name)
(string-append
(string-cut-from-end
(apply string-append
(map (lambda (item)
(string-append
(if (symbol? item)
(symbol->string item)
(number->string item))
"/"))
name))
1)
".sld")))
(define get-imports
(lambda (result implementation rest)
(cond ((null? rest) result)
((equal? (car rest) 'import) (cdr rest))
((member 'cond-expand (car rest))
(if (assoc implementation (cdr (car rest)))
(get-imports result
implementation
(cdr (assoc implementation
(cdr (car rest)))))
(get-imports result
implementation
(cdr (assoc 'else
(cdr (car rest)))))))
((member 'import (car rest))
(get-imports (append result (list) (cdr (car rest)))
implementation
(cdr rest)))
(else (get-imports result implementation (cdr rest))))))
(define remove-nonexistent
(lambda (directories paths)
(apply append
(map
(lambda (path)
(if (file-exists? (search-library-file directories path))
(list path)
(list)))
paths))))
(define library-dependencies
(lambda (implementation directories path previous-indent indent)
(for-each (lambda (item) (display " ")) indent)
(display path)
(let ((full-path (search-library-file directories path)))
(if (not (file-exists? full-path))
(begin
(display #\space)
(display "not found, ignoring")
(newline)
(list))
(begin
(newline)
(letrec* ((raw-data (with-input-from-file full-path (lambda () (read))))
(data (if (equal? (car raw-data) 'define-library)
(cdr raw-data)
raw-data))
(imports (flatten-dependencies (list)
(get-imports (list)
implementation
data)))
(filtered-imports (filter-out-scheme-dependencies imports))
(paths (map library-name->path filtered-imports))
(flat-tree (apply append
(map (lambda (dependency-path)
(append (list dependency-path)
(reverse (library-dependencies implementation
directories
dependency-path
indent
(append indent (list #\space #\space))))))
paths))))
(remove-nonexistent directories (reverse flat-tree))))))))

10
libs/library-util.sld Normal file
View File

@ -0,0 +1,10 @@
(define-library
(libs library-util)
(import (scheme base)
(scheme read)
(scheme write)
(scheme file)
(libs util))
(export library-dependencies)
(include "library-util.scm"))

37
libs/util.sld
View File

@ -1,6 +1,7 @@
(define-library
(libs util)
(import (scheme base)
(scheme file)
(scheme process-context)
(retropikzel pffi))
(export string-replace
@ -13,7 +14,8 @@
change-file-suffix
string-join
util-getenv
dirname)
dirname
search-library-file)
(begin
(define util-getenv
@ -34,7 +36,7 @@
(lambda (string-content replace with)
(string-map (lambda (c)
(if (char=? c replace)
with c))
with c))
string-content)))
(define string-replace-one
@ -46,14 +48,14 @@
with c))
string-content))))
(define string-replace-one-from-end
(lambda (string-content replace with)
(let ((replaced? #f))
(list->string (reverse (map (lambda (c)
(if (and (not replaced?)
(char=? c replace))
with c))
(reverse (string->list string-content))))))))
(define string-replace-one-from-end
(lambda (string-content replace with)
(let ((replaced? #f))
(list->string (reverse (map (lambda (c)
(if (and (not replaced?)
(char=? c replace))
with c))
(reverse (string->list string-content))))))))
(define string-ends-with?
(lambda (string-content end)
@ -79,7 +81,7 @@
(lambda (string-content cut-length)
(string-copy string-content
0
(- (string-length string-content) 4))))
(- (string-length string-content) cut-length))))
(define string-find
@ -126,4 +128,15 @@
(cond ((= index 0) item)
((= index size) item)
(else (string-append item between))))
string-list)))))))
string-list)))))
(define search-library-file
(lambda (directories path)
(let ((result path))
(for-each
(lambda (directory)
(let ((full-path (string-append directory "/" path)))
(when (file-exists? full-path)
(set! result full-path))))
directories)
result)))))