[2fb9cd]: contrib / sb-simple-streams / iodefs.lisp Maximize Restore History

Download this file

iodefs.lisp    170 lines (146 with data), 6.3 kB

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