;;; -*- lisp -*-
+;;;
+;;; **********************************************************************
+;;; This code was written by Paul Foley and has been placed in the public
+;;; domain.
+;;;
-;;; This code is in the public domain.
+;;; Sbcl port by Rudi Schlatte.
-;;; The cmucl implementation of simple-streams was done by Paul Foley,
-;;; who placed the code in the public domain. Sbcl port by Rudi
-;;; Schlatte.
+;;;
+;;; **********************************************************************
+;;;
+;;; Macros needed by the simple-streams implementation
-;;; This is just for compatibility with Franz demo code
+(in-package "SB-SIMPLE-STREAMS")
+
+(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-STREAM")
- (:import-from "SB-SIMPLE-STREAM"
+ (: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"))
-(use-package "SB-SIMPLE-STREAMS")
-
+#+nil
(provide :iodefs)
projects / sbcl.git / blobdiff