From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 20 Aug 2001 02:49:18 +0000 (+0000)
Subject: Change .pkd file to have clearly defined exports and imports that
X-Git-Tag: 20090517-FFI~2585
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8eb5812fef951a3532c9f69b3be1918956355d96;p=mit-scheme.git

Change .pkd file to have clearly defined exports and imports that
directly correspond to those written by the programmer in the .pkg
file.  This eliminates the duplicate links that were present in the
previous design.
---

diff --git a/v7/src/cref/conpkg.scm b/v7/src/cref/conpkg.scm
index 6d80c4503..9a165f866 100644
--- a/v7/src/cref/conpkg.scm
+++ b/v7/src/cref/conpkg.scm
@@ -1,6 +1,6 @@
 #| -*-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
 
@@ -48,96 +48,83 @@ USA.
 		      (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)))))))
+
 (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?))))
-
-(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
diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm
index df82d6783..9677aa2f3 100644
--- a/v7/src/cref/object.scm
+++ b/v7/src/cref/object.scm
@@ -1,6 +1,6 @@
 #| -*-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
 
@@ -70,7 +70,8 @@ USA.
   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)))
@@ -155,10 +156,12 @@ USA.
   (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))
 
 (define-structure
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index fdf55707a..c05b8c684 100644
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,6 +1,6 @@
 #| -*-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
 
@@ -460,27 +460,24 @@ USA.
 		    (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))
@@ -489,11 +486,9 @@ USA.
 			 (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)))))))))
 
 (define (package-lookup package name)
   (let package-loop ((package package))
@@ -527,7 +522,7 @@ USA.
 		(for-each (lambda (names)
 			    (link! package (car names)
 				   destination (cdr names)
-				   new?))
+				   package new?))
 			  (cdr export))))
 	    (package-description/exports description))
   (for-each (lambda (import)
@@ -535,7 +530,7 @@ USA.
 		(for-each (lambda (names)
 			    (link! source (cdr names)
 				   package (car names)
-				   new?))
+				   package new?))
 			  (cdr import))))
 	    (package-description/imports description)))
 
@@ -553,7 +548,7 @@ USA.
 
 (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)))
@@ -569,7 +564,7 @@ USA.
       (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)))
diff --git a/v7/src/cref/triv.pkg b/v7/src/cref/triv.pkg
index 2c7fdaa32..2ffc0e6ef 100644
--- a/v7/src/cref/triv.pkg
+++ b/v7/src/cref/triv.pkg
@@ -1,6 +1,6 @@
 #| -*-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
 
@@ -34,7 +34,7 @@ USA.
 			'#()
 			(list->vector
 			 (map (lambda (name)
-				(vector name (cons (car ancestors) name)))
+				(vector name (car ancestors)))
 			      exported-names))
 			(list->vector
 			 (map (lambda (n.p)
diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm
index 3860f2780..25631fca6 100644
--- a/v7/src/runtime/packag.scm
+++ b/v7/src/runtime/packag.scm
@@ -1,6 +1,6 @@
 #| -*-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
 
@@ -249,8 +249,8 @@ USA.
   (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)
@@ -288,29 +288,20 @@ USA.
 				      (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))))
 
 ;; CONSTRUCT-PACKAGES-FROM-FILE is called from the cold load and must
 ;; only use procedures that are inline-coded by the compiler.
@@ -348,9 +339,9 @@ USA.
 		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))
@@ -364,21 +355,18 @@ USA.
 (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))