Retropikzel
/
compile-r7rs
1
0
Fork 0
Code Issues

Dont stop if library can not be compiled

This commit is contained in:
retropikzel 2025-11-21 21:59:27 +02:00
parent 0544cef633
commit e2a6ef3ee2
2 changed files with 124 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
compile-scheme.scm
View File

@ -87,7 +87,8 @@
"a.out" "a.out"
#f)))) #f))))
(if (and (symbol=? scheme-type 'compiler) (if (and (symbol=? scheme-type 'compiler)
(symbol=? compilation-target 'php)) ;(symbol=? compilation-target 'php)
)
(string-append outfile ".bin") (string-append outfile ".bin")
outfile))) outfile)))

240
libs/library-util.sld
View File

@ -7,129 +7,133 @@
(libs util)) (libs util))
(export library-dependencies) (export library-dependencies)
(begin (begin
(define filter-out-scheme-dependencies (define filter-out-scheme-dependencies
(lambda (dependencies) (lambda (dependencies)
(let ((result (list))) (let ((result (list)))
(for-each (for-each
(lambda (dependency) (lambda (dependency)
(when (not (equal? (car dependency) 'scheme)) (when (not (equal? (car dependency) 'scheme))
(set! result (append result (list dependency))))) (set! result (append result (list dependency)))))
dependencies) dependencies)
result))) result)))
(define flatten-dependencies (define flatten-dependencies
(lambda (result dependencies) (lambda (result dependencies)
(if (null? dependencies) (if (null? dependencies)
result result
(flatten-dependencies (append result (flatten-dependencies (append result
(list (list
(if (or (equal? (car (car dependencies)) 'only) (if (or (equal? (car (car dependencies)) 'only)
(equal? (car (car dependencies)) 'except) (equal? (car (car dependencies)) 'except)
(equal? (car (car dependencies)) 'prefix) (equal? (car (car dependencies)) 'prefix)
(equal? (car (car dependencies)) 'rename)) (equal? (car (car dependencies)) 'rename))
(car (cdr (car dependencies))) (car (cdr (car dependencies)))
(car dependencies)))) (car dependencies))))
(cdr dependencies))))) (cdr dependencies)))))
(define library-name->path (define library-name->path
(lambda (name) (lambda (name)
(string-append (string-append
(string-cut-from-end (string-cut-from-end
(apply string-append (apply string-append
(map (lambda (item) (map (lambda (item)
(string-append (string-append
(if (symbol? item) (if (symbol? item)
(symbol->string item) (symbol->string item)
(number->string item)) (number->string item))
"/")) "/"))
name)) name))
1) 1)
".sld"))) ".sld")))
(define get-imports (define get-imports
(lambda (result implementation rest) (lambda (result implementation rest)
(cond (cond
((null? rest) result) ((null? rest) result)
((equal? (car rest) 'import) (cdr rest)) ((equal? (car rest) 'import) (cdr rest))
((member 'cond-expand (car rest)) ((member 'cond-expand (car rest))
(if (assoc implementation (cdr (car rest))) (if (assoc implementation (cdr (car rest)))
(get-imports result (get-imports result
implementation implementation
(cdr (assoc implementation (cdr (assoc implementation
(cdr (car rest))))) (cdr (car rest)))))
(get-imports result (get-imports result
implementation implementation
(cdr (or (assoc 'else (cdr (or (assoc 'else
(cdr (car rest))) (cdr (car rest)))
(cons #f '())))))) (cons #f '()))))))
((member 'import (car rest)) ((member 'import (car rest))
(get-imports (append result (list) (cdr (car rest))) (get-imports (append result (list) (cdr (car rest)))
implementation implementation
(cdr rest))) (cdr rest)))
(else (get-imports result implementation (cdr rest)))))) (else (get-imports result implementation (cdr rest))))))
(define remove-nonexistent (define remove-nonexistent
(lambda (directories paths) (lambda (directories paths)
(apply append (apply append
(map (map
(lambda (path)
(if (file-exists? (search-library-file directories path))
(list path)
(list)))
paths))))
;; To get dependencies from R7RS and R6RS libraries we need to read trough all
;; the nonportable stuff first and then when encountering first ( not in
;; comments, read from that
(define read-until-library
(lambda (path) (lambda (path)
(if (file-exists? (search-library-file directories path))
(list path)
(list)))
paths))))
;; To get dependencies from R7RS and R6RS libraries we need to read trough all
;; the nonportable stuff first and then when encountering first ( not in
;; comments, read from that
(define read-until-library
(lambda (path)
(letrec (letrec
((looper (lambda (c) ((looper (lambda (c)
(cond (cond
((char=? c #\() ((char=? c #\()
(read)) (read))
((char=? c #\;) ((char=? c #\;)
(read-line) (read-line)
(looper (peek-char))) (looper (peek-char)))
(else (else
(read-char) (read-char)
(looper (peek-char))))))) (looper (peek-char)))))))
(with-input-from-file (with-input-from-file
path path
(lambda () (lambda ()
(looper (peek-char))))))) (looper (peek-char)))))))
(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) (call-with-current-continuation
;(display path) (lambda (k)
(let ((full-path (search-library-file directories path))) (with-exception-handler
(if (not (file-exists? full-path)) (lambda (x)
(begin (display "Error on compiling library (ignoring): ")
;(display #\space) (write x)
;(display "not found, ignoring") (newline)
;(newline) (k (list)))
(list)) (lambda ()
(begin
(newline) (let ((full-path (search-library-file directories path)))
(letrec* ((raw-data (read-until-library full-path)) (if (not (file-exists? full-path))
(data (if (equal? (car raw-data) 'define-library) (list)
(cdr raw-data) (begin
raw-data)) (newline)
(imports (flatten-dependencies (list) (letrec* ((raw-data (read-until-library full-path))
(get-imports (list) (data (if (equal? (car raw-data) 'define-library)
implementation (cdr raw-data)
data))) raw-data))
(filtered-imports (filter-out-scheme-dependencies imports)) (imports (flatten-dependencies (list)
(paths (map library-name->path filtered-imports)) (get-imports (list)
(flat-tree (apply append implementation
(map (lambda (dependency-path) data)))
(append (list dependency-path) (filtered-imports (filter-out-scheme-dependencies imports))
(reverse (library-dependencies implementation (paths (map library-name->path filtered-imports))
directories (flat-tree (apply append
dependency-path (map (lambda (dependency-path)
indent (append (list dependency-path)
(append indent (list #\space #\space)))))) (reverse (library-dependencies implementation
paths)))) directories
(remove-nonexistent directories (reverse flat-tree)))))))))) dependency-path
indent
(append indent (list #\space #\space))))))
paths))))
(remove-nonexistent directories (reverse flat-tree))))))))))))))