contrib/sb-simple-streams/iodefs.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 ;;;
  11 ;;; **********************************************************************
  12 ;;;
  13 ;;; Macros needed by the simple-streams implementation
  14
  15 (in-package "SB-SIMPLE-STREAMS")
  16
  17 (defun file-namestring (pathname)
  18   (sb-ext:native-namestring (sb-int:physicalize-pathname pathname) :as-file t))
  19
  20 (defmacro def-stream-class (name superclasses slots &rest options)
  21   `(defclass ,name ,superclasses ,slots ,@options))
  22
  23
  24 ;; All known stream flags.  Note that the position in the constant
  25 ;; list is significant (cf. %flags below).
  26 (sb-int:defconstant-eqx +flag-bits+
  27                         '(:simple       ; instance is valid
  28                           :input :output ; direction
  29                           :dual :string ; type of stream
  30                           :eof          ; latched EOF
  31                           :dirty        ; output buffer needs write
  32                           :interactive) ; interactive stream
  33                         #'equal)
  34
  35 (eval-when (:compile-toplevel :load-toplevel :execute)
  36   (defun %flags (flags)
  37     (loop for flag in flags
  38           as pos = (position flag +flag-bits+)
  39         when (eq flag :gray) do
  40           (error "Gray streams not supported.")
  41         if pos
  42           sum (ash 1 pos) into bits
  43         else
  44           collect flag into unused
  45       finally (when unused
  46                 (warn "Invalid stream instance flag~P: ~{~S~^, ~}"
  47                       (length unused) unused))
  48               (return bits))))
  49
  50 ;;; Setup an environment where sm, funcall-stm-handler and
  51 ;;; funcall-stm-handler-2 are valid and efficient for a stream of type
  52 ;;; class-name or for the stream argument (in which case the
  53 ;;; class-name argument is ignored).  In nested with-stream-class
  54 ;;; forms, the inner with-stream-class form must specify a stream
  55 ;;; argument if the outer one specifies one, or the wrong object will
  56 ;;; be accessed.
  57
  58 (defmacro with-stream-class ((class-name &optional stream) &body body)
  59   (if stream
  60     (let ((stm (gensym "STREAM"))
  61           (slt (gensym "SV")))
  62       `(let* ((,stm ,stream)
  63               (,slt (sb-kernel:%instance-ref ,stm 1)))
  64          (declare (type ,class-name ,stm)
  65                   (type simple-vector ,slt)
  66                   (ignorable ,slt))
  67          (macrolet ((sm (slot-name stream)
  68                       (declare (ignore stream))
  69                       #-count-sm
  70                       `(slot-value ,',stm ',slot-name)
  71                       #+count-sm
  72                       `(%sm ',slot-name ,',stm))
  73                     (add-stream-instance-flags (stream &rest flags)
  74                       (declare (ignore stream))
  75                       `(setf (sm %flags ,',stm) (logior (the fixnum (sm %flags ,',stm))
  76                                                         ,(%flags flags))))
  77                     (remove-stream-instance-flags (stream &rest flags)
  78                       (declare (ignore stream))
  79                       `(setf (sm %flags ,',stm) (logandc2 (the fixnum (sm %flags ,',stm))
  80                                                           ,(%flags flags))))
  81                     (any-stream-instance-flags (stream &rest flags)
  82                       (declare (ignore stream))
  83                       `(not (zerop (logand (the fixnum (sm %flags ,',stm))
  84                                            ,(%flags flags))))))
  85            ,@body)))
  86     `(macrolet ((sm (slot-name stream)
  87                   #-count-sm
  88                   `(slot-value ,stream ',slot-name)
  89                   #+count-sm
  90                   `(%sm ',slot-name ,stream)))
  91        ,@body)))
  92
  93 (defmacro sm (slot-name stream)
  94   "Access the named slot in Stream."
  95   (warn "Using ~S macro outside ~S." 'sm 'with-stream-class)
  96   `(slot-value ,stream ',slot-name))
  97
  98 (defmacro funcall-stm-handler (slot-name stream &rest args)
  99   "Call the strategy function named by Slot-Name on Stream."
 100   (let ((s (gensym)))
 101     `(let ((,s ,stream))
 102        (funcall (sm ,slot-name ,s) ,s ,@args))))
 103
 104 (defmacro funcall-stm-handler-2 (slot-name arg1 stream &rest args)
 105   "Call the strategy function named by Slot-Name on Stream."
 106   (let ((s (gensym)))
 107     `(let ((,s ,stream))
 108        (funcall (sm ,slot-name ,s) ,arg1 ,s ,@args))))
 109
 110 (defmacro add-stream-instance-flags (stream &rest flags)
 111   "Set the given Flags in Stream."
 112   (let ((s (gensym "STREAM")))
 113     `(let ((,s ,stream))
 114        (with-stream-class (simple-stream ,s)
 115          (add-stream-instance-flags ,s ,@flags)))))
 116
 117 (defmacro remove-stream-instance-flags (stream &rest flags)
 118   "Clear the given Flags in Stream."
 119   (let ((s (gensym "STREAM")))
 120     `(let ((,s ,stream))
 121        (with-stream-class (simple-stream ,s)
 122          (remove-stream-instance-flags ,s ,@flags)))))
 123
 124 (defmacro any-stream-instance-flags (stream &rest flags)
 125   "Determine whether any one of the Flags is set in Stream."
 126   (let ((s (gensym "STREAM")))
 127     `(let ((,s ,stream))
 128        (with-stream-class (simple-stream ,s)
 129          (any-stream-instance-flags ,s ,@flags)))))
 130
 131 (defmacro simple-stream-dispatch (stream single dual string)
 132   (let ((s (gensym "STREAM")))
 133     `(let ((,s ,stream))
 134        (with-stream-class (simple-stream ,s)
 135          (let ((%flags (sm %flags ,s)))
 136            (cond ((zerop (logand %flags ,(%flags '(:string :dual))))
 137                   ,single)
 138                  ((zerop (logand %flags ,(%flags '(:string))))
 139                   ,dual)
 140                  (t
 141                   ,string)))))))
 142
 143 (defmacro simple-stream-dispatch-2 (stream non-string string)
 144   (let ((s (gensym "STREAM")))
 145     `(let ((,s ,stream))
 146        (with-stream-class (simple-stream ,s)
 147          (let ((%flags (sm %flags ,s)))
 148            (cond ((zerop (logand %flags ,(%flags '(:string))))
 149                   ,non-string)
 150                  (t
 151                   ,string)))))))
 152
 153
 154 ;;;; The following two forms are for Franz source-compatibility,
 155 ;;;; disabled at the moment.
 156
 157 #+nil
 158 (defpackage "EXCL"
 159   (:use "SB-SIMPLE-STREAMS")
 160   (:import-from "SB-SIMPLE-STREAMS"
 161         "BUFFER" "BUFFPOS" "BUFFER-PTR"
 162         "OUT-BUFFER" "MAX-OUT-POS"
 163         "INPUT-HANDLE" "OUTPUT-HANDLE"
 164         "MELDED-STREAM"
 165         "J-READ-CHARS"))
 166
 167 #+nil
 168 (provide :iodefs)
 169