diff options
Diffstat (limited to 'manifest.scm')
| -rw-r--r-- | manifest.scm | 350 |
1 files changed, 350 insertions, 0 deletions
diff --git a/manifest.scm b/manifest.scm new file mode 100644 index 0000000..77d6f1b --- /dev/null +++ b/manifest.scm @@ -0,0 +1,350 @@ +;"manifest.scm" List SLIB module requires and exports. +;Copyright (C) 2003 Aubrey Jaffer +; +;Permission to copy this software, to modify it, to redistribute it, +;to distribute modified versions, and to use it for any purpose is +;granted, subject to the following restrictions and understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warranty or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +(require 'line-i/o) + +;;@code{(require 'manifest)} +;;@ftindex manifest + +;;@noindent +;;In some of these examples, @var{slib:catalog} is the SLIB part of +;;the catalog; it is free of compiled and implementation-specific +;;entries. It would be defined by: +;; +;;@example +;;(define slib:catalog (cdr (member (assq 'null *catalog*) *catalog*))) +;;@end example + +;;@body +;;Returns a list of the features @code{require}d by @1 assuming the +;;predicate @2 and association-list @3. +(define (file->requires file provided? catalog) + (call-with-input-file file + (lambda (port) + (define requires '()) + (define (add-require feature) + (if (and (not (provided? (cadr feature))) + (not (assq (cadr feature) catalog))) + (slib:warn file 'unknown 'feature feature)) + (if (not (memq (cadr feature) requires)) + (set! requires (cons (cadr feature) requires)))) + (let loop ((sexp (read port))) + (cond ((or (eof-object? sexp) (not (pair? sexp)) (not (list? sexp))) + (reverse requires)) + (else + (case (car sexp) + ((require) + (cond ((not (= 2 (length sexp))) + (slib:warn 'bad 'require sexp)) + (else (add-require (cadr sexp)))) + (loop (read port))) + ((require-if) + (cond ((not (= 3 (length sexp))) + (slib:warn 'bad 'require-if sexp)) + ((not (and (pair? (cadr sexp)) + (list? (cadr sexp)) + (eq? 'quote (caadr sexp)))) + (slib:warn + 'file->requires 'unquoted 'feature)) + ((feature-eval + (cadadr sexp) + (lambda (expression) + (if (provided? expression) #t + (let ((path (cdr (or (assq expression catalog) + '(#f . #f))))) + (cond ((symbol? path) (provided? path)) + (else #f)))))) + (add-require (caddr sexp)))) + (loop (read port))) + (else (reverse requires))))))))) +;;@example +;;(define (provided+? . features) +;; (lambda (feature) +;; (or (memq feature features) (provided? feature)))) +;; +;;(file->requires "obj2str.scm" (provided+? 'compiling) '()) +;; @result{} (string-port generic-write) +;; +;;(file->requires "obj2str.scm" provided? '()) +;; @result{} (string-port) +;;@end example + +;;@body +;;Returns a list of the features @code{require}d by @1 assuming the +;;predicate @2 and association-list @3. +(define (feature->requires feature provided? catalog) + (define (f2r feature) + (define path (cdr (or (assq feature catalog) '(#f . #f)))) + (define (return path) + (file->requires (string-append path (scheme-file-suffix)) + provided? catalog)) + (cond ((not path) #f) + ((string? path) + (return path)) + ((not (pair? path)) + (slib:error feature 'path? path)) + (else (case (car path) + ((source defmacro macro-by-example macro macros-that-work + syntax-case syntactic-closures) + (return (if (pair? (cdr path)) + (cadr path) + (cdr path)))) + ((compiled) (list feature)) + ((aggregate) + (apply append (map f2r (cdr path)))) + (else (slib:error feature 'feature? path)))))) + (f2r feature)) +;;@example +;;(feature->requires 'batch (provided+? 'compiling) *catalog*) +;; @result{} (tree line-i/o databases parameters string-port +;; pretty-print common-list-functions posix-time) +;; +;;(feature->requires 'batch provided? *catalog*) +;; @result{} (tree line-i/o databases parameters string-port +;; pretty-print common-list-functions) +;; +;;(feature->requires 'batch provided? '((batch . "batch"))) +;; @result{} (tree line-i/o databases parameters string-port +;; pretty-print common-list-functions) +;;@end example + +;;@body +;;Returns a list of strings naming existing files loaded (load +;;slib:load slib:load-source macro:load defmacro:load syncase:load +;;synclo:load macwork:load) by @1 or any of the files it loads. +(define (file->loads file) + (define loads '()) + (define (f2l file) + (call-with-input-file file + (lambda (port) + (define (sxp o) + (cond ((eof-object? o)) + ((not (list? o))) + ((< (length o) 2)) + ((memq (car o) '(load slib:load slib:load-source macro:load + defmacro:load syncase:load synclo:load + macwork:load)) + (let ((path (load->path (cadr o)))) + (cond ((not (member path loads)) + (set! loads (cons path loads)) + (f2l path))) + (sxp (read port)))) + ((eq? 'begin (car o)) (for-each sxp (cdr o))) + (else (sxp (read port))))) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* file) + (sxp (read port)) + (set! *load-pathname* old-load-pathname) + loads)))) + (f2l file)) +;;@example +;;(file->loads (in-vicinity (library-vicinity) "scainit.scm")) +;; @result{} ("/usr/local/lib/slib/scaexpp.scm" +;; "/usr/local/lib/slib/scaglob.scm" +;; "/usr/local/lib/slib/scaoutp.scm") +;;@end example + +;;@body +;;Given a @code{(load '<expr>)}, where <expr> is a string or vicinity +;;stuff), @code{(load->path <expr>)} figures a path to the file. +;;@0 returns that path if it names an existing file; otherwise #f. +(define (load->path exp) + (define (cwv vicproc exp) + (let ((a1 (cwp (cadr exp))) + (a2 (cwp (caddr exp)))) + (if (and (string? a1) (string? a2)) (vicproc a1 a2) exp))) + (define (cwp exp) + (cond ((string? exp) exp) + ((not (pair? exp)) ;(slib:warn 'load->path 'strange 'feature exp) + exp) + (else (case (car exp) + ((program-vicinity) (program-vicinity)) + ((library-vicinity) (library-vicinity)) + ((implementation-vicinity) (implementation-vicinity)) + ((user-vicinity) (user-vicinity)) + ((in-vicinity) (cwv in-vicinity exp)) + ((sub-vicinity) (cwv sub-vicinity exp)) + (else (slib:eval exp)))))) + (let ((ans (cwp exp))) + (if (and (string? ans) (file-exists? (string-append ans ".scm"))) + (string-append ans ".scm") + ans))) +;;@example +;;(load->path '(in-vicinity (library-vicinity) "mklibcat")) +;; @result{} "/usr/local/lib/slib/mklibcat.scm" +;;@end example + +;;@body +;;Returns a list of the identifier symbols defined by SLIB (or +;;SLIB-style) file @1. +(define (file->definitions file) + (call-with-input-file file + (lambda (port) + (define defs '()) + (define (sxp o) + (cond ((eof-object? o)) + ((not (list? o))) + ((< (length o) 2)) + ((eq? 'begin (car o)) (for-each sxp (cdr o))) + ((< (length o) 3)) + ((not (memq (car o) + '(define-operation define define-syntax defmacro)))) + ((symbol? (cadr o)) (set! defs (cons (cadr o) defs))) + ((not (pair? (cadr o)))) + ((not (symbol? (caadr o)))) + (else (set! defs (cons (caadr o) defs)))) + (cond ((eof-object? o) defs) + (else (sxp (read port))))) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* file) + (sxp (read port)) + (set! *load-pathname* old-load-pathname) + defs)))) +;;@example +;;(file->definitions "random.scm") +;; @result{} (*random-state* make-random-state +;; seed->random-state copy-random-state random +;; random:chunk) +;;@end example + +;;@body +;;Returns a list of the identifier symbols exported (advertised) by +;;SLIB (or SLIB-style) file @1. +(define (file->exports file) + (call-with-input-file file + (lambda (port) + (define exports '()) + (define seen-at? #f) + (define (top) + (define c (peek-char port)) + (cond ((eof-object? c)) + ((char=? #\newline c) + (read-line port) + (set! seen-at? #f) + (top)) + ((char-whitespace? c) + (read-char port) + (top)) + ((char=? #\; c) + (read-char port) + (cmt)) + (else (sxp (read port)) + (if (char-whitespace? (peek-char port)) (read-char port)) + (top)))) + (define (cmt) + (define c (peek-char port)) + (cond ((eof-object? c)) + ((char=? #\; c) + (read-char port) + (cmt)) + ((char=? #\@ c) + (set! seen-at? #t) + (read-line port) + (top)) + (else + (read-line port) + (top)))) + (define (sxp o) + (cond ((eof-object? o)) + ((not seen-at?)) + ((not (list? o))) + ((< (length o) 2)) + ((eq? 'begin (car o)) (for-each sxp (cdr o))) + ((< (length o) 3)) + ((not (memq (car o) '(define define-syntax defmacro)))) + ((symbol? (cadr o)) (set! exports (cons (cadr o) exports))) + ((not (pair? (cadr o)))) + ((not (symbol? (caadr o)))) + (else (set! exports (cons (caadr o) exports))))) + (let ((old-load-pathname *load-pathname*)) + (set! *load-pathname* file) + (top) + (set! *load-pathname* old-load-pathname) + exports)))) +;;@example +;;(file->exports "random.scm") +;; @result{} (make-random-state seed->random-state +;; copy-random-state random) +;; +;;(file->exports "randinex.scm") +;; @result{} (random:solid-sphere! random:hollow-sphere! +;; random:normal-vector! random:normal +;; random:exp random:uniform) +;;@end example + +;;@body +;;Returns a list of lists; each sublist holding the name of the file +;;implementing @1, and the identifier symbols exported (advertised) by +;;SLIB (or SLIB-style) feature @1, in @2. +(define (feature->export-alist feature catalog) + (define (f2e feature) + (define path (cdr (or (assq feature catalog) '(#f . #f)))) + (define (return path) + (define path.scm (string-append path (scheme-file-suffix))) + (cond ((file-exists? path.scm) + (cons path.scm (file->exports path.scm))) + (else (slib:warn 'feature->export-alist 'path? path.scm) + (list path)))) + (cond ((not path) '()) + ((symbol? path) (f2e path)) + ((string? path) (list (return path))) + ((not (pair? path)) + (slib:error 'feature->export-alist feature 'path? path)) + (else (case (car path) + ((source defmacro macro-by-example macro macros-that-work + syntax-case syntactic-closures) + (list (return (if (pair? (cdr path)) + (cadr path) + (cdr path))))) + ((compiled) (map list (cdr path))) + ((aggregate) (apply append (map f2e (cdr path)))) + (else (slib:warn 'feature->export-alist feature 'feature? path) + '()))))) + (f2e feature)) +;;@body +;;Returns a list of all exports of @1. +(define (feature->exports feature catalog) + (apply append (map cdr (feature->export-alist feature catalog)))) +;;@noindent +;;In the case of @code{aggregate} features, more than one file may +;;have export lists to report: +;; +;;@example +;;(feature->export-alist 'r5rs slib:catalog)) +;; @result{} (("/usr/local/lib/slib/values.scm" +;; call-with-values values) +;; ("/usr/local/lib/slib/mbe.scm" +;; define-syntax macro:expand +;; macro:load macro:eval) +;; ("/usr/local/lib/slib/eval.scm" +;; eval scheme-report-environment +;; null-environment interaction-environment)) +;; +;;(feature->export-alist 'stdio *catalog*) +;; @result{} (("/usr/local/lib/slib/scanf.scm" +;; fscanf sscanf scanf scanf-read-list) +;; ("/usr/local/lib/slib/printf.scm" +;; sprintf printf fprintf) +;; ("/usr/local/lib/slib/stdio.scm" +;; stderr stdout stdin)) +;; +;;(feature->exports 'stdio slib:catalog) +;; @result{} (fscanf sscanf scanf scanf-read-list +;; sprintf printf fprintf stderr stdout stdin) +;;@end example |