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

core/dlists/dlists.factor

@@ -144,6 +144,11 @@ PRIVATE>
 : dlist-delete ( obj dlist -- obj/f )
     >r [ eq? ] curry r> delete-node-if ;
 
+: dlist-delete-all ( dlist -- )
+    f over set-dlist-front
+    f over set-dlist-back
+    0 swap set-dlist-length ;
+
 : dlist-each ( dlist quot -- )
     [ dlist-node-obj ] swap compose dlist-each-node ; inline
 

core/io/files/files-tests.factor

@@ -2,7 +2,8 @@ IN: temporary
 USING: tools.test io.files io threads kernel continuations ;
 
 [ "passwd" ] [ "/etc/passwd" file-name ] unit-test
-[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
+[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
+[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
 
 [ ] [
     "test-foo.txt" resource-path <file-writer> [

core/io/files/files.factor

@@ -64,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
     normalize-directory dup (directory) fixup-directory ;
 
 : last-path-separator ( path -- n ? )
-    [ length 2 [-] ] keep [ path-separator? ] find-last* ;
+    [ length 1- ] keep [ path-separator? ] find-last* ;
 
 TUPLE: no-parent-directory path ;
 
@@ -83,7 +83,11 @@ TUPLE: no-parent-directory path ;
     } cond ;
 
 : file-name ( path -- string )
-    dup last-path-separator [ 1+ tail ] [ drop ] if ;
+    right-trim-separators {
+        { [ dup empty? ] [ drop "/" ] }
+        { [ dup last-path-separator ] [ 1+ tail ] }
+        { [ t ] [ drop ] }
+    } cond ;
 
 : resource-path ( path -- newpath )
     \ resource-path get [ image parent-directory ] unless*

core/parser/parser-tests.factor

@@ -349,6 +349,14 @@ IN: temporary
         "IN: temporary : foo ; TUPLE: foo ;"
         <string-reader> "redefining-a-class-4" parse-stream drop
     ] [ [ redefine-error? ] is? ] must-fail-with
+
+    [ ] [
+        "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
+    ] unit-test
+
+    [
+        "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
+    ] must-fail
 ] with-file-vocabs
 
 [

core/parser/parser.factor

@@ -307,10 +307,14 @@ SYMBOL: lexer-factory
 
 ! Parsing word utilities
 : parse-effect ( -- effect )
-    ")" parse-tokens { "--" } split1 dup [
+    ")" parse-tokens "(" over member? [
+        "Stack effect declaration must not contain (" throw
+    ] [
+        { "--" } split1 dup [
             <effect>
         ] [
             "Stack effect declaration must contain --" throw
+        ] if
     ] if ;
 
 TUPLE: bad-number ;

core/vocabs/loader/loader.factor

@@ -149,12 +149,14 @@ SYMBOL: load-help?
     dup modified-sources swap modified-docs ;
 
 : load-error. ( vocab error -- )
-    "While loading " rot dup >vocab-link write-object ":" print
+    "==== " write >r
-    print-error ;
+    dup vocab-name swap f >vocab-link write-object ":" print nl
+    r> print-error ;
 
 TUPLE: require-all-error vocabs ;
 
 : require-all-error ( vocabs -- )
+    [ vocab-name ] map
     \ require-all-error construct-boa throw ;
 
 M: require-all-error summary
@@ -167,7 +169,6 @@ M: require-all-error summary
                 [ [ require ] [ 2array , ] recover ] each
             ] { } make
             dup empty? [ drop ] [
-                "==== LOAD ERRORS:" print
                 dup [ nl load-error. ] assoc-each
                 keys require-all-error
             ] if

extra/asn1/asn1-tests.factor

@@ -5,11 +5,11 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ;
 ] unit-test
 
 [ "testing" ] [
-    "\u0004\u0007testing" <string-reader> [ asn-syntax read-ber ] with-stream
+    "\u000004\u000007testing" <string-reader> [ asn-syntax read-ber ] with-stream
 ] unit-test
 
 [ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [
-    "0$\u0002\u0001\u0001`\u001f\u0002\u0001\u0003\u0004\rAdministrator\u0080\u000bad_is_bogus"
+    "0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus"
     <string-reader> [ asn-syntax read-ber ] with-stream
 ] unit-test
 

extra/concurrency/concurrency-tests.factor

@@ -6,6 +6,8 @@ namespaces tools.test continuations dlists strings math words
 match quotations concurrency.private ;
 IN: temporary
 
+[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test
+
 [ V{ 1 2 3 } ] [
   0 <vector>
   make-mailbox

extra/concurrency/concurrency.factor

@@ -73,7 +73,7 @@ PRIVATE>
 
 : mailbox-get?* ( pred mailbox timeout -- obj )
     2over >r >r (mailbox-block-unless-pred) r> r>
-    mailbox-data delete-node ; inline
+    mailbox-data delete-node-if ; inline
 
 : mailbox-get? ( pred mailbox -- obj )
     f mailbox-get?* ;

extra/hardware-info/windows/ce/ce.factor

@@ -10,25 +10,25 @@ T{ wince-os } os set-global
     "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
     [ GlobalMemoryStatus ] keep ;
 
-M: wince cpus ( -- n ) 1 ;
+M: wince-os cpus ( -- n ) 1 ;
 
-M: wince memory-load ( -- n )
+M: wince-os memory-load ( -- n )
     memory-status MEMORYSTATUS-dwMemoryLoad ;
 
-M: wince physical-mem ( -- n )
+M: wince-os physical-mem ( -- n )
     memory-status MEMORYSTATUS-dwTotalPhys ;
 
-M: wince available-mem ( -- n )
+M: wince-os available-mem ( -- n )
     memory-status MEMORYSTATUS-dwAvailPhys ;
 
-M: wince total-page-file ( -- n )
+M: wince-os total-page-file ( -- n )
     memory-status MEMORYSTATUS-dwTotalPageFile ;
 
-M: wince available-page-file ( -- n )
+M: wince-os available-page-file ( -- n )
     memory-status MEMORYSTATUS-dwAvailPageFile ;
 
-M: wince total-virtual-mem ( -- n )
+M: wince-os total-virtual-mem ( -- n )
     memory-status MEMORYSTATUS-dwTotalVirtual ;
 
-M: wince available-virtual-mem ( -- n )
+M: wince-os available-virtual-mem ( -- n )
     memory-status MEMORYSTATUS-dwAvailVirtual ;

extra/http/server/templating/templating.factor

@@ -32,17 +32,18 @@ M: template-lexer skip-word
 DEFER: <% delimiter
 
 : check-<% ( lexer -- col )
-    "<%" over line-text rot lexer-column start* ;
+    "<%" over lexer-line-text rot lexer-column start* ;
 
 : found-<% ( accum lexer col -- accum )
     [
-        over line-text >r >r lexer-column r> r> subseq parsed
+        over lexer-line-text
+        >r >r lexer-column r> r> subseq parsed
         \ write-html parsed
     ] 2keep 2 + swap set-lexer-column ;
 
 : still-looking ( accum lexer -- accum )
     [
-        dup line-text swap lexer-column tail
+        dup lexer-line-text swap lexer-column tail
         parsed \ print-html parsed
     ] keep next-line ;
 

extra/math/constants/constants-docs.factor

@@ -4,7 +4,7 @@ IN: math.constants
 ARTICLE: "math-constants" "Constants"
 "Standard mathematical constants:"
 { $subsection e }
-{ $subsection gamma }
+{ $subsection euler }
 { $subsection phi }
 { $subsection pi }
 "Various limits:"
@@ -17,7 +17,7 @@ ABOUT: "math-constants"
 HELP: e
 { $values { "e" "base of natural logarithm" } } ;
 
-HELP: gamma
+HELP: euler
 { $values { "gamma" "Euler-Mascheroni constant" } }
 { $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ;
 

extra/math/constants/constants.factor

@@ -3,7 +3,7 @@
 IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
-: gamma ( -- gamma ) 0.57721566490153286060 ; inline
+: euler ( -- gamma ) 0.57721566490153286060 ; inline
 : phi ( -- phi ) 1.61803398874989484820 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline

extra/math/matrices/elimination/elimination.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.vectors math.matrices namespaces
-sequences parser ;
+sequences ;
 IN: math.matrices.elimination
 
 SYMBOL: matrix
@@ -20,6 +20,9 @@ SYMBOL: matrix
 
 : cols ( -- n ) 0 nth-row length ;
 
+: skip ( i seq quot -- n )
+    over >r find* drop r> length or ; inline
+
 : first-col ( row# -- n )
     #! First non-zero column
     0 swap nth-row [ zero? not ] skip ;

extra/nehe/5/5.factor

@@ -108,10 +108,12 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
 
 : nehe5-update-thread ( gadget -- )  
   dup nehe5-gadget-quit? [
+    drop
+  ] [
     redraw-interval sleep 
     dup relayout-1  
     nehe5-update-thread 
-  ] unless ;
+  ] if ;
 
 M: nehe5-gadget graft* ( gadget -- )
  [ f swap set-nehe5-gadget-quit? ] keep

extra/openssl/openssl-tests.factor

@@ -1,6 +1,6 @@
 USING: alien alien.c-types assocs bit-arrays hashtables io io.files
 io.sockets kernel mirrors openssl.libcrypto openssl.libssl
-namespaces math math.parser openssl prettyprint sequences tools.test unix ;
+namespaces math math.parser openssl prettyprint sequences tools.test ;
 
 ! =========================================================
 ! Some crypto functions (still to be turned into words)

extra/openssl/openssl.factor

@@ -4,7 +4,7 @@
 ! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
 
 USING: alien alien.c-types assocs kernel libc namespaces
-openssl.libcrypto openssl.libssl sequences unix ;
+openssl.libcrypto openssl.libssl sequences ;
 
 IN: openssl
 

extra/partial-continuations/partial-continuations.factor

@@ -6,7 +6,7 @@ USING: kernel continuations arrays sequences quotations ;
 : breset ( quot -- )
     [ 1array swap keep first continue-with ] callcc1 nip ;
 
-: (bshift) ( v r k -- )
+: (bshift) ( v r k -- obj )
     >r dup first -rot r>
     [
         rot set-first
@@ -19,4 +19,4 @@ USING: kernel continuations arrays sequences quotations ;
         over >r
         [ (bshift) ] 2curry swap call
         r> first continue-with
-    ] callcc1 2nip ;
+    ] callcc1 2nip ; inline

extra/random-tester/random-tester.factor

@@ -17,9 +17,9 @@ TUPLE: random-tester-error ;
 : test-compiler ! ( data... quot -- ... )
     errored off
     dup quot set
-    datastack clone >vector dup pop* before set
+    datastack 1 head* before set
-    [ call ] catch drop
+    [ call ] [ drop ] recover
-    datastack clone after set
+    datastack after set
     clear
     before get [ ] each
     quot get [ compile-call ] [ errored on ] recover ;

extra/regexp/regexp.factor

@@ -77,7 +77,7 @@ PRIVATE>
 
 : 'hex' ( -- parser )
     "x" token 'hex-digit' 2 exactly-n &>
-    "u" token 'hex-digit' 4 exactly-n &> <|>
+    "u" token 'hex-digit' 6 exactly-n &> <|>
     [ hex> ] <@ ;
 
 : satisfy-tokens ( assoc -- parser )

extra/serialize/serialize-tests.factor

@@ -10,8 +10,6 @@ TUPLE: serialize-test a b ;
 
 C: <serialize-test> serialize-test
 
-: CURRY< \ > parse-until first2 curry parsed ; parsing
-
 : objects
     {
         f
@@ -33,7 +31,7 @@ C: <serialize-test> serialize-test
         B{ 50 13 55 64 1 }
         ?{ t f t f f t f }
         F{ 1.0 3.0 4.0 1.0 2.35 0.33 }
-        CURRY< 1 [ 2 ] >
+        << 1 [ 2 ] curry parsed >>
         { { "a" "bc" } { "de" "fg" } }
         H{ { "a" "bc" } { "de" "fg" } }
     } ;

extra/state-parser/state-parser-tests.factor

@@ -1,4 +1,4 @@
-USING: tools.test state-parser kernel io strings ;
+USING: tools.test state-parser kernel io strings ascii ;
 
 [ "hello" ] [ "hello" [ rest ] string-parse ] unit-test
 [ 2 4 ] [ "12\n123" [ rest drop get-line get-column ] string-parse ] unit-test

extra/tuple-syntax/tuple-syntax-tests.factor

@@ -1,4 +1,5 @@
 USING: tools.test tuple-syntax ;
+IN: temporary
 
 TUPLE: foo bar baz ;
 

extra/tuple-syntax/tuple-syntax.factor

@@ -1,4 +1,5 @@
-USING: kernel sequences slots parser words classes ;
+USING: kernel sequences slots parser words classes
+slots.private ;
 IN: tuple-syntax
 
 ! TUPLE: foo bar baz ;
@@ -7,15 +8,15 @@ IN: tuple-syntax
 : parse-object ( -- object )
     scan-word dup parsing? [ V{ } clone swap execute first ] when ;
 
-: parse-slot-writer ( tuple -- slot-setter )
+: parse-slot-writer ( tuple -- slot# )
     scan dup "}" = [ 2drop f ] [
         1 head* swap class "slots" word-prop
-        [ slot-spec-name = ] with find nip slot-spec-writer
+        [ slot-spec-name = ] with find nip slot-spec-offset
     ] if ;
 
 : parse-slots ( accum tuple -- accum tuple )
     dup parse-slot-writer
-    [ parse-object pick rot execute parse-slots ] when* ;
+    [ parse-object pick rot set-slot parse-slots ] when* ;
 
 : TUPLE{
     scan-word construct-empty parse-slots parsed ; parsing

extra/ui/gadgets/editors/editors.factor

@@ -249,11 +249,11 @@ M: editor gadget-text* editor-string % ;
 : extend-selection ( editor -- )
     dup request-focus dup editor-caret click-loc ;
 
-: mouse-elt ( -- elelement )
+: mouse-elt ( -- element )
     hand-click# get {
+        { 1 T{ one-char-elt } }
         { 2 T{ one-word-elt } }
-        { 3 T{ one-line-elt } }
+    } at T{ one-line-elt } or ;
-    } at T{ one-char-elt } or ;
 
 : drag-direction? ( loc editor -- ? )
     editor-mark* <=> 0 < ;

extra/xmode/utilities/utilities-tests.factor

@@ -1,6 +1,6 @@
 IN: temporary
-USING: xmode.utilities tools.test xml xml.data
+USING: xmode.utilities tools.test xml xml.data kernel strings
-kernel strings vectors sequences io.files prettyprint assocs ;
+vectors sequences io.files prettyprint assocs unicode.case ;
 
 [ "hi" 3 ] [
     { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find