079b9084 |
1 | (in-package :lisp-on-lines) |
2 | |
b7657b86 |
3 | (defgeneric generic-format (stream string &rest args) |
4 | (:method (stream string &rest args) |
5 | (apply #'format stream string args))) |
6 | |
7 | |
8 | |
9 | |
079b9084 |
10 | (defun make-enclosing-package (name) |
11 | (make-package name :use '())) |
12 | |
13 | (defgeneric enclose-symbol (symbol package) |
14 | (:method ((symbol symbol) |
15 | (package package)) |
16 | (if (symbol-package symbol) |
17 | (intern (format nil "~A::~A" |
18 | (package-name (symbol-package symbol)) |
19 | (symbol-name symbol)) |
20 | package) |
21 | (or (get symbol package) |
22 | (setf (get symbol package) (gensym)))))) |
23 | |
4358148e |
24 | (defmacro with-active-descriptions (descriptions &body body) |
25 | `(with-active-layers ,(mapcar #'defining-description descriptions) |
26 | |
27 | ,@body)) |
b7657b86 |
28 | |
29 | (defmacro with-inactive-descriptions (descriptions &body body) |
30 | `(with-inactive-layers ,(mapcar #'defining-description descriptions) |
31 | |
32 | ,@body)) |
33 | |
079b9084 |
34 | #| |
35 | 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. |
36 | |# |
37 | |
38 | |
39 | (defvar *description-definers* |
40 | (make-enclosing-package "DESCRIPTION-DEFINERS")) |
41 | |
42 | (defun defining-description (name) |
4358148e |
43 | "Takes the name of a description and returns its internal name." |
079b9084 |
44 | (case name |
079b9084 |
45 | ((nil) (error "NIL is not a valid description name.")) |
46 | (otherwise (enclose-symbol name *description-definers*)))) |
47 | |
4358148e |
48 | (defmethod initargs.slots (class) |
49 | "Returns ALIST of (initargs) . slot." |
50 | (mapcar #'(lambda (slot) |
079b9084 |
51 | (cons (closer-mop:slot-definition-initargs slot) |
4358148e |
52 | slot)) |
53 | (closer-mop:class-slots class))) |
079b9084 |
54 | |
4358148e |
55 | (defun find-slot-using-initarg (class initarg) |
079b9084 |
56 | (cdr (assoc-if #'(lambda (x) (member initarg x)) |
4358148e |
57 | (initargs.slots class)))) |
b7657b86 |
58 | |
59 | (defun ensure-class-finalized (class) |
60 | (unless (class-finalized-p class) |
61 | (finalize-inheritance class))) |
62 | |
63 | (defun superclasses (class) |
64 | (ensure-class-finalized class) |
65 | (rest (class-precedence-list class))) |
4358148e |
66 | |
079b9084 |
67 | |
68 | |
69 | ;;;!-- TODO: this has been so mangled that, while working, it's ooogly! |
4358148e |
70 | ;;;!-- do we still use this? |
71 | |
079b9084 |
72 | (defun initargs-plist->special-slot-bindings (class initargs-plist) |
73 | "returns a list of (slot-name value) Given a plist of initargs such as one would pass to :DEFAULT-INITARGS." |
74 | (let ((initargs.slot-names-alist (initargs.slot-names class))) |
75 | (loop for (initarg value) on initargs-plist |
76 | nconc (let ((slot-name |
77 | )) |
78 | (when slot-name ;ignore invalid initargs. (good idea/bad idea?) |
79 | (list slot-name value)))))) |
80 | |
4358148e |
81 | (defun dprint (format-string &rest args) |
82 | (apply #'format t (concatenate 'string format-string "~%") args)) |
83 | |
84 | |
079b9084 |
85 | |
86 | |