various cleaning in vv macro. fix sb-ext compat issue in tests.

rel paths in tests

run-tests.sh

@@ -4,9 +4,9 @@ set -e
 sbcl --quit \
      --eval '(handler-case (ql:quickload :veq :verbose t)
                            (error (c) (format t "STAGE1FAIL: ~a" c)
-                                      (sb-ext:quit :unix-status 2)))'\
+                                      (uiop:quit 2)))'\
      --eval '(ql:quickload :prove)'\
      --eval '(handler-case (asdf:test-system :veq)
                            (error (c) (format t "STAGE2FAIL: ~a" c)
-                                      (sb-ext:quit :unix-status 3)))'
+                                      (uiop:quit 3)))'
 

src/array-utils.lisp

@@ -13,21 +13,16 @@
           :adjustable nil))))
 
 (defmacro new-stride ((from to type &optional (v 0)) arr)
-  (declare (fixnum from to) (symbol arr))
+  (declare (fixnum from to))
   "shift arr from stride to stride."
   (unless (> to from 0) (error "NEW-STRIDE: must have (> to from 0)"))
-  `(fvprogn
-    (let ((n (/ (,(vvsym type 1 :$num) ,arr) ,from))
-          (v* (coerce ,v ',(psymb :veq type))))
-      (declare (fixnum n))
-      (,(vvsym type 1 :with-arrays)
-        (:n n :cnt c :itr i
-         :arr ((arr* ,from ,arr)
-               (res ,to (,(vvsym type nil :$zero) (* ,to n))))
-         :fxs ((fx ((:va ,from o)) (values o ,@(loop repeat (- to from)
-                                                     collect 'v*))))
-         :exs ((res c (fx arr*))))
-        res))))
+  `(fvprogn ; TODO: to less than from
+    (let ((v* (coerce ,v ',(psymb :veq type))))
+      (declare (,(psymb :veq type) v*))
+      (labels ((fx ((:va ,from x))
+                 (values (:vr x ,@(loop for i from 0 repeat from collect i))
+                         ,@(loop repeat (- to from) collect 'v*))))
+        (,(vvsym type 1 (mkstr from to :_@$fx)) ,arr)))))
 
 (defmacro define-constr (type)
   (labels ((nm (n) (vvsym type 1 n)))

src/generic-utils.lisp

@@ -180,7 +180,7 @@ returns (values c sym*), where sym* is sym with the padding characters removed"
         do (setf s (the string (subseq s 1))) (incf c))
   (values c (if rht (reverse s) s)))
 
-(defun edge-chars-str (ch s &optional rht)
+(defun edge-str (ch s &optional rht)
   (declare (optimize speed) (character ch) (string s) (boolean rht))
   "count number of padding characters ch  in s from the left (or right)
 returns (values c sym*), where sym* is s with the padding characters removed"

src/ops-vv-helpers.lisp

@@ -25,6 +25,8 @@
   ; (declare (optimize speed (safety 2)) (list p keys))
   (every (lambda (k) (= (gk p k) 0)) keys))
 
+(defun vverr (expr msg)
+  (error "~&VV error at~%sym: ~a~%msg: ~a~%expr:~s~&" (car expr) msg expr))
 
 (defun car-match-modifier (mod b)
   (declare (optimize speed (safety 2)) (symbol mod))
@@ -41,43 +43,46 @@
                     (second b))
           (values nil nil nil b))))
 
+; -- ARRAY CONF -----------------------------------------------------------------
 
-(defun fx-strip (fx pkg)
-  (when fx (psymb pkg (strip-symbols fx *vv-special*))))
+(defun niloutconf (p b) (values `((:out . nil) ,@p) b))
 
-; -- ARRAY CONF -----------------------------------------------------------------
+(defun tailconf (p b &aux (b2 (subseq b 2)))
+  (declare (optimize speed) (list p b))
+  (mvb (ismod ind) (car-match-modifier *vv-?@* (car b2))
 
-(defun vvconf (b &key (vv-sym *vv-!@*))
-  (declare (optimize speed (safety 2)) (list b))
-  (mvb (short-ty fx-full-str dim dimout) (unpack-vvsym (car b)
-                                           :s vv-sym :symout nil)
+    (values `((:rht . ,(if ismod (cdar b2) b2)) (:@modrht . ,ismod)
+              ,@(when (and ismod (> (the pn ismod) 0)) `((:ind . ,ind)))
+              ,@p) b)))
+
+(defun fx-strip (fx pkg) (when fx (psymb pkg (strip-symbols fx *vv-special*))))
+
+(defun vvconf (b vv-sym &aux (s (car b)))
+  (declare (optimize speed (safety 2)) (list b) (symbol s))
+  (mvb (short-ty sfx-full dim dimout) (unpack-vvsym s :s vv-sym :symout nil)
     (declare (pn dim dimout))
-    (let* ((pkg (symbol-package (car b)))
-           (fx-str (nth-value 1 (edge-chars-str *vv-bang* fx-full-str t)))
-           (fx (psymb pkg fx-str))
-           (fx* (fx-strip fx-str pkg))
-           (ldots (edge-chars-str *vv-dot* fx-str))
-           (rdots (edge-chars-str *vv-dot* fx-str t))
-           (larrs (edge-chars-str *vv-arr* fx-str))
-           (rarrs (edge-chars-str *vv-arr* fx-str t))
-           (bangs (edge-chars-str *vv-bang* fx-full-str t)))
-      (declare (symbol fx) (string fx-str)
-               (pn ldots rdots larrs rarrs bangs))
-      (when (and (> bangs 0) (not (= dim dimout))) ; resulting array must be new
-        (error "!: inconsistent outdim with !: ~a" b))
-      (when (< (length fx-str) 1) (error "vv: missing fx name in: ~a" b))
-
-      `((:dim . ,dim) (:dimout . ,dimout) (:pkg . ,pkg) (:! . ,bangs)
-        (:fx . ,fx) (:fx* . ,fx*)
-        (:ty . ,(type-from-short short-ty t))
-        (:aty . ,(arrtype short-ty 'vector))
-        (:$l . ,larrs) (:.l . ,ldots) (:$r . ,rarrs) (:.r . ,rdots)
-        (:dots . ,(max ldots rdots)) (:arrs . ,(max larrs rarrs))
+    (let* ((pkg (symbol-package s))
+           (sfx (nth-value 1 (edge-str *vv-bang* sfx-full t)))
+           (fx (psymb pkg sfx)) (fx* (fx-strip sfx pkg))
+           (ldots (edge-str *vv-dot* sfx)) (rdots (edge-str *vv-dot* sfx t))
+           (larrs (edge-str *vv-arr* sfx)) (rarrs (edge-str *vv-arr* sfx t))
+           (bangs (edge-str *vv-bang* sfx-full t)))
+      (declare (symbol fx) (string sfx) (pn ldots rdots larrs rarrs bangs))
+      (when (and (> bangs 0) (not (= dim dimout))) (vverr b "bad outdim"))
+      (when (< (length sfx) 1) (vverr b "missing fx name"))
+      (when (> (* larrs rarrs) 1) (vverr b "too many arrays ($)"))
+      (when (> (* ldots rdots) 0) (vverr b "broadcasting (.) on both sides"))
+
+      `((:dim . ,dim) (:dimout . ,dimout) (:pkg . ,pkg) (:fx . ,fx) (:fx* . ,fx*)
+        (:ty . ,(type-from-short short-ty t)) (:aty . ,(arrtype short-ty 'vector))
+        (:.l . ,ldots) (:.r . ,rdots) (:dots . ,(max ldots rdots))
+        (:$l . ,larrs) (:$r . ,rarrs) (:! . ,bangs)
         ; defaults:
         (:ind . ind) (:out . t) (:lft-sym . ,(gensym "LFT")) (:rht-sym . ,(gensym "RHT"))
         (:itr-lft-sym . ,(gensym "ITR-LFT")) (:itr-rht-sym . ,(gensym "ITR-RHT"))
         (:itr-out-sym . ,(gensym "ITR-OUT")) (:out-sym . ,(gensym "OUT"))
-        (:rep-sym . ,(gensym "REP"))))))
+        (:rep-sym . ,(gensym "REP"))
+        (:mode . ,vv-sym) (:sym . ,s)))))
 
 (defun ?@-index-type (o) (ecase o (:l 'list) (:p 'pvec) (:i 'ivec) (:v 'vector)))
 (defun ?@-loop-type (o) (ecase o (:l 'in) ((:p :i :v) 'across)))
@@ -90,10 +95,10 @@
                (declare (list slice) )
                (case (length slice)
                  (0 `(0 ,n)) (1 `(,(car slice) ,n)) (2 slice)
-                 (otherwise (error "?@ (lft): bad # of elements: ~a" b)))))
+                 (otherwise (vverr b "?@ (lft): bad # of elements")))))
       (mvb (ismod opt slice expr) (car-match-modifier *vv-?@* (second b))
         (declare (ignore ismod))
-        (unless expr (error "?@ (lft): missing arg in ~a" b))
+        (unless expr (vverr b "?@ (lft): missing arg"))
         (let ((opt (kv opt)))
           (values
            (case opt
@@ -117,20 +122,20 @@
                              with ,(gk p :rep-sym) of-type pn = (- ,lmod-b ,lmod-a)
                              for ,(gk p :itr-lft-sym) of-type pn from ,lmod-a)
                        ,@p)))
-             (otherwise (error "?@ (lft): unexpected option: ~a~%in ~a" opt b)))
+             (otherwise (vverr b "?@ (lft): unexpected option")))
            b))))))
 
 (defun rconf (p b)
   (declare (optimize speed) (list p b))
   (awg (rmod-a)
     (labels ((pad-slice (slice) ; we never need the second slicer for rht
-               (declare (list slice) )
+               (declare (list slice))
                (case (length slice) (0 `(0)) ((1 2) `(,(first slice)))
-                     (otherwise (error "?@ (rht): bad # of elements in: ~a" b)))))
+                     (otherwise (vverr b "?@ (rht): bad # of elements")))))
 
       (mvb (ismod opt slice expr) (car-match-modifier *vv-?@* (third b))
         (declare (ignore ismod))
-        (unless expr (error "?@ (rht): missing arg in ~a" b))
+        (unless expr (vverr b "?@ (rht): missing arg"))
         (let ((opt (kv opt)))
           (values
            (case opt
@@ -144,33 +149,21 @@
                        (:rht-mod with ,rmod-a of-type pn = ,(first slice)
                                  for ,(gk p :itr-rht-sym) of-type pn from ,rmod-a)
                        ,@p)))
-             (otherwise (error "?@ (rht): unexpected option: ~a~%in ~a" opt b)))
+             (otherwise (vverr b "?@ (rht): unexpected option")))
            b))))))
 
-(defun tailconf (p b &aux (b2 (subseq b 2)))
-  (declare (optimize speed) (list p b))
-  (mvb (ismod ind) (car-match-modifier *vv-?@* (car b2))
-
-    (values `((:rht . ,(if ismod (cdar b2) b2)) (:@modrht . ,ismod)
-              ,@(when (and ismod (> (the pn ismod) 0)) `((:ind . ,ind)))
-              ,@p) b)))
-
-(defun niloutconf (p b) (values `((:out . nil) ,@p) b))
-
 ; -- ARRAY HELPERS --------------------------------------------------------------
 
 (defun $row (p i arr)
   (declare (keyword arr i))
   `(-$ ,(gk p :dim) ,(gk p arr) :inds (,(gk p i)) :atype ,(gk p :aty)))
 
-
 (defun vec-select-itr (p)
   (declare (optimize speed))
   (let ((with-out (if (gk+ p :!) (gk p :lft-sym)
                     `($make :n (* ,(gk p :dimout) ,(gk p :rep-sym))
                             :type ,(gk p :ty) :v ,(type-default (gk p :ty) nil)))))
-    `(,@(gk p :lft t)
-      ,@(gk p :rht-mod t) ; rep, lft, rht itr via lconf/rconf
+    `(,@(gk p :lft t) ,@(gk p :rht-mod t) ; from lconf/rconf
       ,@(when (gk p :out t) ; output array
               `(with ,(gk p :out-sym) of-type ,(gk p :aty) = ,with-out))
       repeat ,(gk p :rep-sym) ; repeat, via lconf

src/ops-vv.lisp

@@ -214,88 +214,70 @@ expecting ~a or ~a, got: ~a)" b dim (1+ dim) l))
                                 (values ,@row))))))
            finally (return ,(gk p :out-sym)))))
 
+(defmacro vverr-len (b wanted got)
+  `(unless ,wanted
+     (vverr ,b (format nil "bad # of elements. wanted ~a, got: ~a" ',wanted ,got))))
+
 (defun vv-proc (body)
   (declare (optimize speed (safety 2)))
   (labels
-    ((err (p b msg) (error (format nil "VV: ~a, for: ~s~%in: ~s " msg (gk p :fx) b)))
-     (tx-m@ (b &aux (p (vvconf b :vv-sym #.(mkstr *vv-m@*)))) (procm@fx b p)) ; m@
-     (tx-r@ (b &aux (p (vvconf b :vv-sym #.(mkstr *vv-r@*)))) (procr@$fx b p)) ; r@
-
-     (tx-!@ (b &aux (p (vvconf b)))
-       (cond
-         ((> (the pn (gk p :arrs)) 1) (err p b "!@: invalid input, too many $"))
-         ((gk+ p :.l :.r) (err p b "!@: vec broadcasting on both sides"))
-         ((gk+ p :.l :$r) (err p b "!@: .fx$ not implemented"))
-
-         ((gk+ p :$l :$r)
-          (unless (= 3 (length b)) (err p b "!@: bad # of elements"))
-          (proc!@$fx$ b p))
-
-         ((gk+ p :$l :.r)
-          (unless (> (length b) 2) (err p b "!@: missing vecs"))
-          (proc!@$fx. b p))
-         ((gk+ p :$r) (err p b "!@: fx$ not implemented"))
-
-         ((gk+ p :$l)
-          (unless (> (length b) 2) (err p b "!@: missing vecs"))
-          (proc!@$fx b p))
-         ((gk+ p :.r) (proc!@fx. b p))
-         ((gk+ p :.l) ([email protected] b p))
-
-         ((gk0 p :$l :$r :.l :.r) (proc!@fx b p))
-         (t (err p b "!@: unexpected input"))))
-
-     (tx-_@ (b &aux (p (vvconf b :vv-sym #.(mkstr *vv-_@*))))
-       (cond
-         ((> (the pn (gk p :arrs)) 1) (err p b "_@: invalid input, too many $"))
-         ((gk+ p :.l :.r) (err p b "_@: vec broadcasting on both sides"))
-
-         ((gk+ p :$l :.r) (proc_@$fx. b p))
-
-         ((gk+ p :$l)
-          (unless (= 2 (length b)) (err p b "_@: bad # of elements"))
-          (proc_@$fx b p))
-
-         ((gk0 p :$l :$r :.l :.r) (proc_@fx b p))
-         (t (err p b "_@: unexpected input"))))
-
-     (tx-.@ (b &aux (p (vvconf b :vv-sym #.(mkstr *vv-.@*))))
-       (cond
-         ((gk0 p :$l :$r :.l :.r) (proc.@fx b p))
-
-         ((gk+ p :$l)
-          (unless (= 2 (length b)) (err p b ".@: bad # of elements"))
-          (proc.@$fx b p))
-
-         (t (err p b ".@: unexpected input"))))
-
-     (tx-x@ (b &aux (p (vvconf b :vv-sym #.(mkstr *vv-x@*)))) (procx@$fx b p))
-     (tx-%@ (b &aux (p (vvconf b :vv-sym #.(mkstr *vv-%@*))))
-        (cond
-          ((not (gk0 p :$r :.r :.l)) (err p b "%@: bad configuration"))
-
-          ((gk+ p :$l)
-           (unless (= (length b) 3) (err p b "%@: bad number of elements") )
-           (proc%@$fx b p))
-
-          (t (proc%@fx b p))))
-
+    ((m@ (b &aux (p (vvconf b #.(mkstr *vv-m@*)))) (procm@fx b p))
+     (r@ (b &aux (p (vvconf b #.(mkstr *vv-r@*)))) (procr@$fx b p))
+     (x@ (b &aux (p (vvconf b #.(mkstr *vv-x@*)))) (procx@$fx b p))
+     (%@ (b &aux (p (vvconf b #.(mkstr *vv-%@*))) (l (length b)))
+       (cond ((not (gk0 p :$r :.r :.l)) (vverr b "bad configuration"))
+             ((gk+ p :$l)
+              (vverr-len b (= l 3) l)
+              (proc%@$fx b p))
+             (t (proc%@fx b p))))
+
+     (!@ (b &aux (p (vvconf b #.(mkstr *vv-!@*))) (l (length b)))
+       (cond ((gk+ p :.l :$r) (vverr b "not implemented"))
+             ((gk+ p :$l :$r)
+              (vverr-len b (= l 3) l)
+              (proc!@$fx$ b p))
+             ((gk+ p :$l :.r)
+              (vverr-len b (> l 2) l)
+              (proc!@$fx. b p))
+             ((gk+ p :$r) (vverr b "not implemented"))
+             ((gk+ p :$l)
+              (vverr-len b (> l 2) l)
+              (proc!@$fx b p))
+             ((gk+ p :.r) (proc!@fx. b p))
+             ((gk+ p :.l) ([email protected] b p))
+             ((gk0 p :$l :$r :.l :.r) (proc!@fx b p))
+             (t (vverr b "unexpected input"))))
+
+     (_@ (b &aux (p (vvconf b #.(mkstr *vv-_@*))) (l (length b)))
+       (cond ((gk+ p :$l :.r) (proc_@$fx. b p))
+             ((gk+ p :$l)
+              (vverr-len b (= l 2) l)
+              (proc_@$fx b p))
+             ((gk0 p :$l :$r :.l :.r) (proc_@fx b p))
+             (t (vverr b "unexpected input"))))
+     (.@ (b &aux (p (vvconf b #.(mkstr *vv-.@*))) (l (length b)))
+       (cond ((gk0 p :$l :$r :.l :.r) (proc.@fx b p))
+             ((gk+ p :$l)
+              (vverr-len b (= l 2) l)
+              (proc.@$fx b p))
+             (t (vverr b "unexpected input"))))
+
+     (split (b) (cons (rec (car b)) (rec (cdr b))))
      (rec (b) ; this messy, but much faster to define s as late as possible,
-              ; and once only (before it was hidden in fxs)
        (cond ((or (null b) (atom b)) (return-from rec b))
              ((not (and (listp b) (symbolp (car b))))
-              (return-from rec (cons (rec (car b)) (rec (cdr b))))))
+              (return-from rec (split b))))
 
        (let ((s (mkstr (car b))))
          (declare (string s))
-         (cond ((match-substr #.(mkstr *vv-!@*) s) (rec (tx-!@ b)))
-               ((match-substr #.(mkstr *vv-_@*) s) (rec (tx-_@ b)))
-               ((match-substr #.(mkstr *vv-.@*) s) (rec (tx-.@ b)))
-               ((match-substr #.(mkstr *vv-r@*) s) (rec (tx-r@ b)))
-               ((match-substr #.(mkstr *vv-%@*) s) (rec (tx-%@ b)))
-               ((match-substr #.(mkstr *vv-x@*) s) (rec (tx-x@ b)))
-               ((match-substr #.(mkstr *vv-m@*) s) (rec (tx-m@ b)))
-               (t (cons (rec (car b)) (rec (cdr b))))))))
+         (cond ((match-substr #.(mkstr *vv-!@*) s) (rec (!@ b)))
+               ((match-substr #.(mkstr *vv-_@*) s) (rec (_@ b)))
+               ((match-substr #.(mkstr *vv-.@*) s) (rec (.@ b)))
+               ((match-substr #.(mkstr *vv-r@*) s) (rec (r@ b)))
+               ((match-substr #.(mkstr *vv-%@*) s) (rec (%@ b)))
+               ((match-substr #.(mkstr *vv-x@*) s) (rec (x@ b)))
+               ((match-substr #.(mkstr *vv-m@*) s) (rec (m@ b)))
+               (t (split b))))))
     (rec body)))
 
 (defmacro define-vv-macro ()

test/arr.lisp

@@ -17,14 +17,18 @@
       (is a #(100.2f0 2f0) :test #'equalp)
       (is (veq:lst (f2!@+ (veq:f2$ a) 2f0 3f0)) '(102.2f0 5f0)))
 
-    (is (veq:d$_ (loop for i from 0 below 3
-                      collect (list (veq:df i)
-                                    (veq:df (1+ i)))))
-        #(0d0 1d0 1d0 2d0 2d0 3d0)
-        :test #'equalp)
+    (is-arr (veq:d$_ (loop for i from 0 below 3
+                           collect (list (veq:df i) (veq:df (1+ i)))))
+            #(0d0 1d0 1d0 2d0 2d0 3d0))
+
+    (is-arr (veq:d_ '(1d0 2d0 3d0 4d0)) #(1d0 2d0 3d0 4d0))
+    (let ((a (list 1d0 2d0))) (is-arr (veq:d_ a) #(1d0 2d0)))
+
+    (is-arr (veq:new-stride (2 3 :ff) (veq:f$~ (6) 1f0 2f0 3f0 4f0 5f0 6f0))
+            #(1f0 2f0 0f0 3f0 4f0 0f0 5f0 6f0 0f0))
 
-    (is (veq:d_ '(1d0 2d0 3d0 4d0)) #(1d0 2d0 3d0 4d0) :test #'equalp)
-    (let ((a (list 1d0 2d0))) (is (veq:d_ a) #(1d0 2d0) :test #'equalp))))
+    (is-arr (veq:new-stride (2 4 :ff 2f0) (veq:f$~ (6) 1f0 2f0 3f0 4f0 5f0 6f0))
+            #(1.0 2.0 2.0 2.0 3.0 4.0 2.0 2.0 5.0 6.0 2.0 2.0))))
 
 
 (subtest "lerp"