123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163 |
- ;;; Ported from Scheme 48 1.9. See file COPYING for notices and license.
- ;;;
- ;;; Port Author: Andrew Whatson
- ;;;
- ;;; Original Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
- ;;;
- ;;; scheme48-1.9.2/scheme/bcomp/scan-package.scm
- ;;;
- ;;; Scanning structures and processing package clauses.
- ;;;
- ;;; Utility for compile-structures (link/link.scm) and
- ;;; ensure-loaded (env/load-package.scm).
- ;;;
- ;;; Returns a list of all packages reachable from STRUCTS that answer true to
- ;;; INCLUDE-THIS-PACKAGE?.
- (define-module (prescheme bcomp scan-package)
- #:use-module (prescheme scheme48)
- #:use-module (prescheme filename)
- #:use-module (prescheme bcomp binding)
- #:use-module (prescheme bcomp cenv)
- #:use-module (prescheme bcomp mtype)
- #:use-module (prescheme bcomp package)
- #:use-module (prescheme bcomp read-form)
- #:export (collect-packages
- package-source))
- (define (collect-packages structs include-this-package?)
- (let ((package-seen '())
- (structure-seen '())
- (packages '()))
- (letrec ((recur
- (lambda (structure visited)
- (if (memq (structure-package structure) visited)
- (warning 'collect-packages "cycle in structures dependencies"
- structure visited))
- (if (not (memq structure structure-seen))
- (begin
- (set! structure-seen (cons structure structure-seen))
- (let ((package (structure-package structure)))
- (if (not (memq package package-seen))
- (begin
- (set! package-seen (cons package package-seen))
- (if (include-this-package? package)
- (let ((visited (cons package visited)))
- (for-each (lambda (struct)
- (recur struct visited))
- (package-opens package))
- (for-each (lambda (name+struct)
- (recur (cdr name+struct) visited))
- (package-accesses package))
- (set! packages (cons package packages))))))))))))
- (for-each (lambda (struct)
- (recur struct '()))
- structs)
- (reverse packages))))
- ; Walk through PACKAGE's clauses to find the source code. The relevant
- ; clauses are:
- ; (files name ...)
- ; (begin form ...)
- ; (define-all-operators)
- ; (usual-transforms name ...)
- ;
- ; Returns a list of pairs (file . (node1 node2 ...)), a list of names
- ; of standard transforms, and a boolean value which is true if the package
- ; is to include definitions of all primitives.
- (define (package-source package)
- (let* ((config-file (package-file-name package))
- (dir (if config-file
- (file-name-directory config-file)
- #f)))
- (call-with-values
- (lambda ()
- (fold->3 (lambda (clause stuff transforms primitives?)
- (case (car clause)
- ((files)
- (values (read-files (cdr clause) stuff dir package)
- transforms
- primitives?))
- ((begin)
- (values (cons (cons config-file (cdr clause))
- stuff)
- transforms
- primitives?))
- ((integrate)
- (set-package-integrate?! package
- (or (null? (cdr clause))
- (cadr clause)))
- (values stuff transforms primitives?))
- ((optimize)
- (values stuff transforms primitives?))
- ((define-all-operators)
- (values stuff transforms #t))
- ((usual-transforms)
- (values stuff
- (append (reverse (cdr clause)) transforms)
- primitives?))
- ((reader)
- (let ((r (force (comp-env-macro-eval (package->environment package)))))
- (set-package-reader! package ((car r) (cadr clause) (cdr r))))
- (values stuff transforms primitives?))
- (else
- (assertion-violation 'package-source
- "unrecognized define-structure keyword"
- clause))))
- (package-clauses package)
- '() '() #f))
- (lambda (stuff transforms primitives?)
- (values (reverse stuff)
- (reverse transforms)
- primitives?)))))
- ; Also prints out the filenames (courtesy of READ-FORMS).
- (define (read-files all-files stuff dir package)
- (force-output (current-output-port)) ; just to be nice
- (fold (lambda (filespec stuff)
- (let ((file (namestring filespec
- dir
- *scheme-file-type*)))
- (display #\space (current-noise-port))
- (cons (cons file (read-forms file package #f))
- stuff)))
- all-files
- stuff))
- (define (package-optimizer-names package)
- (if (package-integrate? package)
- (let ((opts (apply append
- (map cdr (filter (lambda (clause)
- (eq? (car clause) 'optimize))
- (package-clauses package))))))
- (reduce (lambda (name opts)
- (if (memq name opts)
- opts
- (cons name opts)))
- opts
- '()))
- '()))
- (define (check-structure structure)
- (let ((undefined '()))
- (for-each-export
- (lambda (name want-type binding)
- (if (binding? binding)
- (let ((have-type (binding-type binding)))
- (if (not (compatible-types? have-type want-type))
- (warning 'check-structure
- "Type in interface doesn't match binding"
- name
- `(binding: ,(type->sexp have-type #t))
- `(interface: ,(type->sexp want-type #t))
- structure)))
- (set! undefined (cons name undefined))))
- structure)
- (if (not (null? undefined))
- (warning 'check-structure
- "Structure has undefined exports"
- structure
- undefined))))
|