utils/symbols.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          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 9652 2004-06-17 20:32:00Z kevin $
  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 :iolib-utils)
  20
  21 ;;; Symbol functions
  22
  23 (eval-when (:compile-toplevel :load-toplevel :execute)
  24   (when (char= #\a (schar (symbol-name '#:a) 0))
  25     (pushnew :iolib-utils-lowercase-reader *features*))
  26   (when (not (string= (symbol-name '#:a)
  27                       (symbol-name '#:A)))
  28     (pushnew :iolib-utils-case-sensitive *features*)))
  29
  30 (defun string-default-case (str)
  31   #+(and (not iolib-utils-lowercase-reader)) (string-upcase str)
  32   #+(and iolib-utils-lowercase-reader) (string-downcase str))
  33
  34 (eval-when (:compile-toplevel :load-toplevel :execute)
  35   (setq cl:*features* (delete :iolib-utils-lowercase-reader *features*))
  36   (setq cl:*features* (delete :iolib-utils-case-sensitive *features*)))
  37
  38 (defun concat-symbol-pkg (pkg &rest args)
  39   (declare (dynamic-extent args))
  40   (flet ((stringify (arg)
  41            (etypecase arg
  42              (string
  43               (string-upcase arg))
  44              (symbol
  45               (symbol-name arg)))))
  46     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
  47       (nth-value 0 (intern (string-default-case str)
  48                            (if pkg pkg *package*))))))
  49
  50 (defun concat-symbol (&rest args)
  51   (apply #'concat-symbol-pkg nil args))
  52
  53 (defun ensure-keyword (name)
  54   "Returns keyword for a name"
  55   (etypecase name
  56     (keyword name)
  57     (string (nth-value 0 (intern (string-default-case name) :keyword)))
  58     (symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
  59
  60 (defun ensure-keyword-upcase (desig)
  61   (nth-value 0 (intern (string-upcase
  62                         (symbol-name (ensure-keyword desig))) :keyword)))
  63
  64 (defun ensure-keyword-default-case (desig)
  65   (nth-value 0 (intern (string-default-case
  66                         (symbol-name (ensure-keyword desig))) :keyword)))
  67
  68 (export '(string-default-case concat-symbol-pkg concat-symbol
  69           ensure-keyword ensure-keyword-upcase ensure-keyword-default-case))