Initial commit
This commit is contained in:
commit
3db2796c95
|
|
@ -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)))))))
|
||||
Loading…
Reference in New Issue