symbols.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          cl-symbols.lisp
   6 ;;;; Purpose:       Returns all defined Common Lisp symbols
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Apr 2000
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (in-package #:kmrcl)
  20
  21 (defun cl-symbols ()
  22   (append (cl-variables) (cl-functions)))
  23
  24 (defun cl-variables ()
  25   (let ((vars '()))
  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))
  31                    (boundp sym))
  32           (push sym vars))))
  33     (nreverse vars)))
  34
  35 (defun cl-functions ()
  36   (let ((funcs '()))
  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))
  42                    (fboundp sym))
  43           (push sym funcs))))
  44     (nreverse funcs)))
  45
  46 ;;; Symbol functions
  47
  48 (eval-when (:compile-toplevel :load-toplevel :execute)
  49   (when (char= #\a (schar (symbol-name '#:a) 0))
  50     (pushnew :lowercase-reader *features*)))
  51
  52 (defun string-default-case (str)
  53    #+(and (not case-sensitive) (not lowercase-reader))
  54    (string-upcase str)
  55    #+(and (not case-sensitive) lowercase-reader)
  56    (string-downcase str)
  57    #+case-sensitive
  58    str)
  59
  60 (defun concat-symbol-pkg (pkg &rest args)
  61   (declare (dynamic-extent args))
  62   (flet ((stringify (arg)
  63            (etypecase arg
  64              (string
  65               (string-upcase arg))
  66              (symbol
  67               (symbol-name arg)))))
  68     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
  69       (intern (string-default-case str)
  70               (if pkg pkg *package*)))))
  71
  72
  73 (defun concat-symbol (&rest args)
  74   (apply #'concat-symbol-pkg nil args))
  75
  76 (defun ensure-keyword (name)
  77   "Returns keyword for a name"
  78   (etypecase name
  79     (keyword name)
  80     (string (intern (string-default-case name) :keyword))
  81     (symbol (intern (symbol-name name) :keyword))))
  82
  83 (defun show (&optional (what :variables) (package *package*))
  84   (ecase what
  85     (:variables (show-variables package))
  86     (:functions (show-functions package))))
  87
  88 (defun show-variables (package)
  89   (do-symbols (s package)
  90     (multiple-value-bind (sym status)
  91         (find-symbol (symbol-name s) package)
  92       (when (and (or (eq status :external)
  93                      (eq status :internal))
  94                  (boundp sym))
  95         (format t "~&Symbol ~S~T -> ~S~%"
  96                 sym
  97                 (symbol-value sym))))))
  98
  99 (defun show-functions (package)
 100   (do-symbols (s package)
 101     (multiple-value-bind (sym status)
 102         (find-symbol (symbol-name s) package)
 103       (when (and (or (eq status :external)
 104                      (eq status :internal))
 105                  (fboundp sym))
 106         (format t "~&Function ~S~T -> ~S~%"
 107                 sym
 108                 (symbol-function sym))))))
 109
 110 (defun find-test-generic-functions (instance)
 111   "Return a list of symbols for generic functions specialized on the
 112 class of an instance and whose name begins with the string 'test-'"
 113   (let ((res)
 114         (package (symbol-package (class-name (class-of instance)))))
 115     (do-symbols (s package)
 116       (multiple-value-bind (sym status)
 117           (find-symbol (symbol-name s) package)
 118         (when (and (or (eq status :external)
 119                        (eq status :internal))
 120                    (fboundp sym)
 121                    (eq (symbol-package sym) package)
 122                    (> (length (symbol-name sym)) 5)
 123                    (string-equal "test-" (subseq (symbol-name sym) 0 5))
 124                    (typep (symbol-function sym) 'generic-function)
 125                    (plusp
 126                     (length
 127                      (compute-applicable-methods
 128                       (ensure-generic-function sym)
 129                       (list instance)))))
 130           (push sym res))))
 131     (nreverse res)))
 132
 133 (defun run-tests-for-instance (instance)
 134   (dolist (gf-name(find-test-generic-functions instance))
 135     (funcall gf-name instance))
 136   (values))