r4666: *** empty log message ***

[kmrcl.git] / symbols.lisp

diff --git a/symbols.lisp b/symbols.lisp
new file mode 100644 (file)
index 0000000..f2af14b
--- /dev/null
+++ b/symbols.lisp
@@ -0,0 +1,99 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cl-symbols.lisp
+;;;; Purpose:       Returns all defined Common Lisp symbols
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: symbols.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+(defun cl-symbols ()
+  (append (cl-variables) (cl-functions)))
+
+(defun cl-variables ()
+  (let ((vars '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+         (find-symbol (symbol-name s) 'common-lisp)
+       (when (and (or (eq status :external)
+                      (eq status :internal))
+                  (boundp sym))
+         (push sym vars))))
+    (nreverse vars)))
+
+(defun cl-functions ()
+  (let ((funcs '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) 'common-lisp)
+       (when (and (or (eq status :external)
+                      (eq status :internal))
+                  (fboundp sym))
+         (push sym funcs))))
+    (nreverse funcs)))
+
+;;; Symbol functions
+
+(defun concat-symbol-pkg (pkg &rest args)
+  (declare (dynamic-extent args))
+  (flet ((stringify (arg)
+           (etypecase arg
+             (string
+              (string-upcase arg))
+             (symbol
+              (symbol-name arg)))))
+    (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
+      (intern #-case-sensitive (string-upcase str)
+             #+case-sensitive str
+             (if pkg pkg *package*)))))
+
+
+(defun concat-symbol (&rest args)
+  (apply #'concat-symbol-pkg nil args))
+
+(defun ensure-keyword (name)
+  "Returns keyword for a name"
+  (etypecase name
+    (keyword name)
+    (string (intern #-case-sensitive (string-upcase name)
+                   #+case-sensitive name
+                   :keyword))
+    (symbol (intern (symbol-name name) :keyword))))
+
+(defun show (&optional (what :variables) (package *package*))
+  (ecase what
+    (:variables (show-variables package))
+    (:functions (show-functions package))))
+
+(defun show-variables (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                    (eq status :internal))
+                (boundp sym))
+       (format t "~&Symbol ~S~T -> ~S~%"
+               sym
+               (symbol-value sym))))))
+
+(defun show-functions (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                    (eq status :internal))
+                (fboundp sym))
+       (format t "~&Function ~S~T -> ~S~%"
+               sym
+               (symbol-function sym))))))