diff --git a/run-tests.sh b/run-tests.sh index 58d93e0..269c551 100755 --- a/run-tests.sh +++ b/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)))' diff --git a/src/array-utils.lisp b/src/array-utils.lisp index 4fdd40b..3eb5b5f 100644 --- a/src/array-utils.lisp +++ b/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))) diff --git a/src/generic-utils.lisp b/src/generic-utils.lisp index 6bfb5a1..f0372e6 100644 --- a/src/generic-utils.lisp +++ b/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" diff --git a/src/ops-vv-helpers.lisp b/src/ops-vv-helpers.lisp index 3612002..859fa6d 100644 --- a/src/ops-vv-helpers.lisp +++ b/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 diff --git a/src/ops-vv.lisp b/src/ops-vv.lisp index 4dc7d05..798284e 100644 --- a/src/ops-vv.lisp +++ b/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) (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 - ((> (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) (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 ((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 () diff --git a/test/arr.lisp b/test/arr.lisp index 7518dcf..9378365 100644 --- a/test/arr.lisp +++ b/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" diff --git a/test/run.lisp b/test/run.lisp old mode 100644 new mode 100755 index 5f7bf85..ff2bba4 --- a/test/run.lisp +++ b/test/run.lisp @@ -5,11 +5,12 @@ (in-package #:veq-tests) -(defvar *files* `(#P"test/veq.lisp" #P"test/macro.lisp" - #P"test/macro-vv.lisp" #P"test/arr.lisp" - #P"test/checks.lisp" #P"test/mat.lisp")) +(defparameter *files* + (mapcar (lambda (p) (asdf:system-relative-pathname "veq/tests" p)) + '(#P"test/veq.lisp" #P"test/macro.lisp" + #P"test/macro-vv.lisp" #P"test/arr.lisp" + #P"test/checks.lisp" #P"test/mat.lisp"))) -; TODO: print test file runtime? (defun run-tests () (loop with fails = 0 for f in *files* @@ -17,8 +18,7 @@ (unless (prove:run f :reporter :fiveam) (incf fails)) (format t "~&done: ~a~%" (veq::mkstr f)) - finally (return (unless (< fails 1) - (sb-ext:quit :unix-status 7))))) + finally (return (unless (< fails 1) (uiop:quit 7))))) (defmacro is-arr (&rest rest) `(is ,@rest :test #'equalp)) diff --git a/test/veq.lisp b/test/veq.lisp old mode 100755 new mode 100644 index fcd1f63..cad18c9 --- a/test/veq.lisp +++ b/test/veq.lisp @@ -11,7 +11,7 @@ (is (veq::strip-symbols (veq::mkstr 'name!abc?) (mapcar #'veq::mkstr '(:! :? :hi))) "NAMEABC") (is (veq:lst (veq::edge-fx (lambda (c) (equal #\F c)) (veq::mkstr 'ffffhiii))) '(4 "HIII")) - (is (veq:lst (veq::edge-chars-str #\F (veq::mkstr 'ffffhiii))) '(4 "HIII")) + (is (veq:lst (veq::edge-str #\F (veq::mkstr 'ffffhiii))) '(4 "HIII")) (is (veq:lst (veq:~ :a)) '(:a)) (is (veq:lst (values 3 2) (values 7 8)) '(3 2 7 8)) diff --git a/veq.asd b/veq.asd index f10ce9d..5be2265 100644 --- a/veq.asd +++ b/veq.asd @@ -3,7 +3,7 @@ :description "reasonably fast operations for 1-4d vectors, matrices, and arrays of vectors." :author "anders hoff / @inconvergent / inconvergent@gmail.com" - :version "4.5.2" :licence "MIT" + :version "4.5.3" :licence "MIT" :in-order-to ((asdf:test-op (asdf:test-op #:veq/tests))) :pathname "src/" :serial nil :depends-on (#+SBCL #:sb-cltl2) @@ -43,8 +43,8 @@ arrays of vectors." (:file "easing" :depends-on ("macrolets")))) (asdf:defsystem #:veq/tests - :depends-on (#:veq #:prove) - :version "4.5.2" + :depends-on (#:veq #:prove #:asdf #:uiop) + :version "4.5.3" :perform (asdf:test-op (o s) (uiop:symbol-call ':veq-tests '#:run-tests)) :pathname "test/" :serial t :components ((:file "run")))