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                            (or 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 (defun make-symbol-name (sym)
  69   (let* ((name (symbol-name sym))
  70          (start (if (char= (char name 0) #\$) 1 0))
  71          (end (- (length name)
  72                  (if (char= (char name (1- (length name))) #\$) 1 0))))
  73     (concatenate 'string (subseq name start end) "-")))
  74
  75 (defun make-gensym (var)
  76   (etypecase var
  77     (symbol `(,var (gensym ,(make-symbol-name var))))
  78     (cons   `(,(first var) (gensym ,(string (second var)))))))
  79
  80 (defmacro with-gensyms (vars &body body)
  81   (if vars
  82       `(let ,(mapcar #'make-gensym vars)
  83          ,@body)
  84       `(progn ,@body)))
  85
  86 ;; cribbed from ALEXANDRIA
  87 (defmacro once-only (names &body forms)
  88   "Evaluates FORMS with NAMES rebound to temporary variables,
  89 ensuring that each is evaluated only once.
  90 Example:
  91   (defmacro cons1 (x) (once-only (x) `(cons ,x ,x)))
  92   (let ((y 0)) (cons1 (incf y))) => (1 . 1)"
  93   (flet ((make-gensym-list (length &optional x)
  94            "Returns a list of LENGTH gensyms, each generated with a call to
  95 GENSYM using (if provided) as the argument."
  96            (loop :repeat length
  97               :collect (gensym x))))
  98     (let ((gensyms (make-gensym-list (length names) "ONCE-ONLY")))
  99       ;; bind in user-macro
 100       `(let ,(mapcar (lambda (g n) (list g `(gensym ,(make-symbol-name n))))
 101                      gensyms names)
 102          ;; bind in final expansion
 103          `(let (,,@(mapcar (lambda (g n) ``(,,g ,,n)) gensyms names))
 104             ;; bind in user-macro
 105             ,(let ,(mapcar #'list names gensyms)
 106                   ,@forms))))))
 107
 108 (export '(string-default-case concat-symbol-pkg concat-symbol
 109           ensure-keyword ensure-keyword-upcase ensure-keyword-default-case
 110           with-gensyms once-only))