Include some more new stuff.
[clinton/lisp-on-lines.git] / src / utilities.lisp
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
17 #|
18 Descriptoons 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.
19 |#
20
21
22 (defvar *description-definers*
23 (make-enclosing-package "DESCRIPTION-DEFINERS"))
24
25 (defun defining-description (name)
26 "Takes the name of a layer and returns its internal name."
27 (case name
28 ((t) 't)
29 ((nil) (error "NIL is not a valid description name."))
30 (otherwise (enclose-symbol name *description-definers*))))
31
32
33 (defmethod initargs.slot-names (class)
34 "Returns ALIST of (initargs) . slot-name."
35 (nreverse (mapcar #'(lambda (slot)
36 (cons (closer-mop:slot-definition-initargs slot)
37 (closer-mop:slot-definition-name slot)))
38 (closer-mop:class-slots class))))
39
40 (defun find-slot-name-from-initarg (class initarg)
41 (cdr (assoc-if #'(lambda (x) (member initarg x))
42 (initargs.slot-names class))))
43
44
45 ;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
46 (defun initargs-plist->special-slot-bindings (class initargs-plist)
47 "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS."
48 (let ((initargs.slot-names-alist (initargs.slot-names class)))
49 (loop for (initarg value) on initargs-plist
50 nconc (let ((slot-name
51 ))
52 (when slot-name ;ignore invalid initargs. (good idea/bad idea?)
53 (list slot-name value))))))
54
55
56