[mcclim-cvs] CVS mcclim/Drei

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv10820

Modified Files:
	lisp-syntax.lisp 
Log Message:
Handle vector and array forms better.


--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp	2007/01/21 23:07:45	1.19
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp	2007/01/31 14:31:59	1.20
@@ -2835,12 +2835,19 @@
                           (setf (clim-mop:slot-value-using-class
                                  class tree slotd)
                                 new)))))))
-               ((arrayp tree)
+               ((vectorp tree)
                 (loop for i from 0 below (length tree) do
                      (let* ((old (aref tree i))
                             (new (circle-subst old-new-alist old)))
                        (unless (eq old new)
                          (setf (aref tree i) new)))))
+               ((arrayp tree)
+                (loop with array-size = (array-total-size tree)
+                   for i from 0 below array-size do
+                   (let* ((old (row-major-aref tree i))
+                          (new (circle-subst old-new-alist old)))
+                     (unless (eq old new)
+                       (setf (row-major-aref tree i) new)))))
                (t
                 (let ((a (circle-subst old-new-alist (car tree)))
                       (d (circle-subst old-new-alist (cdr tree))))
@@ -3015,7 +3022,18 @@
 
 (defmethod form-to-object ((syntax lisp-syntax) (form simple-vector-form)
                            &key &allow-other-keys)
-  (apply #'vector (call-next-method)))
+  (let* ((contents (call-next-method))
+         (lexeme-string (form-string syntax (first (children form))))
+         (size (parse-integer lexeme-string :start 1
+                              :end (1- (length lexeme-string))
+                              :junk-allowed t))
+         (vector (make-array (or size (length contents)))))
+    (loop for cons = contents then (or rest cons)
+       for element = (first cons)
+       for rest = (rest cons)
+       for i below (length vector) do
+       (setf (aref vector i) element)
+       finally (return vector))))
 
 (defmethod form-to-object ((syntax lisp-syntax) (form incomplete-string-form)
                            &key &allow-other-keys)
@@ -3105,6 +3123,26 @@
                            &rest args)
   (apply #'label-placeholder syntax form (extract-label syntax form) t args))
 
+(defmethod form-to-object ((syntax lisp-syntax) (form array-form)
+                           &rest args)
+  (let* ((rank-string (form-string syntax (first (children form))))
+         (rank (parse-integer rank-string :start 1
+                              :end (1- (length rank-string))))
+         (array-contents (apply #'form-to-object syntax (second (children form)) args)))
+    (labels ((dimensions (rank contents)
+               (cond ((= rank 0)
+                      nil)
+                     ((= rank 1)
+                      (list (length contents)))
+                     (t
+                      (let ((goal (dimensions (1- rank) (first contents))))
+                        (dolist (element (rest contents))
+                          (unless (equal goal (dimensions (1- rank) element))
+                            (form-conversion-error syntax form "jagged multidimensional array")))
+                        (cons (length contents) goal))))))
+      (make-array (dimensions rank array-contents)
+                  :initial-contents array-contents))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; Arglist fetching.