Merge https://git.gitorious.org/trivial-gray-streams/trivial-gray-streams into flexi

COPYING

@@ -0,0 +1,22 @@
+    Copyright (c) 2005 David Lichteblau
+    Copyright (c) 2013 Anton Vodonosov <avodonosov@yandex.ru>
+
+    Permission is hereby granted, free of charge, to any person
+    obtaining a copy of this software and associated documentation files
+    (the "Software"), to deal in the Software without restriction,
+    including without limitation the rights to use, copy, modify, merge,
+    publish, distribute, sublicense, and/or sell copies of the Software,
+    and to permit persons to whom the Software is furnished to do so,
+    subject to the following conditions:
+
+    The above copyright notice and this permission notice shall be
+    included in all copies or substantial portions of the Software.
+
+    THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+    EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+    MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+    NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+    BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+    ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+    CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+    SOFTWARE.

Makefile

@@ -0,0 +1,3 @@
+.PHONY: clean
+clean:
+	rm -f *.fasl *.x86f *.fas *.ufsl *.lib *.pfsl

README

@@ -0,0 +1,34 @@
+trivial-gray-streams
+====================
+
+This system provides an extremely thin compatibility layer for gray
+streams.  It is nearly *too* trivial for a complete package, except that
+I have copy&pasted this code into enough projects now that I decided to
+factor it out once again now, and then *never* have to touch it again.
+
+
+How to use it
+=============
+
+1. Use the package TRIVIAL-GRAY-STREAMS instead of whatever
+   implementation-specific package you would have to use otherwise to
+   get at gray stream symbols.
+2. For STREAM-READ-SEQUENCE and STREAM-WRITE-SEQUENCE, notice that we
+   use two required arguments and allow additional keyword arguments.
+   So the lambda list when defining a method on either function should look
+   like this:
+     (stream sequence start end &key)
+
+
+Extensions
+==========
+
+Generic function STREAM-READ-SEQUENCE (stream sequence start end &key)
+Generic function STREAM-WRITE-SEQUENCE (stream sequence start end &key)
+
+        See above.
+
+Generic function STREAM-FILE-POSITION (stream) => file position
+Generic function (SETF STREAM-FILE-POSITION) (position-spec stream) => successp
+
+        Will only be called by ABCL, ACL, LispWorks, CCL, CLISP, SBCL and MOCL.

build.xcvb

@@ -0,0 +1,7 @@
+#+xcvb
+(module
+  (:fullname "trivial-gray-streams"
+   :depends-on
+    ("package"
+     "streams")
+   :supersedes-asdf ("trivial-gray-streams")))

package.lisp

@@ -0,0 +1,77 @@
+#+xcvb (module ())
+
+(in-package :cl-user)
+
+#+:abcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :gray-streams))
+
+#+cmu
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require :gray-streams))
+
+#+allegro
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (fboundp 'excl:stream-write-string)
+    (require "streamc.fasl")))
+
+#+ecl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (gray::redefine-cl-functions))
+
+(macrolet
+    ((frob ()
+       (let ((gray-class-symbols
+              '(#:fundamental-stream
+                #:fundamental-input-stream #:fundamental-output-stream
+                #:fundamental-character-stream #:fundamental-binary-stream
+                #:fundamental-character-input-stream #:fundamental-character-output-stream
+                #:fundamental-binary-input-stream #:fundamental-binary-output-stream))
+             (gray-function-symbols
+              '(#:stream-read-char
+                #:stream-unread-char #:stream-read-char-no-hang
+                #:stream-peek-char #:stream-listen #:stream-read-line
+                #:stream-clear-input #:stream-write-char #:stream-line-column
+                #:stream-start-line-p #:stream-write-string #:stream-terpri
+                #:stream-fresh-line #:stream-finish-output #:stream-force-output
+                #:stream-clear-output #:stream-advance-to-column
+                #:stream-read-byte #:stream-write-byte)))
+	 `(progn
+
+            (defpackage impl-specific-gray
+              (:use :cl)
+              (:import-from
+               #+sbcl :sb-gray
+               #+allegro :excl
+               #+cmu :ext
+               #+(or clisp ecl mocl) :gray
+               #+openmcl :ccl
+               #+lispworks :stream
+               #+abcl :gray-streams
+               #-(or sbcl allegro cmu clisp openmcl lispworks ecl abcl mocl) ...
+               ,@gray-class-symbols
+               ,@gray-function-symbols)
+              (:export
+               ,@gray-class-symbols
+               ,@gray-function-symbols))
+
+            (defpackage :trivial-gray-streams
+              (:use :cl)
+              (:import-from #:impl-specific-gray
+                            ;; We import and re-export only
+                            ;; function symbols;
+                            ;; But we define our own classes
+                            ;; mirroring the gray class hierarchy
+                            ;; of the lisp implementation (this
+                            ;; is necessary to define our methods
+                            ;; for particular generic functions)
+                            ,@gray-function-symbols)
+              (:export ,@gray-class-symbols
+                       ,@gray-function-symbols
+                       ;; extension functions
+                       #:stream-read-sequence
+                       #:stream-write-sequence
+                       #:stream-file-position
+                       ;; deprecated
+                       #:trivial-gray-stream-mixin))))))
+  (frob))

streams.lisp

@@ -0,0 +1,255 @@
+#+xcvb (module (:depends-on ("package")))
+
+(in-package :trivial-gray-streams)
+
+(defclass fundamental-stream (impl-specific-gray:fundamental-stream) ())
+(defclass fundamental-input-stream
+    (fundamental-stream impl-specific-gray:fundamental-input-stream) ())
+(defclass fundamental-output-stream
+    (fundamental-stream impl-specific-gray:fundamental-output-stream) ())
+(defclass fundamental-character-stream
+    (fundamental-stream impl-specific-gray:fundamental-character-stream) ())
+(defclass fundamental-binary-stream
+    (fundamental-stream impl-specific-gray:fundamental-binary-stream) ())
+(defclass fundamental-character-input-stream
+    (fundamental-input-stream fundamental-character-stream
+     impl-specific-gray:fundamental-character-input-stream) ())
+(defclass fundamental-character-output-stream
+    (fundamental-output-stream fundamental-character-stream
+     impl-specific-gray:fundamental-character-output-stream) ())
+(defclass fundamental-binary-input-stream
+    (fundamental-input-stream fundamental-binary-stream
+     impl-specific-gray:fundamental-binary-input-stream) ())
+(defclass fundamental-binary-output-stream
+    (fundamental-output-stream fundamental-binary-stream
+     impl-specific-gray:fundamental-binary-output-stream) ())
+
+(defgeneric stream-read-sequence
+    (stream sequence start end &key &allow-other-keys))
+(defgeneric stream-write-sequence
+    (stream sequence start end &key &allow-other-keys))
+
+(defgeneric stream-file-position (stream))
+(defgeneric (setf stream-file-position) (newval stream))
+
+;;; Default methods for stream-read/write-sequence.
+;;;
+;;; It would be nice to implement default methods
+;;; in trivial gray streams, maybe borrowing the code
+;;; from some of CL implementations. But now, for
+;;; simplicity we will fallback to default implementation
+;;; of the implementation-specific analogue function which calls us.
+
+(defmethod stream-read-sequence ((stream fundamental-input-stream) seq start end &key)
+  'fallback)
+
+(defmethod stream-write-sequence ((stream fundamental-output-stream) seq start end &key)
+  'fallback)
+
+(defmacro or-fallback (&body body)
+  `(let ((result ,@body))
+     (if (eq result (quote fallback))
+         (call-next-method)
+         result)))
+
+;; Implementations should provide this default method, I believe, but
+;; at least sbcl and allegro don't.
+(defmethod stream-terpri ((stream fundamental-output-stream))
+  (write-char #\newline stream))
+
+;; stream-file-position could be specialized to
+;; fundamental-stream, but to support backward
+;; compatibility with flexi-streams, we specialize
+;; it on T. The reason: flexi-streams calls stream-file-position
+;; for non-gray stream:
+;; https://github.com/edicl/flexi-streams/issues/4
+(defmethod stream-file-position ((stream t))
+  nil)
+
+(defmethod (setf stream-file-position) (newval (stream t))
+  (declare (ignore newval))
+  nil)
+
+#+abcl
+(progn
+  (defmethod gray-streams:stream-read-sequence 
+      ((s fundamental-input-stream) seq &optional start end)
+    (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+  
+  (defmethod gray-streams:stream-write-sequence 
+      ((s fundamental-output-stream) seq &optional start end)
+    (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+  
+  (defmethod gray-streams:stream-write-string 
+      ((stream xp::xp-structure) string &optional (start 0) (end (length string)))
+    (xp::write-string+ string stream start end))
+
+  #+#.(cl:if (cl:and (cl:find-package :gray-streams)
+		     (cl:find-symbol "STREAM-FILE-POSITION" :gray-streams))
+	     '(:and)
+	     '(:or))
+  (defmethod gray-streams:stream-file-position
+      ((s fundamental-stream) &optional position)
+    (if position
+        (setf (stream-file-position s) position)
+        (stream-file-position s))))
+
+#+allegro
+(progn
+  (defmethod excl:stream-read-sequence
+      ((s fundamental-input-stream) seq &optional start end)
+    (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+
+  (defmethod excl:stream-write-sequence
+      ((s fundamental-output-stream) seq &optional start end)
+    (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+  (defmethod excl::stream-file-position
+       ((stream fundamental-stream) &optional position)
+     (if position
+         (setf (stream-file-position stream) position)
+         (stream-file-position stream))))
+
+#+cmu
+(progn
+  (defmethod ext:stream-read-sequence
+      ((s fundamental-input-stream) seq &optional start end)
+    (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+  (defmethod ext:stream-write-sequence
+      ((s fundamental-output-stream) seq &optional start end)
+    (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))))
+
+#+lispworks
+(progn
+  (defmethod stream:stream-read-sequence
+      ((s fundamental-input-stream) seq start end)
+    (or-fallback (stream-read-sequence s seq start end)))
+  (defmethod stream:stream-write-sequence
+      ((s fundamental-output-stream) seq start end)
+    (or-fallback (stream-write-sequence s seq start end)))
+
+  (defmethod stream:stream-file-position ((stream fundamental-stream))
+    (stream-file-position stream))
+  (defmethod (setf stream:stream-file-position)
+      (newval (stream fundamental-stream))
+    (setf (stream-file-position stream) newval)))
+
+#+openmcl
+(progn
+  (defmethod ccl:stream-read-vector
+      ((s fundamental-input-stream) seq start end)
+    (or-fallback (stream-read-sequence s seq start end)))
+  (defmethod ccl:stream-write-vector
+      ((s fundamental-output-stream) seq start end)
+    (or-fallback (stream-write-sequence s seq start end)))
+
+  (defmethod ccl:stream-read-list ((s fundamental-input-stream) list count)
+    (or-fallback (stream-read-sequence s list 0 count)))
+  (defmethod ccl:stream-write-list ((s fundamental-output-stream) list count)
+    (or-fallback (stream-write-sequence s list 0 count)))
+
+  (defmethod ccl::stream-position ((stream fundamental-stream) &optional new-position)
+    (if new-position
+	(setf (stream-file-position stream) new-position)
+	(stream-file-position stream))))
+
+;; up to version 2.43 there were no
+;; stream-read-sequence, stream-write-sequence
+;; functions in CLISP
+#+clisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (when (find-symbol (string '#:stream-read-sequence) '#:gray)
+    (pushnew :clisp-has-stream-read/write-sequence *features*)))
+
+#+clisp
+(progn
+
+  #+clisp-has-stream-read/write-sequence
+  (defmethod gray:stream-read-sequence
+      (seq (s fundamental-input-stream) &key start end)
+    (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+
+  #+clisp-has-stream-read/write-sequence
+  (defmethod gray:stream-write-sequence
+      (seq (s fundamental-output-stream) &key start end)
+    (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+
+  ;;; for old CLISP
+  (defmethod gray:stream-read-byte-sequence
+      ((s fundamental-input-stream)
+       seq
+       &optional start end no-hang interactive)
+    (when no-hang
+      (error "this stream does not support the NO-HANG argument"))
+    (when interactive
+      (error "this stream does not support the INTERACTIVE argument"))
+    (or-fallback (stream-read-sequence s seq start end)))
+
+  (defmethod gray:stream-write-byte-sequence
+      ((s fundamental-output-stream)
+       seq
+       &optional start end no-hang interactive)
+    (when no-hang
+      (error "this stream does not support the NO-HANG argument"))
+    (when interactive
+      (error "this stream does not support the INTERACTIVE argument"))
+    (or-fallback (stream-write-sequence s seq start end)))
+
+  (defmethod gray:stream-read-char-sequence
+      ((s fundamental-input-stream) seq &optional start end)
+    (or-fallback (stream-read-sequence s seq start end)))
+
+  (defmethod gray:stream-write-char-sequence
+      ((s fundamental-output-stream) seq &optional start end)
+    (or-fallback (stream-write-sequence s seq start end)))
+
+  ;;; end of old CLISP read/write-sequence support
+
+  (defmethod gray:stream-position ((stream fundamental-stream) position)
+    (if position
+        (setf (stream-file-position stream) position)
+        (stream-file-position stream))))
+
+#+sbcl
+(progn
+  (defmethod sb-gray:stream-read-sequence
+      ((s fundamental-input-stream) seq &optional start end)
+    (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+  (defmethod sb-gray:stream-write-sequence
+      ((s fundamental-output-stream) seq &optional start end)
+    (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+  (defmethod sb-gray:stream-file-position 
+      ((stream fundamental-stream) &optional position)
+    (if position
+        (setf (stream-file-position stream) position)
+        (stream-file-position stream)))
+  ;; SBCL extension:
+  (defmethod sb-gray:stream-line-length ((stream fundamental-stream))
+    80))
+
+#+ecl
+(progn
+  (defmethod gray:stream-read-sequence
+    ((s fundamental-input-stream) seq &optional start end)
+    (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+  (defmethod gray:stream-write-sequence
+    ((s fundamental-output-stream) seq &optional start end)
+    (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq))))))
+
+#+mocl
+(progn
+  (defmethod gray:stream-read-sequence
+      ((s fundamental-input-stream) seq &optional start end)
+    (or-fallback (stream-read-sequence s seq (or start 0) (or end (length seq)))))
+  (defmethod gray:stream-write-sequence
+      ((s fundamental-output-stream) seq &optional start end)
+    (or-fallback (stream-write-sequence s seq (or start 0) (or end (length seq)))))
+  (defmethod gray:stream-file-position
+      ((stream fundamental-stream) &optional position)
+    (if position
+	(setf (stream-file-position stream) position)
+	(stream-file-position stream))))
+
+;; deprecated
+(defclass trivial-gray-stream-mixin () ())
+

test/package.lisp

@@ -0,0 +1,6 @@
+(defpackage trivial-gray-streams-test 
+  (:use :cl #:trivial-gray-streams)
+  (:shadow #:method)
+  (:export #:run-tests
+           #:failed-test-names))
+

test/run-on-many-lisps.lisp

@@ -0,0 +1,66 @@
+(ql:quickload :trivial-gray-streams)
+(ql:quickload :test-grid-agent)
+(ql:quickload :cl-fad)
+(in-package :cl-user)
+
+(defparameter *abcl* (make-instance 'lisp-exe:abcl
+                                    :java-exe-path "C:\\Program Files\\Java\\jdk1.6.0_26\\bin\\java"
+                                    :abcl-jar-path "C:\\Users\\anton\\unpacked\\abcl\\abcl-bin-1.1.0\\abcl.jar"))
+(defparameter *clisp* (make-instance 'lisp-exe:clisp :exe-path "clisp"))
+(defparameter *ccl-1.8-x86* (make-instance 'lisp-exe:ccl
+                                           :exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl.exe"))
+(defparameter *ccl-1.8-x86-64* (make-instance 'lisp-exe:ccl
+                                              :exe-path "C:\\Users\\anton\\unpacked\\ccl\\ccl-1.8-windows\\wx86cl64.exe"))
+(defparameter *sbcl-1.1.0.45* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.45\\run.bat"))
+(defparameter *sbcl-win-branch-64* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat"))
+(defparameter *sbcl-win-branch-32* (make-instance 'lisp-exe:sbcl :exe-path "C:\\Program Files (x86)\\Steel Bank Common Lisp\\1.1.0.36.mswinmt.1201-284e340\\run.bat"))
+(defparameter *ecl-bytecode* (make-instance 'lisp-exe:ecl
+                                            :exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe"
+                                            :compiler :bytecode))
+(defparameter *ecl-lisp-to-c* (make-instance 'lisp-exe:ecl
+                                             :exe-path "C:\\Users\\anton\\projects\\ecl\\bin\\ecl.exe"
+                                             :compiler :lisp-to-c))
+(defparameter *acl* (make-instance 'lisp-exe:acl :exe-path "C:\\Program Files (x86)\\acl90express\\alisp.exe"))
+
+(defun run-on-many-lisps (run-description test-run-dir quicklisp-dir lisps)
+  (ensure-directories-exist test-run-dir)
+  (let ((fasl-root (merge-pathnames "fasl/" test-run-dir)))
+    (labels ((log-name (lisp)
+               (substitute #\- #\.
+                           ;; Substitute dots by hypens if our main process is CCL, it 
+                           ;; prepends the > symbol before dots;
+                           ;; for example: 1.1.0.36.mswinmt.1201-284e340 => 1>.1>.0>.36>.mswinmt.1201-284e340
+                           ;; When we pass such a pathname to another lisps, they can't handle it.
+                           (string-downcase (tg-agent::implementation-identifier lisp))))
+             (fasl-dir (lisp)
+               (merge-pathnames (format nil "~A/" (log-name lisp))
+                                fasl-root))
+             (run (lisp)
+               (let* ((lib-result (tg-agent::proc-run-libtest lisp
+                                                              :trivial-gray-streams
+                                                              run-description
+                                                              (merge-pathnames (log-name lisp) test-run-dir)
+                                                              quicklisp-dir
+                                                              (fasl-dir lisp)))
+                      (status (getf lib-result :status)))
+                 (if (listp status)
+                     (getf status :failed-tests)
+                     status))))
+      (let ((results (mapcar (lambda (lisp)
+                               (list (tg-agent::implementation-identifier lisp)
+                                     (run lisp)))
+                             lisps)))
+        (tg-utils::write-to-file results (merge-pathnames "resutls.lisp" test-run-dir))
+        (cl-fad:delete-directory-and-files fasl-root)
+        results))))
+
+(run-on-many-lisps '(:lib-world "quicklisp 2013-02-17 + trivial-gray-streams.head"
+                     :contact-email "avodonosov@yandex.ru")
+                   "C:\\Users\\anton\\projects\\trivial-gray-streams\\test\\"
+                   (merge-pathnames "quicklisp/" (user-homedir-pathname))
+                   (list *sbcl-1.1.0.45* *sbcl-win-branch-64* *sbcl-win-branch-32*
+                         *abcl*
+                         *clisp*
+                         *ccl-1.8-x86* *ccl-1.8-x86-64*                         
+                         *ecl-bytecode* *ecl-lisp-to-c*
+                         *acl*))

test/test-framework.lisp

@@ -0,0 +1,60 @@
+(in-package :trivial-gray-streams-test)
+
+;;; test framework
+
+#|
+  Used like this:
+
+  (list (test (add) (assert (= 5 (+ 2 2))))
+        (test (mul) (assert (= 4 (* 2 2))))
+        (test (subst) (assert (= 3 (- 4 2)))))
+
+  => ;; list of test results, 2 failed 1 passed
+     (#<TEST-RESULT ADD :FAIL The assertion (= 5 (+ 2 2)) failed.>
+      #<TEST-RESULT MUL :OK>
+      #<TEST-RESULT SUBST :FAIL The assertion (= 3 (- 4 2)) failed.>)
+
+|#
+
+(defclass test-result ()
+  ((name :type symbol
+         :initarg :name
+         :initform (error ":name is requierd")
+         :accessor name)
+   (status :type (or (eql :ok) (eql :fail))
+           :initform :ok
+           :initarg :status
+           :accessor status)
+   (cause :type (or null condition)
+          :initform nil
+          :initarg :cause
+          :accessor cause)))
+
+(defun failed-p (test-result)
+  (eq (status test-result) :fail))
+
+(defmethod print-object ((r test-result) stream)
+  (print-unreadable-object (r stream :type t)
+    (format stream "~S ~S~@[ ~A~]" (name r) (status r) (cause r))))
+
+(defparameter *allow-debugger* nil)
+
+(defun test-impl (name body-fn)
+  (flet ((make-result (status &optional cause)
+           (make-instance 'test-result :name name :status status :cause cause)))
+    (handler-bind ((serious-condition
+                    (lambda (c)
+                      (unless *allow-debugger*
+                        (format t "FAIL: ~A~%" c)
+                        (return-from test-impl                          
+                          (make-result :fail c))))))
+      (format t "Running test ~S... " name)
+      (funcall body-fn)
+      (format t "OK~%")
+      (make-result :ok))))
+
+(defmacro test ((name) &body body)
+  "If the BODY signals a SERIOUS-CONDITION
+this macro returns a failed TEST-RESULT; otherwise
+returns a successfull TEST-RESULT."
+  `(test-impl (quote ,name) (lambda () ,@body)))

test/test.lisp

@@ -0,0 +1,212 @@
+(in-package :trivial-gray-streams-test)
+
+;;; assert-invoked - a tool to check that specified method with parameters has
+;;; been invoked during execution of a code body
+
+(define-condition invoked ()
+  ((method :type (or symbol cons) ;; cons is for (setf method)
+           :accessor method
+           :initarg :method
+           :initform (error ":method is required"))
+   (args :type list
+         :accessor args
+         :initarg :args
+         :initform nil)))
+
+(defun assert-invoked-impl (method args body-fn)
+  (let ((expected-invocation (cons method args))
+        (actual-invocations nil))
+    (handler-bind ((invoked (lambda (i)
+                              (let ((invocation (cons (method i) (args i))))
+                                (when (equalp invocation expected-invocation)
+                                  (return-from assert-invoked-impl nil))
+                                (push invocation actual-invocations)))))
+      (funcall body-fn))
+    (let ((*package* (find-package :keyword))) ; ensures package prefixes are printed
+      (error "expected invocation: ~(~S~) actual: ~{~(~S~)~^, ~}"
+             expected-invocation (reverse actual-invocations)))))
+
+(defmacro assert-invoked ((method &rest args) &body body)
+  "If during execution of the BODY the specified METHOD with ARGS
+hasn't been invoked, signals an ERROR."
+  `(assert-invoked-impl (quote ,method) (list ,@args) (lambda () ,@body)))
+
+(defun invoked (method &rest args)
+  (signal 'invoked :method method :args args))
+
+;;; The tests.
+
+#|
+  We will define a gray stream class, specialise 
+  the gray generic function methods on it and test that the methods
+  are invoked when we call functions from common-lisp package
+  on that stream.
+
+  Some of the gray generic functions are only invoked by default
+  methods of other generic functions:
+
+      cl:format ~t or cl:pprint -> stream-advance-to-column -> stream-line-column
+                                                               stream-write-char
+      cl:fresh-line -> stream-fresh-line -> stream-start-line-p -> stream-line-column
+                                            stream-terpri
+
+
+  If we define our methods for stream-advance-to-column and stream-fresh-line,
+  then stream-start-line-p, stream-terpri, stram-line-column are not invoked.
+
+  Therefore we define another gray stream class. The first class is used
+  for all lower level functions (stream-terpri). The second class
+  is used to test methods for higher level functions (stream-fresh-line).
+|#
+
+(defclass test-stream (fundamental-binary-input-stream
+                       fundamental-binary-output-stream
+                       fundamental-character-input-stream
+                       fundamental-character-output-stream)
+  ())
+
+(defclass test-stream2 (test-stream) ())
+
+(defmethod stream-read-char ((stream test-stream))
+  (invoked 'stream-read-char stream))
+
+(defmethod stream-unread-char ((stream test-stream) char)
+  (invoked 'stream-unread-char stream char))
+
+(defmethod stream-read-char-no-hang ((stream test-stream))
+  (invoked 'stream-read-char-no-hang stream))
+
+(defmethod stream-peek-char ((stream test-stream))
+  (invoked 'stream-peek-char stream))
+
+(defmethod stream-listen ((stream test-stream))
+  (invoked 'stream-listen stream))
+
+(defmethod stream-read-line ((stream test-stream))
+  (invoked 'stream-read-line stream))
+
+(defmethod stream-clear-input ((stream test-stream))
+  (invoked 'stream-clear-input stream))
+
+(defmethod stream-write-char ((stream test-stream) char)
+  (invoked 'stream-write-char stream char))
+
+(defmethod stream-line-column ((stream test-stream))
+  (invoked 'stream-line-column stream))
+
+(defmethod stream-start-line-p ((stream test-stream))
+  (invoked 'stream-start-line-p stream))
+
+(defmethod stream-write-string ((stream test-stream) string &optional start end)
+  (invoked 'stream-write-string stream string start end))
+
+(defmethod stream-terpri ((stream test-stream))
+  (invoked 'stream-terpri stream))
+
+(defmethod stream-fresh-line ((stream test-stream2))
+  (invoked 'stream-fresh-line stream))
+
+(defmethod stream-finish-output ((stream test-stream))
+  (invoked 'stream-finish-output stream))
+
+(defmethod stream-force-output ((stream test-stream))
+  (invoked 'stream-force-output stream))
+
+(defmethod stream-clear-output ((stream test-stream))
+  (invoked 'stream-clear-output stream))
+
+(defmethod stream-advance-to-column ((stream test-stream2) column)
+  (invoked 'stream-advance-to-column stream column))
+
+(defmethod stream-read-byte ((stream test-stream))
+  (invoked 'stream-read-byte stream))
+
+(defmethod stream-write-byte ((stream test-stream) byte)
+  (invoked 'stream-write-byte stream byte))
+
+(defmethod stream-read-sequence ((s test-stream) seq start end &key)
+  (invoked 'stream-read-sequence s seq :start start :end end))
+
+(defmethod stream-write-sequence ((s test-stream) seq start end &key)
+  (invoked 'stream-write-sequence s seq :start start :end end))
+
+(defmethod stream-file-position ((s test-stream))
+  (invoked 'stream-file-position s))
+
+(defmethod (setf stream-file-position) (newval (s test-stream))
+  (invoked '(setf stream-file-position) newval s))
+
+;; Convinience macro, used when we want to name
+;; the test case with the same name as of the gray streams method we test.
+(defmacro test-invoked ((method &rest args) &body body)
+  `(test (,method)
+     (assert-invoked (,method ,@args)
+       ,@body)))
+
+(defun run-tests ()
+  (let ((s (make-instance 'test-stream))
+        (s2 (make-instance 'test-stream2)))
+    (list
+     (test-invoked (stream-read-char s)
+       (read-char s))
+     (test-invoked (stream-unread-char s #\a)
+       (unread-char #\a s))
+     (test-invoked (stream-read-char-no-hang s)
+       (read-char-no-hang s))
+     (test-invoked (stream-peek-char s)
+       (peek-char nil s))
+     (test-invoked (stream-listen s)
+       (listen s))
+     (test-invoked (stream-read-line s)
+       (read-line s))
+     (test-invoked (stream-clear-input s)
+       (clear-input s))
+     (test-invoked (stream-write-char s #\b)
+       (write-char #\b s))
+     (test-invoked (stream-line-column s)
+       (format s "~10,t"))
+     (test-invoked (stream-start-line-p s)
+       (fresh-line s))
+     (test-invoked (stream-write-string s "hello" 1 4)
+       (write-string "hello" s :start 1 :end 4))
+     (test-invoked (stream-terpri s)
+       (fresh-line s))
+     (test-invoked (stream-fresh-line s2)
+       (fresh-line s2))
+     (test-invoked (stream-finish-output s)
+       (finish-output s))
+     (test-invoked (stream-force-output s)
+       (force-output s))
+     (test-invoked (stream-clear-output s)
+       (clear-output s))
+     (test-invoked (stream-advance-to-column s2 10)
+        (format s2 "~10,t"))
+     (test-invoked (stream-read-byte s)
+       (read-byte s))
+     (test-invoked (stream-write-byte s 1)
+       (write-byte 1 s))
+     ;;; extensions
+     (test-invoked (stream-read-sequence s #(1 2) :start 0 :end 1)
+       (read-sequence #(1 2) s :start 0 :end 1))
+     (test-invoked (stream-write-sequence s #(1 2) :start 0 :end 1)
+       (write-sequence #(1 2) s :start 0 :end 1))
+     (test-invoked (stream-file-position s)
+       (file-position s))
+     (test (setf-stream-file-position)
+       (assert-invoked ((setf stream-file-position) 9 s)
+         (file-position s 9))))))
+
+(defun failed-tests (results)
+  (remove-if-not #'failed-p results))
+
+(defun failed-test-names (results)
+  (mapcar (lambda (result)
+            (string-downcase (name result)))
+          (failed-tests results)))
+               
+#|
+(failed-test-names (run-tests))
+
+(setf *allow-debugger* nil))
+
+|#

trivial-gray-streams-test.asd

@@ -0,0 +1,10 @@
+;;; -*- mode: lisp -*-
+
+(defsystem :trivial-gray-streams-test
+  :version "2.0"
+  :depends-on (:trivial-gray-streams)
+  :pathname #P"test/"
+  :serial t
+  :components ((:file "package")
+               (:file "test-framework")
+               (:file "test")))

trivial-gray-streams.asd

@@ -0,0 +1,10 @@
+;;; -*- mode: lisp -*-
+
+(defsystem :trivial-gray-streams
+  :description "Compatibility layer for Gray Streams (see http://www.cliki.net/Gray%20streams)."
+  :license "MIT"
+  :author "David Lichteblau"
+  :maintainer "Anton Vodonosov <avodonosov@yandex.ru>"
+  :version "2.0"
+  :serial t
+  :components ((:file "package") (:file "streams")))