utils.lisp

   1
   2
   3 (in-package :cl-tuples)
   4
   5 ;; float that fits within range of x86 hardware register minus tag (rather sbcl oriented)
   6 (deftype fast-float ()
   7   #+sbcl `(single-float   (#.(- (expt 2f0 64))) (#.(expt 2f0 64)))
   8   #-sbcl single-float)
   9
  10 ;; to do -- alexandria has these anyway -- use that
  11 (defmacro with-gensyms ((&rest names) &body body)
  12   "Classic macro for creating named unique symbols."
  13   `(let ,(loop for n in names collect `(,n (gensym)))
  14      ,@body))
  15
  16 (defmacro once-only ((&rest names) &body body)
  17   "Evaluate arguments once only in macro form body"
  18   (let ((gensyms (loop for n in names collect (gensym))))
  19     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
  20        `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
  21           ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
  22              ,@body)))))
  23
  24 ;; define helper functions we will use
  25
  26 (defun gensym-list (n)
  27   "Give us a list of gensyms n elements long"
  28   (loop
  29      for index from 0 below n
  30      collect (gensym)))
  31
  32 (defun last-char (str)
  33   (char str (1- (length str))))
  34
  35 (defun symbol-to-string (sym)
  36   "If the argument is a symbol or string, return it as a string."
  37   (check-type sym (or symbol string))
  38   (cond
  39     ((symbolp sym)
  40      (symbol-name sym))
  41     ((stringp sym)
  42      sym)))
  43
  44
  45 (defun make-adorned-symbol (name &key prefix suffix asterisk package)
  46   (check-type name (or string symbol))
  47   (check-type prefix (or symbol string null))
  48   (check-type suffix (or symbol string null))
  49   (intern (concatenate 'string
  50                        (when prefix
  51                          (string prefix))
  52                        (when prefix  "-")
  53                        (string name)
  54                        (when suffix
  55                          "-")
  56                        (when suffix
  57                          (string suffix))
  58                        (when asterisk
  59                          (string "*")))
  60           (if package package *package*)))
  61
  62 (defun make-suffixed-symbol (name suffix)
  63   (make-adorned-symbol name :suffix suffix))
  64
  65 (defun make-prefixed-symbol (name prefix)
  66   (make-adorned-symbol name :prefix prefix))
  67
  68 (defun is-asterisk-symbol (s)
  69   (let
  70           ((ss (symbol-to-string s)))
  71         (eql (aref ss (1- (length ss))) #\*)))
  72
  73 (defun make-element-names (elements type-name)
  74   "Given a list of element names form a set of symbols of the form
  75      <type-name>-<element-name> as used in struct elements."
  76   (check-type elements symbol)
  77   (check-type type-name symbol)
  78   (mapcar #'(lambda (x)
  79               (find-symbol
  80                (concatenate 'string
  81                             (symbol-name type-name) "-struct-"
  82                             (symbol-name x))))
  83           elements))
  84