From 29a161ff6af695752e2f7dc82c675637c2314b95 Mon Sep 17 00:00:00 2001 From: retropikzel Date: Thu, 8 May 2025 19:44:59 +0300 Subject: [PATCH] Added proper dependency resolution system --- compile-r7rs.scm | 24 +++++++++- libs/data.sld | 39 +++++++--------- libs/library-util.scm | 102 ++++++++++++++++++++++++++++++++++++++++++ libs/library-util.sld | 10 +++++ libs/util.sld | 37 ++++++++++----- 5 files changed, 174 insertions(+), 38 deletions(-) create mode 100644 libs/library-util.scm create mode 100644 libs/library-util.sld diff --git a/compile-r7rs.scm b/compile-r7rs.scm index f53c884..684db79 100644 --- a/compile-r7rs.scm +++ b/compile-r7rs.scm @@ -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 diff --git a/libs/data.sld b/libs/data.sld index dce01dc..21a208d 100644 --- a/libs/data.sld +++ b/libs/data.sld @@ -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" " " diff --git a/libs/library-util.scm b/libs/library-util.scm new file mode 100644 index 0000000..2583c26 --- /dev/null +++ b/libs/library-util.scm @@ -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)))))))) diff --git a/libs/library-util.sld b/libs/library-util.sld new file mode 100644 index 0000000..bfef792 --- /dev/null +++ b/libs/library-util.sld @@ -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")) + diff --git a/libs/util.sld b/libs/util.sld index b3262ab..f868c27 100644 --- a/libs/util.sld +++ b/libs/util.sld @@ -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)))))