From 6b6b5c318e57986142a2cdbc63186f21b16a427a Mon Sep 17 00:00:00 2001 From: pc <pc@p-cos.net> Date: Sun, 11 Sep 2005 12:47:06 +0000 Subject: [PATCH] Added checks for layer inheritance. Inheritance between layers is not officially supported yet, but I have already added checks for ensuring active and inactive that would result in incorrect layer orderings. darcs-hash:47fd8d829607c3210815da6d8b0057f58853f33e --- cx-layer.lisp | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/cx-layer.lisp b/cx-layer.lisp index c968b10..5e83b0d 100644 --- a/cx-layer.lisp +++ b/cx-layer.lisp @@ -52,10 +52,13 @@ (let ((layer-class (find-layer layer)) (active-context-specializer (layer-context-specializer active-context))) (when (subtypep active-context-specializer layer-class) - (if (eq (first (class-direct-superclasses active-context-specializer)) layer-class) - (return-from maybe-create-active-layer-context active-context) - (setq active-context (ensure-inactive-layer-context layer active-context) - active-context-specializer (layer-context-specializer active-context)))) + (let ((first-layer (first (class-direct-superclasses active-context-specializer)))) + (cond ((eq first-layer layer-class) + (return-from maybe-create-active-layer-context active-context)) + ((subtypep first-layer layer-class) + (error "Layer ~S cannot be placed in front of ~S because the latter inherits from the former." (layer-name layer-class) (layer-name first-layer))) + (t (setq active-context (ensure-inactive-layer-context layer active-context) + active-context-specializer (layer-context-specializer active-context)))))) (let ((new-specializer (make-instance 'standard-class :direct-superclasses @@ -94,7 +97,10 @@ finally (return (loop with new-layer-context = *root-context* for active-layer in (cdr active-layers) - unless (eq active-layer layer-class) do + if (subtypep active-layer layer-class) do + (unless (eq active-layer layer-class) + (error "The layer ~S cannot be deactivated or rearranged because the active layer ~S inherits from it." (layer-name layer-class) (layer-name active-layer))) + else do (setq new-layer-context (ensure-active-layer-context (class-name active-layer) -- GitLab