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: symbols.lisp,v 1.2 2003/06/06 21:59:30 kevin Exp $
  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 (defun concat-symbol-pkg (pkg &rest args)
  49   (declare (dynamic-extent args))
  50   (flet ((stringify (arg)
  51            (etypecase arg
  52              (string
  53               (string-upcase arg))
  54              (symbol
  55               (symbol-name arg)))))
  56     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
  57       (intern #-case-sensitive (string-upcase str)
  58               #+case-sensitive str
  59               (if pkg pkg *package*)))))
  60
  61
  62 (defun concat-symbol (&rest args)
  63   (apply #'concat-symbol-pkg nil args))
  64
  65 (defun ensure-keyword (name)
  66   "Returns keyword for a name"
  67   (etypecase name
  68     (keyword name)
  69     (string (intern #-case-sensitive (string-upcase name)
  70                     #+case-sensitive name
  71                     :keyword))
  72     (symbol (intern (symbol-name name) :keyword))))
  73
  74 (defun show (&optional (what :variables) (package *package*))
  75   (ecase what
  76     (:variables (show-variables package))
  77     (:functions (show-functions package))))
  78
  79 (defun show-variables (package)
  80   (do-symbols (s package)
  81     (multiple-value-bind (sym status)
  82         (find-symbol (symbol-name s) package)
  83       (when (and (or (eq status :external)
  84                      (eq status :internal))
  85                  (boundp sym))
  86         (format t "~&Symbol ~S~T -> ~S~%"
  87                 sym
  88                 (symbol-value sym))))))
  89
  90 (defun show-functions (package)
  91   (do-symbols (s package)
  92     (multiple-value-bind (sym status)
  93         (find-symbol (symbol-name s) package)
  94       (when (and (or (eq status :external)
  95                      (eq status :internal))
  96                  (fboundp sym))
  97         (format t "~&Function ~S~T -> ~S~%"
  98                 sym
  99                 (symbol-function sym))))))