1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: cl-symbols.lisp
6 ;;;; Purpose: Returns all defined Common Lisp symbols
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
12 ;;;; KMRCL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
21 (defun cl-symbol-list (test-fn)
23 (do-symbols (s 'common-lisp)
24 (multiple-value-bind (sym status)
25 (find-symbol (symbol-name s) 'common-lisp)
26 (when (and (or (eq status :external)
27 (eq status :internal))
28 (funcall test-fn sym))
32 (defun cl-variables ()
33 (cl-symbol-list #'boundp))
35 (defun cl-functions ()
36 (cl-symbol-list #'fboundp))
39 (nconc (cl-variables) (cl-functions)))
41 (eval-when (:compile-toplevel :load-toplevel :execute)
42 (when (char= #\a (schar (symbol-name '#:a) 0))
43 (pushnew 'kmrcl::kmrcl-lowercase-reader *features*))
44 (when (not (string= (symbol-name '#:a)
46 (pushnew 'kmrcl::kmrcl-case-sensitive *features*)))
48 (defun string-default-case (str)
49 #+(and (not kmrcl::kmrcl-lowercase-reader)) (string-upcase str)
50 #+(and kmrcl::kmrcl-lowercase-reader) (string-downcase str))
52 (eval-when (:compile-toplevel :load-toplevel :execute)
53 (setq cl:*features* (delete 'kmrcl::kmrcl-lowercase-reader *features*))
54 (setq cl:*features* (delete 'kmrcl::kmrcl-case-sensitive *features*)))
56 (defun concat-symbol-pkg (pkg &rest args)
57 (declare (dynamic-extent args))
58 (flet ((stringify (arg)
64 (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
65 (nth-value 0 (intern (string-default-case str)
66 (if pkg pkg *package*))))))
69 (defun concat-symbol (&rest args)
70 (apply #'concat-symbol-pkg nil args))
72 (defun ensure-keyword (name)
73 "Returns keyword for a name"
76 (string (nth-value 0 (intern (string-default-case name) :keyword)))
77 (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
79 (defun ensure-keyword-upcase (desig)
80 (nth-value 0 (intern (string-upcase
81 (symbol-name (ensure-keyword desig))) :keyword)))
83 (defun ensure-keyword-default-case (desig)
84 (nth-value 0 (intern (string-default-case
85 (symbol-name (ensure-keyword desig))) :keyword)))
87 (defun show (&optional (what :variables) (package *package*))
89 (:variables (show-variables package))
90 (:functions (show-functions package))))
92 (defun print-symbols (package test-fn value-fn &optional (stream *standard-output*))
93 (do-symbols (s package)
94 (multiple-value-bind (sym status)
95 (find-symbol (symbol-name s) package)
96 (when (and (or (eq status :external)
97 (eq status :internal))
98 (funcall test-fn sym))
99 (format stream "~&Symbol ~S~T -> ~S~%"
101 (funcall value-fn sym))))))
103 (defun show-variables (&optional (package *package*) (stream *standard-output*))
104 (print-symbols package 'boundp 'symbol-value stream))
106 (defun show-functions (&optional (package *package*) (stream *standard-output*))
107 (print-symbols package 'fboundp 'symbol-function stream))
109 (defun find-test-generic-functions (instance)
110 "Return a list of symbols for generic functions specialized on the
111 class of an instance and whose name begins with the string 'test-'"
113 (package (symbol-package (class-name (class-of instance)))))
114 (do-symbols (s package)
115 (multiple-value-bind (sym status)
116 (find-symbol (symbol-name s) package)
117 (when (and (or (eq status :external)
118 (eq status :internal))
120 (eq (symbol-package sym) package)
121 (> (length (symbol-name sym)) 5)
122 (string-equal "test-" (subseq (symbol-name sym) 0 5))
123 (typep (symbol-function sym) 'generic-function)
126 (compute-applicable-methods
127 (ensure-generic-function sym)
132 (defun run-tests-for-instance (instance)
133 (dolist (gf-name (find-test-generic-functions instance))
134 (funcall gf-name instance))