Properties are special now!
[clinton/lisp-on-lines.git] / src / utilities.lisp
CommitLineData
079b9084 1(in-package :lisp-on-lines)
2
3(defun make-enclosing-package (name)
4 (make-package name :use '()))
5
6(defgeneric enclose-symbol (symbol package)
7 (:method ((symbol symbol)
8 (package package))
9 (if (symbol-package symbol)
10 (intern (format nil "~A::~A"
11 (package-name (symbol-package symbol))
12 (symbol-name symbol))
13 package)
14 (or (get symbol package)
15 (setf (get symbol package) (gensym))))))
16
4358148e 17(defmacro with-active-descriptions (descriptions &body body)
18 `(with-active-layers ,(mapcar #'defining-description descriptions)
19
20 ,@body))
079b9084 21#|
22Descriptoons are represented as ContextL classes and layers. To avoid nameclashes with other classes or layers, the name of a description is actually mappend to an internal unambiguous name which is used instead of the regular name.
23|#
24
25
26(defvar *description-definers*
27 (make-enclosing-package "DESCRIPTION-DEFINERS"))
28
29(defun defining-description (name)
4358148e 30 "Takes the name of a description and returns its internal name."
079b9084 31 (case name
079b9084 32 ((nil) (error "NIL is not a valid description name."))
33 (otherwise (enclose-symbol name *description-definers*))))
34
4358148e 35(defmethod initargs.slots (class)
36 "Returns ALIST of (initargs) . slot."
37 (mapcar #'(lambda (slot)
079b9084 38 (cons (closer-mop:slot-definition-initargs slot)
4358148e 39 slot))
40 (closer-mop:class-slots class)))
079b9084 41
4358148e 42(defun find-slot-using-initarg (class initarg)
079b9084 43 (cdr (assoc-if #'(lambda (x) (member initarg x))
4358148e 44 (initargs.slots class))))
45
079b9084 46
47
48;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
4358148e 49;;;!-- do we still use this?
50
079b9084 51(defun initargs-plist->special-slot-bindings (class initargs-plist)
52 "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS."
53 (let ((initargs.slot-names-alist (initargs.slot-names class)))
54 (loop for (initarg value) on initargs-plist
55 nconc (let ((slot-name
56 ))
57 (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
58 (list slot-name value))))))
59
4358148e 60(defun dprint (format-string &rest args)
61 (apply #'format t (concatenate 'string format-string "~%") args))
62
63
079b9084 64
65