lassik
/
scheme-deps
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Initial commit

This commit is contained in:
Lassi Kortela 2022-09-15 19:44:45 +03:00
commit 3db2796c95
1 changed files with 303 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

303
scheme-deps.sld Normal file
View File

@ -0,0 +1,303 @@
(define-library (scheme-deps)
(export main)
(import (except (scheme base) features)
(scheme file)
(scheme read)
(scheme write)
(only (srfi 1) append-map append-reverse fold any every remove)
(srfi 193))
(cond-expand
(chibi
(import (chibi show)
(chibi show pretty)))
(gauche
(import (only (gauche base) pprint)))
(else))
(cond-expand
(chibi
(begin
(define (pretty-print obj)
(show #t (pretty obj)))))
(gauche
(begin
(define (pretty-print obj)
(pprint obj))))
(else
(begin
(define (pretty-print obj)
(write obj)
(newline)))))
(begin
(define edisp
(lambda objs
(for-each (lambda (obj) (display obj (current-error-port)))
objs)
(newline (current-error-port))))
(define (read-all)
(let loop ((xs '()))
(let ((x (read)))
(if (eof-object? x) (reverse xs) (loop (cons x xs))))))
;;
(define (natural? obj)
(and (integer? obj) (exact? obj) (not (negative? obj))))
;;
(define first car)
(define second cadr)
(define rest cdr)
(define (list<? < a b)
(cond ((null? a) (not (null? b)))
((null? b) #f)
((< (first a) (first b)) #t)
((< (first b) (first a)) #f)
(else (list<? < (rest a) (rest b)))))
(define (sorted-insert-unique < elem list)
(let loop ((before '()) (tail list))
(cond ((or (not (pair? tail))
(< elem (first tail)))
(append-reverse before (cons elem tail)))
((< (first tail) elem)
(loop (cons (first tail) before)
(rest tail)))
(else
list))))
(define (sort-unique < list)
(let loop ((sorted '()) (list list))
(if (null? list)
sorted
(loop (sorted-insert-unique < (first list) sorted)
(rest list)))))
(define (nonnull-list? obj)
(and (list? obj)
(not (null? obj))))
(define (head? form head)
(and (nonnull-list? form)
(equal? head (first form))))
(define (dehead form head)
(if (head? form head)
(rest form)
(error "Mismatch" form head)))
(define (if-nonnull head tail)
(if (null? tail) '() `((,head ,@tail))))
;;
(define (string-join parts delim)
(if (null? parts)
""
(fold (lambda (parts whole) (string-append whole delim parts))
(first parts)
(rest parts))))
;;
(define (valid-library-name-part? obj)
(or (symbol? obj) (natural? obj)))
(define (valid-library-name? obj)
(and (nonnull-list? obj)
(every valid-library-name-part? obj)))
(define (library-name-part->string part)
(cond ((symbol? part) (symbol->string part))
((number? part) (number->string part))
(else (error "Bad library name part" part))))
(define (library-name-part<? a b)
(string<? (library-name-part->string a)
(library-name-part->string b)))
(define (library-name<? a b)
(list<? library-name-part<? a b))
(define (format-library-name library-name separator extension)
(string-append (string-join (map library-name-part->string library-name)
separator)
extension))
(define (library-name->filename library-name)
(format-library-name library-name "/" ".sld"))
;;
(define (no-consumer value) (error "No consumer"))
(define (producer consumer) (lambda (value) ((consumer) value)))
(define consume-name (make-parameter no-consumer))
(define consume-import (make-parameter no-consumer))
(define consume-include (make-parameter no-consumer))
(define produce-name (producer consume-name))
(define produce-import (producer consume-import))
(define produce-include (producer consume-include))
(define features (make-parameter '()))
(define libraries (make-parameter '()))
;;
(define (requirement-satisfied? exp)
(cond ((symbol? exp)
(not (not (member exp (features)))))
((head? exp 'library)
(if (= 2 (length exp))
(not (not (member (second exp) (libraries))))
(error "Bad (library ...) requirement")))
((head? exp 'not)
(if (= 2 (length exp))
(not (requirement-satisfied? (second exp)))
(error "Bad (not ...) requirement" exp)))
((head? exp 'and)
(every requirement-satisfied? exp))
((head? exp 'or)
(any requirement-satisfied? exp))
(else
(error "Bad cond-expand requirement" exp))))
(define (walk-cond-expand form)
(let loop ((clauses (dehead form 'cond-expand)))
(if (null? clauses)
(error "No cond-expand clause matches these features" (features))
(let ((clause (first clauses)))
(cond ((not (nonnull-list? clause))
(error "Bad cond-expand clause" clause))
((or (equal? 'else (first clause))
(requirement-satisfied? (first clause)))
(walk-library-declarations (rest clause)))
(else
(loop (rest clauses))))))))
(define (walk-include form)
(if (and (head? form 'include) (= 2 (length form)))
(produce-include (second form))
(error "Bad include" form)))
(define (walk-import-set import-set)
(cond ((or (head? import-set 'except)
(head? import-set 'only)
(head? import-set 'prefix)
(head? import-set 'rename))
(walk-import-set (second import-set)))
((list? import-set)
(produce-import import-set))
(else
(error "Bad import set" import-set))))
(define (walk-import form)
(for-each walk-import-set (dehead form 'import)))
(define ignored-declarations
'(begin export))
(define (walk-library-declaration decl)
(cond ((head? decl 'cond-expand)
(walk-cond-expand decl))
((head? decl 'include)
(walk-include decl))
((head? decl 'import)
(walk-import decl))
((and (nonnull-list? decl)
(member (first decl) ignored-declarations))
(values))
(else
(edisp "warning: ignoring unknown library declaration " decl)
(values))))
(define (walk-library-declarations decls)
(for-each walk-library-declaration decls))
(define (walk-define-library exp)
(unless (and (head? exp 'define-library) (>= (length exp) 3))
(error "Bad define-library" exp))
(let ((name (second exp))
(decls (rest (rest exp))))
(unless (valid-library-name? name)
(error "Bad library name" name))
(produce-name name)
(walk-library-declarations decls)))
(define (walk-sld-file sld-file)
(for-each walk-define-library
(with-input-from-file sld-file read-all)))
(define-record-type <library>
(make-library name source-file imports includes)
library?
(name library-name)
(source-file library-source-file)
(imports library-imports)
(includes library-includes))
(define (standard-or-implementation-library? library-name)
(member (first library-name)
'(chicken rnrs scheme srfi)))
(define (library->chicken-extension library)
(define (library-name->chicken library-name)
(string->symbol (format-library-name library-name "." "")))
`(extension
,(library-name->chicken (library-name library))
(source ,(library-source-file library))
,@(if-nonnull 'source-dependencies
(library-includes library))
,@(if-nonnull 'component-dependencies
(map library-name->chicken
(remove standard-or-implementation-library?
(library-imports library))))
(csc-options "-R" "r7rs"
"-X" "r7rs")))
(define-syntax add-to
(syntax-rules ()
((add-to lis <)
(lambda (elem)
(set! lis (sorted-insert-unique < elem lis))))))
(define (process-sld-file sld-file)
(let ((name '())
(imports '())
(includes '()))
(parameterize ((consume-name (lambda (x) (set! name x)))
(consume-import (add-to imports library-name<?))
(consume-include (add-to includes string<?)))
(walk-sld-file sld-file))
(make-library name sld-file imports includes)))
(define (print-chicken libs)
(for-each
pretty-print
`((distribution-files
,@(sort-unique
string<?
(append-map (lambda (lib)
(cons (library-source-file lib)
(library-includes lib)))
libs)))
(components
,@(map library->chicken-extension
libs)))))
(define main
(lambda ignored
(parameterize ((features '(chicken))
(libraries '((srfi 13))))
(let ((libs (map process-sld-file (command-args))))
(print-chicken libs)))))))