| 1 | (in-package :lisp-on-lines) |
| 2 | |
| 3 | (defgeneric generic-format (stream string &rest args) |
| 4 | (:method (stream string &rest args) |
| 5 | (apply #'format stream string args))) |
| 6 | |
| 7 | |
| 8 | |
| 9 | |
| 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 | |
| 24 | (defmacro with-active-descriptions (descriptions &body body) |
| 25 | `(with-active-layers ,(mapcar #'defining-description descriptions) |
| 26 | |
| 27 | ,@body)) |
| 28 | |
| 29 | (defmacro with-inactive-descriptions (descriptions &body body) |
| 30 | `(with-inactive-layers ,(mapcar #'defining-description descriptions) |
| 31 | |
| 32 | ,@body)) |
| 33 | |
| 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) |
| 43 | "Takes the name of a description and returns its internal name." |
| 44 | (case name |
| 45 | ((nil) (error "NIL is not a valid description name.")) |
| 46 | (otherwise (enclose-symbol name *description-definers*)))) |
| 47 | |
| 48 | (defmethod initargs.slots (class) |
| 49 | "Returns ALIST of (initargs) . slot." |
| 50 | (mapcar #'(lambda (slot) |
| 51 | (cons (closer-mop:slot-definition-initargs slot) |
| 52 | slot)) |
| 53 | (closer-mop:class-slots class))) |
| 54 | |
| 55 | (defun find-slot-using-initarg (class initarg) |
| 56 | (cdr (assoc-if #'(lambda (x) (member initarg x)) |
| 57 | (initargs.slots class)))) |
| 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))) |
| 66 | |
| 67 | |
| 68 | |
| 69 | ;;;!-- TODO: this has been so mangled that, while working, it's ooogly! |
| 70 | ;;;!-- do we still use this? |
| 71 | |
| 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 | |
| 81 | (defun dprint (format-string &rest args) |
| 82 | (apply #'format t (concatenate 'string format-string "~%") args)) |
| 83 | |
| 84 | |
| 85 | |
| 86 | |