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