Merge remote-tracking branch 'upstream/master'

basis/core-foundation/strings/strings.factor

@@ -3,7 +3,7 @@
 USING: alien.c-types alien.data alien.syntax alien.strings
 io.encodings.string kernel sequences byte-arrays
 io.encodings.utf8 math core-foundation core-foundation.arrays
-destructors parser fry alien words ;
+core-foundation.data destructors parser fry alien words ;
 IN: core-foundation.strings
 
 TYPEDEF: void* CFStringRef
@@ -60,6 +60,9 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
     CFStringEncoding encoding
 ) ;
 
+FUNCTION: CFStringRef CFCopyDescription ( CFTypeRef cf ) ;
+FUNCTION: CFStringRef CFCopyTypeIDDescription ( CFTypeID type_id ) ;
+
 : prepare-CFString ( string -- byte-array )
     [
         dup HEX: 10ffff >
@@ -88,6 +91,11 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
 : <CFStringArray> ( seq -- alien )
     [ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
 
+: CF>description ( cf -- description )
+    [ CFCopyDescription &CFRelease CF>string ] with-destructors ;
+: CFType>description ( cf -- description )
+    CFGetTypeID [ CFCopyTypeIDDescription &CFRelease CF>string ] with-destructors ;
+
 SYNTAX: CFSTRING: 
     CREATE scan-object 
     [ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi

basis/editors/vim/vim.factor

@@ -16,7 +16,7 @@ M: vim vim-command
     ] { } make ;
 
 : vim ( file line -- )
-    vim-command run-detached drop ;
+    vim-command run-process drop ;
 
 "vim" vim-path set-global
 [ vim ] edit-hook set-global

basis/game/input/iokit/iokit.factor

@@ -1,5 +1,6 @@
 USING: cocoa cocoa.plists core-foundation iokit iokit.hid
 kernel cocoa.enumeration destructors math.parser cocoa.application 
+core-foundation.data core-foundation.strings
 sequences locals combinators.short-circuit threads
 namespaces assocs arrays combinators hints alien
 core-foundation.run-loop accessors sequences.private
@@ -270,11 +271,26 @@ M: iokit-game-input-backend reset-mouse
 : device-removed-callback ( -- alien )
     [ (device-removed-callback) ] IOHIDDeviceCallback ;
 
+! Lion sends the input callback an IOHIDQueue as the "sender".
+! Leopard and Snow Leopard send an IOHIDDevice.
+! This function gets the IOHIDDevice regardless of which is received
+: get-input-device ( sender -- device )
+    dup CFGetTypeID {
+        { [ dup IOHIDDeviceGetTypeID = ] [ drop ] }
+        { [ dup IOHIDQueueGetTypeID = ] [ drop IOHIDQueueGetDevice ] }
+        [
+            drop
+            "input callback doesn't know how to deal with "
+            swap CF>description append throw
+        ]
+    } cond ;
+
 :: (device-input-callback) ( context result sender value -- )
+    sender get-input-device :> device
     {
-        { [ sender mouse-device? ] [ +mouse-state+ get-global value record-mouse ] }
+        { [ device mouse-device? ] [ +mouse-state+ get-global value record-mouse ] }
-        { [ sender controller-device? ] [
+        { [ device controller-device? ] [
-            sender +controller-states+ get-global at value record-controller
+            device +controller-states+ get-global at value record-controller
         ] }
         [ +keyboard-state+ get-global value record-keyboard ]
     } cond ;

basis/iokit/hid/hid.factor

@@ -125,6 +125,7 @@ TYPEDEF: uint IOHIDQueueOptionsType
 TYPEDEF: uint IOHIDElementFlags
 TYPEDEF: void* IOHIDDeviceRef
 TYPEDEF: void* IOHIDElementRef
+TYPEDEF: void* IOHIDQueueRef
 TYPEDEF: void* IOHIDValueRef
 TYPEDEF: void* IOHIDManagerRef
 TYPEDEF: void* IOHIDTransactionRef
@@ -253,3 +254,7 @@ FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
 FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
 FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;
 
+! IOHIDQueue
+
+FUNCTION: CFTypeID IOHIDQueueGetTypeID ( ) ;
+FUNCTION: IOHIDDeviceRef IOHIDQueueGetDevice ( IOHIDQueueRef queue ) ;

basis/math/functions/functions-tests.factor

@@ -32,6 +32,7 @@ IN: math.functions.tests
 [ 0.0 ] [ 0.0 1.0 ^ ] unit-test
 [ 1/0. ] [ 0 -2 ^ ] unit-test
 [ t ] [ 0 0.0 ^ fp-nan? ] unit-test
+[ t ] [ 0.0 0.0 ^ fp-nan? ] unit-test
 [ 1/0. ] [ 0 -2.0 ^ ] unit-test
 [ 0 ] [ 0 3.0 ^ ] unit-test
 [ 0 ] [ 0 3 ^ ] unit-test

basis/math/functions/functions.factor

@@ -82,8 +82,8 @@ M: complex exp >rect [ exp ] dip polar> ; inline
 : real^? ( x y -- ? )
     2dup [ real? ] both? [ drop 0 >= ] [ 2drop f ] if ; inline
 
-: 0^ ( x -- z )
+: 0^ ( zero x -- z )
-    [ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
+    swap [ 0/0. ] swap '[ 0 < 1/0. _ ? ] if-zero ; inline
 
 : (^mod) ( x y n -- z )
     [ make-bits 1 ] dip dup
@@ -100,7 +100,7 @@ PRIVATE>
 
 : ^ ( x y -- z )
     {
-        { [ over 0 = ] [ nip 0^ ] }
+        { [ over zero? ] [ 0^ ] }
         { [ dup integer? ] [ integer^ ] }
         { [ 2dup real^? ] [ [ >float ] bi@ fpow ] }
         [ ^complex ]

basis/opengl/gl/extensions/extensions.factor

@@ -50,6 +50,6 @@ reset-gl-function-number-counter
 SYNTAX: GL-FUNCTION:
     gl-function-calling-convention
     scan-function-name
-    "{" expect "}" parse-tokens over prefix
+    "{" expect "}" parse-tokens over suffix
     gl-function-counter '[ _ _ gl-function-pointer ]
     ";" scan-c-args define-indirect ;

build-support/factor.sh

@@ -539,7 +539,7 @@ update_bootstrap() {
 }
 
 refresh_image() {
-    ./$FACTOR_BINARY -script -e="USING: vocabs.loader system memory ; refresh-all USE: memory save 0 exit"
+    ./$FACTOR_BINARY -script -e="USING: vocabs.loader vocabs.refresh system memory ; refresh-all save 0 exit"
     check_ret factor
 }
 

core/strings/strings-tests.factor

@@ -67,6 +67,10 @@ unit-test
 [ ] [ HEX: 4321 3 "s" get set-nth ] unit-test
 [ ] [ HEX: 654321 5 "s" get set-nth ] unit-test
 
+[ ] [ HEX: -1 5 "s" get set-nth ] unit-test
+[ ] [ HEX: 80,0000 5 "s" get set-nth ] unit-test
+[ ] [ HEX: 100,0000 5 "s" get set-nth ] unit-test
+
 [
     {
         CHAR: h
@@ -121,5 +125,3 @@ unit-test
         [ <string> clone resize-string first ] keep =
     ] all-integers?
 ] unit-test
-
-[ HEX: 7fffff ] [ { -1 } >string first ] unit-test

extra/24-game/24-game.factor

@@ -8,6 +8,7 @@ arrays words quotations accessors math.parser backtrack assocs ;
 IN: 24-game
 SYMBOL: commands
 : nop ( -- ) ;
+: spin ( a b c -- c b a ) swapd swap swap ;
 : do-something ( a b -- c ) { + - * } amb-execute ;
 : maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
 : some-rots ( a b c -- a b c )

extra/mason/child/child-tests.factor

@@ -1,26 +1,27 @@
 IN: mason.child.tests
-USING: mason.child mason.config tools.test namespaces io kernel sequences ;
+USING: mason.child mason.config tools.test namespaces io kernel
+sequences system ;
 
 [ { "nmake" "/f" "nmakefile" "x86-32" } ] [
     [
-        "winnt" target-os set
+        winnt target-os set
-        "x86.32" target-cpu set
+        x86.32 target-cpu set
         make-cmd
     ] with-scope
 ] unit-test
 
 [ { "make" "macosx-x86-32" } ] [
     [
-        "macosx" target-os set
+        macosx target-os set
-        "x86.32" target-cpu set
+        x86.32 target-cpu set
         make-cmd
     ] with-scope
 ] unit-test
 
 [ { "./factor.com" "-i=boot.winnt-x86.32.image" "-no-user-init" } ] [
     [
-        "winnt" target-os set
+        winnt target-os set
-        "x86.32" target-cpu set
+        x86.32 target-cpu set
         boot-cmd
     ] with-scope
 ] unit-test

extra/mason/child/child.factor

@@ -9,14 +9,14 @@ IN: mason.child
 
 : nmake-cmd ( -- args )
     { "nmake" "/f" "nmakefile" }
-    target-cpu get "." split "-" join suffix ;
+    target-cpu get name>> "." split "-" join suffix ;
 
 : gnu-make-cmd ( -- args )
     gnu-make platform 2array ;
 
 : make-cmd ( -- args )
     {
-        { [ target-os get "winnt" = ] [ nmake-cmd ] }
+        { [ target-os get winnt = ] [ nmake-cmd ] }
         [ gnu-make-cmd ]
     } cond ;
 
@@ -30,7 +30,7 @@ IN: mason.child
     ] with-directory ;
 
 : factor-vm ( -- string )
-    target-os get "winnt" = "./factor.com" "./factor" ? ;
+    target-os get winnt = "./factor.com" "./factor" ? ;
 
 : boot-cmd ( -- cmd )
     [

extra/mason/email/email-tests.factor

@@ -1,10 +1,11 @@
 IN: mason.email.tests
-USING: mason.email mason.common mason.config namespaces tools.test ;
+USING: mason.email mason.common mason.config namespaces
+tools.test system ;
 
 [ "mason on linux-x86-64: 12345 -- error" ] [
     [
-        "linux" target-os set
+        linux target-os set
-        "x86.64" target-cpu set
+        x86.64 target-cpu set
         "12345" current-git-id set
         status-error report-subject
     ] with-scope

extra/mason/platform/platform.factor

@@ -5,13 +5,14 @@ mason.config bootstrap.image assocs ;
 IN: mason.platform
 
 : (platform) ( os cpu -- string )
+    [ name>> ] bi@
     { { CHAR: . CHAR: - } } substitute "-" glue ;
 
 : platform ( -- string )
     target-os get target-cpu get (platform) ;
 
 : gnu-make ( -- string )
-    target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;
+    target-os get { freebsd openbsd netbsd } member? "gmake" "make" ? ;
 
 : boot-image-arch ( -- string )
     target-os get target-cpu get arch ;

extra/mason/release/branch/branch-tests.factor

@@ -1,13 +1,14 @@
 IN: mason.release.branch.tests
-USING: mason.release.branch mason.config tools.test namespaces ;
+USING: mason.release.branch mason.config tools.test namespaces
+system ;
 
 [ { "git" "push" "-f" "joe@blah.com:/my/git" "master:clean-linux-x86-32" } ] [
     [
         "joe" branch-username set
         "blah.com" branch-host set
         "/my/git" branch-directory set
-        "linux" target-os set
+        linux target-os set
-        "x86.32" target-cpu set
+        x86.32 target-cpu set
         push-to-clean-branch-cmd
     ] with-scope
 ] unit-test
@@ -18,8 +19,8 @@ USING: mason.release.branch mason.config tools.test namespaces ;
         "joe" image-username set
         "blah.com" image-host set
         "/stuff/clean" image-directory set
-        "netbsd" target-os set
+        netbsd target-os set
-        "x86.64" target-cpu set
+        x86.64 target-cpu set
         upload-clean-image-cmd
     ] with-scope
 ] unit-test

extra/trees/avl/avl.factor

@@ -136,7 +136,7 @@ GENERIC: avl-delete ( key node -- node shorter? deleted? )
 M: f avl-delete ( key f -- f f f ) nip f f ;
 
 : (avl-delete) ( key node -- node shorter? deleted? )
-    tuck node-link avl-delete [
+    swap over node-link avl-delete [
         [ over set-node-link ] dip [ balance-delete ] [ f ] if
     ] dip ;
 

misc/vim/syntax/factor.vim

@@ -48,8 +48,8 @@ syn keyword factorBoolean f t
 syn keyword factorBreakpoint B
 syn keyword factorFrySpecifier @ _ contained
 syn keyword factorDeclaration delimiter deprecated final flushable foldable inline recursive
-syn match factorCallQuotation /\<call(\s\(\S*\s\)\?--\(\s\S*\)\?\s)\>/
+syn match factorCallQuotation /\<call(\s\+\(\S*\s\+\)*--\(\s\+\S*\)*\s\+)\>/ contained contains=factorStackEffect
-syn match factorExecute /\<execute(\s\(\S*\s\)\?--\(\s\S*\)\?\s)\>/
+syn match factorExecute /\<execute(\s\+\(\S*\s\+\)*--\(\s\+\S*\)*\s\+)\>/ contained contains=factorStackEffect
 syn keyword factorCallNextMethod call-next-method
 
 syn keyword factorKeyword or 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry tri-curry* tri-curry@ swap and 2nip throw bi-curry (clone) hashcode* compose 2dip if 3tri unless compose? tuple keep 2curry equal? assert tri 2drop most <wrapper> boolean? identity-hashcode identity-tuple? null new dip bi-curry@ rot xor identity-tuple boolean
@@ -148,8 +148,11 @@ syn match factorMultiStringContents /.*/ contained
 "syn match factorStackEffectErr /\<)\>/
 "syn region factorStackEffectErr start=/\<(\>/ end=/\<)\>/
 "syn region factorStackEffect start=/\<(\>/ end=/\<)\>/ contained
-syn match factorStackEffect /\<(\s\(\S*\s\)\?--\(\s\S*\)\?\s)\>/ contained
+syn match factorStackEffect /(\s\+\(\S*\s\+\)*--\(\s\+\S*\)*\s\+)\>/ contained contains=factorStackDelims,factorStackItems,factorCallExecuteDelim
-syn match factorLiteralStackEffect /\<((\s\(\S*\s\)\?--\(\s\S*\)\?\s))\>/
+syn match factorLiteralStackEffect /((\s\+\(\S*\s\+\)*--\(\s\+\S*\)*\s\+))\>/ contained contains=factorStackDelims,factorStackItems
+syn match factorStackItems contained "\<\S\+\>"
+syn keyword factorStackDelims contained ( ) (( )) --
+syn match factorCallExecuteDelim contained /(\s/
 
 "adapted from lisp.vim
 if exists("g:factor_norainbow")
@@ -199,6 +202,9 @@ if version >= 508 || !exists("did_factor_syn_inits")
     HiLink factorShebang                PreProc
     HiLink factorShebangErr             Error
     HiLink factorStackEffect            Typedef
+    HiLink factorStackDelims            Delimiter
+    HiLink factorCallExecuteDelim       Delimiter
+    HiLink factorStackItems             Identifier
     HiLink factorLiteralStackEffect     Typedef
     HiLink factorTodo                   Todo
     HiLink factorInclude                Include

vm/Config.macosx

@@ -14,7 +14,7 @@ else
 	LIBS = -lm -framework Cocoa -framework AppKit
 endif
 
-LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
+LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module \
 	-current_version $(VERSION) \
 	-compatibility_version $(VERSION) \
 	-fvisibility=hidden \