From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 10 Jan 1995 20:38:15 +0000 (+0000)
Subject: Add new directives INCLUDE and EXTEND-PACKAGE.
X-Git-Tag: 20090517-FFI~6774
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=32b96bbee7aeba784b3a206c7ac8223f53580f0f;p=mit-scheme.git

Add new directives INCLUDE and EXTEND-PACKAGE.
---

diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
index 1826934b3..cf69a19a2 100644
--- a/v7/src/cref/make.scm
+++ b/v7/src/cref/make.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 1.13 1995/01/05 20:21:58 cph Exp $
+$Id: make.scm,v 1.14 1995/01/10 20:38:15 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -46,4 +46,4 @@ MIT in each case. |#
      (lambda ()
        (load-option 'RB-TREE)
        (package/system-loader "cref" '() false)))))
-(add-system! (make-system "CREF" 1 13 '()))
\ No newline at end of file
+(add-system! (make-system "CREF" 1 14 '()))
\ No newline at end of file
diff --git a/v7/src/cref/object.scm b/v7/src/cref/object.scm
index ff55ae537..1f9dbd26e 100644
--- a/v7/src/cref/object.scm
+++ b/v7/src/cref/object.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: object.scm,v 1.7 1993/10/12 00:00:56 cph Exp $
+$Id: object.scm,v 1.8 1995/01/10 20:38:07 cph Exp $
 
-Copyright (c) 1988-93 Massachusetts Institute of Technology
+Copyright (c) 1988-95 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -40,14 +40,14 @@ MIT in each case. |#
 		   (type vector)
 		   (named
 		    (string->symbol "#[(cross-reference)package-description]"))
-		   (constructor make-package-description)
+		   (constructor make-package-description (name parent))
 		   (conc-name package-description/))
-  (name false read-only true)
-  (file-cases false read-only true)
-  (parent false read-only true)
-  (initialization false read-only true)
-  (exports false read-only true)
-  (imports false read-only true))
+  (name #f read-only #t)
+  (file-cases '())
+  (parent #f read-only #t)
+  (initialization #f)
+  (exports '())
+  (imports '()))
 
 (define-structure (pmodel
 		   (type vector)
@@ -62,28 +62,16 @@ MIT in each case. |#
 (define-structure (package
 		   (type vector)
 		   (named (string->symbol "#[(cross-reference)package]"))
-		   (constructor %make-package
-				(name file-cases files initialization parent))
+		   (constructor make-package (name parent))
 		   (conc-name package/))
-  (name false read-only true)
-  (file-cases false read-only true)
-  (files false read-only true)
-  (initialization false read-only true)
+  (name #f read-only #t)
+  (file-cases '())
+  (files '())
+  (initialization #f)
   parent
   (children '())
-  (bindings (make-rb-tree eq? symbol<?) read-only true)
-  (references (make-rb-tree eq? symbol<?) read-only true))
-
-(define (make-package name file-cases initialization parent)
-  (let ((files
-	 (append-map! (lambda (file-case)
-			(append-map cdr (cdr file-case)))
-		      file-cases)))
-    (%make-package name
-		   file-cases
-		   files
-		   initialization
-		   parent)))
+  (bindings (make-rb-tree eq? symbol<?) read-only #t)
+  (references (make-rb-tree eq? symbol<?) read-only #t))
 
 (define-integrable (package/n-files package)
   (length (package/files package)))
diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 9a24eb0f2..f26116751 100644
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: redpkg.scm,v 1.7 1995/01/06 00:14:12 cph Exp $
+$Id: redpkg.scm,v 1.8 1995/01/10 20:38:00 cph Exp $
 
 Copyright (c) 1988-95 Massachusetts Institute of Technology
 
@@ -41,13 +41,11 @@ MIT in each case. |#
   (let ((model-pathname (merge-pathnames filename)))
     (with-values
 	(lambda ()
-	  (sort-descriptions
-	   (map (lambda (expression)
-		  (parse-package-expression expression))
-		(read-package-description-file model-pathname))))
-      (lambda (packages globals)
+	  (sort-descriptions (read-and-parse-model model-pathname)))
+      (lambda (packages extensions globals)
 	(descriptions->pmodel
 	 packages
+	 extensions
 	 (map (lambda (pathname)
 		(cons
 		 (->namestring pathname)
@@ -75,33 +73,28 @@ MIT in each case. |#
 	 model-pathname)))))
 
 (define (sort-descriptions descriptions)
-  (let loop
-      ((descriptions descriptions)
-       (packages '())
-       (globals '()))
-    (cond ((null? descriptions)
-	   (values (reverse! packages) globals))
-	  ((not (car descriptions))
-	   (loop (cdr descriptions) packages globals))
-	  ((package-description? (car descriptions))
-	   (loop (cdr descriptions)
-		 (cons (car descriptions) packages)
-		 globals))
-	  ((and (pair? (car descriptions))
-		(eq? (caar descriptions) 'GLOBAL-DEFINITIONS))
-	   (loop (cdr descriptions)
-		 packages
-		 (append globals (cdr (car descriptions)))))
-	  ((and (pair? (car descriptions))
-		(eq? (caar descriptions) 'NESTED-DESCRIPTIONS))
-	   (loop (append (cdr descriptions) (cdar descriptions))
-		 packages
-		 globals))
-	  (else
-	   (error "Illegal description" (car descriptions))))))
-
-(define (read-package-description-file pathname)
-  (read-file (pathname-default-type pathname "pkg")))
+  (let ((packages '())
+	(extensions '())
+	(globals '()))
+    (let loop ((descriptions descriptions))
+      (for-each (lambda (description)
+		  (case (car description)
+		    ((DEFINE-PACKAGE)
+		     (set! packages (cons (cdr description) packages)))
+		    ((EXTEND-PACKAGE)
+		     (set! extensions (cons (cdr description) extensions)))
+		    ((GLOBAL-DEFINITIONS)
+		     (set! globals
+			   (append! globals (list-copy (cdr description)))))
+		    ((NESTED-DESCRIPTIONS)
+		     (loop (cdr description)))
+		    (else
+		     (error "Unknown description keyword:"
+			    (car description)))))
+		descriptions))
+    (values (reverse! packages)
+	    (reverse! extensions)
+	    globals)))
 
 (define (read-file-analyses! pmodel)
   (for-each (lambda (p&c)
@@ -206,82 +199,138 @@ MIT in each case. |#
 
 ;;;; Package Descriptions
 
-(define (parse-package-expression expression)
-  (if (not (pair? expression))
-      (error "package expression not a pair" expression))
-  (case (car expression)
-    ((DEFINE-PACKAGE)
-     (parse-package-description (parse-name (cadr expression))
-				(cddr expression)))
-    ((GLOBAL-DEFINITIONS)
-     (let ((filenames (cdr expression)))
-       (if (not (check-list filenames string?))
-	   (error "illegal filenames" filenames))
-       (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
-    ((OS-TYPE-CASE)
-     (if (not (and (list? (cdr expression))
-		   (for-all? (cdr expression)
-		     (lambda (clause)
-		       (and (or (eq? 'ELSE (car clause))
-				(and (list? (car clause))
-				     (for-all? (car clause) symbol?)))
-			    (list? (cdr clause)))))))
-	 (error "Malformed expression:" expression))
-     (cons 'NESTED-DESCRIPTIONS
-	   (let loop ((clauses (cdr expression)))
-	     (cond ((null? clauses)
-		    '())
-		   ((or (eq? 'ELSE (caar clauses))
-			(memq microcode-id/operating-system (caar clauses)))
-		    (map parse-package-expression (cdar clauses)))
-		   (else
-		    (loop (cdr clauses)))))))
-    (else
-     (error "unrecognized expression keyword" (car expression)))))
-
-(define (parse-package-description name options)
-  (let ((none "none"))
-    (let ((file-cases '())
-	  (parent none)
-	  (initialization none)
-	  (exports '())
-	  (imports '()))
-      (if (not (list? options))
-	  (error "options not list" options))
-      (for-each (lambda (option)
-		  (if (not (pair? option))
-		      (error "Illegal option" option))
-		  (case (car option)
-		    ((FILES)
-		     (set! file-cases
-			   (cons (parse-filenames (cdr option)) file-cases)))
-		    ((FILE-CASE)
-		     (set! file-cases
-			   (cons (parse-file-case (cdr option)) file-cases)))
-		    ((PARENT)
-		     (if (not (eq? parent none))
-			 (error "option reoccurs" option))
-		     (if (not (and (pair? (cdr option)) (null? (cddr option))))
-			 (error "illegal option" option))
-		     (set! parent (parse-name (cadr option))))
-		    ((EXPORT)
-		     (set! exports (cons (parse-export (cdr option)) exports)))
-		    ((IMPORT)
-		     (set! imports (cons (parse-import (cdr option)) imports)))
-		    ((INITIALIZATION)
-		     (if (not (eq? initialization none))
-			 (error "option reoccurs" option))
-		     (set! initialization (parse-initialization (cdr option))))
-		    (else
-		     (error "unrecognized option keyword" (car option)))))
-		options)
-      (make-package-description
-       name
-       file-cases
-       (if (eq? parent none) 'NONE parent)
-       (if (eq? initialization none) '#F initialization)
-       (reverse! exports)
-       (reverse! imports)))))
+(define (read-and-parse-model pathname)
+  (parse-package-expressions
+   (read-file (pathname-default-type pathname "pkg"))
+   pathname))
+
+(define (parse-package-expressions expressions pathname)
+  (map (lambda (expression)
+	 (parse-package-expression expression pathname))
+       expressions))
+
+(define (parse-package-expression expression pathname)
+  (let ((lose
+	 (lambda ()
+	   (error "Ill-formed package expression:" expression))))
+    (if (not (and (pair? expression)
+		  (symbol? (car expression))
+		  (list? (cdr expression))))
+	(lose))
+    (case (car expression)
+      ((DEFINE-PACKAGE)
+       (cons 'DEFINE-PACKAGE
+	     (parse-package-definition (parse-name (cadr expression))
+				       (cddr expression))))
+      ((EXTEND-PACKAGE)
+       (cons 'EXTEND-PACKAGE
+	     (parse-package-extension (parse-name (cadr expression))
+				      (cddr expression))))
+      ((GLOBAL-DEFINITIONS)
+       (let ((filenames (cdr expression)))
+	 (if (not (for-all? filenames string?))
+	     (lose))
+	 (cons 'GLOBAL-DEFINITIONS (map parse-filename filenames))))
+      ((OS-TYPE-CASE)
+       (if (not (and (list? (cdr expression))
+		     (for-all? (cdr expression)
+		       (lambda (clause)
+			 (and (or (eq? 'ELSE (car clause))
+				  (and (list? (car clause))
+				       (for-all? (car clause) symbol?)))
+			      (list? (cdr clause)))))))
+	   (lose))
+       (cons 'NESTED-DESCRIPTIONS
+	     (let loop ((clauses (cdr expression)))
+	       (cond ((null? clauses)
+		      '())
+		     ((or (eq? 'ELSE (caar clauses))
+			  (memq microcode-id/operating-system (caar clauses)))
+		      (parse-package-expressions (cdar clauses) pathname))
+		     (else
+		      (loop (cdr clauses)))))))
+      ((INCLUDE)
+       (cons 'NESTED-DESCRIPTIONS
+	     (let ((filenames (cdr expression)))
+	       (if (not (for-all? filenames string?))
+		   (lose))
+	       (append-map (lambda (filename)
+			     (read-and-parse-model
+			      (merge-pathnames filename pathname)))
+			   filenames))))
+      (else
+       (lose)))))
+
+(define (parse-package-definition name options)
+  (check-package-options options)
+  (call-with-values
+      (lambda ()
+	(let ((option (assq 'PARENT options)))
+	  (if option
+	      (let ((options (delq option options)))
+		(if (not (and (pair? (cdr option))
+			      (null? (cddr option))))
+		    (error "Ill-formed PARENT option:" option))
+		(if (assq 'PARENT options)
+		    (error "Multiple PARENT options."))
+		(values (parse-name (cadr option)) options))
+	      (values 'NONE options))))
+    (lambda (parent options)
+      (let ((package (make-package-description name parent)))
+	(process-package-options package options)
+	package))))
+
+(define (parse-package-extension name options)
+  (check-package-options options)
+  (let ((option (assq 'PARENT options)))
+    (if option
+	(error "PARENT option illegal in package extension:" option)))
+  (let ((package (make-package-description name 'NONE)))
+    (process-package-options package options)
+    package))
+
+(define (check-package-options options)
+  (if (not (list? options))
+      (error "Package options must be a list:" options))
+  (for-each (lambda (option)
+	      (if (not (and (pair? option)
+			    (symbol? (car option))
+			    (list? (cdr option))))
+		  (error "Ill-formed package option:" option)))
+	    options))
+
+(define (process-package-options package options)
+  (for-each (lambda (option)
+	      (case (car option)
+		((FILES)
+		 (set-package-description/file-cases!
+		  package
+		  (append (package-description/file-cases package)
+			  (list (parse-filenames (cdr option))))))
+		((FILE-CASE)
+		 (set-package-description/file-cases!
+		  package
+		  (append (package-description/file-cases package)
+			  (list (parse-file-case (cdr option))))))
+		((EXPORT)
+		 (set-package-description/exports!
+		  package
+		  (append (package-description/exports package)
+			  (list (parse-export (cdr option))))))
+		((IMPORT)
+		 (set-package-description/imports!
+		  package
+		  (append (package-description/imports package)
+			  (list (parse-import (cdr option))))))
+		((INITIALIZATION)
+		 (if (package-description/initialization package)
+		     (error "Multiple INITIALIZATION options:" option))
+		 (set-package-description/initialization!
+		  package
+		  (parse-initialization (cdr option))))
+		(else
+		 (error "Unrecognized option keyword:" (car option)))))
+	    options))
 
 (define (parse-name name)
   (if (not (check-list name symbol?))
@@ -333,39 +382,27 @@ MIT in each case. |#
 
 ;;;; Packages
 
-(define (package-lookup package name)
-  (let package-loop ((package package))
-    (or (package/find-binding package name)
-	(and (package/parent package)
-	     (package-loop (package/parent package))))))
-
-(define (name->package packages name)
-  (list-search-positive packages
-    (lambda (package)
-      (symbol-list=? name (package/name package)))))
-
-(define (descriptions->pmodel descriptions globals pathname)
+(define (descriptions->pmodel descriptions extensions globals pathname)
   (let ((packages
 	 (map (lambda (description)
-		(make-package
-		 (package-description/name description)
-		 (package-description/file-cases description)
-		 (package-description/initialization description)
-		 'UNKNOWN))
+		(make-package (package-description/name description) 'UNKNOWN))
 	      descriptions))
 	(extra-packages '()))
     (let ((root-package
 	   (or (name->package packages '())
-	       (make-package '() '() '#F false))))
+	       (make-package '() #f))))
       (let ((get-package
-	     (lambda (name)
+	     (lambda (name intern?)
 	       (if (null? name)
 		   root-package
 		   (or (name->package packages name)
 		       (name->package extra-packages name)
-		       (let ((package (make-package name '() #F 'UNKNOWN)))
-			 (set! extra-packages (cons package extra-packages))
-			 package))))))
+		       (if intern?
+			   (let ((package (make-package name 'UNKNOWN)))
+			     (set! extra-packages
+				   (cons package extra-packages))
+			     package)
+			   (error "Unknown package name:" name)))))))
 	;; GLOBALS is a list of the bindings supplied externally.
 	(for-each
 	 (lambda (global)
@@ -373,7 +410,7 @@ MIT in each case. |#
 	    (let ((namestring (->namestring (car global))))
 	      (lambda (entry)
 		(for-each
-		 (let ((package (get-package (car entry))))
+		 (let ((package (get-package (car entry) #t)))
 		   (lambda (name)
 		     (bind! package
 			    name
@@ -381,37 +418,72 @@ MIT in each case. |#
 		 (cdr entry))))
 	    (cdr global)))
 	 globals)
-	(for-each (lambda (package description)
-		    (let ((parent
-			   (let ((parent-name
-				  (package-description/parent description)))
-			     (and (not (eq? parent-name 'NONE))
-				  (get-package parent-name)))))
-		      (set-package/parent! package parent)
-		      (if parent
-			  (set-package/children!
-			   parent
-			   (cons package (package/children parent)))))
-		    (for-each (lambda (export)
-				(let ((destination (get-package (car export))))
-				  (for-each (lambda (name)
-					      (link! package name
-						     destination name))
-					    (cdr export))))
-			      (package-description/exports description))
-		    (for-each (lambda (import)
-				(let ((source (get-package (car import))))
-				  (for-each (lambda (name)
-					      (link! source name package name))
-					    (cdr import))))
-			      (package-description/imports description)))
-		  packages
-		  descriptions))
+	(for-each
+	 (lambda (package description)
+	   (let ((parent
+		  (let ((parent-name (package-description/parent description)))
+		    (and (not (eq? parent-name 'NONE))
+			 (get-package parent-name #t)))))
+	     (set-package/parent! package parent)
+	     (if parent
+		 (set-package/children!
+		  parent
+		  (cons package (package/children parent)))))
+	   (process-package-description package description get-package))
+	 packages
+	 descriptions)
+	(for-each
+	 (lambda (extension)
+	   (process-package-description
+	    (get-package (package-description/name extension) #f)
+	    extension
+	    get-package))
+	 extensions))
       (make-pmodel root-package
-		   (make-package primitive-package-name '() '() false)
+		   (make-package primitive-package-name #f)
 		   packages
 		   extra-packages
 		   pathname))))
+
+(define (package-lookup package name)
+  (let package-loop ((package package))
+    (or (package/find-binding package name)
+	(and (package/parent package)
+	     (package-loop (package/parent package))))))
+
+(define (name->package packages name)
+  (list-search-positive packages
+    (lambda (package)
+      (symbol-list=? name (package/name package)))))
+
+(define (process-package-description package description get-package)
+  (let ((file-cases (package-description/file-cases description)))
+    (set-package/file-cases! package
+			     (append! (package/file-cases package)
+				      (list-copy file-cases)))
+    (set-package/files!
+     package
+     (append! (package/files package)
+	      (append-map! (lambda (file-case)
+			     (append-map cdr (cdr file-case)))
+			   file-cases))))
+  (let ((initialization (package-description/initialization description)))
+    (if (and initialization
+	     (package/initialization package))
+	(error "Multiple package initializations:" initialization))
+    (set-package/initialization! package initialization))
+  (for-each (lambda (export)
+	      (let ((destination (get-package (car export) #t)))
+		(for-each (lambda (name)
+			    (link! package name destination name))
+			  (cdr export))))
+	    (package-description/exports description))
+  (for-each (lambda (import)
+	      (let ((source (get-package (car import) #t)))
+		(for-each (lambda (name)
+			    (link! source name package name))
+			  (cdr import))))
+	    (package-description/imports description)))
 
 (define primitive-package-name
   (list (string->symbol "#[(cross-reference reader)primitives]")))