From 096c8a5ed4c99f1edbc33c9f05c295a3323f829a Mon Sep 17 00:00:00 2001
From: jgarcia <jgarcia>
Date: Wed, 7 May 2008 08:06:30 +0000
Subject: [PATCH] There were missing method definitions for built in streams in
 GRAY. Added a class ANSI-STREAM for simplifying writing methods for builtin
 streams.

---
 src/CHANGELOG         |   3 +
 src/clos/builtin.lsp  |  15 +++--
 src/clos/streams.lsp  | 145 ++++++++++++++++++++++++++----------------
 src/lsp/config.lsp.in |   2 +-
 4 files changed, 101 insertions(+), 64 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index a01e19b69..e6572acca 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -89,6 +89,9 @@ ECL 0.9k:
    or shadow import the symbols associated to generic versions in the packages
    where methods on these functions are defined.
 
+ - By user request, ECL provides a function (GRAY:REDEFINE-CL-FUNCTIONS) which
+   will make the above mentioned functions generic.
+
  - Interpreted forms now remember the file in which they were defined
    and what form number they represent.
 
diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp
index 27784a586..233329d08 100644
--- a/src/clos/builtin.lsp
+++ b/src/clos/builtin.lsp
@@ -61,13 +61,14 @@
 	        (base-string string vector)
 	        (bit-vector vector)
 	    (stream)
-		(file-stream stream)
-		(echo-stream stream)
-		(string-stream stream)
-		(two-way-stream stream)
-		(synonym-stream stream)
-		(broadcast-stream stream)
-		(concatenated-stream stream)
+	      (ansi-stream stream)
+		(file-stream ansi-stream)
+		(echo-stream ansi-stream)
+		(string-stream ansi-stream)
+		(two-way-stream ansi-stream)
+		(synonym-stream ansi-stream)
+		(broadcast-stream ansi-stream)
+		(concatenated-stream ansi-stream)
 	    (character)
 	    (number)
 	      (real number)
diff --git a/src/clos/streams.lsp b/src/clos/streams.lsp
index 8989de30c..d5eaeecc3 100644
--- a/src/clos/streams.lsp
+++ b/src/clos/streams.lsp
@@ -12,6 +12,8 @@
 
 (in-package "GRAY")
 
+(import 'clos::ansi-stream)
+
 ;;;
 ;;; This is the generic function interface for CLOS streams.
 ;;;
@@ -262,20 +264,16 @@
 
 (defmethod stream-clear-input ((stream fundamental-character-input-stream))
   nil)
-(defmethod stream-clear-input ((stream stream))
-  (bug-or-error stream 'stream-clear-input))
-(defmethod stream-clear-input ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
+(defmethod stream-clear-input ((stream ansi-stream))
+  (cl:clear-input stream))
 
 
 ;; CLEAR-OUTPUT
 
 (defmethod stream-clear-output ((stream fundamental-output-stream))
   nil)
-(defmethod stream-clear-output ((stream stream))
-  (bug-or-error stream 'stream-clear-output))
-(defmethod stream-clear-output ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
+(defmethod stream-clear-output ((stream ansi-stream))
+  (cl:clear-output stream))
 
 
 ;; CLOSE
@@ -285,46 +283,32 @@
   (setf (open-stream-p stream) nil)
   t)
 
-(defmethod close ((stream stream) &key abort)
+(defmethod close ((stream ansi-stream) &key abort)
   (cl:close stream :abort abort))
 
-(defmethod close ((non-stream t) &key abort)
-  (declare (ignore abort))
-  (error 'type-error :datum non-stream :expected-type 'stream))
-
 ;; STREAM-ELEMENT-TYPE
 
 (defmethod stream-element-type ((stream fundamental-character-stream))
   'character)
 
-(defmethod stream-element-type ((stream fundamental-stream))
-  (bug-or-error stream 'stream-element-type))
-
-(defmethod stream-element-type ((stream stream))
+(defmethod stream-element-type ((stream ansi-stream))
   (cl:stream-element-type stream))
 
-(defmethod stream-element-type ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
-
 
 ;; FINISH-OUTPUT
 
 (defmethod stream-finish-output ((stream fundamental-output-stream))
   nil)
-(defmethod stream-finish-output ((stream stream))
-  (bug-or-error stream 'stream-finish-output))
-(defmethod stream-finish-output ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
+(defmethod stream-finish-output ((stream ansi-stream))
+  (cl:finish-output stream))
 
 
 ;; FORCE-OUTPUT
 
 (defmethod stream-force-output ((stream fundamental-output-stream))
   nil)
-(defmethod stream-force-output ((stream stream))
-  (bug-or-error stream 'stream-force-output))
-(defmethod stream-force-output ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
+(defmethod stream-force-output ((stream ansi-stream))
+  (cl:force-output stream))
 
 
 ;; FRESH-LINE
@@ -334,6 +318,9 @@
     (stream-terpri stream)
     t))
 
+(defmethod stream-fresh-line ((stream ansi-stream))
+  (cl:fresh-line ansi-stream))
+
 
 ;; INPUT-STREAM-P
 
@@ -343,20 +330,15 @@
 (defmethod input-stream-p ((stream fundamental-input-stream))
   t)
 
-(defmethod input-stream-p ((stream stream))
+(defmethod input-stream-p ((stream ansi-stream))
   (cl:input-stream-p stream))
 
-(defmethod input-stream-p ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
-
 
 ;; INTERACTIVE-STREAM-P
 
-(defmethod stream-interactive-p ((stream stream))
-  (bug-or-error stream 'stream-interactive-p))
+(defmethod stream-interactive-p ((stream ansi-stream))
+  (cl:interactive-stream-p stream))
 
-(defmethod stream-interactive-p ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
 
 ;; LINE-COLUMN
 
@@ -372,15 +354,15 @@
       (stream-unread-char stream char)
       t)))
 
+(defmethod stream-listen ((stream ansi-stream))
+  (cl:listen stream))
+
 
 ;; OPEN-STREAM-P
 
-(defmethod open-stream-p ((stream stream))
+(defmethod open-stream-p ((stream ansi-stream))
   (cl:open-stream-p stream))
 
-(defmethod open-stream-p ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
-
 
 ;; OUTPUT-STREAM-P
 
@@ -390,12 +372,9 @@
 (defmethod output-stream-p ((stream fundamental-output-stream))
   t)
 
-(defmethod output-stream-p ((stream stream))
+(defmethod output-stream-p ((stream ansi-stream))
   (cl:output-stream-p stream))
 
-(defmethod output-stream-p ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
-
 
 ;; PEEK-CHAR
 
@@ -405,13 +384,26 @@
       (stream-unread-char stream char))
     char))
 
+(defmethod stream-peek-char ((stream ansi-stream))
+  (cl:peek-char stream))
+
 
 ;; READ-BYTE
 
-(defmethod stream-read-byte ((stream stream))
-  (bug-or-error stream 'stream-read-byte))
-(defmethod stream-read-byte ((non-stream t))
-  (error 'type-error :datum non-stream :expected-type 'stream))
+(defmethod stream-read-byte ((stream ansi-stream))
+  (cl:read-byte stream))
+
+
+;; READ-CHAR
+
+(defmethod stream-read-char ((stream ansi-stream))
+  (cl:read-char stream))
+
+
+;; UNREAD-CHAR
+
+(defmethod stream-unread-char ((stream ansi-stream) (c character))
+  (cl:unread-char stream c))
 
 
 ;; READ-CHAR-NO-HANG
@@ -419,6 +411,9 @@
 (defmethod stream-read-char-no-hang ((stream fundamental-character-input-stream))
   (stream-read-char stream))
 
+(defmethod stream-read-char-no-hang ((stream ansi-stream))
+  (cl:read-char-no-hang stream))
+
 
 ;; READ-LINE
 
@@ -441,6 +436,9 @@
 	      (setf (schar res index) ch)
 	      (incf index)))))))
 
+(defmethod stream-read-line ((stream ansi-stream))
+  (cl:read-line stream))
+
 
 ;; READ-SEQUENCE
 
@@ -454,6 +452,10 @@
                                  &optional (start 0) (end nil))
   (si::do-read-sequence seq stream start end))
 
+(defmethod stream-read-sequence ((stream ansi-stream) (seq sequence)
+				 &optional (start 0) (end nil))
+  (si:do-read-sequence stream seq start end))
+
 
 ;; START-LINE-P
 
@@ -469,26 +471,36 @@
 (defmethod streamp ((no-stream t))
   nil)
 
+
 ;; WRITE-BYTE
 
-(defmethod stream-write-byte ((stream stream) integer)
-  (bug-or-error stream 'stream-write-byte))
-(defmethod stream-write-byte ((non-stream t) integer)
-  (error 'type-error :datum non-stream :expected-type 'stream))
+(defmethod stream-write-byte ((stream ansi-stream) integer)
+  (cl:write-byte stream integer))
+
+
+;; WRITE-CHAR
+
+(defmethod stream-write-char ((stream ansi-stream) (c character))
+  (cl:write-char stream))
 
 
 ;; WRITE-SEQUENCE
 
 (defmethod stream-write-sequence ((stream fundamental-character-output-stream)
                                   (seq sequence)
-                                  &optional (start 0) (end nil))
+                                  &optional (start 0) end)
   (si::do-write-sequence seq stream start end))
 
 (defmethod stream-write-sequence ((stream fundamental-binary-output-stream)
                                   (seq sequence)
-                                  &optional (start 0) (end nil))
+                                  &optional (start 0) end)
   (si::do-write-sequence seq stream start end))
 
+(defmethod stream-write-sequence ((stream ansi-stream) (seq sequence)
+                                  &optional (start 0) end)
+  (si::do-write-sequence seq stream start end))
+
+
 ;; WRITE-STRING
 
 (defmethod stream-write-string ((stream fundamental-character-output-stream)
@@ -503,15 +515,36 @@
       (stream-write-char stream (aref string pos))))
   string)
 
+(defmethod stream-write-string ((stream ansi-stream) string &optional (start 0) end)
+  (cl:write-string stream))
+
 
 ;; TERPRI
 
 (defmethod stream-terpri ((stream fundamental-character-output-stream))
   (stream-write-char stream #\Newline))
 
+(defmethod stream-terpri ((stream ansi-stream))
+  (cl:terpri stream))
+
+(eval-when (:compile-toplevel :execute)
+  (defconstant +conflicting-symbols+ '(cl:close cl:stream-element-type cl:input-stream-p
+				       cl:open-stream-p cl:output-stream-p cl:streamp)))
+
 (let ((p (find-package "GRAY")))
   (do-external-symbols (s (find-package "COMMON-LISP"))
-    (unless (member s '(cl:close cl:stream-element-type cl:input-stream-p
-			cl:open-stream-p cl:output-stream-p cl:streamp))
+    (unless (member s '#.+conflicting-symbols+)
       (export s p))))
 
+(defun redefine-cl-functions ()
+  "Some functions in CL package are expected to be generic. We make them so."
+  (let ((x (si::package-lock "COMMON-LISP" nil)))
+    (loop for cl-symbol in '#.+conflicting-symbols+
+       with gray-package = (find-package "GRAY")
+       do (let ((gray-symbol (find-symbol (symbol-name cl-symbol) gray-package)))
+	    (setf (fdefinition cl-symbol) (fdefinition gray-symbol))
+	    (unintern gray-symbol gray-package)
+	    (import cl-symbol gray-package)
+	    (export cl-symbol gray-package)))
+    (si::package-lock "COMMON-LISP" x)
+    nil))
diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in
index 4baf77f51..fe0bfb8fb 100644
--- a/src/lsp/config.lsp.in
+++ b/src/lsp/config.lsp.in
@@ -46,7 +46,7 @@ Returns, as a string, the location of the machine on which ECL runs."
 (defun lisp-implementation-version ()
   "Args:()
 Returns the version of your ECL as a string."
-  "@PACKAGE_VERSION@ (CVS 2008-05-05 14:58)")
+  "@PACKAGE_VERSION@ (CVS 2008-05-07 10:04)")
 
 (defun machine-type ()
   "Args: ()