Merge branch 'master' of git://factorcode.org/git/factor

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -1,7 +1,7 @@
 IN: compiler.cfg.linear-scan.tests
 USING: tools.test random sorting sequences sets hashtables assocs
 kernel fry arrays splitting namespaces math accessors vectors
-math.order
+math.order grouping
 cpu.architecture
 compiler.cfg.instructions
 compiler.cfg.registers

basis/grouping/grouping-tests.factor

@@ -1,4 +1,5 @@
-USING: grouping tools.test kernel sequences arrays ;
+USING: grouping tools.test kernel sequences arrays
+math ;
 IN: grouping.tests
 
 [ { 1 2 3 } 0 group ] must-fail

basis/io/files/unix/unix-tests.factor

@@ -1,7 +1,8 @@
 USING: tools.test io.files io.files.temp io.pathnames
 io.directories io.files.info io.files.info.unix continuations
 kernel io.files.unix math.bitwise calendar accessors
-math.functions math unix.users unix.groups arrays sequences ;
+math.functions math unix.users unix.groups arrays sequences
+grouping ;
 IN: io.files.unix.tests
 
 [ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test

basis/roman/roman.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel math math.order math.vectors
 namespaces make quotations sequences splitting.monotonic
-sequences.private strings unicode.case lexer parser ;
+sequences.private strings unicode.case lexer parser
+grouping ;
 IN: roman
 
 <PRIVATE

basis/unix/authors.txt

@@ -1 +1,2 @@
 Slava Pestov
+Eduardo Cavazos

basis/unix/unix.factor

@@ -1,4 +1,5 @@
 ! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2008 Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax kernel libc
 sequences continuations byte-arrays strings math namespaces

core/assocs/assocs-docs.factor

@@ -115,6 +115,7 @@ $nl
 { $subsection assoc-map }
 { $subsection assoc-push-if }
 { $subsection assoc-filter }
+{ $subsection assoc-filter-as }
 { $subsection assoc-contains? }
 { $subsection assoc-all? }
 "Additional combinators:"
@@ -232,6 +233,12 @@ HELP: assoc-filter
 { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "subassoc" "a new assoc" } }
 { $description "Outputs an assoc of the same type as " { $snippet "assoc" } " consisting of all entries for which the predicate quotation yields true." } ;
 
+HELP: assoc-filter-as
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
+{ $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields true." } ;
+
+{ assoc-filter assoc-filter-as } related-words
+
 HELP: assoc-contains?
 { $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "?" "a boolean" } }
 { $description "Tests if the assoc contains an entry satisfying a predicate by applying the quotation to each entry in turn. Iteration stops if an entry is found for which the quotation outputs a true value." } ;

core/byte-arrays/byte-arrays-docs.factor

@@ -30,6 +30,10 @@ HELP: <byte-array> ( n -- byte-array )
 { $values { "n" "a non-negative integer" } { "byte-array" "a new byte array" } }
 { $description "Creates a new byte array holding " { $snippet "n" } " bytes." } ;
 
+HELP: (byte-array)
+{ $values { "n" "a non-negative integer" } { "byte-array" "a new byte array" } }
+{ $description "Creates a new byte array with unspecified contents of length " { $snippet "n" } " bytes." } ;
+
 HELP: >byte-array
 { $values { "seq" "a sequence" } { "byte-array" byte-array } }
 { $description

core/generic/standard/standard-tests.factor

@@ -4,7 +4,8 @@ generic.standard strings sequences arrays kernel accessors words
 specialized-arrays.double byte-arrays bit-arrays parser
 namespaces make quotations stack-checker vectors growable
 hashtables sbufs prettyprint byte-vectors bit-vectors
-specialized-vectors.double definitions generic sets graphs assocs ;
+specialized-vectors.double definitions generic sets graphs assocs
+grouping ;
 
 GENERIC: lo-tag-test ( obj -- obj' )
 

core/kernel/kernel-tests.factor

@@ -1,7 +1,7 @@
 USING: arrays byte-arrays kernel kernel.private math memory
 namespaces sequences tools.test math.private quotations
 continuations prettyprint io.streams.string debugger assocs
-sequences.private accessors locals.backend ;
+sequences.private accessors locals.backend grouping ;
 IN: kernel.tests
 
 [ 0 ] [ f size ] unit-test

core/math/floats/floats-tests.factor

@@ -1,4 +1,5 @@
-USING: kernel math math.constants tools.test sequences ;
+USING: kernel math math.constants tools.test sequences
+grouping ;
 IN: math.floats.tests
 
 [ t ] [ 0.0 float? ] unit-test

core/math/math-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel sequences quotations
-math.private ;
+math.private byte-arrays io.binary ;
 IN: math
 
 HELP: number=
@@ -306,6 +306,10 @@ HELP: find-last-integer
 { $description "Applies the quotation to each integer from " { $snippet "n" } " down to 0, inclusive. Iteration stops when the quotation outputs a true value or 0 is reached. If the quotation yields a true value for some integer, the word outputs that integer. Otherwise, the word outputs " { $link f } "." }
 { $notes "This word is used to implement " { $link find-last } "." } ;
 
+HELP: byte-array>bignum
+{ $values { "byte-array" byte-array } { "n" integer } }
+{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link >le } " or " { $link >be } " instead." } ;
+
 ARTICLE: "division-by-zero" "Division by zero"
 "Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value."
 $nl

core/sequences/sequences-docs.factor

@@ -679,12 +679,28 @@ HELP: append
     }
 } ;
 
+HELP: append-as
+{ $values { "seq1" sequence } { "seq2" sequence } { "exemplar" sequence } { "newseq" sequence } }
+{ $description "Outputs a new sequence of the same type as " { $snippet "exemplar" } " consisting of the elements of " { $snippet "seq1" } " followed by " { $snippet "seq2" } "." }
+{ $errors "Throws an error if " { $snippet "seq1" } " or " { $snippet "seq2" } " contain elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." }
+{ $examples 
+    { $example "USING: prettyprint sequences ;"
+        "{ 1 2 } B{ 3 4 } B{ } append-as ."
+        "B{ 1 2 3 4 }"
+    }
+    { $example "USING: prettyprint sequences strings ;"
+        "\"go\" \"ing\" SBUF\" \" append-as ."
+        "SBUF\" going\""
+    }
+} ;
+
+{ append append-as } related-words
+
 HELP: prepend
 { $values { "seq1" sequence } { "seq2" sequence } { "newseq" sequence } }
 { $description "Outputs a new sequence of the same type as " { $snippet "seq2" } " consisting of the elements of " { $snippet "seq2" } " followed by " { $snippet "seq1" } "." }
 { $errors "Throws an error if " { $snippet "seq1" } " contains elements not permitted in sequences of the same class as " { $snippet "seq2" } "." }
-{ $examples 
+{ $examples { $example "USING: prettyprint sequences ;"
-    { $example "USING: prettyprint sequences ;"
         "{ 1 2 } B{ 3 4 } prepend ."
         "B{ 3 4 1 2 }"
     }
@@ -705,6 +721,19 @@ HELP: 3append
     }
 } ;
 
+HELP: 3append-as
+{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "exemplar" sequence } { "newseq" sequence } }
+{ $description "Outputs a new sequence consisting of the elements of " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } " in turn of the same type as " { $snippet "exemplar" } "." }
+{ $errors "Throws an error if " { $snippet "seq1" } ", " { $snippet "seq2" } ", or " { $snippet "seq3" } " contain elements not permitted in sequences of the same class as " { $snippet "exemplar" } "." }
+{ $examples
+    { $example "USING: prettyprint sequences ;"
+        "\"a\" \"b\" \"c\" SBUF\" \" 3append-as ."
+        "SBUF\" abc\""
+    }
+} ;
+
+{ 3append 3append-as } related-words
+
 HELP: surround
 { $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "newseq" sequence } }
 { $description "Outputs a new sequence with " { $snippet "seq1" } " inserted between " { $snippet "seq2" } " and " { $snippet "seq3" } "." }
@@ -891,6 +920,16 @@ HELP: produce
     { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" }
 } ;
 
+HELP: produce-as
+{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "exemplar" sequence } { "seq" "a sequence" } }
+{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." }
+{ $examples
+    "The following example divides a number by two until we reach zero, and accumulates intermediate results:"
+    { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] V{ } produce-as nip ." "V{ 668 334 167 83 41 20 10 5 2 1 0 }" }
+    "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:"
+    { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] B{ } produce-as ." "B{ 8 2 2 9 }" }
+} ;
+
 HELP: sigma
 { $values { "seq" sequence } { "quot" quotation } { "n" number } }
 { $description "Like map sum, but without creating an intermediate sequence." }
@@ -1359,8 +1398,10 @@ ARTICLE: "sequences-reshape" "Reshaping sequences"
 
 ARTICLE: "sequences-appending" "Appending sequences"
 { $subsection append }
+{ $subsection append-as }
 { $subsection prepend }
 { $subsection 3append }
+{ $subsection 3append-as }
 { $subsection surround }
 { $subsection glue }
 { $subsection concat }
@@ -1417,6 +1458,7 @@ ARTICLE: "sequences-combinators" "Sequence combinators"
 { $subsection map-index }
 { $subsection accumulate }
 { $subsection produce }
+{ $subsection produce-as }
 "Filtering:"
 { $subsection push-if }
 { $subsection filter }

core/sorting/sorting-tests.factor

@@ -1,5 +1,5 @@
 USING: sorting sequences kernel math math.order random
-tools.test vectors sets vocabs ;
+tools.test vectors sets vocabs grouping ;
 IN: sorting.tests
 
 [ { } ] [ { } natural-sort ] unit-test

core/vocabs/loader/loader-tests.factor

@@ -3,7 +3,7 @@ USING: vocabs.loader tools.test continuations vocabs math
 kernel arrays sequences namespaces io.streams.string
 parser source-files words assocs classes.tuple definitions
 debugger compiler.units tools.vocabs accessors eval
-combinators vocabs.parser ;
+combinators vocabs.parser grouping ;
 
 ! This vocab should not exist, but just in case...
 [ ] [

extra/project-euler/052/052.factor

@@ -1,7 +1,8 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators.short-circuit kernel math
-    project-euler.common sequences sorting ;
+    project-euler.common sequences sorting
+    grouping ;
 IN: project-euler.052
 
 ! http://projecteuler.net/index.php?section=problems&id=52

misc/fuel/fuel-debug-uses.el

@@ -47,7 +47,8 @@
                          (substring-no-properties (thing-at-point 'line)))))
               (when in-usings (setq line (concat "! " line)))
               (push line lines))
-            (when (and in-usings (looking-at ".*\\_<;\\_>")) (setq in-usings nil))
+            (when (and in-usings (looking-at "\\(^\\|.* \\);\\( \\|\n\\)"))
+              (setq in-usings nil))
             (forward-line))
           (reverse lines))))))
 

misc/fuel/fuel-edit.el

@@ -33,6 +33,11 @@
 
 ;;; Auxiliar functions:
 
+(defun fuel-edit--looking-at-vocab ()
+  (save-excursion
+    (fuel-syntax--beginning-of-defun)
+    (looking-at "USING:\\|USE:")))
+
 (defun fuel-edit--try-edit (ret)
   (let* ((err (fuel-eval--retort-error ret))
          (loc (fuel-eval--retort-result ret)))
@@ -92,9 +97,9 @@ With prefix, asks for the word to edit."
                    (fuel-completion--read-word "Edit word: ")))
          (cmd `(:fuel* ((:quote ,word) fuel-get-edit-location)))
          (marker (and (not arg) (point-marker))))
-    (condition-case nil
+    (if (and (not arg) (fuel-edit--looking-at-vocab))
-        (fuel-edit--try-edit (fuel-eval--send/wait cmd))
+        (fuel-edit-vocabulary nil word)
-      (error (fuel-edit-vocabulary nil word)))
+      (fuel-edit--try-edit (fuel-eval--send/wait cmd)))
     (when marker (ring-insert find-tag-marker-ring marker))))
 
 (defun fuel-edit-word-doc-at-point (&optional arg word)

misc/fuel/fuel-font-lock.el

@@ -82,12 +82,24 @@
                  ((looking-at "\\(TUPLE\\|SYMBOLS\\|VARS\\): ")
                   'factor-font-lock-symbol)
                  (t 'default))))
+        ((char-equal (char-after (nth 8 state)) ?U)
+         'factor-font-lock-parsing-word)
         (t 'factor-font-lock-comment)))
 
 (defconst fuel-font-lock--font-lock-keywords
   `((,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect)
     (,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
     (,fuel-syntax--vocab-ref-regexp  2 'factor-font-lock-vocabulary-name)
+    (,fuel-syntax--constructor-regex (1 'factor-font-lock-word)
+                                     (2 'factor-font-lock-type-name)
+                                     (3 'factor-font-lock-invalid-syntax nil t))
+    (,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
+                                 (2 'factor-font-lock-type-name)
+                                 (3 'factor-font-lock-invalid-syntax nil t))
+    (,fuel-syntax--rename-regex (1 'factor-font-lock-word)
+                                (2 'factor-font-lock-vocabulary-name)
+                                (3 'factor-font-lock-word)
+                                (4 'factor-font-lock-invalid-syntax nil t))
     (,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration)
     (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word)
     (,fuel-syntax--alias-definition-regex (1 'factor-font-lock-word)

misc/fuel/fuel-syntax.el

@@ -187,6 +187,7 @@
                 "QUALIFIED-WITH:" "QUALIFIED:"
                 "RENAME:"
                 "SINGLETON:" "SLOT:" "SYMBOL:"
+                "TYPEDEF:"
                 "USE:"
                 "VAR:")))
 
@@ -208,6 +209,15 @@
           (format ":[^ ]* [^ ]+\\(%s\\)*" fuel-syntax--stack-effect-regex)
           "M[^:]*: [^ ]+ [^ ]+"))
 
+(defconst fuel-syntax--constructor-regex
+  "\\_<C: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
+
+(defconst fuel-syntax--typedef-regex
+  "\\_<TYPEDEF: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
+
+(defconst fuel-syntax--rename-regex
+  "\\_<RENAME: +\\(\\w+\\) +\\(\\w+\\) +=> +\\(\\w+\\)\\( .*\\)?$")
+
 
 ;;; Factor syntax table
 
@@ -239,10 +249,10 @@
     ("\\_<<\\(\"\\)\\_>" (1 "\""))
     ("\\_<\\(\"\\)>\\_>" (1 "\""))
     ;; Multiline constructs
-    ("\\_<USING:\\( \\)\\(;\\)" (1 "<b") (2 ">b"))
+    ("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
     ("\\_<USING:\\( \\)" (1 "<b"))
     ("\\_<TUPLE: +\\w+? +< +\\w+? *\\( \\)" (1 "<b"))
-    ("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\)\\([^<]\\|\\_>\\)" (2 "<b"))
+    ("\\_<\\(TUPLE\\|SYMBOLS\\|VARS\\): +\\w+? *\\( \\)\\([^<\n]\\|\\_>\\)" (2 "<b"))
     ("\\(\n\\| \\);\\_>" (1 ">b"))
     ;; Let and lambda:
     ("\\_<\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))