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 ensure-keyword-upcase (desig)
  84   (intern (string-upcase (symbol-name (ensure-keyword desig))) :keyword))
  85
  86 (defun ensure-keyword-default-case (desig)
  87   (intern (string-default-case (symbol-name (ensure-keyword desig))) :keyword))
  88
  89 (defun show (&optional (what :variables) (package *package*))
  90   (ecase what
  91     (:variables (show-variables package))
  92     (:functions (show-functions package))))
  93
  94 (defun show-variables (package)
  95   (do-symbols (s package)
  96     (multiple-value-bind (sym status)
  97         (find-symbol (symbol-name s) package)
  98       (when (and (or (eq status :external)
  99                      (eq status :internal))
 100                  (boundp sym))
 101         (format t "~&Symbol ~S~T -> ~S~%"
 102                 sym
 103                 (symbol-value sym))))))
 104
 105 (defun show-functions (package)
 106   (do-symbols (s package)
 107     (multiple-value-bind (sym status)
 108         (find-symbol (symbol-name s) package)
 109       (when (and (or (eq status :external)
 110                      (eq status :internal))
 111                  (fboundp sym))
 112         (format t "~&Function ~S~T -> ~S~%"
 113                 sym
 114                 (symbol-function sym))))))
 115
 116 (defun find-test-generic-functions (instance)
 117   "Return a list of symbols for generic functions specialized on the
 118 class of an instance and whose name begins with the string 'test-'"
 119   (let ((res)
 120         (package (symbol-package (class-name (class-of instance)))))
 121     (do-symbols (s package)
 122       (multiple-value-bind (sym status)
 123           (find-symbol (symbol-name s) package)
 124         (when (and (or (eq status :external)
 125                        (eq status :internal))
 126                    (fboundp sym)
 127                    (eq (symbol-package sym) package)
 128                    (> (length (symbol-name sym)) 5)
 129                    (string-equal "test-" (subseq (symbol-name sym) 0 5))
 130                    (typep (symbol-function sym) 'generic-function)
 131                    (plusp
 132                     (length
 133                      (compute-applicable-methods
 134                       (ensure-generic-function sym)
 135                       (list instance)))))
 136           (push sym res))))
 137     (nreverse res)))
 138
 139 (defun run-tests-for-instance (instance)
 140   (dolist (gf-name(find-test-generic-functions instance))
 141     (funcall gf-name instance))
 142   (values))