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