/usr/share/common-lisp/source/metatilities-base/dev/names.lisp is in cl-metatilities-base 20120909-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 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | --- not loaded ---
;;; numbered-instances-mixin
;;;
;;; a sort of light-weight named-object-mixin
(defclass* numbered-instances-mixin (copyable-mixin)
((object-number :unbound i))
(:copy-set-slots (object-number (get-next-instance-number (class-name (class-of self)))))
(:export-slots object-number))
(defmethod object-number ((object numbered-instances-mixin))
(set-object-number-if-necessary object))
(defun set-object-number-if-necessary (object)
"Sets a numbered-instances-mixin's object number if it hasn't already been
set. Returns the object number."
(if (slot-boundp object 'object-number)
(slot-value object 'object-number)
(setf (slot-value object 'object-number)
(get-next-instance-number object))))
(defmethod initialize-instance :after ((object numbered-instances-mixin) &key)
(set-object-number-if-necessary object))
(defmethod update-instance-for-different-class :after ((previous numbered-instances-mixin) (target numbered-instances-mixin) &key)
(setf (slot-value target 'object-number)
(get-next-instance-number (class-name (class-of target)))))
(defgeneric get-next-instance-number (thing)
(:documentation "")
(:method ((class-name symbol))
(prog1
(get class-name 'object-number 0)
(setf (get class-name 'object-number)
(1+ (get class-name 'object-number 0)))))
(:method ((object standard-object))
(get-next-instance-number (class-name-of object))))
(defmethod print-object ((object numbered-instances-mixin) stream)
(let ((number (object-number object)))
(print-unreadable-object (object stream :type t :identity t)
(format stream "~S" number))))
(defun reset-symbol-numbering ()
(loop for name in (mapcar #'class-name
(subclasses* (find-class 'numbered-instances-mixin))) do
(reset-symbol-numbering-for-class name)))
(defun reset-symbol-numbering-for-class (class-name)
(setf (get class-name 'object-number) 0))
(defun numbered-symbols-count ()
(loop for name in (mapcar #'class-name
(subclasses* (find-class 'numbered-instances-mixin))) sum
(get name 'object-number 0)))
(defun remove-numbered-symbols (&key (verbose? t))
(let ((grand-total 0))
(loop for name in (sort
(mapcar #'class-name
(subclasses* (find-class 'numbered-instances-mixin)))
#'string-lessp) do
(let ((i 0)
(total (get name 'object-number 0)))
(loop while (< i total) do
(unintern (find-symbol (format nil "~A-~D" name i)))
(incf i))
(when (and (plusp i) verbose?)
(format t "~&~40A: ~A" name i))
(incf grand-total total)))
(format t "~&~&~40A: ~A" "Grand Total" grand-total))
(reset-symbol-numbering))
(defun remove-numbered-symbols* (&key (verbose? t) (gap-size 10))
(loop for name in (sort
(mapcar #'class-name
(subclasses* (find-class 'numbered-instances-mixin)))
#'string-lessp) do
;; Extra is a bit of hack
(let ((extra gap-size)
(i 0))
(loop while (or (find-symbol (format nil "~A-~D" name i))
(plusp extra)) do
(unless (unintern (find-symbol (format nil "~A-~D" name i)))
(decf extra))
(incf i))
(when (and (plusp (- i (- gap-size extra)))
verbose?)
(format t "~&~40A: ~A" name (- i (- gap-size extra)))))))
;;; object-with-name
;;;
;;; An object-with-name has a name slot which gets filled in automatically
;;; unless a name is passed in as an initarg.
(defclass* object-with-name (numbered-instances-mixin)
((name :type symbol ir))
(:documentation "Allows each instance to have an name. One is generated
for it if not provided. The name is always a symbol.")
:copy-slots)
(defmethod print-object ((object object-with-name) stream)
(let ((name (and (slot-boundp object 'name) (slot-value object 'name))))
(print-unreadable-object (object stream :type t :identity t)
(format stream "~:[<unnamed>~;~s~]" name name))))
(defmethod make-name ((object object-with-name) &optional new-name)
"Make a name for yourself if necessary. This version insures name is a symbol."
(let ((class-name (class-name (class-of object))))
(macrolet ((form-name-symbol (&rest strings)
`(form-symbol-in-package *package* ,@strings)))
(cond ((not new-name) (form-name-symbol
(string-upcase class-name)
"-"
(princ-to-string (object-number object))))
((symbolp new-name) new-name)
((stringp new-name) (form-name-symbol new-name))
(t (form-name-symbol (princ-to-string new-name)))))))
(defmethod initialize-instance :around ((object object-with-name) &rest initargs &key name)
(if name
(apply #'call-next-method object :name (name->symbol name) initargs)
(apply #'call-next-method object :name (make-name object name) initargs)))
(defmethod name->symbol ((name symbol))
name)
(defmethod name->symbol ((name string))
(form-symbol name))
(defmethod update-instance-for-different-class :after ((previous object-with-name)
(target object-with-name) &key)
;;?? changing class always gives a new name...
(setf (slot-value target 'name)
(make-name target nil)))
(defmethod (setf name) (new-name (object object-with-name))
(setf (slot-value object 'name)
(make-name object new-name)))
|