#| -*-Scheme-*-
-$Id: conpkg.scm,v 1.11 2001/08/18 04:48:34 cph Exp $
+$Id: conpkg.scm,v 1.12 2001/08/20 02:48:57 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(package-structure<? (car a) (car b))))))
(list->vector (map cdr alist)))))
+(define (package-structure<? x y)
+ (cond ((package/topological<? x y) true)
+ ((package/topological<? y x) false)
+ (else (package<? x y))))
+
+(define (package/topological<? x y)
+ (and (not (eq? x y))
+ (let loop ((y (package/parent y)))
+ (and y
+ (if (eq? x y)
+ true
+ (loop (package/parent y)))))))
+\f
(define (construct-external-description package extension?)
- (call-with-values
- (lambda ()
- (split-bindings-list (package/sorted-bindings package)))
- (lambda (internal exports imports)
+ (call-with-values (lambda () (split-links package))
+ (lambda (exports imports)
(vector (package/name package)
(let loop ((package package))
(let ((parent (package/parent package)))
(if parent
(cons (package/name parent) (loop parent))
'())))
- (map (let ((map-files
- (lambda (clause)
- (map ->namestring
- (file-case-clause/files clause)))))
- (lambda (file-case)
- (cons (file-case/type file-case)
- (if (file-case/type file-case)
- (map (lambda (clause)
- (cons (file-case-clause/keys clause)
- (map-files clause)))
- (file-case/clauses file-case))
- (map-files
- (car (file-case/clauses file-case)))))))
+ (map (lambda (file-case)
+ (cons (file-case/type file-case)
+ (if (file-case/type file-case)
+ (map (lambda (clause)
+ (cons (file-case-clause/keys clause)
+ (map-files clause)))
+ (file-case/clauses file-case))
+ (map-files
+ (car (file-case/clauses file-case))))))
(package/file-cases package))
(package/initialization package)
(package/finalization package)
- (list->vector internal)
(list->vector
- (map (lambda (n.l)
- (list->vector
- (cons (car n.l)
- (map (lambda (link)
- (let ((dest (link/destination link)))
- (cons (package/name
- (binding/package dest))
- (binding/name dest))))
- (cdr n.l)))))
+ (map binding/name
+ (list-transform-positive (package/sorted-bindings package)
+ (lambda (binding)
+ (and (binding/new? binding)
+ (binding/internal? binding)
+ (not (there-exists? (binding/links binding)
+ (lambda (link)
+ (memq link
+ (package/links package))))))))))
+ (list->vector
+ (map (lambda (link)
+ (let ((source (link/source link))
+ (destination (link/destination link)))
+ (let ((sn (binding/name source))
+ (dp (package/name (binding/package destination)))
+ (dn (binding/name destination)))
+ (if (eq? sn dn)
+ (vector sn dp)
+ (vector sn dp dn)))))
exports))
(list->vector
- (map (lambda (n.s)
- (let ((name (car n.s))
- (source (cdr n.s)))
- (if (eq? name (binding/name source))
- (vector name
- (package/name (binding/package source)))
- (vector name
- (package/name (binding/package source))
- (binding/name source)))))
+ (map (lambda (link)
+ (let ((source (link/source link))
+ (destination (link/destination link)))
+ (let ((dn (binding/name destination))
+ (sp (package/name (binding/package source)))
+ (sn (binding/name source)))
+ (if (eq? dn sn)
+ (vector dn sp)
+ (vector dn sp sn)))))
imports))
extension?))))
-\f
-(define (split-bindings-list bindings)
- (let loop ((bindings bindings) (internal '()) (exports '()) (imports '()))
- (if (pair? bindings)
- (let ((binding (car bindings))
- (bindings (cdr bindings)))
- (let ((name (binding/name binding))
- (source (binding/source-binding binding))
- (links
- (list-transform-positive (binding/links binding) link/new?)))
- (if (and source
- (or (binding/new? binding)
- (pair? links)))
- (if (eq? binding source)
- (if (pair? links)
- (loop bindings
- internal
- (cons (cons name links) exports)
- imports)
- (loop bindings
- (cons name internal)
- exports
- imports))
- (loop bindings
- internal
- exports
- (cons (cons name source) imports)))
- (loop bindings internal exports imports))))
- (values (reverse! internal) (reverse! exports) (reverse! imports)))))
-(define (package-structure<? x y)
- (cond ((package/topological<? x y) true)
- ((package/topological<? y x) false)
- (else (package<? x y))))
+(define (split-links package)
+ (let loop ((links (package/links package)) (exports '()) (imports '()))
+ (if (pair? links)
+ (let ((link (car links))
+ (links (cdr links)))
+ (if (eq? (binding/package (link/source link)) package)
+ (loop links (cons link exports) imports)
+ (loop links exports (cons link imports))))
+ (values exports imports))))
-(define (package/topological<? x y)
- (and (not (eq? x y))
- (let loop ((y (package/parent y)))
- (and y
- (if (eq? x y)
- true
- (loop (package/parent y)))))))
\ No newline at end of file
+(define (map-files clause)
+ (map ->namestring (file-case-clause/files clause)))
\ No newline at end of file
#| -*-Scheme-*-
-$Id: object.scm,v 1.12 2001/08/18 04:48:44 cph Exp $
+$Id: object.scm,v 1.13 2001/08/20 02:49:01 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
parent
(children '())
(bindings (make-rb-tree eq? symbol<?) read-only #t)
- (references (make-rb-tree eq? symbol<?) read-only #t))
+ (references (make-rb-tree eq? symbol<?) read-only #t)
+ (links '()))
(define-integrable (package/n-files package)
(length (package/files package)))
(destination #f read-only #t)
(new? #f read-only #t))
-(define (make-link source-binding destination-binding new?)
+(define (make-link source-binding destination-binding owner-package new?)
(let ((link (%make-link source-binding destination-binding new?)))
(set-binding/links! source-binding
(cons link (binding/links source-binding)))
+ (set-package/links! owner-package
+ (cons link (package/links owner-package)))
link))
\f
(define-structure
#| -*-Scheme-*-
-$Id: redpkg.scm,v 1.16 2001/08/18 04:48:59 cph Exp $
+$Id: redpkg.scm,v 1.17 2001/08/20 02:49:09 cph Exp $
Copyright (c) 1988-2001 Massachusetts Institute of Technology
(loop parent (cdr ancestors)))
(set-package/parent! package #f))))
(let ((expression (make-expression package namestring #f)))
- ;; Unlinked internal names: just bind them.
+ ;; Unlinked internal names.
(for-each-vector-element (vector-ref desc 5)
(lambda (name)
(bind! package name expression #f)))
- ;; Exported bindings: bind the name and link it to the
- ;; external names.
+ ;; Exported bindings.
(for-each-vector-element (vector-ref desc 6)
(lambda (entry)
- (let ((name (vector-ref entry 0)))
+ (let ((name (vector-ref entry 0))
+ (external-package (get-package (vector-ref entry 1) #t))
+ (external-name
+ (if (fix:= (vector-length entry) 2)
+ (vector-ref entry 0)
+ (vector-ref entry 2))))
(bind! package name expression #f)
- (let ((n (vector-length entry)))
- (do ((i 1 (fix:+ i 1)))
- ((fix:= i n))
- (let ((p.n (vector-ref entry i)))
- (link! package
- name
- (get-package (car p.n) #t)
- (cdr p.n)
- #f)))))))
- ;; Imported bindings: bind just the external name and link
- ;; it to the internal name.
+ (link! package name
+ external-package external-name
+ package #f))))
+ ;; Imported bindings.
(for-each-vector-element (vector-ref desc 7)
(lambda (entry)
(let ((external-package (get-package (vector-ref entry 1) #t))
(vector-ref entry 0)
(vector-ref entry 2))))
(bind! external-package external-name expression #f)
- (link! external-package
- external-name
- package
- (vector-ref entry 0)
- #f)))))))))
+ (link! external-package external-name
+ package (vector-ref entry 0)
+ package #f)))))))))
\f
(define (package-lookup package name)
(let package-loop ((package package))
(for-each (lambda (names)
(link! package (car names)
destination (cdr names)
- new?))
+ package new?))
(cdr export))))
(package-description/exports description))
(for-each (lambda (import)
(for-each (lambda (names)
(link! source (cdr names)
package (car names)
- new?))
+ package new?))
(cdr import))))
(package-description/imports description)))
(define (link! source-package source-name
destination-package destination-name
- new?)
+ owner-package new?)
(let ((source-binding (intern-binding! source-package source-name new?))
(destination-binding
(package/find-binding destination-package destination-name)))
(rb-tree/insert! (package/bindings destination-package)
destination-name
destination-binding)
- (make-link source-binding destination-binding new?))))
+ (make-link source-binding destination-binding owner-package new?))))
(define (intern-binding! package name new?)
(let ((binding (package/find-binding package name)))
#| -*-Scheme-*-
-$Id: triv.pkg,v 1.5 2001/08/18 04:49:06 cph Exp $
+$Id: triv.pkg,v 1.6 2001/08/20 02:49:18 cph Exp $
Copyright (c) 2001 Massachusetts Institute of Technology
'#()
(list->vector
(map (lambda (name)
- (vector name (cons (car ancestors) name)))
+ (vector name (car ancestors)))
exported-names))
(list->vector
(map (lambda (n.p)
#| -*-Scheme-*-
-$Id: packag.scm,v 14.32 2001/08/18 04:47:26 cph Exp $
+$Id: packag.scm,v 14.33 2001/08/20 02:48:31 cph Exp $
Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
(initialization #f read-only #t)
(finalization #f read-only #t)
(internal-names #f read-only #t)
- (internal-bindings #f read-only #t)
- (external-bindings #f read-only #t)
+ (exports #f read-only #t)
+ (imports #f read-only #t)
(extension? #f read-only #t))
(define (package-file? object)
(eq? (car clause) 'ELSE))
(list-of-type? (cdr clause) string?)))))))))
(vector-of-type? (package-description/internal-names object) symbol?)
- (vector-of-type? (package-description/internal-bindings object)
- (lambda (binding)
- (and (vector? binding)
- (let ((n (vector-length binding)))
- (and (fix:>= n 2)
- (symbol? (vector-ref binding 0))
- (let loop ((i 1))
- (or (fix:= i n)
- (and (let ((p.n (vector-ref binding i)))
- (and (pair? p.n)
- (package-name? (car p.n))
- (symbol? (cdr p.n))))
- (loop (fix:+ i 1))))))))))
- (vector-of-type? (package-description/external-bindings object)
- (lambda (binding)
- (and (vector? binding)
- (or (fix:= (vector-length binding) 2)
- (fix:= (vector-length binding) 3))
- (symbol? (vector-ref binding 0))
- (package-name? (vector-ref binding 1))
- (or (fix:= (vector-length binding) 2)
- (symbol? (vector-ref binding 2))))))
+ (vector-of-type? (package-description/exports object) link-description?)
+ (vector-of-type? (package-description/imports object) link-description?)
(boolean? (package-description/extension? object))))
+
+(define (link-description? object)
+ (and (vector? object)
+ (cond ((fix:= (vector-length object) 2)
+ (and (symbol? (vector-ref object 0))
+ (package-name? (vector-ref object 1))))
+ ((fix:= (vector-length object) 3)
+ (and (symbol? (vector-ref object 0))
+ (package-name? (vector-ref object 1))
+ (symbol? (vector-ref object 2))))
+ (else #f))))
\f
;; CONSTRUCT-PACKAGES-FROM-FILE is called from the cold load and must
;; only use procedures that are inline-coded by the compiler.
null-environment))
(cons (package-description/internal-names description)
(lambda (name) name))
- (cons (package-description/internal-bindings description)
+ (cons (package-description/exports description)
(lambda (binding) (vector-ref binding 0)))
- (cons (package-description/external-bindings description)
+ (cons (package-description/imports description)
(lambda (binding) (vector-ref binding 0))))))
(let loop ((path name) (package system-global-package))
(if (pair? (cdr path))
(define (create-links-from-description description)
(let ((environment
(find-package-environment (package-description/name description))))
- (let ((bindings (package-description/internal-bindings description)))
+ (let ((bindings (package-description/exports description)))
(let ((n (vector-length bindings)))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
(let ((binding (vector-ref bindings i)))
- (let ((name (vector-ref binding 0))
- (n (vector-length binding)))
- (do ((i 1 (fix:+ i 1)))
- ((fix:= i n))
- (let ((link (vector-ref binding i)))
- (link-variables (find-package-environment (car link))
- (cdr link)
- environment
- name))))))))
- (let ((bindings (package-description/external-bindings description)))
+ (link-variables (find-package-environment (vector-ref binding 1))
+ (if (fix:= (vector-length binding) 3)
+ (vector-ref binding 2)
+ (vector-ref binding 0))
+ environment
+ (vector-ref binding 0))))))
+ (let ((bindings (package-description/imports description)))
(let ((n (vector-length bindings)))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
projects / mit-scheme.git / commitdiff