1 (in-package :lisp-on-lines
)
3 (defgeneric generic-format
(stream string
&rest args
)
4 (:method
(stream string
&rest args
)
5 (apply #'format stream string args
)))
10 (defun make-enclosing-package (name)
11 (make-package name
:use
'()))
13 (defgeneric enclose-symbol
(symbol package
)
14 (:method
((symbol symbol
)
16 (if (symbol-package symbol
)
17 (intern (format nil
"~A::~A"
18 (package-name (symbol-package symbol
))
21 (or (get symbol package
)
22 (setf (get symbol package
) (gensym))))))
24 (defmacro with-active-descriptions
(descriptions &body body
)
25 `(with-active-layers ,(mapcar #'defining-description descriptions
)
29 (defmacro with-inactive-descriptions
(descriptions &body body
)
30 `(with-inactive-layers ,(mapcar #'defining-description descriptions
)
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.
39 (defvar *description-definers
*
40 (make-enclosing-package "DESCRIPTION-DEFINERS"))
42 (defun defining-description (name)
43 "Takes the name of a description and returns its internal name."
45 ((nil) (error "NIL is not a valid description name."))
46 (otherwise (enclose-symbol name
*description-definers
*))))
48 (defmethod initargs.slots
(class)
49 "Returns ALIST of (initargs) . slot."
50 (mapcar #'(lambda (slot)
51 (cons (closer-mop:slot-definition-initargs slot
)
53 (closer-mop:class-slots class
)))
55 (defun find-slot-using-initarg (class initarg
)
56 (cdr (assoc-if #'(lambda (x) (member initarg x
))
57 (initargs.slots class
))))
59 (defun ensure-class-finalized (class)
60 (unless (class-finalized-p class
)
61 (finalize-inheritance class
)))
63 (defun superclasses (class)
64 (ensure-class-finalized class
)
65 (rest (class-precedence-list class
)))
69 ;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
70 ;;;!-- do we still use this?
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
78 (when slot-name
;ignore invalid initargs. (good idea/bad idea?)
79 (list slot-name value
))))))
81 (defun dprint (format-string &rest args
)
82 (apply #'format t
(concatenate 'string format-string
"~%") args
))