From 0f383318a079bd0c7bb23c909f30771b1c20b29c Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Thu, 31 Jul 2008 09:33:25 +0200 Subject: Add Sacla to the repository. --- Sacla/testbed.lisp | 217 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 217 insertions(+) create mode 100644 Sacla/testbed.lisp (limited to 'Sacla/testbed.lisp') diff --git a/Sacla/testbed.lisp b/Sacla/testbed.lisp new file mode 100644 index 0000000..6d5e54a --- /dev/null +++ b/Sacla/testbed.lisp @@ -0,0 +1,217 @@ +;; Copyright (C) 2002-2004, Yuji Minejima +;; ALL RIGHTS RESERVED. +;; +;; $Id: testbed.lisp,v 1.4 2004/09/02 06:59:43 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defpackage "TESTBED" + (:nicknames "TB") + (:shadow "DEFMACRO" "DEFINE-CONDITION") + (:use "COMMON-LISP")) + +(in-package "TESTBED") + +(defun shadow-cl-symbol (name &optional type) + (multiple-value-bind (cl-symbol status) (find-symbol name "CL") + (when (eq status :external) + (let ((symbol (progn (shadow name) (intern name "TB")))) + ;; type + (when (and (not (eq type :condition)) + (or (member cl-symbol + '(not and mod satisfies eql not values member or)) + (subtypep cl-symbol t)) + (not (member cl-symbol '(error)))) + (eval `(deftype ,symbol (&rest rest) + (if rest + (cons ',cl-symbol rest) + ',cl-symbol)))) + ;; function + (when (and (not (eq type :function)) (fboundp cl-symbol) + (not (fboundp symbol))) + (setf (symbol-function symbol) (symbol-function cl-symbol))) + ;; variable + (when (and (not (eq type :variable)) (boundp cl-symbol) + (not (boundp symbol))) + (setf (symbol-value symbol) (symbol-value cl-symbol))) + ;; (setf name) + (when (and (not (eq type :setf)) (fboundp `(setf ,cl-symbol)) + (not (fboundp `(setf ,symbol)))) + (setf (fdefinition `(setf ,symbol)) (fdefinition `(setf ,cl-symbol))))) + t))) + +(defvar *testbed-compile* nil) + +(cl:defmacro defmacro (symbol &rest rest) + "testbed::defmacro" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :function) + (cond + ((string= name "DEFINE-CONDITION") + `(cl:defmacro new-define-condition ,@rest)) + (t `(progn + (cl:defmacro ,(intern name) ,@rest) + #-cmu + (when *testbed-compile* + (compile ',(intern name))) ;; cmucl 18e fails + ))))) + +(cl:defmacro define-condition (symbol parent-types &rest rest) + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :condition) + (if (fboundp 'new-define-condition) + `(new-define-condition ,(intern name) ,parent-types ,@rest) + (progn + (setq parent-types (cond + ((null parent-types) (list (intern "CONDITION"))) + (t parent-types))) + `(cl:define-condition ,(intern name) ,parent-types ,@rest))))) + +(defmacro defvar (symbol &rest rest) + "testbed::defvar" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :variable) + `(cl:defvar ,(intern name) ,@rest))) + +(defmacro defun (function-name &rest rest) + "testbed::defun" + (if (symbolp function-name) + (let ((name (symbol-name function-name))) + (shadow-cl-symbol name :function) + `(progn + (cl:defun ,(intern name) ,@rest) + (when *testbed-compile* + (compile ',(intern name))))) + `(cl:defun (setf ,(cadr function-name)) ,@rest))) + +(defmacro defsetf (symbol &rest rest) + "testbed::defsetf" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :setf) + (fmakunbound `(setf ,(intern name))) + `(cl:defsetf ,(intern name) ,@rest))) + +(defmacro define-setf-expander (symbol &rest rest) + "testbed::define-setf-expander" + (let ((name (symbol-name symbol))) + (shadow-cl-symbol name :setf) + (fmakunbound `(setf ,(intern name))) + `(cl:define-setf-expander ,(intern name) ,@rest))) + +(defun clone-package-system () + (error "clone-package-system is not defined in testbed.lisp.")) + +(defun ld (name) + (cond + ((string= name "cons") + ;;(shadow '("CONS" "CONSP" "CAR" "CDR")) + ) + ((string= name "hash-table") + (shadow '("HASH-TABLE" "HASH-TABLE-P" "HASH-TABLE-COUNT" + "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" + "HASH-TABLE-SIZE" "HASH-TABLE-TEST") "TB")) + ((string= name "package") ; needs hash-table + (shadow '("PACKAGE" "PACKAGEP" "MAKE-PACKAGE" "FIND-PACKAGE" + "SHADOWING-IMPORT" "IMPORT" "USE-PACKAGE" "*PACKAGE*" + "DELETE-PACKAGE" "EXPORT") "TB") + (defun symbol-package (symbol) + (get symbol 'symbol-package)) + + (defsetf symbol-package (symbol) (new-package) + `(setf (get ,symbol 'symbol-package) ,new-package)) + ) + ((string= name "loop") ; needs hash-table and package + ) + ((string= name "condition") + (shadow '("CONDITION" + "BREAK" "ASSERT" + "CERROR" "ERROR" "SIGNAL" "WARN" + + "TYPE-ERROR-DATUM" "TYPE-ERROR-EXPECTED-TYPE" + "PACKAGE-ERROR-PACKAGE" "PRINT-NOT-READABLE-OBJECT" + "FILE-ERROR-PATHNAME" "STREAM-ERROR-STREAM" + "CELL-ERROR-NAME" "UNBOUND-SLOT-INSTANCE" + "ARITHMETIC-ERROR-OPERATION" "ARITHMETIC-ERROR-OPERANDS" + "SIMPLE-CONDITION-FORMAT-CONTROL" + "SIMPLE-CONDITION-FORMAT-ARGUMENTS" + + "CHECK-TYPE" "HANDLER-BIND" "HANDLER-CASE" + "INVOKE-RESTART" "RESTART" "MAKE-RESTART" + "RESTART-NAME" "RESTART-FUNCTION" "RESTART-REPORT-FUNCTION" + "RESTART-INTERACTIVE-FUNCTION" "RESTART-TEST-FUNCTION" + "RESTART-CASE" "RESTART-BIND" + "ABORT" "MUFFLE-WARNING" "CONTINUE" "STORE-VALUE" "USE-VALUE" + ) + "TB") + + (eval `(cl:define-condition ,(intern "CONDITION") (cl:condition) ())) + + ) + ((string= name "reader") + (shadow '("READTABLE" "READTABLEP" "READTABLE-CASE" "*READTABLE*" + "READER-ERROR") "TB")) + ((string= name "printer") ; needs reader + (shadow '("PRINT-OBJECT"))) + ((string= name "sequence") + (shadow '("SEARCH"))) + ((string= name "clos") + ) + ) + (let ((*package* (find-package "TESTBED"))) + (funcall #'load (concatenate 'string cl-user::*sacla-lisp-dir* "/" name)) + + (cond + ((string= name "package") + (format t "~%Cloning the package system!~%") + (clone-package-system)) + ((string= name "loop") + ))) + ) + +(defun test (name) + (let ((tests (with-open-file (in (concatenate 'string + cl-user::*sacla-lisp-tests-dir* + "/" name ".lisp")) + (loop for sexp = (read in nil) + while sexp + collect sexp)))) + (format t "Testing ~d tests in ~S~%" (length tests) name) + (do* ((count 1 (1+ count)) + (failed 0) + (skipped 0) + (err nil nil) + (tests tests (cdr tests))) + ((null tests) + (format t "~%All = ~d~%OK = ~d~%Skipped = ~d~%Failed = ~d~%" + (1- count) (- count 1 skipped failed) skipped failed) + (return (zerop failed))) + (format t "~d " count) + (case (handler-case (eval (first tests)) (error (e) (setq err e) nil)) + ((nil) + (format t "Failed : ~S~%" (first tests)) + (when err (print err)) + (incf failed)) + (skipped + (format t "Skipped ") + (incf skipped)))))) -- cgit v1.2.3