[git] CMU Common Lisp branch rtoy-lisp-trig updated. snapshot-2013-12-a-11-g1ae2d46
Raymond Toy
rtoy at common-lisp.net
Wed Dec 18 03:45:20 UTC 2013
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, rtoy-lisp-trig has been updated
via 1ae2d46cf3e9776ff35c6d6eddf3d73f6b0b66a1 (commit)
from 1266d1ff1eb938136e8ae684eb9e3be8009ec350 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 1ae2d46cf3e9776ff35c6d6eddf3d73f6b0b66a1
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Tue Dec 17 19:45:02 2013 -0800
Remove RT.
diff --git a/src/code/module.lisp b/src/code/module.lisp
index 42b0ac2..70ccba7 100644
--- a/src/code/module.lisp
+++ b/src/code/module.lisp
@@ -148,12 +148,6 @@
(defmodule "asdf"
"modules:asdf/asdf")
-(defmodule :rt
- "modules:rt/rt")
-
-(defmodule "rt"
- "modules:rt/rt")
-
;; Allow user to specify "cmu-contribs" or :cmu-contribs.
(defmodule "cmu-contribs"
"modules:contrib")
diff --git a/src/contrib/rt/rt.asd b/src/contrib/rt/rt.asd
deleted file mode 100644
index 718e965..0000000
--- a/src/contrib/rt/rt.asd
+++ /dev/null
@@ -1,33 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name: rt.asd
-;;;; Purpose: ASDF definition file for Rt
-;;;; Programmer: Kevin M. Rosenberg
-;;;; Date Started: Sep 2002
-;;;;
-;;;; $Id$
-;;;;
-;;;; This file, part of cl-rt, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; cl-rt users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the GNU Lesser General Public License
-;;;; (http://www.gnu.org/licenses/lgpl.html)
-;;;; *************************************************************************
-
-(in-package :asdf)
-
-(defsystem :rt
- :name "cl-rt"
- :version "1990.12.19"
- :maintainer "Kevin M. Rosenberg <kmr at debian.org>"
- :licence "MIT"
- :description "MIT Regression Tester"
- :long-description "RT provides a framework for writing regression test suites"
- :perform (load-op :after (op rt)
- (pushnew :rt cl:*features*))
- :components
- ((:file "rt")))
-
-
diff --git a/src/contrib/rt/rt.lisp b/src/contrib/rt/rt.lisp
deleted file mode 100644
index 3df87c4..0000000
--- a/src/contrib/rt/rt.lisp
+++ /dev/null
@@ -1,409 +0,0 @@
-;-*-syntax:COMMON-LISP;Package:(RT :use "COMMON-LISP" :colon-mode :external)-*-
-
-#|----------------------------------------------------------------------------|
- | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
- | |
- | Permission to use, copy, modify, and distribute this software and its |
- | documentation for any purpose and without fee is hereby granted, provided |
- | that this copyright and permission notice appear in all copies and |
- | supporting documentation, and that the name of M.I.T. not be used in |
- | advertising or publicity pertaining to distribution of the software |
- | without specific, written prior permission. M.I.T. makes no |
- | representations about the suitability of this software for any purpose. |
- | It is provided "as is" without express or implied warranty. |
- | |
- | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
- | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
- | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
- | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
- | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
- | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
- | SOFTWARE. |
- |----------------------------------------------------------------------------|#
-
-(defpackage #:regression-test
- (:nicknames #:rtest #-lispworks #:rt)
- (:use #:cl)
- (:export #:*do-tests-when-defined* #:*test* #:continue-testing
- #:deftest #:do-test #:do-tests #:get-test #:pending-tests
- #:rem-all-tests #:rem-test)
- (:documentation "The MIT regression tester with pfdietz's modifications"))
-
-;;This was the December 19, 1990 version of the regression tester, but
-;;has since been modified.
-
-(in-package :regression-test)
-
-(declaim (ftype (function (t) t) get-entry expanded-eval do-entries))
-(declaim (type list *entries*))
-(declaim (ftype (function (t &rest t) t) report-error))
-(declaim (ftype (function (t &optional t) t) do-entry))
-
-(defvar *test* nil "Current test name")
-(defvar *do-tests-when-defined* nil)
-(defvar *entries* '(nil) "Test database. Has a leading dummy cell that does not contain an entry.")
-(defvar *entries-tail* *entries* "Tail of the *entries* list")
-(defvar *entries-table* (make-hash-table :test #'equal)
- "Map the names of entries to the cons cell in *entries* that precedes the one whose car is the entry.")
-(defvar *in-test* nil "Used by TEST")
-(defvar *debug* nil "For debugging")
-(defvar *catch-errors* t "When true, causes errors in a test to be caught.")
-(defvar *print-circle-on-failure* nil
- "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
-
-(defvar *compile-tests* nil "When true, compile the tests before running them.")
-(defvar *expanded-eval* nil "When true, convert the tests into a form that is less likely to have compiler optimizations.")
-(defvar *optimization-settings* '((safety 3)))
-
-(defvar *expected-failures* nil
- "A list of test names that are expected to fail.")
-
-(defvar *notes* (make-hash-table :test 'equal)
- "A mapping from names of notes to note objects.")
-
-(defstruct (entry (:conc-name nil))
- pend name props form vals)
-
-;;; Note objects are used to attach information to tests.
-;;; A typical use is to mark tests that depend on a particular
-;;; part of a set of requirements, or a particular interpretation
-;;; of the requirements.
-
-(defstruct note
- name
- contents
- disabled ;; When true, tests with this note are considered inactive
- )
-
-;; (defmacro vals (entry) `(cdddr ,entry))
-
-(defmacro defn (entry)
- (let ((var (gensym)))
- `(let ((,var ,entry))
- (list* (name ,var) (form ,var) (vals ,var)))))
-
-(defun entry-notes (entry)
- (let* ((props (props entry))
- (notes (getf props :notes)))
- (if (listp notes)
- notes
- (list notes))))
-
-(defun has-disabled-note (entry)
- (let ((notes (entry-notes entry)))
- (loop for n in notes
- for note = (if (note-p n) n
- (gethash n *notes*))
- thereis (and note (note-disabled note)))))
-
-(defun pending-tests ()
- (loop for entry in (cdr *entries*)
- when (and (pend entry) (not (has-disabled-note entry)))
- collect (name entry)))
-
-(defun rem-all-tests ()
- (setq *entries* (list nil))
- (setq *entries-tail* *entries*)
- (clrhash *entries-table*)
- nil)
-
-(defun rem-test (&optional (name *test*))
- (let ((pred (gethash name *entries-table*)))
- (when pred
- (if (null (cddr pred))
- (setq *entries-tail* pred)
- (setf (gethash (name (caddr pred)) *entries-table*) pred))
- (setf (cdr pred) (cddr pred))
- (remhash name *entries-table*)
- name)))
-
-(defun get-test (&optional (name *test*))
- (defn (get-entry name)))
-
-(defun get-entry (name)
- (let ((entry ;; (find name (the list (cdr *entries*))
- ;; :key #'name :test #'equal)
- (cadr (gethash name *entries-table*))
- ))
- (when (null entry)
- (report-error t
- "~%No test with name ~:@(~S~)."
- name))
- entry))
-
-(defmacro deftest (name &rest body)
- (let* ((p body)
- (properties
- (loop while (keywordp (first p))
- unless (cadr p)
- do (error "Poorly formed deftest: ~A~%"
- (list* 'deftest name body))
- append (list (pop p) (pop p))))
- (form (pop p))
- (vals p))
- `(add-entry (make-entry :pend t
- :name ',name
- :props ',properties
- :form ',form
- :vals ',vals))))
-
-(defun add-entry (entry)
- (setq entry (copy-entry entry))
- (let* ((pred (gethash (name entry) *entries-table*)))
- (cond
- (pred
- (setf (cadr pred) entry)
- (report-error nil
- "Redefining test ~:@(~S~)"
- (name entry)))
- (t
- (setf (gethash (name entry) *entries-table*) *entries-tail*)
- (setf (cdr *entries-tail*) (cons entry nil))
- (setf *entries-tail* (cdr *entries-tail*))
- )))
- (when *do-tests-when-defined*
- (do-entry entry))
- (setq *test* (name entry)))
-
-(defun report-error (error? &rest args)
- (cond (*debug*
- (apply #'format t args)
- (if error? (throw '*debug* nil)))
- (error? (apply #'error args))
- (t (apply #'warn args)))
- nil)
-
-(defun do-test (&optional (name *test*))
- #-sbcl (do-entry (get-entry name))
- #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
- (do-entry (get-entry name))))
-
-(defun my-aref (a &rest args)
- (apply #'aref a args))
-
-(defun my-row-major-aref (a index)
- (row-major-aref a index))
-
-(defun equalp-with-case (x y)
- "Like EQUALP, but doesn't do case conversion of characters.
- Currently doesn't work on arrays of dimension > 2."
- (cond
- ((eq x y) t)
- ((consp x)
- (and (consp y)
- (equalp-with-case (car x) (car y))
- (equalp-with-case (cdr x) (cdr y))))
- ((and (typep x 'array)
- (= (array-rank x) 0))
- (equalp-with-case (my-aref x) (my-aref y)))
- ((typep x 'vector)
- (and (typep y 'vector)
- (let ((x-len (length x))
- (y-len (length y)))
- (and (eql x-len y-len)
- (loop
- for i from 0 below x-len
- for e1 = (my-aref x i)
- for e2 = (my-aref y i)
- always (equalp-with-case e1 e2))))))
- ((and (typep x 'array)
- (typep y 'array)
- (not (equal (array-dimensions x)
- (array-dimensions y))))
- nil)
-
- ((typep x 'array)
- (and (typep y 'array)
- (let ((size (array-total-size x)))
- (loop for i from 0 below size
- always (equalp-with-case (my-row-major-aref x i)
- (my-row-major-aref y i))))))
-
- (t (eql x y))))
-
-(defun do-entry (entry &optional
- (s *standard-output*))
- (catch '*in-test*
- (setq *test* (name entry))
- (setf (pend entry) t)
- (let* ((*in-test* t)
- ;; (*break-on-warnings* t)
- (aborted nil)
- r)
- ;; (declare (special *break-on-warnings*))
-
- (block aborted
- (setf r
- (flet ((%do
- ()
- (cond
- (*compile-tests*
- (multiple-value-list
- (funcall (compile
- nil
- `(lambda ()
- (declare
- (optimize ,@*optimization-settings*))
- ,(form entry))))))
- (*expanded-eval*
- (multiple-value-list
- (expanded-eval (form entry))))
- (t
- (multiple-value-list
- (eval (form entry)))))))
- (if *catch-errors*
- (handler-bind
- (#-ecl (style-warning #'muffle-warning)
- (error #'(lambda (c)
- (setf aborted t)
- (setf r (list c))
- (return-from aborted nil))))
- (%do))
- (%do)))))
-
- (setf (pend entry)
- (or aborted
- (not (equalp-with-case r (vals entry)))))
-
- (when (pend entry)
- (let ((*print-circle* *print-circle-on-failure*))
- (format s "~&Test ~:@(~S~) failed~
- ~%Form: ~S~
- ~%Expected value~P: ~
- ~{~S~^~%~17t~}~%"
- *test* (form entry)
- (length (vals entry))
- (vals entry))
- (handler-case
- (let ((st (format nil "Actual value~P: ~
- ~{~S~^~%~15t~}.~%"
- (length r) r)))
- (format s "~A" st))
- (error () (format s "Actual value: #<error during printing>~%")
- ))
- (finish-output s)
- ))))
- (when (not (pend entry)) *test*))
-
-(defun expanded-eval (form)
- "Split off top level of a form and eval separately. This reduces the chance that
- compiler optimizations will fold away runtime computation."
- (if (not (consp form))
- (eval form)
- (let ((op (car form)))
- (cond
- ((eq op 'let)
- (let* ((bindings (loop for b in (cadr form)
- collect (if (consp b) b (list b nil))))
- (vars (mapcar #'car bindings))
- (binding-forms (mapcar #'cadr bindings)))
- (apply
- (the function
- (eval `(lambda ,vars ,@(cddr form))))
- (mapcar #'eval binding-forms))))
- ((and (eq op 'let*) (cadr form))
- (let* ((bindings (loop for b in (cadr form)
- collect (if (consp b) b (list b nil))))
- (vars (mapcar #'car bindings))
- (binding-forms (mapcar #'cadr bindings)))
- (funcall
- (the function
- (eval `(lambda (,(car vars) &aux ,@(cdr bindings)) ,@(cddr form))))
- (eval (car binding-forms)))))
- ((eq op 'progn)
- (loop for e on (cdr form)
- do (if (null (cdr e)) (return (eval (car e)))
- (eval (car e)))))
- ((and (symbolp op) (fboundp op)
- (not (macro-function op))
- (not (special-operator-p op)))
- (apply (symbol-function op)
- (mapcar #'eval (cdr form))))
- (t (eval form))))))
-
-(defun continue-testing ()
- (if *in-test*
- (throw '*in-test* nil)
- (do-entries *standard-output*)))
-
-(defun do-tests (&optional
- (out *standard-output*))
- (dolist (entry (cdr *entries*))
- (setf (pend entry) t))
- (if (streamp out)
- (do-entries out)
- (with-open-file
- (stream out :direction :output)
- (do-entries stream))))
-
-(defun do-entries* (s)
- (format s "~&Doing ~A pending test~:P ~
- of ~A tests total.~%"
- (count t (the list (cdr *entries*)) :key #'pend)
- (length (cdr *entries*)))
- (finish-output s)
- (dolist (entry (cdr *entries*))
- (when (and (pend entry)
- (not (has-disabled-note entry)))
- (format s "~@[~<~%~:; ~:@(~S~)~>~]"
- (do-entry entry s))
- (finish-output s)
- ))
- (let ((pending (pending-tests))
- (expected-table (make-hash-table :test #'equal)))
- (dolist (ex *expected-failures*)
- (setf (gethash ex expected-table) t))
- (let ((new-failures
- (loop for pend in pending
- unless (gethash pend expected-table)
- collect pend)))
- (if (null pending)
- (format s "~&No tests failed.")
- (progn
- (format s "~&~A out of ~A ~
- total tests failed: ~
- ~:@(~{~<~% ~1:;~S~>~
- ~^, ~}~)."
- (length pending)
- (length (cdr *entries*))
- pending)
- (if (null new-failures)
- (format s "~&No unexpected failures.")
- (when *expected-failures*
- (format s "~&~A unexpected failures: ~
- ~:@(~{~<~% ~1:;~S~>~
- ~^, ~}~)."
- (length new-failures)
- new-failures)))
- ))
- (finish-output s)
- (null pending))))
-
-(defun do-entries (s)
- #-sbcl (do-entries* s)
- #+sbcl (handler-bind ((sb-ext:code-deletion-note #'muffle-warning))
- (do-entries* s)))
-
-;;; Note handling functions and macros
-
-(defmacro defnote (name contents &optional disabled)
- `(eval-when (:load-toplevel :execute)
- (let ((note (make-note :name ',name
- :contents ',contents
- :disabled ',disabled)))
- (setf (gethash (note-name note) *notes*) note)
- note)))
-
-(defun disable-note (n)
- (let ((note (if (note-p n) n
- (setf n (gethash n *notes*)))))
- (unless note (error "~A is not a note or note name." n))
- (setf (note-disabled note) t)
- note))
-
-(defun enable-note (n)
- (let ((note (if (note-p n) n
- (setf n (gethash n *notes*)))))
- (unless note (error "~A is not a note or note name." n))
- (setf (note-disabled note) nil)
- note))
-----------------------------------------------------------------------
Summary of changes:
src/code/module.lisp | 6 -
src/contrib/rt/rt.asd | 33 ----
src/contrib/rt/rt.lisp | 409 ------------------------------------------------
3 files changed, 448 deletions(-)
delete mode 100644 src/contrib/rt/rt.asd
delete mode 100644 src/contrib/rt/rt.lisp
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list