Coverage report: /home/ellis/comp/core/std/sym.lisp

KindCoveredAll%
expression4184 48.8
branch36 50.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; sym.lisp --- Symbol utils
2
 
3
 ;; inspired by alexandria/symbols.lisp
4
 
5
 ;;; Code:
6
 (in-package :std/sym)
7
 
8
 ;;(std::reexport-from 
9
 ;; :sb-int
10
 ;; :include '(:with-unique-names :symbolicate :package-symbolicate :keywordicate :gensymify*))
11
 
12
 ;; On SBCL, `with-unique-names' is defined under
13
 ;; src/code/primordial-extensions.lisp. We use that instead of
14
 ;; defining our own.
15
 (eval-when (:compile-toplevel :load-toplevel :execute)
16
   (setf (macro-function 'with-gensyms) (macro-function 'with-unique-names)))
17
 
18
 (declaim (inline ensure-symbol))
19
 (defun ensure-symbol (name &optional (package *package*))
20
   "Returns a symbol with name designated by NAME, accessible in package
21
 designated by PACKAGE. If symbol is not already accessible in PACKAGE, it is
22
 interned there. Returns a secondary value reflecting the status of the symbol
23
 in the package, which matches the secondary return value of INTERN.
24
 
25
 Example:
26
 
27
   (ensure-symbol :cons :cl) => cl:cons, :external"
28
   (intern (string name) package))
29
 
30
 (defun maybe-intern (name package)
31
   "Intern NAME in PACKAGE if it exists, else return a fresh symbol of the same name."
32
   (values
33
    (if package
34
        (intern name (if (eq t package) *package* package))
35
        (make-symbol name))))
36
 
37
 (declaim (inline format-symbol))
38
 (defun format-symbol (package control &rest arguments)
39
   "Constructs a string by applying ARGUMENTS to string designator CONTROL as
40
 if by FORMAT within WITH-STANDARD-IO-SYNTAX, and then creates a symbol named
41
 by that string.
42
 
43
 If PACKAGE is NIL, returns an uninterned symbol, if package is T, returns a
44
 symbol interned in the current package, and otherwise returns a symbol
45
 interned in the package designated by PACKAGE."
46
   (maybe-intern (with-standard-io-syntax
47
                   (apply #'format nil (string control) arguments))
48
                 package))
49
 
50
 (defun make-keyword (name)
51
   "Interns the string designated by NAME in the KEYWORD package."
52
   (intern (string name) :keyword))
53
 
54
 (defmacro make-slot-name (name)
55
   "make slot-name"
56
   `(intern ,(string-upcase name) :keyword))
57
 
58
 (defun make-gensym (name)
59
   "If NAME is a non-negative integer, calls GENSYM using it. Otherwise NAME
60
 must be a string designator, in which case calls GENSYM using the designated
61
 string as the argument."
62
   (gensym (if (typep name '(integer 0))
63
               name
64
               (string name))))
65
 
66
 (defun mkstr (&rest args)
67
   "Print all ARGS to a temporary stream using PRINC and return the output as a string."
68
   (with-output-to-string (s)
69
     (dolist (a args) (princ a s))))
70
 
71
 (defun symb (&rest args)
72
   "Intern a new symbol with a name equal to the result of applying MKSTR to ARGS."
73
   (values (intern (apply #'mkstr args))))
74
 
75
 (sb-ext:with-unlocked-packages (:sb-int)
76
   (handler-bind
77
       ((sb-kernel:redefinition-warning #'muffle-warning))
78
     (defun make-gensym-list (length &optional (x "G"))
79
       "Returns a list of LENGTH gensyms, each generated as if with a call to
80
 MAKE-GENSYM, using the second (optional, defaulting to \"G\")
81
 argument. This function is implemented in SBCL
82
 src/code/primordial-extensions.lisp but re-implemented here. The only
83
 difference is that we also handle non-zero integers, which can be
84
 passed as the first argument to `gensym'."
85
       (let ((g (if (typep x '(integer 0)) x (string x))))
86
         (loop repeat length
87
               collect (gensym g))))))
88
 
89
 ;; FBOUNDP!, VBOUNDP! are described in the C-MERA paper.
90
 (defun fboundp! (function &optional env)
91
   "Check if function or macro is bound globally or lexically."
92
   (sb-cltl2::function-information function env))
93
 
94
 (defun vboundp! (variable &optional env)
95
   "Check if variable or symbol macro is bound  globally or lexically."
96
   (sb-cltl2::variable-information variable env))
97
 
98
 ;;; Aliases
99
 ;; from LPARALLEL
100
 (defmacro alias-function (alias orig)
101
   "Define an ALIAS of function ORIG."
102
   `(progn
103
      (setf (symbol-function ',alias) #',orig)
104
      (define-compiler-macro ,alias (&rest args)
105
        `(,',orig ,@args))
106
      ',alias))
107
 
108
 (defmacro alias-macro (alias orig)
109
   "Define an ALIAS of macro ORIG."
110
   `(progn
111
      (setf (macro-function ',alias) (macro-function ',orig))
112
      ',alias))