src/utilities.lisp

   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 (defmacro with-active-descriptions (descriptions &body body)
  18        `(with-active-layers ,(mapcar #'defining-description descriptions)
  19
  20          ,@body))
  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)
  30   "Takes the name of a description and returns its internal name."
  31   (case name
  32     ((nil) (error "NIL is not a valid description name."))
  33     (otherwise (enclose-symbol name *description-definers*))))
  34
  35 (defmethod initargs.slots (class)
  36   "Returns ALIST of (initargs) . slot."
  37   (mapcar #'(lambda (slot)
  38               (cons (closer-mop:slot-definition-initargs slot)
  39                     slot))
  40                     (closer-mop:class-slots class)))
  41
  42 (defun find-slot-using-initarg (class initarg)
  43   (cdr (assoc-if #'(lambda (x) (member initarg x))
  44                                    (initargs.slots class))))
  45
  46
  47
  48 ;;;!-- TODO: this has been so mangled that, while working, it's ooogly!
  49 ;;;!-- do we still use this?
  50
  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
  60 (defun dprint (format-string &rest args)
  61   (apply #'format t (concatenate 'string format-string "~%") args))
  62
  63
  64
  65