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 | #| |
22 | 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. |
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 | |