contrib/sb-simple-streams/string.lisp

   1 ;;; -*- lisp -*-
   2 ;;;
   3 ;;; **********************************************************************
   4 ;;; This code was written by Paul Foley and has been placed in the public
   5 ;;; domain.
   6 ;;;
   7
   8 ;;; Sbcl port by Rudi Schlatte.
   9
  10 (in-package "SB-SIMPLE-STREAMS")
  11
  12 ;;;
  13 ;;; **********************************************************************
  14 ;;;
  15 ;;; String-Simple-Stream and relatives
  16
  17 (def-stream-class string-input-simple-stream (string-simple-stream)
  18   ())
  19
  20 (def-stream-class string-output-simple-stream (string-simple-stream)
  21   ((out-buffer :initform nil :type (or simple-stream-buffer null))
  22    (outpos :initform 0 :type fixnum)
  23    (max-out-pos :initform 0 :type fixnum)))
  24
  25 (def-stream-class composing-stream (string-simple-stream)
  26   ())
  27
  28 (def-stream-class fill-pointer-output-simple-stream
  29     (string-output-simple-stream)
  30   ())
  31
  32 (def-stream-class xp-simple-stream (string-output-simple-stream)
  33   ())
  34
  35 (def-stream-class annotation-output-simple-stream (string-output-simple-stream)
  36   ())
  37
  38 (defmethod device-open :before ((stream string-input-simple-stream) options)
  39   ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
  40   (with-stream-class (string-input-simple-stream stream)
  41     (let ((string (getf options :string)))
  42       (when (and string (null (sm buffer stream)))
  43         (let ((start (getf options :start))
  44               (end (or (getf options :end) (length string))))
  45           (setf (sm buffer stream) string
  46                 (sm buffpos stream) start
  47                 (sm buffer-ptr stream) end))))
  48     (install-string-input-character-strategy stream)
  49     (add-stream-instance-flags stream :string :input :simple)))
  50
  51 (defmethod device-open :before ((stream string-output-simple-stream) options)
  52   ;; Taken with permission from ftp://ftp.franz.com/pub/duane/Simp-stms.ppt
  53   (with-stream-class (string-output-simple-stream stream)
  54     (unless (sm out-buffer stream)
  55       (let ((string (getf options :string)))
  56         (if string
  57             (setf (sm out-buffer stream) string
  58                   (sm max-out-pos stream) (length string))
  59             (let ((buflen (max (device-buffer-length stream) 16)))
  60               (setf (sm out-buffer stream) (make-string buflen)
  61                     (sm max-out-pos stream) buflen)))))
  62     (unless (sm control-out stream)
  63       (setf (sm control-out stream) *std-control-out-table*))
  64     (install-string-output-character-strategy stream)
  65     (add-stream-instance-flags stream :string :output :simple)))
  66
  67 (defmethod device-open ((stream string-simple-stream) options)
  68   (declare (ignore options))
  69   (with-stream-class (string-simple-stream stream)
  70     (if (and (any-stream-instance-flags stream :simple)
  71              (any-stream-instance-flags stream :input :output))
  72         t
  73         nil)))
  74
  75 (defmethod device-file-position ((stream string-simple-stream))
  76   (with-stream-class (simple-stream stream)
  77     (sm buffpos stream)))
  78
  79 (defmethod (setf device-file-position) (value (stream string-simple-stream))
  80   (with-stream-class (simple-stream stream)
  81     (cond ((or (> value (sm buffer-ptr stream))
  82                (< value (- -1 (sm buffer-ptr stream))))
  83            nil)
  84           ((>= value 0)
  85            (setf (sm buffpos stream) value)
  86            t)
  87           (t
  88            (setf (sm buffpos stream) (+ (sm buffer-ptr stream) value 1))
  89            t))))
  90
  91 (defmethod device-file-length ((stream string-simple-stream))
  92   (with-stream-class (simple-stream stream)
  93     (sm buffer-ptr stream)))
  94
  95 (defmethod device-open ((stream fill-pointer-output-simple-stream) options)
  96   #| do something |#
  97   stream)
  98
  99 (defmethod device-file-position ((stream fill-pointer-output-simple-stream))
 100   (with-stream-class (fill-pointer-output-simple-stream stream)
 101     (fill-pointer (sm out-buffer stream))))
 102
 103 (defmethod (setf device-file-position)
 104     (value (stream fill-pointer-output-simple-stream))
 105   (with-stream-class (fill-pointer-output-simple-stream stream)
 106     (let ((buffer (sm out-buffer stream)))
 107       (cond ((or (> value (array-total-size buffer))
 108                  (< value (- -1 (array-total-size buffer))))
 109              nil)
 110             ((>= value 0)
 111              (setf (fill-pointer buffer) value))
 112             (t
 113              (setf (fill-pointer buffer)
 114                    (+ (array-total-size buffer) value 1)))))))
 115
 116 (defmethod device-open ((stream xp-simple-stream) options)
 117   #| do something |#
 118   stream)