X-Git-Url: http://git.kpe.io/?p=kmrcl.git;a=blobdiff_plain;f=symbols.lisp;h=802deb31bd8235b47075ff580356530206815290;hp=f2af14bc4430a8935736ab95d3208f7e36b23248;hb=54cd6cb1b9550ac2310e2c6dffc9cdecd2bdccd3;hpb=4de7f25a69c218303f170314ac26217770a531ed diff --git a/symbols.lisp b/symbols.lisp index f2af14b..802deb3 100644 --- a/symbols.lisp +++ b/symbols.lisp @@ -7,43 +7,51 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: symbols.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $ -;;;; -;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg ;;;; ;;;; KMRCL users are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package :kmrcl) +(in-package #:kmrcl) -(defun cl-symbols () - (append (cl-variables) (cl-functions))) +;;; Symbol functions -(defun cl-variables () +(defun cl-symbol-list (test-fn) (let ((vars '())) (do-symbols (s 'common-lisp) (multiple-value-bind (sym status) - (find-symbol (symbol-name s) 'common-lisp) - (when (and (or (eq status :external) - (eq status :internal)) - (boundp sym)) - (push sym vars)))) + (find-symbol (symbol-name s) 'common-lisp) + (when (and (or (eq status :external) + (eq status :internal)) + (funcall test-fn sym)) + (push sym vars)))) (nreverse vars))) +(defun cl-variables () + (cl-symbol-list #'boundp)) + (defun cl-functions () - (let ((funcs '())) - (do-symbols (s 'common-lisp) - (multiple-value-bind (sym status) - (find-symbol (symbol-name s) 'common-lisp) - (when (and (or (eq status :external) - (eq status :internal)) - (fboundp sym)) - (push sym funcs)))) - (nreverse funcs))) + (cl-symbol-list #'fboundp)) -;;; Symbol functions +(defun cl-symbols () + (nconc (cl-variables) (cl-functions))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew 'kmrcl::kmrcl-lowercase-reader *features*)) + (when (not (string= (symbol-name '#:a) + (symbol-name '#:A))) + (pushnew 'kmrcl::kmrcl-case-sensitive *features*))) + +(defun string-default-case (str) + #+(and (not kmrcl::kmrcl-lowercase-reader)) (string-upcase str) + #+(and kmrcl::kmrcl-lowercase-reader) (string-downcase str)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setq cl:*features* (delete 'kmrcl::kmrcl-lowercase-reader *features*)) + (setq cl:*features* (delete 'kmrcl::kmrcl-case-sensitive *features*))) (defun concat-symbol-pkg (pkg &rest args) (declare (dynamic-extent args)) @@ -54,9 +62,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,34 +73,63 @@ "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 (:variables (show-variables package)) (:functions (show-functions package)))) -(defun show-variables (package) +(defun print-symbols (package test-fn value-fn &optional (stream *standard-output*)) (do-symbols (s package) (multiple-value-bind (sym status) - (find-symbol (symbol-name s) package) + (find-symbol (symbol-name s) package) (when (and (or (eq status :external) - (eq status :internal)) - (boundp sym)) - (format t "~&Symbol ~S~T -> ~S~%" - sym - (symbol-value sym)))))) + (eq status :internal)) + (funcall test-fn sym)) + (format stream "~&Symbol ~S~T -> ~S~%" + sym + (funcall value-fn sym)))))) -(defun show-functions (package) - (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)) - (format t "~&Function ~S~T -> ~S~%" - sym - (symbol-function sym)))))) +(defun show-variables (&optional (package *package*) (stream *standard-output*)) + (print-symbols package 'boundp 'symbol-value stream)) + +(defun show-functions (&optional (package *package*) (stream *standard-output*)) + (print-symbols package 'fboundp 'symbol-function stream)) + +(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))