From 80fe23bfe746c1d31d5406965e4b102db7a0849d Mon Sep 17 00:00:00 2001
From: toy <toy>
Date: Wed, 29 Jan 2003 02:16:31 +0000
Subject: [PATCH] From Gerd Moellmann:

o Entomotomy bug optional-environment-arg-mistakes:

  Recognize the optional environment argument for typep, subtypep,
  upgraded-array-element-type, upgraded-complex-part-type, and various
  other functions that take an optional environment arg.  Currently,
  all we do with the environment is ignore it.

o Entomotomy bug defknowns-for-bit-array-setters-wrong

  Defknowns for %bitset and %sbitset was only allowing vectors, not
  multidimensional arrays.
---
 code/numbers.lisp  |  5 +++--
 code/pred.lisp     | 12 ++++++++----
 compiler/fndb.lisp | 35 +++++++++++++++++++++--------------
 3 files changed, 32 insertions(+), 20 deletions(-)

diff --git a/code/numbers.lisp b/code/numbers.lisp
index f9d82828d..bdf36c4d6 100644
--- a/code/numbers.lisp
+++ b/code/numbers.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.45 2002/10/07 17:44:12 toy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/numbers.lisp,v 1.46 2003/01/29 02:16:30 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -270,9 +270,10 @@
 
 ;;;; Complexes:
 
-(defun upgraded-complex-part-type (spec)
+(defun upgraded-complex-part-type (spec &optional environment)
   "Returns the element type of the most specialized COMPLEX number type that
    can hold parts of type Spec."
+  (declare (ignore environment))
   (cond ((subtypep spec 'single-float)
 	 'single-float)
 	((subtypep spec 'double-float)
diff --git a/code/pred.lisp b/code/pred.lisp
index 6e6403391..0c6745436 100644
--- a/code/pred.lisp
+++ b/code/pred.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.54 2003/01/23 15:26:51 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/pred.lisp,v 1.55 2003/01/29 02:16:30 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -147,9 +147,11 @@
 
 ;;;; UPGRADED-ARRAY-ELEMENT-TYPE  --  public
 ;;;
-(defun upgraded-array-element-type (spec)
+(defun upgraded-array-element-type (spec &optional environment)
   "Return the element type that will actually be used to implement an array
    with the specifier :ELEMENT-TYPE Spec."
+  ;; Type expansion (TYPE-EXPAND) currently doesn't handle environments.
+  (declare (ignore environment))
   (type-specifier
    (array-type-specialized-element-type
     (specifier-type `(array ,spec)))))
@@ -158,11 +160,12 @@
 ;;;
 ;;; Just parse the type specifiers and call csubtype.
 ;;; 
-(defun subtypep (type1 type2)
+(defun subtypep (type1 type2 &optional environment)
   "Return two values indicating the relationship between type1 and type2:
   T and T: type1 definitely is a subtype of type2.
   NIL and T: type1 definitely is not a subtype of type2.
   NIL and NIL: who knows?"
+  (declare (ignore environment))
   (csubtypep (specifier-type type1) (specifier-type type2)))
 
 
@@ -174,8 +177,9 @@
 ;;;
 ;;; Just call %typep
 ;;; 
-(defun typep (object type)
+(defun typep (object type &optional environment)
   "Return T iff OBJECT is of type TYPE."
+  (declare (ignore environment))
   (%typep object type))
 
   
diff --git a/compiler/fndb.lisp b/compiler/fndb.lisp
index 9848e89d7..608d7215b 100644
--- a/compiler/fndb.lisp
+++ b/compiler/fndb.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.100 2002/12/29 23:35:06 pmai Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/fndb.lisp,v 1.101 2003/01/29 02:16:31 toy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -59,25 +59,32 @@
 
 (in-package "C")
 
+(deftype lexenv-or-null () '(or null lexical-environment))
+
 
 ;;;; Information for known functions:
 
 (defknown coerce (t type-specifier) t
 	  (movable foldable)			  ; Is defined to signal errors. 
-  :derive-type (result-type-specifier-nth-arg 2))
+	  ;; :derive-type (result-type-specifier-nth-arg 2)
+	  ;; This is wrong.  (coerce 1 'complex) returns 1, not COMPLEX.
+  )
 
 (defknown type-of (t) t (foldable flushable))
 
 ;;; Can be affected by type definitions...
 (defknown (upgraded-complex-part-type upgraded-array-element-type)
-	  (type-specifier) type-specifier
-  (flushable))
+	  (type-specifier &optional lexenv-or-null)
+          type-specifier
+	  (flushable))
 
 
 ;;;; In the "Predicates" chapter:
 
-(defknown typep (t type-specifier) boolean (foldable flushable))
-(defknown subtypep (type-specifier type-specifier) (values boolean boolean)
+(defknown typep (t type-specifier &optional lexenv-or-null)
+          boolean (foldable flushable))
+(defknown subtypep (type-specifier type-specifier &optional lexenv-or-null)
+          (values boolean boolean)
 	  (foldable flushable))
 
 (defknown (null symbolp atom consp listp numberp integerp rationalp floatp
@@ -95,7 +102,7 @@
 
 (deftype name-for-class () 't)
 (defknown class-name (class) name-for-class (flushable))
-(defknown find-class (name-for-class &optional t lexical-environment)
+(defknown find-class (name-for-class &optional t lexenv-or-null)
   (or class null) ())
 (defknown class-of (t) class (flushable))
 (defknown layout-of (t) layout (flushable))
@@ -119,7 +126,7 @@
 (defknown makunbound (symbol) symbol)
 (defknown fmakunbound ((or symbol cons)) (or symbol cons)
   (unsafe explicit-check))
-(defknown get-setf-expansion ((or list symbol) &optional lexical-environment)
+(defknown get-setf-expansion ((or list symbol) &optional lexenv-or-null)
  (values list list list form form)
  (flushable))
 
@@ -141,13 +148,13 @@
 
 ;;;; In the "Macros" chapter:
 
-(defknown macro-function (symbol &optional lexical-environment)
+(defknown macro-function (symbol &optional lexenv-or-null)
   (or function null)
   (flushable))
-(defknown (macroexpand macroexpand-1) (t &optional lexical-environment)
+(defknown (macroexpand macroexpand-1) (t &optional lexenv-or-null)
   (values form &optional boolean))
 
-(defknown compiler-macro-function (t &optional lexical-environment)
+(defknown compiler-macro-function (t &optional lexenv-or-null)
   (or function null)
   (flushable))
 
@@ -793,7 +800,7 @@
 ;;;; In the "Eval" chapter:
 
 (defknown eval (t) *)
-(defknown constantp (t &optional lexical-environment) boolean
+(defknown constantp (t &optional lexenv-or-null) boolean
   (foldable flushable))
 
 
@@ -1171,8 +1178,8 @@
 (defknown %put (symbol t t) t (unsafe))
 (defknown %setelt (sequence index t) t (unsafe))
 (defknown %svset (simple-vector index t) t (unsafe))
-(defknown %bitset (bit-vector &rest index) bit (unsafe))
-(defknown %sbitset (simple-bit-vector &rest index) bit (unsafe))
+(defknown %bitset ((array bit) &rest index) bit (unsafe))
+(defknown %sbitset ((simple-array bit) &rest index) bit (unsafe))
 (defknown %charset (string index character) character (unsafe))
 (defknown %scharset (simple-string index character) character (unsafe))
 (defknown %set-symbol-value (symbol t) t (unsafe))
-- 
GitLab