ian/dotfiles
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

sbcl stuff

Browse source
This commit is contained in:
Ian Keane 2020-01-20 14:13:08 -05:00
parent 1d1dbc34df
commit 5d91dbb667
335 changed files with 119806 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

22
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/COPYING Normal file
View file

@ -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.

3
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/Makefile Normal file
View file

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

40
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/README Normal file
View file

@ -0,0 +1,40 @@
trivial-gray-streams
====================
Gray streams is an interface proposed for inclusion with ANSI CL
by David N. Gray in Issue STREAM-DEFINITION-BY-USER
(http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html).
The proposal did not make it into ANSI CL, but most popular
CL implementations implement this facility anyway.
This system provides an extremely thin compatibility layer for gray
streams.
How to use it
=============
Use the package TRIVIAL-GRAY-STREAMS to refer Gray stream
classes to inherit from, generic functions to implement.
Extensions
==========
The Gray proposal was made before the ANCI CL standard was finalized,
and was based on the Common Lisp The Language book.
The book does not have cl:file-position, cl:read-sequence, cl:write-sequence
functions. That's why (we think) the Gray proposal does not specify
their counterparts: stream-file-position, stream-read-sequence, stream-write-sequence.
trivial-gray-streams supports these functions:
Generic function STREAM-READ-SEQUENCE (stream sequence start end &key)
Generic function STREAM-WRITE-SEQUENCE (stream sequence start end &key)
Notice that we use two required arguments and allow additional
keyword arguments. Your methods on these function should have
compliant lambda lists:
(stream sequence start end &key)
Generic function STREAM-FILE-POSITION (stream) => file position
Generic function (SETF STREAM-FILE-POSITION) (position-spec stream) => successp

7
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/build.xcvb Normal file
View file

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

77
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/package.lisp Normal file
View file

@ -0,0 +1,77 @@
#+xcvb (module ())
(in-package :cl-user)
#+:abcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :gray-streams))
#+(or cmu genera)
(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")))
#+(or ecl clasp)
(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 clasp) :gray
#+openmcl :ccl
#+lispworks :stream
#+(or abcl genera) :gray-streams
#-(or sbcl allegro cmu clisp openmcl lispworks ecl clasp abcl mocl genera) ...
,@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))

292
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/streams.lisp Normal file
View file

@ -0,0 +1,292 @@
#+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)
(declare (ignore seq start end))
'fallback)
(defmethod stream-write-sequence ((stream fundamental-output-stream) seq start end &key)
(declare (ignore seq start end))
'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))))
;; Untill 2014-08-09 CMUCL did not have stream-file-position:
;; http://trac.common-lisp.net/cmucl/ticket/100
#+cmu
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (find-symbol (string '#:stream-file-position) '#:ext)
(pushnew :cmu-has-stream-file-position *features*)))
#+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)))))
#+cmu-has-stream-file-position
(defmethod ext:stream-file-position ((stream fundamental-stream))
(stream-file-position stream))
#+cmu-has-stream-file-position
(defmethod (setf ext:stream-file-position) (position (stream fundamental-stream))
(setf (stream-file-position stream) position)))
#+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))
#+(or ecl clasp)
(progn
(defmethod gray::stream-file-position
((stream fundamental-stream) &optional position)
(if position
(setf (stream-file-position stream) position)
(stream-file-position stream)))
(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))))
#+genera
(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-file-position
((stream fundamental-stream))
(stream-file-position stream))
(defmethod (setf gray-streams:stream-file-position)
(position (stream fundamental-stream))
(setf (stream-file-position stream) position)))
;; deprecated
(defclass trivial-gray-stream-mixin () ())

6
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/package.lisp Normal file
View file

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

66
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/run-on-many-lisps.lisp Normal file
View file

@ -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*))

60
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test-framework.lisp Normal file
View file

@ -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)
(let ((result (make-result :fail c)))
(return-from test-impl result))))))
(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)))

213
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/test/test.lisp Normal file
View file

@ -0,0 +1,213 @@
(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
(let ((seq (vector 1 2)))
(test-invoked (stream-read-sequence s seq :start 0 :end 1)
(read-sequence seq s :start 0 :end 1))
(test-invoked (stream-write-sequence s seq :start 0 :end 1)
(write-sequence seq 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))
|#

10
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams-test.asd Normal file
View file

@ -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")))

10
sbcl/.quicklisp/dists/quicklisp/software/trivial-gray-streams-20181018-git/trivial-gray-streams.asd Normal file
View file

@ -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")))