X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=symbols.lisp;h=870426e3e426169733930484047e168791a43908;hp=7ec505f699e90d5df674d5543dc8ea222238ffea;hb=e96b017d2a09ffd9c9279cb4c2341c53f0581022;hpb=4a5b626f01db51b02f969adb33ddad6aa9ee303a diff --git a/symbols.lisp b/symbols.lisp index 7ec505f..870426e 100644 --- a/symbols.lisp +++ b/symbols.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: symbols.lisp,v 1.2 2003/06/06 21:59:30 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -45,6 +45,21 @@ ;;; Symbol functions +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :kmrcl-lowercase-reader *features*)) + (when (not (string= (symbol-name '#:a) + (symbol-name '#:A))) + (pushnew :kmrcl-case-sensitive *features*))) + +(defun string-default-case (str) + #+(and (not kmrcl-lowercase-reader)) (string-upcase str) + #+(and kmrcl-lowercase-reader) (string-downcase str)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete :kmrcl-lowercase-reader *features*)) + (setq cl:*features* (delete :kmrcl-case-sensitive *features*))) + (defun concat-symbol-pkg (pkg &rest args) (declare (dynamic-extent args)) (flet ((stringify (arg) @@ -54,9 +69,8 @@ (symbol (symbol-name arg))))) (let ((str (apply #'concatenate 'string (mapcar #'stringify args)))) - (intern #-case-sensitive (string-upcase str) - #+case-sensitive str - (if pkg pkg *package*))))) + (nth-value 0 (intern (string-default-case str) + (if pkg pkg *package*)))))) (defun concat-symbol (&rest args) @@ -66,10 +80,16 @@ "Returns keyword for a name" (etypecase name (keyword name) - (string (intern #-case-sensitive (string-upcase name) - #+case-sensitive name - :keyword)) - (symbol (intern (symbol-name name) :keyword)))) + (string (nth-value 0 (intern (string-default-case name) :keyword))) + (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) + +(defun ensure-keyword-upcase (desig) + (nth-value 0 (intern (string-upcase + (symbol-name (ensure-keyword desig))) :keyword))) + +(defun ensure-keyword-default-case (desig) + (nth-value 0 (intern (string-default-case + (symbol-name (ensure-keyword desig))) :keyword))) (defun show (&optional (what :variables) (package *package*)) (ecase what @@ -97,3 +117,31 @@ (format t "~&Function ~S~T -> ~S~%" sym (symbol-function sym)))))) + +(defun find-test-generic-functions (instance) + "Return a list of symbols for generic functions specialized on the +class of an instance and whose name begins with the string 'test-'" + (let ((res) + (package (symbol-package (class-name (class-of instance))))) + (do-symbols (s package) + (multiple-value-bind (sym status) + (find-symbol (symbol-name s) package) + (when (and (or (eq status :external) + (eq status :internal)) + (fboundp sym) + (eq (symbol-package sym) package) + (> (length (symbol-name sym)) 5) + (string-equal "test-" (subseq (symbol-name sym) 0 5)) + (typep (symbol-function sym) 'generic-function) + (plusp + (length + (compute-applicable-methods + (ensure-generic-function sym) + (list instance))))) + (push sym res)))) + (nreverse res))) + +(defun run-tests-for-instance (instance) + (dolist (gf-name(find-test-generic-functions instance)) + (funcall gf-name instance)) + (values))