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
12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; KMRCL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
22 (append (cl-variables) (cl-functions)))
24 (defun cl-variables ()
26 (do-symbols (s 'common-lisp)
27 (multiple-value-bind (sym status)
28 (find-symbol (symbol-name s) 'common-lisp)
29 (when (and (or (eq status :external)
30 (eq status :internal))
35 (defun cl-functions ()
37 (do-symbols (s 'common-lisp)
38 (multiple-value-bind (sym status)
39 (find-symbol (symbol-name s) 'common-lisp)
40 (when (and (or (eq status :external)
41 (eq status :internal))
48 (eval-when (:compile-toplevel :load-toplevel :execute)
49 (when (char= #\a (schar (symbol-name '#:a) 0))
50 (pushnew :kmrcl-lowercase-reader *features*))
51 (when (not (string= (symbol-name '#:a)
53 (pushnew :kmrcl-case-sensitive *features*)))
55 (defun string-default-case (str)
56 #+kmrcl-case-sensitive str
57 #+(and (not kmrcl-case-sensitive) (not kmrcl-lowercase-reader)) (string-upcase str)
58 #+(and (not kmrcl-case-sensitive) kmrcl-lowercase-reader) (string-downcase str))
60 (eval-when (:compile-toplevel :load-toplevel :execute)
61 (setq cl:*features* (delete :kmrcl-lowercase-reader *features*))
62 (setq cl:*features* (delete :kmrcl-case-sensitive *features*)))
64 (defun concat-symbol-pkg (pkg &rest args)
65 (declare (dynamic-extent args))
66 (flet ((stringify (arg)
72 (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
73 (nth-value 0 (intern (string-default-case str)
74 (if pkg pkg *package*))))))
77 (defun concat-symbol (&rest args)
78 (apply #'concat-symbol-pkg nil args))
80 (defun ensure-keyword (name)
81 "Returns keyword for a name"
84 (string (nth-value 0 (intern (string-default-case name) :keyword)))
85 (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
87 (defun ensure-keyword-upcase (desig)
88 (nth-value 0 (intern (string-upcase
89 (symbol-name (ensure-keyword desig))) :keyword)))
91 (defun ensure-keyword-default-case (desig)
92 (nth-value 0 (intern (string-default-case
93 (symbol-name (ensure-keyword desig))) :keyword)))
95 (defun show (&optional (what :variables) (package *package*))
97 (:variables (show-variables package))
98 (:functions (show-functions package))))
100 (defun show-variables (package)
101 (do-symbols (s package)
102 (multiple-value-bind (sym status)
103 (find-symbol (symbol-name s) package)
104 (when (and (or (eq status :external)
105 (eq status :internal))
107 (format t "~&Symbol ~S~T -> ~S~%"
109 (symbol-value sym))))))
111 (defun show-functions (package)
112 (do-symbols (s package)
113 (multiple-value-bind (sym status)
114 (find-symbol (symbol-name s) package)
115 (when (and (or (eq status :external)
116 (eq status :internal))
118 (format t "~&Function ~S~T -> ~S~%"
120 (symbol-function sym))))))
122 (defun find-test-generic-functions (instance)
123 "Return a list of symbols for generic functions specialized on the
124 class of an instance and whose name begins with the string 'test-'"
126 (package (symbol-package (class-name (class-of instance)))))
127 (do-symbols (s package)
128 (multiple-value-bind (sym status)
129 (find-symbol (symbol-name s) package)
130 (when (and (or (eq status :external)
131 (eq status :internal))
133 (eq (symbol-package sym) package)
134 (> (length (symbol-name sym)) 5)
135 (string-equal "test-" (subseq (symbol-name sym) 0 5))
136 (typep (symbol-function sym) 'generic-function)
139 (compute-applicable-methods
140 (ensure-generic-function sym)
145 (defun run-tests-for-instance (instance)
146 (dolist (gf-name(find-test-generic-functions instance))
147 (funcall gf-name instance))