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 | |
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 | |