[mcclim-cvs] CVS mcclim/Drei
thenriksen
thenriksen at common-lisp.net
Wed Jan 31 14:31:59 UTC 2007
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.
More information about the Mcclim-cvs
mailing list