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   #+(and (not kmrcl-lowercase-reader)) (string-upcase str)
  57   #+(and kmrcl-lowercase-reader) (string-downcase str))
  58
  59 (eval-when (:compile-toplevel :load-toplevel :execute)
  60   (setq cl:*features* (delete :kmrcl-lowercase-reader *features*))
  61   (setq cl:*features* (delete :kmrcl-case-sensitive *features*)))
  62
  63 (defun concat-symbol-pkg (pkg &rest args)
  64   (declare (dynamic-extent args))
  65   (flet ((stringify (arg)
  66            (etypecase arg
  67              (string
  68               (string-upcase arg))
  69              (symbol
  70               (symbol-name arg)))))
  71     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
  72       (nth-value 0 (intern (string-default-case str)
  73                            (if pkg pkg *package*))))))
  74
  75
  76 (defun concat-symbol (&rest args)
  77   (apply #'concat-symbol-pkg nil args))
  78
  79 (defun ensure-keyword (name)
  80   "Returns keyword for a name"
  81   (etypecase name
  82     (keyword name)
  83     (string (nth-value 0 (intern (string-default-case name) :keyword)))
  84     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
  85
  86 (defun ensure-keyword-upcase (desig)
  87   (nth-value 0 (intern (string-upcase
  88                         (symbol-name (ensure-keyword desig))) :keyword)))
  89
  90 (defun ensure-keyword-default-case (desig)
  91   (nth-value 0 (intern (string-default-case
  92                         (symbol-name (ensure-keyword desig))) :keyword)))
  93
  94 (defun show (&optional (what :variables) (package *package*))
  95   (ecase what
  96     (:variables (show-variables package))
  97     (:functions (show-functions package))))
  98
  99 (defun show-variables (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                  (boundp sym))
 106         (format t "~&Symbol ~S~T -> ~S~%"
 107                 sym
 108                 (symbol-value sym))))))
 109
 110 (defun show-functions (package)
 111   (do-symbols (s package)
 112     (multiple-value-bind (sym status)
 113         (find-symbol (symbol-name s) package)
 114       (when (and (or (eq status :external)
 115                      (eq status :internal))
 116                  (fboundp sym))
 117         (format t "~&Function ~S~T -> ~S~%"
 118                 sym
 119                 (symbol-function sym))))))
 120
 121 (defun find-test-generic-functions (instance)
 122   "Return a list of symbols for generic functions specialized on the
 123 class of an instance and whose name begins with the string 'test-'"
 124   (let ((res)
 125         (package (symbol-package (class-name (class-of instance)))))
 126     (do-symbols (s package)
 127       (multiple-value-bind (sym status)
 128           (find-symbol (symbol-name s) package)
 129         (when (and (or (eq status :external)
 130                        (eq status :internal))
 131                    (fboundp sym)
 132                    (eq (symbol-package sym) package)
 133                    (> (length (symbol-name sym)) 5)
 134                    (string-equal "test-" (subseq (symbol-name sym) 0 5))
 135                    (typep (symbol-function sym) 'generic-function)
 136                    (plusp
 137                     (length
 138                      (compute-applicable-methods
 139                       (ensure-generic-function sym)
 140                       (list instance)))))
 141           (push sym res))))
 142     (nreverse res)))
 143
 144 (defun run-tests-for-instance (instance)
 145   (dolist (gf-name(find-test-generic-functions instance))
 146     (funcall gf-name instance))
 147   (values))