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 ;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17 (in-package #:kmrcl)
  18
  19 ;;; Symbol functions
  20
  21 (defun cl-symbol-list (test-fn)
  22   (let ((vars '()))
  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))
  29           (push sym vars))))
  30     (nreverse vars)))
  31
  32 (defun cl-variables ()
  33   (cl-symbol-list #'boundp))
  34
  35 (defun cl-functions ()
  36   (cl-symbol-list #'fboundp))
  37
  38 (defun cl-symbols ()
  39   (nconc (cl-variables) (cl-functions)))
  40
  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)
  45                       (symbol-name '#:A)))
  46     (pushnew 'kmrcl::kmrcl-case-sensitive *features*)))
  47
  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))
  51
  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*)))
  55
  56 (defun concat-symbol-pkg (pkg &rest args)
  57   (declare (dynamic-extent args))
  58   (flet ((stringify (arg)
  59            (etypecase arg
  60              (string
  61               (string-upcase arg))
  62              (symbol
  63               (symbol-name arg)))))
  64     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
  65       (nth-value 0 (intern (string-default-case str)
  66                            (if pkg pkg *package*))))))
  67
  68
  69 (defun concat-symbol (&rest args)
  70   (apply #'concat-symbol-pkg nil args))
  71
  72 (defun ensure-keyword (name)
  73   "Returns keyword for a name"
  74   (etypecase name
  75     (keyword name)
  76     (string (nth-value 0 (intern (string-default-case name) :keyword)))
  77     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
  78
  79 (defun ensure-keyword-upcase (desig)
  80   (nth-value 0 (intern (string-upcase
  81                         (symbol-name (ensure-keyword desig))) :keyword)))
  82
  83 (defun ensure-keyword-default-case (desig)
  84   (nth-value 0 (intern (string-default-case
  85                         (symbol-name (ensure-keyword desig))) :keyword)))
  86
  87 (defun show (&optional (what :variables) (package *package*))
  88   (ecase what
  89     (:variables (show-variables package))
  90     (:functions (show-functions package))))
  91
  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~%"
 100                 sym
 101                 (funcall value-fn sym))))))
 102
 103 (defun show-variables (&optional (package *package*) (stream *standard-output*))
 104   (print-symbols package 'boundp 'symbol-value stream))
 105
 106 (defun show-functions (&optional (package *package*) (stream *standard-output*))
 107   (print-symbols package 'fboundp 'symbol-function stream))
 108
 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-'"
 112   (let ((res)
 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))
 119                    (fboundp sym)
 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)
 124                    (plusp
 125                     (length
 126                      (compute-applicable-methods
 127                       (ensure-generic-function sym)
 128                       (list instance)))))
 129           (push sym res))))
 130     (nreverse res)))
 131
 132 (defun run-tests-for-instance (instance)
 133   (dolist (gf-name (find-test-generic-functions instance))
 134     (funcall gf-name instance))
 135   (values))