From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 1 Mar 1991 20:19:54 +0000 (+0000)
Subject: * Add new procedure, CREF/GENERATE-CREF-UNUSUAL, that writes a ".cref"
X-Git-Tag: 20090517-FFI~10889
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ff7362bb5edeed3360d54994d8568a2e33d431c6;p=mit-scheme.git

* Add new procedure, CREF/GENERATE-CREF-UNUSUAL, that writes a ".cref"
  file containing only the unusual cref information, such as unbound
  variables or multiple definitions.  Change
  CREF/GENERATE-CONSTRUCTORS to call this procedure.

* Rewrite cref formatting code to improve performance.  The
  improvement seems only slight.
---

diff --git a/v7/src/cref/cref.pkg b/v7/src/cref/cref.pkg
index 9e402978b..2a6768d84 100644
--- a/v7/src/cref/cref.pkg
+++ b/v7/src/cref/cref.pkg
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.3 1990/10/05 11:31:38 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/cref.pkg,v 1.4 1991/03/01 20:19:34 cph Exp $
 
-Copyright (c) 1988, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-91 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -45,6 +45,7 @@ MIT in each case. |#
 	  cref/generate-all
 	  cref/generate-constructors
 	  cref/generate-cref
+	  cref/generate-cref-unusual
 	  cref/generate-trivial-constructor))
 
 (define-package (cross-reference balanced-binary-tree)
@@ -74,7 +75,10 @@ MIT in each case. |#
   (files "forpkg")
   (parent (cross-reference))
   (export (cross-reference)
-	  format-packages))
+	  format-packages
+	  format-packages-unusual)
+  (import (runtime scode)
+	  symbol-name))
 
 (define-package (cross-reference reader)
   (files "redpkg")
diff --git a/v7/src/cref/forpkg.scm b/v7/src/cref/forpkg.scm
index 96b22c143..4581adf8f 100644
--- a/v7/src/cref/forpkg.scm
+++ b/v7/src/cref/forpkg.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/forpkg.scm,v 1.4 1989/07/20 22:30:29 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/forpkg.scm,v 1.5 1991/03/01 20:19:39 cph Exp $
 
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1991 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -38,67 +38,62 @@ MIT in each case. |#
 	 (integrate-external "object"))
 
 (define (format-packages pmodel)
-  (let ((indentation "  ")
+  (let ((output? (format-packages-unusual pmodel))
+	(port (current-output-port))
+	(indentation "  ")
 	(width 79)
-	#|(root-package (pmodel/root-package pmodel))|#
 	(packages (pmodel/packages pmodel)))
+    (if (not (null? packages))
+	(begin
+	  (if output?
+	      (output-port/write-string port "\f\n"))
+	  (format-package port indentation width (car packages))
+	  (for-each (lambda (package)
+		      (output-port/write-string port "\f\n")
+		      (format-package port indentation width package))
+		    (cdr packages))))))
+
+(define (format-packages-unusual pmodel)
+  (let ((port (current-output-port))
+	(indentation "  ")
+	(width 79)
+	(packages (pmodel/packages pmodel))
+	(output? false))
     (let ((free-references
-	   (mapcan (lambda (package)
-		     (list-transform-negative
-			 (btree-fringe (package/references package))
-		       reference/binding))
-		   packages)))
+	   (append-map! (lambda (package)
+			  (list-transform-negative
+			      (btree-fringe (package/references package))
+			    reference/binding))
+			packages)))
       (if (not (null? free-references))
 	  (begin
-	    (format-references indentation width "Free References" false
+	    (format-references port indentation width "Free References" false
 	      (sort free-references reference<?))
-	    (write-string "\f\n"))))
+	    (set! output? true))))
     (with-values (lambda () (get-value-cells/unusual packages))
       (lambda (undefined multiple)
 	(if (not (null? undefined))
 	    (begin
-	      (format-value-cells indentation width "Undefined Bindings"
+	      (if output?
+		  (output-port/write-string port "\f\n"))
+	      (format-value-cells port indentation width "Undefined Bindings"
 				  undefined)
-	      (write-string "\f\n")))
+	    (set! output? true)))
 	(if (not (null? multiple))
 	    (begin
-	      (format-value-cells indentation width
+	      (if output?
+		  (output-port/write-string port "\f\n"))
+	      (format-value-cells port indentation width
 				  "Bindings with Multiple Definitions"
 				  multiple)
-	      (write-string "\f\n")))))
-#|
-    (if (not (memq root-package packages))
-	(begin
-	  (write-label "Global References")
-	  (for-each
-	   (lambda (binding)
-	     (let ((references (binding/references binding)))
-	       (if (not (null? references))
-		   (format-expressions
-		    indentation width root-package
-		    (write-to-string (binding/name binding))
-		    (mapcan (lambda (reference)
-			      (list-copy (reference/expressions reference)))
-			    references)))))
-	   (btree-fringe (package/bindings root-package)))
-	  (write-string "\f\n")))
-    (format-references
-     indentation width "Primitives" root-package
-     (btree-fringe (package/references (pmodel/primitive-package pmodel))))
-|#
-    (if (not (null? packages))
-	(begin
-	  (format-package indentation width (car packages))
-	  (for-each (lambda (package)
-		      (write-string "\f\n")
-		      (format-package indentation width package))
-		    (cdr packages))))))
+	      (set! output? true)))))
+    output?))
 
-(define (format-package indentation width package)
-  (write-package-name "Package" package)
+(define (format-package port indentation width package)
+  (write-package-name "Package" package port)
   (if (package/parent package)
-      (write-package-name "Parent" (package/parent package)))
-  (format-package/files indentation width package)
+      (write-package-name "Parent" (package/parent package) port))
+  (format-package/files port indentation width package)
   (let ((classes
 	 (classify-bindings-by-package
 	  (lambda (binding)
@@ -106,10 +101,10 @@ MIT in each case. |#
 	  (btree-fringe (package/bindings package)))))
     (let ((class (assq package classes)))
       (if class
-	  (format-package/bindings indentation width package (cdr class)))
+	  (format-package/bindings port indentation width package (cdr class)))
       (for-each (lambda (class)
 		  (if (not (eq? package (car class)))
-		      (format-package/imports indentation width package
+		      (format-package/imports port indentation width package
 					      (car class)
 					      (cdr class))))
 		classes)
@@ -117,24 +112,23 @@ MIT in each case. |#
 	  (for-each
 	   (lambda (class)
 	     (if (not (eq? package (car class)))
-		 (format-package/exports indentation width (car class)
+		 (format-package/exports port indentation width (car class)
 					 (sort (cdr class) binding<?))))
 	   (classify-bindings-by-package
 	    binding/package
-	    (mapcan (lambda (binding)
-		      (list-copy
-		       (value-cell/bindings (binding/value-cell binding))))
-		    (cdr class))))))))
+	    (append-map (lambda (binding)
+			  (value-cell/bindings (binding/value-cell binding)))
+			(cdr class))))))))
 
-(define (format-value-cells indentation width label value-cells)
-  (write-label label)
+(define (format-value-cells port indentation width label value-cells)
+  (write-label label port)
   (for-each (lambda (binding)
 	      (format-expressions
-	       indentation width false
+	       port indentation width false
 	       (string-append
-		(write-to-string (binding/name binding))
+		(binding/name-string binding)
 		" "
-		(write-to-string (package/name (binding/package binding))))
+		(package/name-string (binding/package binding)))
 	       (binding/expressions binding)))
 	    (sort (map value-cell/source-binding value-cells)
 		  binding<?)))
@@ -167,54 +161,60 @@ MIT in each case. |#
      packages)
     (values unlinked linked)))
 
-(define (write-package-name label package)
-  (write-string label)
-  (write-string ": ")
-  (write (package/name package))
-  (newline))
+(define (write-package-name label package port)
+  (output-port/write-string port label)
+  (output-port/write-string port ": ")
+  (output-port/write-string port (package/name-string package))
+  (output-port/write-char port #\newline))
 
-(define (format-package/files indentation width package)
+(define (format-package/files port indentation width package)
   width
   (if (positive? (package/n-files package))
       (begin
-	(newline)
-	(write-label "Files")
+	(output-port/write-char port #\newline)
+	(write-label "Files" port)
 	(for-each (lambda (pathname)
-		    (write-string indentation)
-		    (write (pathname->string pathname))
-		    (newline))
+		    (output-port/write-string port indentation)
+		    (output-port/write-char port #\")
+		    (output-port/write-string port (pathname->string pathname))
+		    (output-port/write-char port #\")
+		    (output-port/write-char port #\newline))
 		  (package/files package)))))
 
-(define (format-package/bindings indentation width package bindings)
+(define (format-package/bindings port indentation width package bindings)
   (format-bindings
-   indentation width package bindings
+   port indentation width package bindings
    "Bindings"
    (lambda (binding)
-     (let ((name (write-to-string (binding/name binding))))
+     (let ((name (binding/name-string binding)))
        (if (< (package/n-files package) 2)
 	   name
-	   (string-append
-	    name
-	    " "
-	    (write-to-string
-	     (map expression/file (binding/expressions binding)))))))))
-
-(define (format-package/imports indentation width local-package remote-package
-				bindings)
-  (format-exports indentation width local-package remote-package bindings
+	   (apply string-append
+		  name
+		  " "
+		  (let loop
+		      ((expressions (binding/expressions binding))
+		       (p "("))
+		    (cons p
+			  (cons (expression/file (car expressions))
+				(if (null? (cdr expressions))
+				    (list ")")
+				    (loop (cdr expressions) " ")))))))))))
+
+(define (format-package/imports port indentation width local-package
+				remote-package bindings)
+  (format-exports port indentation width local-package remote-package bindings
 		  local-map/import "Imports from"))
 
-(define (format-package/exports indentation width remote-package bindings)
-  (format-exports indentation width remote-package remote-package bindings
+(define (format-package/exports port indentation width remote-package bindings)
+  (format-exports port indentation width remote-package remote-package bindings
 		  local-map/export "Exports to"))
 
-(define (format-exports indentation width local-package remote-package
+(define (format-exports port indentation width local-package remote-package
 			bindings local-map label)
   (format-bindings
-   indentation width local-package bindings
-   (string-append label
-		  " package "
-		  (write-to-string (package/name remote-package)))
+   port indentation width local-package bindings
+   (string-append label " package " (package/name-string remote-package))
    (lambda (destination-binding)
      (with-values
 	 (lambda ()
@@ -223,12 +223,12 @@ MIT in each case. |#
        (lambda (local-binding remote-binding)
 	 (let ((local-name (binding/name local-binding))
 	       (remote-name (binding/name remote-binding)))
-	   (let ((name-string (write-to-string local-name)))
+	   (let ((name-string (binding-name->string local-name)))
 	     (if (eq? local-name remote-name)
 		 name-string
 		 (string-append name-string
 				" ["
-				(write-to-string remote-name)
+				(binding-name->string remote-name)
 				"]")))))))))
 
 (define (local-map/export source destination)
@@ -237,17 +237,16 @@ MIT in each case. |#
 (define (local-map/import source destination)
   (values destination source))
 
-(define (format-bindings indentation width package
+(define (format-bindings port indentation width package
 			 bindings label binding->name)
-  (newline)
-  (write-label label)
+  (output-port/write-char port #\newline)
+  (write-label label port)
   (for-each (lambda (binding)
 	      (format-expressions
-	       indentation width package
+	       port indentation width package
 	       (binding->name binding)
-	       (mapcan (lambda (reference)
-			 (list-copy (reference/expressions reference)))
-		       (binding/references binding))))
+	       (append-map reference/expressions
+			   (binding/references binding))))
 	    bindings))
 
 (define (classify-bindings-by-package binding->package bindings)
@@ -267,28 +266,40 @@ MIT in each case. |#
 	  (lambda (x y)
 	    (package<? (car x) (car y))))))
 
-(define (format-references indentation width label package references)
-  (write-label label)
-  (for-each (lambda (reference)
-	      (format-expressions indentation width package
-				  (write-to-string (reference/name reference))
-				  (reference/expressions reference)))
-	    references))
-
-(define (format-expressions indentation width package name expressions)
-  (with-values (lambda ()
-		 (classify-expression-names
-		  (map (lambda (expression)
-			 (expression->name expression package))
-		       expressions)))
+(define (format-references port indentation width label package references)
+  (write-label label port)
+  (for-each
+   (lambda (reference)
+     (format-expressions port indentation width package
+			 (binding-name->string (reference/name reference))
+			 (reference/expressions reference)))
+   references))
+
+(define (format-expressions port indentation width package name expressions)
+  (with-values
+      (lambda ()
+	(classify-expression-names
+	 (map (lambda (expression)
+		(expression->name expression package))
+	      expressions)))
     (lambda (symbols pairs)
-      (write-string indentation)
-      (write-string name)
-      (newline)
+      (output-port/write-string port indentation)
+      (output-port/write-string port name)
+      (output-port/write-char port #\newline)
       (let ((indentation (new-indentation indentation)))
-	(write-strings/compact indentation width
-			       (map write-to-string (sort symbols symbol<?)))
-	(write-items/miser indentation width write
+	(write-strings/compact port indentation width
+			       (map symbol-name (sort symbols symbol<?)))
+	(write-items/miser port indentation width
+	  (lambda (item port)
+	    (output-port/write-char port #\()
+	    (output-port/write-char port #\")
+	    (output-port/write-string port (car item))
+	    (output-port/write-char port #\")
+	    (if (not (null? (cdr item)))
+		(begin
+		  (output-port/write-char port #\space)
+		  (output-port/write-string port (symbol-name (cadr item)))))
+	    (output-port/write-char port #\)))
 	  (sort pairs
 	    (lambda (x y)
 	      (or (string<? (car x) (car y))
@@ -325,12 +336,12 @@ MIT in each case. |#
 		(list (expression/file expression) name)))
 	  (list (expression/file expression))))))
 
-(define (write-label label)
-  (write-string label)
-  (write-string ":")
-  (newline))
+(define (write-label label port)
+  (output-port/write-string port label)
+  (output-port/write-string port ":")
+  (output-port/write-char port #\newline))
 
-(define (write-strings/compact indentation width strings)
+(define (write-strings/compact port indentation width strings)
   (if (not (null? strings))
       (begin
 	(let loop ((strings strings) (offset 0) (prefix indentation))
@@ -339,20 +350,44 @@ MIT in each case. |#
 		(let ((new-offset (+ offset (string-length prefix) length)))
 		  (if (and (> new-offset width)
 			   (not (zero? offset)))
-		      (begin (newline)
-			     (loop strings 0 indentation))
-		      (begin (write-string prefix)
-			     (write-string (car strings))
-			     (loop (cdr strings) new-offset " ")))))))
-	(newline))))
-
-(define (write-items/miser indentation width write-item items)
+		      (begin
+			(output-port/write-char port #\newline)
+			(loop strings 0 indentation))
+		      (begin
+			(output-port/write-string port prefix)
+			(output-port/write-string port (car strings))
+			(loop (cdr strings) new-offset " ")))))))
+	(output-port/write-char port #\newline))))
+
+(define (write-items/miser port indentation width write-item items)
   width
   (for-each (lambda (item)
-	      (write-string indentation)
-	      (write-item item)
-	      (newline))
+	      (output-port/write-string port indentation)
+	      (write-item item port)
+	      (output-port/write-char port #\newline))
 	    items))
 
 (define (new-indentation indentation)
-  (string-append indentation "    "))
\ No newline at end of file
+  (string-append indentation "    "))
+
+(define-integrable (binding/name-string binding)
+  (binding-name->string (binding/name binding)))
+
+(define (binding-name->string name)
+  (if (symbol? name)
+      (symbol-name name)
+      (write-to-string name)))
+
+(define-integrable (package/name-string package)
+  (package-name->string (package/name package)))
+
+(define (package-name->string name)
+  (if (null? name)
+      "()"
+      (apply string-append
+	     (let loop ((name name) (p "("))
+	       (cons p
+		     (cons (binding-name->string (car name))
+			   (if (null? (cdr name))
+			       (list ")")
+			       (loop (cdr name) " "))))))))
\ No newline at end of file
diff --git a/v7/src/cref/make.scm b/v7/src/cref/make.scm
index ee63d8cfe..bea6b825c 100644
--- a/v7/src/cref/make.scm
+++ b/v7/src/cref/make.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.6 1990/10/05 11:34:55 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/make.scm,v 1.7 1991/03/01 20:19:47 cph Exp $
 
-Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
+Copyright (c) 1988-91 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -37,4 +37,4 @@ MIT in each case. |#
 (declare (usual-integrations))
 
 (package/system-loader "cref" '() false)
-(add-system! (make-system "CREF" 1 6 '()))
\ No newline at end of file
+(add-system! (make-system "CREF" 1 7 '()))
\ No newline at end of file
diff --git a/v7/src/cref/toplev.scm b/v7/src/cref/toplev.scm
index 8645ebcfc..24baae047 100644
--- a/v7/src/cref/toplev.scm
+++ b/v7/src/cref/toplev.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/toplev.scm,v 1.3 1989/08/03 23:27:08 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/cref/toplev.scm,v 1.4 1991/03/01 20:19:54 cph Exp $
 
 Copyright (c) 1988, 1989 Massachusetts Institute of Technology
 
@@ -53,9 +53,15 @@ MIT in each case. |#
    (lambda (pathname pmodel)
      (write-cref pathname pmodel))))
 
+(define cref/generate-cref-unusual
+  (generate/common
+   (lambda (pathname pmodel)
+     (write-cref-unusual pathname pmodel))))
+
 (define cref/generate-constructors
   (generate/common
    (lambda (pathname pmodel)
+     (write-cref-unusual pathname pmodel)
      (write-globals pathname pmodel)
      (write-constructor pathname pmodel)
      (write-loader pathname pmodel))))
@@ -95,6 +101,11 @@ MIT in each case. |#
     (lambda ()
       (format-packages pmodel))))
 
+(define (write-cref-unusual pathname pmodel)
+  (with-output-to-file (pathname-new-type pathname "cref")
+    (lambda ()
+      (format-packages-unusual pmodel))))
+
 (define (write-globals pathname pmodel)
   (fasdump (map binding/name
 		(list-transform-positive