Changeset 6633

Timestamp:

May 31, 2007, 5:06:19 PM (17 years ago)

Author:

Gary Byers

Message:

Try to provide some context - "surrounding characters" - for reader/stream
errors on character input streams.

File:

• trunk/ccl/level-1/l1-streams.lisp (modified) (6 diffs)

trunk/ccl/level-1/l1-streams.lisp

@@ -58 +58 @@
     :io
     :output))
+
+;;; Try to return a string containing characters that're near the
+;;; stream's current position, if that makes sense.  Return NIL
+;;; if it doesn't make sense.
+(defmethod stream-surrounding-characters ((s stream))
+  nil)
 
 
@@ -473 +479 @@
 
 
-
-
+(defun %ioblock-surrounding-characters (ioblock)
+  (let* ((inbuf (ioblock-inbuf ioblock)))
+    (when inbuf
+      (let* ((encoding (or (ioblock-encoding ioblock)
+                           (get-character-encoding nil)))
+             (size (ash (character-encoding-code-unit-size encoding) -3))
+             (buffer (io-buffer-buffer inbuf))
+             (idx (io-buffer-idx inbuf))
+             (count (io-buffer-count inbuf)))
+        (unless (= count 0)
+          (let* ((start (max (- idx (* 5 size)) 0))
+                 (end (min (+ idx (* 5 size)) count))
+                 (string (make-string (funcall (character-encoding-length-of-vector-encoding-function encoding) buffer start end))))
+            (funcall (character-encoding-vector-decode-function encoding)
+                     buffer
+                     start
+                     (- end start)
+                     string)
+            (if (position #\Replacement_Character string)
+              (string-trim (string #\Replacement_Character) string)
+              string)))))))
+             
+        
 
 
@@ -3738 +3765 @@
            (synonym-method interactive-stream-p)
            (synonym-method stream-direction)
-           (synonym-method stream-device direction))
+           (synonym-method stream-device direction)
+           (synonym-method stream-surrounding-characters))
 
 
@@ -3797 +3825 @@
   (two-way-input-method stream-read-list l c)
   (two-way-input-method stream-read-vector v start end)
+  (two-way-input-method stream-surrounding-characters)
   (two-way-output-method stream-write-char c)
   (two-way-output-method stream-write-byte b)
@@ -4422 +4451 @@
 
 
+(defmethod stream-surrounding-characters ((s string-input-stream))
+  (let* ((ioblock (basic-stream-ioblock s))
+         (start (string-input-stream-ioblock-start ioblock))
+         (idx (string-input-stream-ioblock-index ioblock))
+         (end (string-input-stream-ioblock-end ioblock))
+         (string (string-stream-ioblock-string ioblock)))
+    (subseq string (max (- idx 5) start) (min (+ idx 5) end))))
+    
+
 (defmethod stream-position ((s string-input-stream) &optional newpos)
   (let* ((ioblock (basic-stream-ioblock s))
@@ -4705 +4743 @@
     (when (open-stream-p stream)
       (stream-force-output stream))))
+
+(defmethod stream-surrounding-characters ((stream buffered-character-input-stream-mixin))
+    (let* ((ioblock (stream-ioblock stream nil)))
+      (and ioblock (%ioblock-surrounding-characters ioblock))))
+
+(defmethod stream-surrounding-characters ((stream basic-character-input-stream))
+    (let* ((ioblock (stream-ioblock stream nil)))
+      (and ioblock (%ioblock-surrounding-characters ioblock))))
+
 
 #|