fixes for ucw+interpreter

[clinton/lisp-on-lines.git] / src / mewa / mewa.lisp

diff --git a/src/mewa/mewa.lisp b/src/mewa/mewa.lisp
index c6f14a3..785f05d 100644 (file)
--- a/src/mewa/mewa.lisp
+++ b/src/mewa/mewa.lisp
@@ -1,4 +1,3 @@
-
 (in-package :mewa)
  
 (defparameter *default-type* :ucw)
@@ -141,7 +140,8 @@ attributes is an alist keyed on the attribute name."
 
 
 (defcomponent mewa ()
-  ((attributes
+  ((ucw::instance :accessor instance :initarg :instance) 
+   (attributes
     :initarg :attributes
     :accessor attributes
     :initform nil)
@@ -251,38 +251,28 @@ attributes is an alist keyed on the attribute name."
   (cdr (assoc attribute (attribute-slot-map self))))
 
 (defmethod initialize-slots ((self mewa))
-  (when (use-instance-class-p self)
-    (setf (classes self) 
-         (append (find-instance-classes self)
-                 (classes self))))
-  (setf (attribute-slot-map self) (find-slot-presentations self))
-  (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self ))))
+  (when (instance self)
+    (when (use-instance-class-p self)
+      (setf (classes self) 
+           (append (find-instance-classes self)
+                   (classes self))))
+    (setf (attribute-slot-map self) (find-slot-presentations self))
+    (setf (slots self) (mapcar #'(lambda (x)(cdr x)) (attribute-slot-map self )))))
   
-
-(defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
-  (let* ((p (make-instance 'mewa-object-presentation))
-        (a (progn (setf (slot-value p 'instance) object)
-                  (initialize-slots p) 
-                  (assoc type (find-all-attributes p))))
-        
-        (i (apply #'make-instance (second a) (plist-union initargs (cddr a)))))
-    (setf (slot-value i 'instance) object)
-    i))
-
 (defmethod make-presentation ((object t) &key (type :viewer) (initargs nil))
   (let* ((p (make-instance 'mewa-object-presentation))
-        (a (progn (setf (slot-value p 'instance) object)
+        (a (progn (setf (slot-value p 'ucw::instance) object)
                   (initialize-slots p) 
                   (assoc type (find-all-attributes p))))
-        
-        (i (apply #'make-instance (or (second a)
-                                      ;; if we didnt find the type, 
-                                      ;; use the symbol as a class. 
-                                      (if (eql (symbol-package type) 
-                                               (find-package 'keyword))
-                                          (symbol-name type)
-                                          type))
-                                      (plist-union initargs (cddr a)))))
+        ;;;; TODO: this can be cleaned up, probably CHANGE-CLASS is better here
+        (i (apply #'change-class p (or (second a)
+                                     ;; if we didnt find the type, 
+                                     ;; use the symbol as a class. 
+                                     (if (eql (symbol-package type) 
+                                              (find-package 'keyword))
+                                         (symbol-name type)
+                                         type))
+                  (plist-union initargs (cddr a)))))
     (setf (slot-value i 'instance) object)
     (initialize-slots i)
     (setf (slot-value i 'initializedp) t)
@@ -295,14 +285,14 @@ attributes is an alist keyed on the attribute name."
                                 (setf (component.place x) place)))
                             (slots mewa))))
   
-(defmethod call-component :before ((from standard-component) (to mewa))
+(arnesi:defmethod/cc call-component :before ((from standard-component) (to mewa))
   (unless (slot-value to 'initializedp)
     (initialize-slots to))
   (setf (slot-value to 'initializedp) t)
-  (setf (slots to) (mapcar #'(lambda (x) (prog2 
-                                            (setf (component.place x) (component.place from))
-                                            x))
-                            (slots to))))
+  (initialize-slots-place (component.place from) to)
+  to)
+
+
 
 (defmacro call-presentation (object &rest args)
   `(present-object ,object :presentation (make-presentation ,object ,@args)))
@@ -351,9 +341,9 @@ attributes is an alist keyed on the attribute name."
 
 (defaction ok ((self mewa) &optional arg)
   "Returns the component if it has not been modified. if it has been, prompt user to save or cancel"
-  (declare (ignore arg))
-  (ensure-instance-sync self)
-  (answer self))
+  ;(declare (ignore arg))
+  (meta-model::sync-instance (instance self))
+  (answer (instance self)))
 
 (defmethod (setf presentation-slot-value) :around (value (slot slot-presentation) instance)
   (let* ((old (prog1 
@@ -372,11 +362,13 @@ attributes is an alist keyed on the attribute name."
       '(mewa-object-presentation :global-properties (:editablep nil))
       (find-attribute t :editor)
       '(mewa-object-presentation :global-properties (:editablep t))
+      (find-attribute t :creator)
+      '(mewa-object-presentation :global-properties (:editablep t))
       (find-attribute t :one-line)
-      '(mewa::mewa-one-line-presentation)
+      '(mewa-one-line-presentation)
       (find-attribute t :listing)
-      '(mewa::mewa-list-presentation :global-properties (:editablep nil) :editablep t)
-      (find-attribute t :search-presentation)
+      '(mewa-list-presentation :global-properties (:editablep nil) :editablep t)
+      (find-attribute t :search-model)
       '(mewa-object-presentation))