diff base/methods.lisp @ 152:3b588c566734

Method for adjust-sequence for standard-composition to keep appropriate time information

darcs-hash:20071114142506-f76cc-2197a0820676834eaddce6480c027069eb845688.gz

--- a/base/methods.lisp	Wed Nov 07 11:14:03 2007 +0000
+++ b/base/methods.lisp	Wed Nov 14 14:25:06 2007 +0000
@@ -459,7 +459,7 @@
 (defmethod sequence:make-sequence-like :around ((o standard-composition) length
 						&key (initial-element nil iep)
 						(initial-contents nil icp))
-  " Around method for make-sequence-like, only with all slots
+  "Around method for make-sequence-like, only with all slots
   preserved from the source sequence (except onset and duration,
   which are calculated afresh)."
   (declare (ignore length initial-element initial-contents iep icp))
@@ -472,21 +472,27 @@
       ;; (setf (timepoint new-sequence)
       ;;    (timepoint (elt new-sequence 0)))
       ;; outside of the loop.
-      (when (or (not start)
-		(< (timepoint element) start))
-	(setf start (timepoint element)))
-      (when (or (not finish)
-		(> (timepoint (cut-off element))
-		   finish))
-	(setf finish (timepoint (cut-off element)))))
+      (when (and element
+                 (or (null start)
+                     (< (timepoint element) start)))
+        (setf start (timepoint element)))
+      (when (and element
+                 (or (null finish)
+                     (> (timepoint (cut-off element))
+                        finish)))
+        (setf finish (timepoint (cut-off element)))))
+    (unless start
+      (setf start 0))
+    (unless finish
+      (setf finish 0))
     (setf (timepoint new-sequence) start
-	  (duration new-sequence) (- finish start))
-    (dolist (slotd (sb-mop:class-slots new-sequence) new-sequence)
+          (duration new-sequence) (- finish start))
+    (dolist (slotd (sb-mop:class-slots (class-of new-sequence)) new-sequence)
       (unless (or (equal (sb-mop:slot-definition-name slotd) 'time)
-		  (equal (sb-mop:slot-definition-name slotd) 'interval))
-	(setf (sb-mop:slot-value-using-class (class-of new-sequence)
+                  (equal (sb-mop:slot-definition-name slotd) 'interval))
+        (setf (sb-mop:slot-value-using-class (class-of new-sequence)
 					     new-sequence
 					     slotd)
-	      (sb-mop:slot-value-using-class (class-of new-sequence)
-					     o ;; if this isn't the same, we're lost anyway
-					     slotd))))))
\ No newline at end of file
+              (sb-mop:slot-value-using-class (class-of new-sequence)
+                                             o ;; if this isn't the same, we're lost anyway
+                                             slotd))))))
\ No newline at end of file