generalizations: Only define npick for >= 1. Fixes #1306.

diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor
index 9b6374ca5f7c1f105bf35b006e638d8d14597bd5..626111fffcca03cd77a73a8cf567e31fc7c86fd2 100644 (file)
--- a/basis/generalizations/generalizations-tests.factor
+++ b/basis/generalizations/generalizations-tests.factor
@@ -6,6 +6,8 @@ IN: generalizations.tests
 { 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test\r
 { 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test\r
 { 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test\r
+[ 1 2 3 4 0 npick ] [ nonpositive-npick? ] must-fail-with\r
+[ 1 2 3 4 -11 npick ] [ nonpositive-npick? ] must-fail-with\r
 \r
 [ 1 1 ndup ] must-infer\r
 { 1 1 } [ 1 1 ndup ] unit-test\r
@@ -25,86 +27,86 @@ IN: generalizations.tests
 [ 1 2 3 4 4 ndrop ] must-infer\r
 { 0 } [ 0 1 2 3 4 4 ndrop ] unit-test\r
 [ [ 1 ] 5 ndip ] must-infer\r
-[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test\r
+{ 1 2 3 4 } [ 2 3 4 [ 1 ] 3 ndip ] unit-test\r
 \r
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer\r
 [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] must-infer\r
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test\r
 { 2 1 2 3 4 5 } [ 1 2 3 4 5 2 '[ drop drop drop drop drop _ ] 5 nkeep ] unit-test\r
-[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
+{ [ 1 2 3 + ] } [ 1 2 3 [ + ] 3 ncurry ] unit-test\r
 \r
-[ "HELLO" ] [ "hello" [ >upper ] 1 napply ] unit-test\r
-[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test\r
+{ "HELLO" } [ "hello" [ >upper ] 1 napply ] unit-test\r
+{ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } } [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test\r
 [ [ dup 2^ 2array ] 5 napply ] must-infer\r
 \r
-[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test\r
+{ { "xyc" "xyd" } } [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test\r
 \r
-[ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test\r
+{ 4 5 1 2 3 } [ 1 2 3 4 5 2 3 mnswap ] unit-test\r
 \r
-[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test\r
+{ 1 2 3 4 5 6 } [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test\r
 \r
-[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test\r
+{ 17 } [ 3 1 3 3 7 5 nsum ] unit-test\r
 { 4 1 } [ 4 nsum ] must-infer-as\r
 \r
 [ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test\r
 { 3 5 } [ 2 nweave ] must-infer-as\r
 \r
-[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]\r
+{ { 0 1 2 } { 3 5 4 } { 7 8 6 } }\r
 [ 9 [ ] each-integer { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test\r
 \r
-[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test\r
+{ 1 2 3 4 1 2 3 } [ 1 2 3 4 3 nover ] unit-test\r
 \r
-[ [ 1 2 3 ] [ 1 2 3 ] ]\r
+{ [ 1 2 3 ] [ 1 2 3 ] }\r
 [ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test\r
 \r
-[ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test\r
+{ 15 3 } [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test\r
 \r
 : nover-test ( -- a b c d e f g )\r
    1 2 3 4 3 nover ;\r
 \r
-[ 1 2 3 4 1 2 3 ] [ nover-test ] unit-test\r
+{ 1 2 3 4 1 2 3 } [ nover-test ] unit-test\r
 \r
 [ '[ number>string _ append ] 4 napply ] must-infer\r
 \r
-[ 6 8 10 12 ] [\r
+{ 6 8 10 12 } [\r
     1 2 3 4\r
     5 6 7 8 [ + ] 4 apply-curry 4 spread*\r
 ] unit-test\r
 \r
-[ 6 ] [ 5 [ 1 + ] 1 spread* ] unit-test\r
-[ 6 ] [ 5 [ 1 + ] 1 cleave* ] unit-test\r
-[ 6 ] [ 5 [ 1 + ] 1 napply  ] unit-test\r
+{ 6 } [ 5 [ 1 + ] 1 spread* ] unit-test\r
+{ 6 } [ 5 [ 1 + ] 1 cleave* ] unit-test\r
+{ 6 } [ 5 [ 1 + ] 1 napply  ] unit-test\r
 \r
-[ 6 ] [ 6 0 spread* ] unit-test\r
-[ 6 ] [ 6 0 cleave* ] unit-test\r
-[ 6 ] [ 6 [ 1 + ] 0 napply ] unit-test\r
+{ 6 } [ 6 0 spread* ] unit-test\r
+{ 6 } [ 6 0 cleave* ] unit-test\r
+{ 6 } [ 6 [ 1 + ] 0 napply ] unit-test\r
 \r
-[ 6 7 8 9 ] [\r
+{ 6 7 8 9 } [\r
     1\r
     5 6 7 8 [ + ] 4 apply-curry 4 cleave*\r
 ] unit-test\r
 \r
-[ 8 3 8 3/2 ] [\r
+{ 8 3 8 3/2 } [\r
     6 5 4 3\r
     2 [ + ] [ - ] [ * ] [ / ] 4 cleave-curry 4 spread*\r
 ] unit-test\r
 \r
-[ 8 4 0 -3 ] [\r
+{ 8 4 0 -3 } [\r
     6 5 4  3\r
     2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*\r
 ] unit-test\r
 \r
-[ { 1 2 } { 3 4 } { 5 6 } ]\r
+{ { 1 2 } { 3 4 } { 5 6 } }\r
 [ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test\r
 \r
-[ { 1 2 3 } { 4 5 6 } ]\r
+{ { 1 2 3 } { 4 5 6 } }\r
 [ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test\r
 \r
-[ { 1 2 3 } { 4 5 6 } ]\r
+{ { 1 2 3 } { 4 5 6 } }\r
 [ 1 2 3 4 5 6 [ 3array ] [ 3array ] 3 2 nspread* ] unit-test\r
 \r
-[ ]\r
+{ }\r
 [ [ 2array ] 2 0 mnapply ] unit-test\r
 \r
-[ ]\r
+{ }\r
 [ 2 0 nspread* ] unit-test\r

diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 303d0d092610859dfdbd4807467a8e4507b8c5a5..8b093b86e06446c6cf83c17ab6203b087e9e1a08 100644 (file)
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -24,8 +24,14 @@ MACRO: call-n ( n -- )
 MACRO: nsum ( n -- )
     1 - [ + ] n*quot ;
 
+ERROR: nonpositive-npick n ;
+
 MACRO: npick ( n -- )
-    1 - [ dup ] [ '[ _ dip swap ] ] repeat ;
+    {
+        { [ dup 0 <= ] [ nonpositive-npick ] }
+        { [ dup 1 = ] [ drop [ dup ] ] }
+        [ 1 - [ dup ] [ '[ _ dip swap ] ] repeat ]
+    } cond ;
 
 MACRO: nover ( n -- )
     dup 1 + '[ _ npick ] n*quot ;