Merge git://factorcode.org/git/factor

core/hashtables/hashtables.factor

@@ -69,10 +69,10 @@ IN: hashtables
 : hash-deleted+ ( hash -- )
     dup hash-deleted 1+ swap set-hash-deleted ; inline
 
-: (set-hash) ( value key hash -- )
+: (set-hash) ( value key hash -- new? )
     2dup new-key@
-    [ rot hash-count+ ] [ rot drop ] if
+    [ rot hash-count+ set-nth-pair t ]
-    set-nth-pair ; inline
+    [ rot drop set-nth-pair f ] if ; inline
 
 : find-pair-next >r 2 fixnum+fast r> ; inline
 
@@ -94,10 +94,10 @@ IN: hashtables
 : find-pair ( array quot -- key value ? ) 0 rot (find-pair) ; inline
 
 : (rehash) ( hash array -- )
-    [ swap pick (set-hash) f ] find-pair 2drop 2drop ;
+    [ swap pick (set-hash) drop f ] find-pair 2drop 2drop ;
 
 : hash-large? ( hash -- ? )
-    dup hash-count 1 fixnum+fast 3 fixnum*fast
+    dup hash-count 3 fixnum*fast
     swap hash-array array-capacity > ;
 
 : hash-stale? ( hash -- ? )
@@ -149,7 +149,7 @@ M: hashtable assoc-size ( hash -- n )
     (rehash) ;
 
 M: hashtable set-at ( value key hash -- )
-    dup ?grow-hash (set-hash) ;
+    dup >r (set-hash) [ r> ?grow-hash ] [ r> drop ] if ;
 
 : associate ( value key -- hash )
     2 <hashtable> [ set-at ] keep ;

core/io/buffers/buffers.factor

@@ -51,12 +51,11 @@ TUPLE: buffer size ptr fill pos ;
 : buffer>> ( buffer -- string )
     dup (buffer>>) 0 rot buffer-reset ;
 
-: (buffer-until) ( start end alien separators -- n )
+: search-buffer-until ( start end alien separators -- n )
     [ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ;
 
-: buffer-until ( separators buffer -- string separator )
+: finish-buffer-until ( buffer n -- string separator )
-    tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll
+    [
-    (buffer-until) [
         over buffer-pos -
         over buffer>
         swap buffer-pop
@@ -64,6 +63,10 @@ TUPLE: buffer size ptr fill pos ;
         buffer>> f
     ] if* ;
 
+: buffer-until ( separators buffer -- string separator )
+    tuck { buffer-pos buffer-fill buffer-ptr } get-slots roll
+    search-buffer-until finish-buffer-until ;
+
 : buffer-length ( buffer -- n )
     dup buffer-fill swap buffer-pos - ;
 

core/optimizer/known-words/known-words.factor

@@ -149,4 +149,4 @@ float-arrays combinators.private ;
 
 \ >be { { fixnum bignum } fixnum } "specializer" set-word-prop
 
-\ (buffer-until) { fixnum fixnum simple-alien string } "specializer" set-word-prop
+\ search-buffer-until { fixnum fixnum simple-alien string } "specializer" set-word-prop

extra/match/match-tests.factor

@@ -5,6 +5,8 @@ IN: temporary
 
 MATCH-VARS: ?a ?b ;
 
+[ f ] [ { ?a ?a } { 1 2 } match ] unit-test
+
 [ H{ { ?a 1 } { ?b 2 } } ] [
  { ?a ?b } { 1 2 } match
 ] unit-test

extra/match/match.factor

@@ -3,7 +3,7 @@
 !
 ! Based on pattern matching code from Paul Graham's book 'On Lisp'.
 USING: parser kernel words namespaces sequences tuples
-combinators macros ;
+combinators macros assocs ;
 IN: match
 
 SYMBOL: _
@@ -22,10 +22,13 @@ SYMBOL: _
 : match-var? ( symbol -- bool )
     dup word? [ "match-var" word-prop ] [ drop f ] if ;
 
+: set-match-var ( value var -- ? )
+    dup namespace key? [ get = ] [ set t ] if ;
+
 : (match) ( value1 value2 -- matched? )
     {
-        { [ dup match-var? ] [ set t ] }
+        { [ dup match-var? ] [ set-match-var ] }
-        { [ over match-var? ] [ swap set t ] }
+        { [ over match-var? ] [ swap set-match-var ] }
         { [ 2dup = ] [ 2drop t ] }
         { [ 2dup [ _ eq? ] either? ] [ 2drop t ] }
         { [ 2dup [ sequence? ] both? ] [
@@ -58,4 +61,6 @@ MACRO: match-cond ( assoc -- )
     } cond ;
 
 : match-replace ( object pattern1 pattern2 -- result )
-    -rot match [ replace-patterns ] bind ;
+    -rot
+    match [ "Pattern does not match" throw ] unless*
+    [ replace-patterns ] bind ;

extra/tools/completion/completion.factor

@@ -39,7 +39,7 @@ vectors words assocs combinators sorting ;
 
 : score ( full fuzzy -- n )
     dup [
-        [ [ length ] 2apply - 15 swap [-] 3 / ] 2keep
+        [ [ length ] 2apply - 15 swap [-] 3 /f ] 2keep
         runs [
             [ 0 [ pick score-1 max ] reduce nip ] keep
             length * +
@@ -50,7 +50,7 @@ vectors words assocs combinators sorting ;
 
 : rank-completions ( results -- newresults )
     sort-keys <reversed>
-    [ 0 [ first max ] reduce 3 / ] keep
+    [ 0 [ first max ] reduce 3 /f ] keep
     [ first < ] curry* subset
     [ second ] map ;
 

extra/ui/tools/walker/walker.factor

@@ -39,7 +39,7 @@ TUPLE: walker model interpreter history ;
 
 : com-back ( walker -- )
     dup walker-history
-    dup empty? [ drop ] [ pop swap call-tool* ] if ;
+    dup empty? [ 2drop ] [ pop swap call-tool* ] if ;
 
 : reset-walker ( walker -- )
     <interpreter> over set-walker-interpreter

extra/ui/windows/windows.factor

@@ -14,21 +14,18 @@ TUPLE: windows-ui-backend ;
 : crlf>lf CHAR: \r swap remove ;
 : lf>crlf [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
 
-: (enum-clipboard) ( n -- n )
-    EnumClipboardFormats win32-error dup 0 > [ dup , (enum-clipboard) ] when ;
-
 : enum-clipboard ( -- seq )
-    [ 0 (enum-clipboard) ] { } make nip ;
+    0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ]
+    { } unfold nip ;
 
 : with-clipboard ( quot -- )
     f OpenClipboard win32-error=0/f
     call
     CloseClipboard win32-error=0/f ; inline
-    
 
 : paste ( -- str )
     [
-        CF_UNICODETEXT IsClipboardFormatAvailable 0 = [
+        CF_UNICODETEXT IsClipboardFormatAvailable zero? [
             ! nothing to paste
             ""
         ] [
@@ -132,7 +129,7 @@ SYMBOL: mouse-captured
     } ;
 
 : key-state-down?
-    GetKeyState 1 16 shift bitand 0 > ;
+    GetKeyState 16 bit? ;
 
 : left-shift? ( -- ? ) VK_LSHIFT key-state-down? ;
 : left-ctrl? ( -- ? ) VK_LCONTROL key-state-down? ;
@@ -309,8 +306,6 @@ SYMBOL: hWnd
     "uint" { "void*" "uint" "long" "long" } "stdcall" [
         [
         pick
-        ! "Message: " write dup get-windows-message-name write
-            ! " " write dup unparse print flush
             {
                 { [ dup WM_CLOSE = ]    [ drop handle-wm-close 0 ] }
                 { [ dup WM_PAINT = ]
@@ -319,7 +314,7 @@ SYMBOL: hWnd
 
                 ! Keyboard events
                 { [ dup WM_KEYDOWN = over WM_SYSKEYDOWN = or ]
-                    [ drop 4dup handle-wm-keydown DefWindowProc ] }
+                [ drop 4dup handle-wm-keydown DefWindowProc ] }
                 { [ dup WM_CHAR = over WM_SYSCHAR = or ]
                     [ drop 4dup handle-wm-char DefWindowProc ] }
                 { [ dup WM_KEYUP = over WM_SYSKEYUP = or ]
@@ -343,7 +338,6 @@ SYMBOL: hWnd
                 { [ t ] [ drop DefWindowProc ] }
             } cond
         ] ui-try
-        ! "finished handling message" print .s flush
      ] alien-callback ;
 
 : do-events ( -- )

vm/Config.windows.ce.arm

@@ -1,5 +1,4 @@
 CC = arm-wince-mingw32ce-gcc
 DLL_SUFFIX=-ce
 EXE_SUFFIX=-ce
-PLAF_DLL_OBJS += vm/os-windows-ce-arm.o
 include vm/Config.windows.ce vm/Config.arm

vm/os-windows-ce.c

@@ -37,7 +37,7 @@ char *getenv(char *name)
 	return 0; /* unreachable */
 }
 
-long exception_handler(PEXCEPTION_RECORD rec, void *frame, void *ctx, void *dispatch)
+void c_to_factor_toplevel(CELL quot)
 {
-	return 0;
+	c_to_factor(quot);
 }