From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Mon, 2 Mar 1992 23:38:09 +0000 (+0000)
Subject: Change use of assoc in constant->label to a use of warning-assoc so
X-Git-Tag: 20090517-FFI~9631
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d0ae2572f13859b6360274d4b57973378eff836a;p=mit-scheme.git

Change use of assoc in constant->label to a use of warning-assoc so
the compiler will issue a warning when coalescing constant objects.
---

diff --git a/v7/src/compiler/back/lapgn3.scm b/v7/src/compiler/back/lapgn3.scm
index 860eb8160..42a6b402a 100644
--- a/v7/src/compiler/back/lapgn3.scm
+++ b/v7/src/compiler/back/lapgn3.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 4.6 1991/10/22 09:02:43 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/back/lapgn3.scm,v 4.7 1992/03/02 23:38:09 jinx Exp $
 
-Copyright (c) 1987-91 Massachusetts Institute of Technology
+Copyright (c) 1987-1992 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -57,6 +57,13 @@ MIT in each case. |#
 (define (allocate-constant-label)
   (allocate-named-label "CONSTANT-"))
 
+(define (warning-assoc obj pairs)
+  (let ((pair (assoc obj pairs)))
+    (if (and (pair? pair)
+	     (not (eqv? obj (car pair))))
+	(warn "Coalescing constant objects" obj (car pair)))
+    pair))
+
 (define-integrable (object->label find read write allocate-label)
   (lambda (object)
     (let ((entry (find object (read))))
@@ -83,7 +90,7 @@ MIT in each case. |#
 					 (string-append (symbol->string object)
 							,suffix))))))))
 (define constant->label
-  (->label assoc *interned-constants*))
+  (->label warning-assoc *interned-constants*))
 
 (define free-reference-label
   (->label assq *interned-variables* "-READ-CELL-"))