src/contextl-hacks.lisp

   1 (in-package :contextl)
   2
   3
   4
   5
   6 ;;; HACK:
   7 ;;; Since i'm not using deflayer, ensure-layer etc,
   8 ;;; There are a few places where contextl gets confused
   9 ;;; trying to locate my description layers.
  10
  11 ;;; TODO: investigate switching to deflayer!
  12
  13 (defun contextl::prepare-layer (layer)
  14   (if (symbolp layer)
  15       (if (eq (symbol-package layer)
  16           (find-package :description-definers))
  17           layer
  18           (contextl::defining-layer layer))
  19
  20       layer))
  21
  22 (defmethod find-layer-class :around ((layer symbol) &optional errorp environment)
  23   (if (eq (symbol-package layer)
  24           (find-package :description-definers))
  25       (find-class layer)
  26       (call-next-method)))
  27
  28
  29 ;;; HACK: We are ending up with classes named NIL in the superclass list.
  30 ;;; These cannot be given the special object superclass when re-initializing
  31 ;;; is it will be in the subclasses superclasses AFTER this class, causing
  32 ;;; a confict.
  33 ;;; Since we don't care about these classes (?) this might work (?)
  34
  35 (defmethod initialize-instance :around
  36   ((class special-class) &rest initargs
  37    &key direct-superclasses)
  38   (declare (dynamic-extent initargs))
  39   (if (or
  40        ;; HACK begins
  41        (not (ignore-errors (class-name class)))
  42        ;; ENDHACK
  43           (loop for superclass in direct-superclasses
  44             thereis (ignore-errors (subtypep superclass 'special-object))))
  45     (call-next-method)
  46     (progn  (apply #'call-next-method class
  47            :direct-superclasses
  48            (append direct-superclasses
  49                    (list (find-class 'special-object)))
  50            initargs))))
  51
  52 (defmethod reinitialize-instance :around
  53   ((class special-class) &rest initargs
  54    &key (direct-superclasses () direct-superclasses-p))
  55   (declare (dynamic-extent initargs))
  56   (if direct-superclasses-p
  57       (if (or  ; Here comes the hack
  58            (not (class-name class))
  59                ;endhack
  60            (loop for superclass in direct-superclasses
  61               thereis (ignore-errors (subtypep superclass 'special-object))))
  62       (call-next-method)
  63       (apply #'call-next-method class
  64              :direct-superclasses
  65              (append direct-superclasses
  66                      (list
  67                       (find-class 'special-object)))
  68              initargs)))
  69      (call-next-method))
  70
  71
  72
  73 (defun funcall-with-special-initargs (bindings thunk)
  74   (let ((arg-count 0))
  75   (special-symbol-progv
  76       (loop for (object . initargs) in bindings
  77             for initarg-keys = (loop for key in initargs by #'cddr
  78                                      collect key into keys
  79                                     count t into count
  80                                     finally (incf arg-count count)
  81                                             (return keys))
  82             nconc (loop for slot in (class-slots (class-of object))
  83                         when (and (slot-definition-specialp slot)
  84                                   (intersection initarg-keys (slot-definition-initargs slot)))
  85                         collect (with-symbol-access
  86                                   (slot-value object (slot-definition-name slot)))))
  87       (make-list arg-count :initial-element nil)
  88     (loop for (object . initargs) in bindings
  89           do (apply #'shared-initialize object nil :allow-other-keys t initargs))
  90     (funcall thunk))))