Change format of ".glo" files to contain package ancestry information.

diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
index 52eba4adb929d2fbb10e8ad6203bf42c14f6c185..c6bf348c6837850c3a01242b9a53a7c8c7dec345 100644 (file)
--- a/v7/src/cref/make.scm
+++ b/v7/src/cref/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: make.scm,v 1.18 1999/01/03 05:22:10 cph Exp $
+$Id: make.scm,v 1.19 2000/01/18 20:38:37 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -32,5 +32,5 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
      (pathname-as-directory "cref")
      (lambda ()
        (load-option 'RB-TREE)
-       (package/system-loader "cref" '() false)))))
-(add-identification! "CREF" 1 18)
\ No newline at end of file
+       (package/system-loader "cref" '() #f)))))
+(add-identification! "CREF" 1 19)
\ No newline at end of file

diff --git a/v7/src/cref/redpkg.scm b/v7/src/cref/redpkg.scm
index 7e150bc45504b567926ab312ae5c6838f6290892..76997ec29c389401a8a9f482ef0ae99afd079ec6 100644 (file)
--- a/v7/src/cref/redpkg.scm
+++ b/v7/src/cref/redpkg.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: redpkg.scm,v 1.11 1999/01/02 06:11:34 cph Exp $
+$Id: redpkg.scm,v 1.12 2000/01/18 20:38:41 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -42,14 +42,27 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                                           "glo")))
                   (if (file-exists? pathname)
                       (let ((contents (fasload pathname)))
-                        (cond ((check-list contents symbol?)
-                               (list (cons '() contents)))
+                        (cond ((and (pair? contents)
+                                    (pair? (car contents))
+                                    (eq? 'VERSION (caar contents))
+                                    (exact-nonnegative-integer?
+                                     (cdar contents)))
+                               (if (not (= 2 (cdar contents)))
+                                   (error "Unknown globals-file version:"
+                                          (cdar contents)))
+                               (cdr contents))
+                              ((check-list contents symbol?)
+                               (list (vector '() '() contents)))
                               ((check-list contents
                                  (lambda (element)
                                    (and (pair? element)
                                         (check-list (car element) symbol?)
                                         (check-list (cdr element) symbol?))))
-                               contents)
+                               (map (lambda (element)
+                                      (vector (car element)
+                                              '()
+                                              (cdr element)))
+                                    contents))
                               (else
                                (warn "Malformed globals file:" pathname)
                                '())))
@@ -409,12 +422,21 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
            (let ((namestring (->namestring (car global))))
              (lambda (entry)
                (for-each
-                (let ((package (get-package (car entry) #t)))
+                (let ((package (get-package (vector-ref entry 0) #t)))
+                  (let loop
+                      ((package package)
+                       (ancestors (vector-ref entry 1)))
+                    (if (eq? 'UNKNOWN (package/parent package))
+                        (if (pair? ancestors)
+                            (let ((parent (get-package (car ancestors) #t)))
+                              (set-package/parent! package parent)
+                              (loop parent (cdr ancestors)))
+                            (set-package/parent! package #f))))
                   (lambda (name)
                     (bind! package
                            name
                            (make-expression package namestring #f))))
-                (cdr entry))))
+                (vector-ref entry 2))))
            (cdr global)))
         globals)
        (for-each

diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm
index 49c028174fd4e6dc12d076cc16501a592c8fef0b..bafe5ce41f07967ab32c477d354b466c59ea4fb8 100644 (file)
--- a/v7/src/cref/toplev.scm
+++ b/v7/src/cref/toplev.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: toplev.scm,v 1.12 1999/01/02 06:11:34 cph Exp $
+$Id: toplev.scm,v 1.13 2000/01/18 20:39:42 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -105,7 +105,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
       (with-output-to-file (pathname-new-type pathname "crf")
        (lambda ()
          (format-packages-unusual pmodel)))))
-
+\f
 (define (write-globals pathname pmodel changes?)
   (if (or changes? (not (file-processed? pathname "pkg" "glo")))
       (let ((package-bindings
@@ -137,8 +137,16 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
                                          package-bindings))
                              unspecific)))))
                  exports)
-       (fasdump (map (lambda (entry)
-                       (cons (package/name (car entry))
-                             (map binding/name (cdr entry))))
-                     package-bindings)
+       (fasdump (cons '(VERSION . 2)
+                      (map (lambda (entry)
+                             (vector (package/name (car entry))
+                                     (let loop ((package (car entry)))
+                                       (let ((parent
+                                              (package/parent package)))
+                                         (if parent
+                                             (cons (package/name parent)
+                                                   (loop parent))
+                                             '())))
+                                     (map binding/name (cdr entry))))
+                           package-bindings))
                 (pathname-new-type pathname "glo")))))
\ No newline at end of file