/usr/share/common-lisp/source/kmrcl/symbols.lisp is in cl-kmrcl 1.106-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | ;;;; -*- 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
;;;;
;;;; This file, part of KMRCL, is Copyright (c) 2002-2010 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)
;;; Symbol functions
(defun cl-symbol-list (test-fn)
(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))
(funcall test-fn sym))
(push sym vars))))
(nreverse vars)))
(defun cl-variables ()
(cl-symbol-list #'boundp))
(defun cl-functions ()
(cl-symbol-list #'fboundp))
(defun cl-symbols ()
(nconc (cl-variables) (cl-functions)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (char= #\a (schar (symbol-name '#:a) 0))
(pushnew 'kmrcl::kmrcl-lowercase-reader *features*))
(when (not (string= (symbol-name '#:a)
(symbol-name '#:A)))
(pushnew 'kmrcl::kmrcl-case-sensitive *features*)))
(defun string-default-case (str)
#+(and (not kmrcl::kmrcl-lowercase-reader)) (string-upcase str)
#+(and kmrcl::kmrcl-lowercase-reader) (string-downcase str))
(eval-when (:compile-toplevel :load-toplevel :execute)
(setq cl:*features* (delete 'kmrcl::kmrcl-lowercase-reader *features*))
(setq cl:*features* (delete 'kmrcl::kmrcl-case-sensitive *features*)))
(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))))
(nth-value 0 (intern (string-default-case 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 (nth-value 0 (intern (string-default-case name) :keyword)))
(symbol (nth-value 0 (intern (symbol-name name) :keyword)))))
(defun ensure-keyword-upcase (desig)
(nth-value 0 (intern (string-upcase
(symbol-name (ensure-keyword desig))) :keyword)))
(defun ensure-keyword-default-case (desig)
(nth-value 0 (intern (string-default-case
(symbol-name (ensure-keyword desig))) :keyword)))
(defun show (&optional (what :variables) (package *package*))
(ecase what
(:variables (show-variables package))
(:functions (show-functions package))))
(defun print-symbols (package test-fn value-fn &optional (stream *standard-output*))
(do-symbols (s package)
(multiple-value-bind (sym status)
(find-symbol (symbol-name s) package)
(when (and (or (eq status :external)
(eq status :internal))
(funcall test-fn sym))
(format stream "~&Symbol ~S~T -> ~S~%"
sym
(funcall value-fn sym))))))
(defun show-variables (&optional (package *package*) (stream *standard-output*))
(print-symbols package 'boundp 'symbol-value stream))
(defun show-functions (&optional (package *package*) (stream *standard-output*))
(print-symbols package 'fboundp 'symbol-function stream))
(defun find-test-generic-functions (instance)
"Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'"
(let ((res)
(package (symbol-package (class-name (class-of instance)))))
(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)
(eq (symbol-package sym) package)
(> (length (symbol-name sym)) 5)
(string-equal "test-" (subseq (symbol-name sym) 0 5))
(typep (symbol-function sym) 'generic-function)
(plusp
(length
(compute-applicable-methods
(ensure-generic-function sym)
(list instance)))))
(push sym res))))
(nreverse res)))
(defun run-tests-for-instance (instance)
(dolist (gf-name (find-test-generic-functions instance))
(funcall gf-name instance))
(values))
|