[MIT-Scheme-devel] CREF fix

[Matt Birkholz]

I tried to import ucode-primitive from (runtime) into (gtk), as I had
into (ffi), but in this case got a warning from CREF:

        Bindings with Multiple Definitions:
          ucode-primitive (runtime system-macros)
              ("../ffi/ffi" alien-function/filename)
              ("../runtime/runtime" ucode-type)

The two "definitions" mention filenames from my global-definitions
declarations:

        (global-definitions "../runtime/runtime")
        (global-definitions "../sos/sos")
        (global-definitions "../ffi/ffi")

The second definition

              ("../runtime/runtime" ucode-type)

is for real, though the reference to ucode-type is bogus.  That just
happens to be the last name bound by that package description.  The
same expression is shared by all of the bindings, so the last one
gives the expression its final value cell (and thus name).  (I fixed
this, creating a new expression for each new binding.)

The first definition

              ("../ffi/ffi" alien-function/filename)

is the extra -- from an import!  The CREF code grokking imports
creates a binding in the model's source package AND DEFINES IT.  I
hacked it to NOT define the source binding -- i.e. NOT add an
expression to the source value cell.  I thought this might generate
new "undefined binding" warnings, but it seems all of the imported
bindings are defined somewhere (else).  (Aren't we tidy. :-)

After rebuilding with this patch, I find few differences from the
original CREF reports system-wide:

        $ for F in */*.crf; do \
        _     if [ -s $F.orig -o -s $F ]; then \
        _         echo diff $F.orig $F; \
        _         diff $F.orig $F; \
        _     fi; \
        _ done
        diff edwin/edwin-os2.crf.orig edwin/edwin-os2.crf
        diff edwin/edwin-unx.crf.orig edwin/edwin-unx.crf
        diff edwin/edwin-w32.crf.orig edwin/edwin-w32.crf
        18,22d17
        < 
        < Bindings with Multiple Definitions:
        <   ucode-primitive (runtime system-macros)
        <       ("../runtime/runtime" ucode-type)
        <       ("../win32/win32" ucode-primitive)
        diff sf/sf-os2.crf.orig sf/sf-os2.crf
        diff sf/sf-unx.crf.orig sf/sf-unx.crf
        diff sf/sf-w32.crf.orig sf/sf-w32.crf
        diff win32/win32-os2.crf.orig win32/win32-os2.crf
        1,7d0
        < Bindings with Multiple Definitions:
        <   graphics-device/buffer? (runtime graphics)
        <       ("../runtime/runtime" make-image-type)
        <       ("../runtime/runtime" make-image-type)
        <   make-image-type (runtime graphics)
        <       ("../runtime/runtime" make-image-type)
        <       ("../runtime/runtime" make-image-type)

5 of the non-empty reports are unchanged.  The diffs in the other two
look correct.

It looks like Edwin on w32 had the same problem I had.  Using
global-definitions from ../runtime/ AND ../win32/ created multiple
definitions of ucode-primitive.  Both import ucode-primitive into some
package.

I seem to have helped out win32 on os2 too.  The (runtime
os2-graphics) package does not define graphics-device/buffer? and
make-image-type -- just import them.

So I am thinking I haven't broken anything, and I've solved my
problem, and so I made this commit:

commit 11d2c07efbcf3cce4bdc03e09d714d05d0d14974
Author: Matt Birkholz <address@hidden>
Date:   Thu Aug 27 16:34:34 2009 -0700

    Fix CREF's spurious "Bindings with Multiple Definitions" warnings.
    
    * redpkg.scm (process-globals-info): Ensured that each definition,
    internal and exported, is created once, with a unique expression.
    (for-each-exported-name): New.
    (bind!): There should now be no need to avoid adding an expression to
    a value-cell more than once.

diff --git a/src/cref/redpkg.scm b/src/cref/redpkg.scm
index 3f6a783..2e6ae32 100644
--- a/src/cref/redpkg.scm
+++ b/src/cref/redpkg.scm
@@ -511,24 +511,27 @@ USA.
                    (set-package/parent! package parent)
                    (loop parent (cdr ancestors)))
                  (set-package/parent! package #f))))
-       (let ((expression (make-expression package namestring #f)))
+       (let ((new-expression
+              (lambda () (make-expression package namestring #f))))
          ;; Unlinked internal names.
          (for-each-vector-element (vector-ref desc 2)
            (lambda (name)
-             (bind! package name expression #f)))
+             (bind! package name (new-expression) #f)))
          ;; Exported bindings.
-         (for-each-vector-element (vector-ref desc 3)
-           (lambda (entry)
-             (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)
-               (link! package name
-                      external-package external-name
-                      package #f))))
+         (for-each-exported-name (vector-ref desc 3)
+           (lambda (name exports)
+             (bind! package name (new-expression) #f)
+             (for-each
+               (lambda (entry)
+                 (let ((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))))
+                   (link! package name
+                          external-package external-name
+                          package #f)))
+               exports)))
          ;; Imported bindings.
          (for-each-vector-element (vector-ref desc 4)
            (lambda (entry)
@@ -537,10 +540,27 @@ USA.
                     (if (fix:= (vector-length entry) 2)
                         (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)
                       package #f)))))))))
+
+(define (for-each-exported-name exports receiver)
+  (for-each
+    (lambda (name.exports)
+      (receiver (car name.exports) (cdr name.exports)))
+    (let ((len (vector-length exports)))
+      (let loop ((i 0)
+                (names.exports '()))
+       (if (fix:< i len)
+           (let* ((export (vector-ref exports i))
+                  (name (vector-ref export 0))
+                  (entry (assq name names.exports)))
+             (if entry
+                 (begin
+                   (set-cdr! entry (cons export (cdr entry)))
+                   (loop (fix:1+ i) names.exports))
+                 (loop (fix:1+ i) (cons (list name export) names.exports))))
+           names.exports)))))
 
 (define (package-lookup package name)
   (let package-loop ((package package))
@@ -592,10 +612,9 @@ USA.
 (define (bind! package name expression new?)
   (let ((value-cell (binding/value-cell (intern-binding! package name new?))))
     (set-expression/value-cell! expression value-cell)
-    (let ((expressions (value-cell/expressions value-cell)))
-      (if (not (memq expression expressions))
-         (set-value-cell/expressions! value-cell
-                                      (cons expression expressions))))))
+    (set-value-cell/expressions! value-cell
+                                (cons expression
+                                      (value-cell/expressions value-cell)))))
 
 (define (link! source-package source-name
               destination-package destination-name