-;;;
-;;; STREAM CLASSES
-;;;
-
-;;; KLUDGE (sat 2003-01-15): def-stream-class and the
-;;; with-stream-class / sm accessors implement a form of "sealing" of
-;;; classes -- i.e., implementing very fast slot access at the price
-;;; of not being able to change the class definition at runtime.
-;;; Instead of a method call, a slot access for a simple-stream
-;;; subclass is a funcall or (when the def-stream-class form has a
-;;; location argument for the slot) a sb-pcl::clos-slots-ref. Given a
-;;; sufficiently advanced PCL with (non-standard) sealing
-;;; declarations, this machinery would be superfluous. For the time
-;;; being, replacing 4 method calls with vector accesses for the fast
-;;; path of read-char seems worthwhile to me. Besides, it's the
-;;; documented interface to simple-stream internals, and so it's worth
-;;; keeping.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (declaim (type hash-table *slot-access-functions*))
- (defvar *slot-access-functions* (make-hash-table))
- (defvar *automagic-accessors* nil))
-
-;;; Commented out in favor of standard class machinery that does not
-;;; depend on implementation internals.
-#+nil
-(defmacro def-stream-class (name superclasses slots &rest options)
- (let ((accessors ())
- (real-slots ()))
- (dolist (slot slots)
- ;; Frob the slot arguments, memorizing either the location (an
- ;; integer) or the accessor of the slot. Optionally construct
- ;; an accessor if none is given.
- (cond ((and (consp slot) (getf (rest slot) 'sb-pcl::location))
- ;; We have got a location specifier. Memorize it and
- ;; extract it until pcl itself can work with these.
- (push (cons (first slot)
- (cons (getf (rest slot) :type t)
- (getf (rest slot) 'sb-pcl::location)))
- accessors)
- (let ((slot (copy-list slot)))
- (remf (rest slot) 'sb-pcl::location) ; until PCL accepts this
- (push slot real-slots)))
- ((or (not (consp slot)) (not (getf (rest slot) :accessor)))
- (if *automagic-accessors*
- ;; Add an :accessor argument, and memorize it. FIXME:
- ;; will this work with sbcl? reader/writers are
- ;; named differently there (see
- ;; src/pcl/slot-name.lisp)
- (let* ((slot (if (consp slot) slot (list slot)))
- (accessor (or (cdr (gethash (first slot)
- *slot-access-functions*))
- (intern (format nil "~A ~A slot ACCESSOR"
- name (first slot))
- "SB-SLOT-ACCESSOR-NAME"))))
- (push (cons (first slot)
- (cons (getf (rest slot) :type t) accessor))
- accessors)
- (push (append slot `(:accessor ,accessor)) real-slots))
- (push slot real-slots)))
- (t
- ;; No location given, but we have an accessor. Memorize it.
- (push (cons (first slot)
- (cons (getf (rest slot) :type t)
- (getf (rest slot) :accessor)))
- accessors)
- (push slot real-slots))))
- `(prog1
- (defclass ,name ,superclasses ,(nreverse real-slots) ,@options)
- (eval-when (:compile-toplevel :load-toplevel :execute)
- ,@(loop for accessor in accessors
- do (let ((exists (gethash (car accessor)
- *slot-access-functions*)))
- (when (and exists
- (integerp (cdr exists))
- (integerp (cddr accessor))
- (/= (cdr exists) (cddr accessor)))
- (warn "~S slot ~S has moved! ~
- I hope you know what you're doing!"
- name (car accessor))))
- collect `(setf (gethash ',(car accessor) *slot-access-functions*)
- ',(cdr accessor)))))))
-
-
-(defmacro def-stream-class (name superclasses slots &rest options)
- (let ((slots (copy-tree slots)))
- (dolist (slot slots) (remf (cdr slot) 'sb-pcl::location))
- `(defclass ,name ,superclasses ,slots ,@options)))