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 :kmrcl-lowercase-reader *features*))
  51   (when (not (string= (symbol-name '#:a)
  52                       (symbol-name '#:A)))
  53     (pushnew :kmrcl-case-sensitive *features*)))
  54
  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))
  59
  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*)))
  63
  64 (defun concat-symbol-pkg (pkg &rest args)
  65   (declare (dynamic-extent args))
  66   (flet ((stringify (arg)
  67            (etypecase arg
  68              (string
  69               (string-upcase arg))
  70              (symbol
  71               (symbol-name arg)))))
  72     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
  73       (nth-value 0 (intern (string-default-case str)
  74                            (if pkg pkg *package*))))))
  75
  76
  77 (defun concat-symbol (&rest args)
  78   (apply #'concat-symbol-pkg nil args))
  79
  80 (defun ensure-keyword (name)
  81   "Returns keyword for a name"
  82   (etypecase name
  83     (keyword name)
  84     (string (nth-value 0 (intern (string-default-case name) :keyword)))
  85     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
  86
  87 (defun ensure-keyword-upcase (desig)
  88   (nth-value 0 (intern (string-upcase
  89                         (symbol-name (ensure-keyword desig))) :keyword)))
  90
  91 (defun ensure-keyword-default-case (desig)
  92   (nth-value 0 (intern (string-default-case
  93                         (symbol-name (ensure-keyword desig))) :keyword)))
  94
  95 (defun show (&optional (what :variables) (package *package*))
  96   (ecase what
  97     (:variables (show-variables package))
  98     (:functions (show-functions package))))
  99
 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))
 106                  (boundp sym))
 107         (format t "~&Symbol ~S~T -> ~S~%"
 108                 sym
 109                 (symbol-value sym))))))
 110
 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))
 117                  (fboundp sym))
 118         (format t "~&Function ~S~T -> ~S~%"
 119                 sym
 120                 (symbol-function sym))))))
 121
 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-'"
 125   (let ((res)
 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))
 132                    (fboundp sym)
 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)
 137                    (plusp
 138                     (length
 139                      (compute-applicable-methods
 140                       (ensure-generic-function sym)
 141                       (list instance)))))
 142           (push sym res))))
 143     (nreverse res)))
 144
 145 (defun run-tests-for-instance (instance)
 146   (dolist (gf-name(find-test-generic-functions instance))
 147     (funcall gf-name instance))
 148   (values))