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

basis/compiler/cfg/builder/blocks/blocks.factor

@@ -60,19 +60,13 @@ IN: compiler.cfg.builder.blocks
 : set-successors ( branches -- )
     ! Set the successor of each branch's final basic block to the
     ! current block.
-    basic-block get dup [
-        '[ [ [ _ ] dip first successors>> push ] when* ] each
-    ] [ 2drop ] if ;
-
-: merge-heights ( branches -- )
-    ! If all elements are f, that means every branch ended with a backward
-    ! jump so the height is irrelevant since this block is unreachable.
-    [ ] find nip [ second current-height set ] [ end-basic-block ] if* ;
+    [ [ [ basic-block get ] dip first successors>> push ] when* ] each ;
 
 : emit-conditional ( branches -- )
     ! branches is a sequence of pairs as above
     end-basic-block
-    [ merge-heights begin-basic-block ]
-    [ set-successors ]
-    bi ;
-
+    dup [ ] find nip dup [
+        second current-height set
+        begin-basic-block
+        set-successors
+    ] [ 2drop ] if ;

basis/compiler/tests/optimizer.factor

@@ -4,7 +4,8 @@ sbufs strings tools.test vectors words sequences.private
 quotations classes classes.algebra classes.tuple.private
 continuations growable namespaces hints alien.accessors
 compiler.tree.builder compiler.tree.optimizer sequences.deep
-compiler.test definitions generic.single shuffle math.order ;
+compiler.test definitions generic.single shuffle math.order
+compiler.cfg.debugger ;
 IN: compiler.tests.optimizer
 
 GENERIC: xyz ( obj -- obj )
@@ -440,3 +441,9 @@ TUPLE: grid-mesh-tuple { length read-only } { step read-only } ;
     ] keep ;
 
 [ { 0.5 } ] [ grid-mesh-test-case ] unit-test
+
+[ { 1 } "bar" ] [ { 1 } [ [ [ [ "foo" throw ] [ "bar" throw ] recover ] attempt-all f ] [ ] recover ] compile-call ] unit-test
+
+GENERIC: bad-push-test-case ( a -- b )
+M: object bad-push-test-case "foo" throw ; inline
+[ { 1 } "bar" ] [ { 1 } [ [ [ [ bad-push-test-case ] [ "bar" throw ] recover ] attempt-all f ] [ ] recover ] compile-call ] unit-test

basis/stack-checker/known-words/known-words.factor

@@ -431,9 +431,9 @@ M: bad-executable summary
 \ quot-compiled? { quotation } { object } define-primitive
 \ quotation-code { quotation } { integer integer } define-primitive \ quotation-code make-flushable
 \ reset-dispatch-stats { } { } define-primitive
-\ resize-array { integer array } { array } define-primitive \ resize-array make-flushable
-\ resize-byte-array { integer byte-array } { byte-array } define-primitive \ resize-byte-array make-flushable
-\ resize-string { integer string } { string } define-primitive \ resize-string make-flushable
+\ resize-array { integer array } { array } define-primitive
+\ resize-byte-array { integer byte-array } { byte-array } define-primitive
+\ resize-string { integer string } { string } define-primitive
 \ retainstack { } { array } define-primitive \ retainstack make-flushable
 \ retainstack-for { c-ptr } { array } define-primitive \ retainstack-for make-flushable
 \ set-alien-cell { c-ptr c-ptr integer } { } define-primitive

basis/stack-checker/row-polymorphism/row-polymorphism.factor

@@ -16,8 +16,8 @@ IN: stack-checker.row-polymorphism
 
 :: (effect-here) ( inner-d old-meta-d-length old-input-count -- effect )
     old-meta-d-length inner-d - input-count get old-input-count - +
-    meta-d length inner-d -
-    [ "x" <array> ] bi@ terminated? get <terminated-effect> ; inline
+    terminated? get [ [ 0 ] [ meta-d length inner-d - ] if [ "x" <array> ] bi@ ] keep
+    <terminated-effect> ; inline
 
 : with-effect-here ( quot -- effect )
     meta-d length input-count get

basis/unix/ffi/ffi.factor

@@ -83,6 +83,8 @@ FUNCTION: c-string getenv ( c-string name ) ;
 FUNCTION: int getgrgid_r ( gid_t gid, group* grp, c-string buffer, size_t bufsize, group** result ) ;
 FUNCTION: int getgrnam_r ( c-string name, group* grp, c-string buffer, size_t bufsize, group** result ) ;
 FUNCTION: passwd* getpwent ( ) ;
+FUNCTION: void setpwent ( ) ;
+FUNCTION: void setpassent ( int stayopen ) ;
 FUNCTION: passwd* getpwuid ( uid_t uid ) ;
 FUNCTION: passwd* getpwnam ( c-string login ) ;
 FUNCTION: int getpwnam_r ( c-string login, passwd* pwd, c-string buffer, size_t bufsize, passwd** result ) ;

basis/unix/time/time.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.syntax calendar
+USING: accessors alien.c-types alien.syntax
 classes.struct kernel math unix.types ;
 IN: unix.time
 
@@ -28,11 +28,6 @@ STRUCT: timezone
     { tz_minuteswest int }
     { tz_dsttime int } ;
 
-: timestamp>timezone ( timestamp -- timezone )
-    gmt-offset>> duration>minutes
-    1
-    \ timezone <struct-boa> ; inline
-
 STRUCT: tm
     { sec int }
     { min int }

basis/unix/types/types.factor

@@ -50,6 +50,4 @@ os {
     { freebsd [ "unix.types.freebsd" require ] }
     { openbsd [ "unix.types.openbsd" require ] }
     { netbsd  [ "unix.types.netbsd"  require ] }
-    { winnt [ ] }
 } case
-

basis/unix/users/users.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings io.encodings.utf8
-io.backend.unix kernel math sequences splitting strings
-combinators.short-circuit grouping byte-arrays combinators
-accessors math.parser fry assocs namespaces continuations
-vocabs.loader system classes.struct unix ;
-IN: unix.users
+USING: accessors alien alien.c-types alien.strings assocs
+byte-arrays classes.struct combinators
+combinators.short-circuit continuations fry grouping
+io.backend.unix io.encodings.utf8 kernel math math.parser
+namespaces sequences splitting strings system unix unix.ffi
+vocabs.loader ;
 QUALIFIED: unix.ffi
+IN: unix.users
 
 TUPLE: passwd user-name password uid gid gecos dir shell ;
 
@@ -31,6 +32,7 @@ M: unix passwd>new-passwd ( passwd -- seq )
     } cleave ;
 
 : with-pwent ( quot -- )
+    setpwent
     [ unix.ffi:endpwent ] [ ] cleanup ; inline
 
 PRIVATE>

core/arrays/arrays-docs.factor

@@ -33,6 +33,8 @@ $nl
     3array
     4array
 }
+"Resizing arrays:"
+{ $subsections resize-array }
 "The class of two-element arrays:"
 { $subsections pair }
 "Arrays can be accessed without bounds checks in a pointer unsafe way."
@@ -69,9 +71,10 @@ HELP: 4array
 { $values { "w" object } { "x" object } { "y" object } { "z" object } { "array" array } }
 { $description "Create a new array with four elements, with " { $snippet "w" } " appearing first." } ;
 
-HELP: resize-array ( n array -- newarray )
-{ $values { "n" "a non-negative integer" } { "array" array } { "newarray" "a new array" } }
-{ $description "Creates a new array of " { $snippet "n" } " elements. The contents of the existing array are copied into the new array; if the new array is shorter, only an initial segment is copied, and if the new array is longer the remaining space is filled in with "{ $link f } "." } ;
+HELP: resize-array ( n array -- new-array )
+{ $values { "n" "a non-negative integer" } { "array" array } { "new-array" array } }
+{ $description "Resizes the array to have a length of " { $snippet "n" } " elements. When making the array shorter, this word may either create a new array or modify the existing array in place. When making the array longer, this word always allocates a new array, filling remaining space with " { $link f } "." }
+{ $side-effects "array" } ;
 
 HELP: pair
 { $class-description "The class of two-element arrays, known as pairs." } ;

core/bootstrap/primitives.factor

@@ -424,10 +424,10 @@ tuple
     { "dll-valid?" "alien.libraries" "primitive_dll_validp" (( dll -- ? )) }
     { "current-callback" "alien.private" "primitive_current_callback" (( -- n )) }
     { "<array>" "arrays" "primitive_array" (( n elt -- array )) }
-    { "resize-array" "arrays" "primitive_resize_array" (( n array -- newarray )) }
+    { "resize-array" "arrays" "primitive_resize_array" (( n array -- new-array )) }
     { "(byte-array)" "byte-arrays" "primitive_uninitialized_byte_array" (( n -- byte-array )) }
     { "<byte-array>" "byte-arrays" "primitive_byte_array" (( n -- byte-array )) }
-    { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) }
+    { "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- new-byte-array )) }
     { "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( slots... layout -- tuple )) }
     { "<tuple>" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) }
     { "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) }

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

@@ -22,7 +22,7 @@ $nl
     3byte-array
     4byte-array
 }
-"Resizing byte-arrays:"
+"Resizing byte arrays:"
 { $subsections resize-byte-array } ;
 
 ABOUT: "byte-arrays"
@@ -70,7 +70,7 @@ HELP: 4byte-array
 
 { 1byte-array 2byte-array 3byte-array 4byte-array } related-words
 
-HELP: resize-byte-array ( n byte-array -- newbyte-array )
-{ $values { "n" "a non-negative integer" } { "byte-array" byte-array }
-        { "newbyte-array" byte-array } }
-{ $description "Creates a new byte-array of n elements.  The contents of the existing byte-array are copied into the new byte-array; if the new byte-array is shorter, only an initial segment is copied, and if the new byte-array is longer the remaining space is filled in with 0." } ;
+HELP: resize-byte-array ( n byte-array -- new-byte-array )
+{ $values { "n" "a non-negative integer" } { "byte-array" byte-array } { "new-byte-array" byte-array } }
+{ $description "Resizes the byte array to have a length of " { $snippet "n" } " elements. When making the byte array shorter, this word may either create a new byte array or modify the existing byte array in place. When making the byte array longer, this word always allocates a new byte array, filling remaining space with zeroes." }
+{ $side-effects "byte-array" } ;

core/strings/strings-docs.factor

@@ -20,6 +20,8 @@ $nl
 }
 "Creating a string from a single character:"
 { $subsections 1string }
+"Resizing strings:"
+{ $subsections resize-string }
 { $see-also "syntax-strings" "sbufs" "unicode" "io.encodings" } ;
 
 ABOUT: "strings"
@@ -53,4 +55,5 @@ HELP: >string
 
 HELP: resize-string ( n str -- newstr )
 { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } }
-{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u000000" } "." } ;
+{ $description "Resizes the string to have a length of " { $snippet "n" } " elements. When making the string shorter, this word may either create a new string or modify the existing string in place. When making the string longer, this word always allocates a new string, filling remaining space with zeroes." }
+{ $side-effects "str" } ;

extra/game/debug/tests/tests.factor

@@ -37,9 +37,9 @@ IN: game.debug.tests
     ] float-array{ } make
     mvp-matrix draw-debug-points
 
-    "Frame: " world frame-number>> number>string append
+    "Frame: " world frame#>> number>string append
     COLOR: purple { 5 5 } world dim>> draw-text
-    world [ 1 + ] change-frame-number drop ;
+    world [ 1 + ] change-frame# drop ;
 
 TUPLE: tests-world < wasd-world frame-number ;
 M: tests-world draw-world* draw-debug-tests ;

extra/gpu/util/wasd/wasd.factor

@@ -54,13 +54,22 @@ M: wasd-world wasd-fly-vertically? drop t ;
 
 CONSTANT: fov 0.7
 
+: wasd-fov-vector ( world -- fov )
+    dim>> dup first2 min >float v/n fov v*n ; inline
+
 :: generate-p-matrix ( world -- matrix )
     world wasd-near-plane :> near-plane
     world wasd-far-plane :> far-plane
 
-    world dim>> dup first2 min >float v/n fov v*n near-plane v*n
+    world wasd-fov-vector near-plane v*n
     near-plane far-plane frustum-matrix4 ;
 
+:: wasd-pixel-ray ( world loc -- direction )
+    loc world dim>> [ /f 0.5 - 2.0 * ] 2map 
+    world wasd-fov-vector v*
+    first2 neg -1.0 0.0 4array
+    world wasd-mv-inv-matrix swap m.v ;
+
 : set-wasd-view ( world location yaw pitch -- world )
     [ >>location ] [ >>yaw ] [ >>pitch ] tri* ;
 

extra/mason/updates/updates.factor

@@ -5,12 +5,10 @@ io.directories io.launcher kernel mason.common mason.platform ;
 IN: mason.updates
 
 : git-reset-cmd ( -- cmd )
-    {
-        "git"
-        "reset"
-        "--hard"
-        "HEAD"
-    } ;
+    { "git" "reset" "--hard" "HEAD" } ;
+
+: git-clean-cmd ( -- cmd )
+    { "git" "clean" "-f" "-d" "-x" } ;
 
 : git-pull-cmd ( -- cmd )
     {
@@ -21,9 +19,13 @@ IN: mason.updates
         "master"
     } ;
 
-: updates-available? ( -- ? )
+: pristine-git ( -- )
     ".git/index" delete-file
     git-reset-cmd short-running-process
+    git-clean-cmd short-running-process ;
+
+: updates-available? ( -- ? )
+    pristine-git
     git-id
     git-pull-cmd short-running-process
     git-id

extra/mason/version/files/files.factor

@@ -10,6 +10,9 @@ IN: mason.version.files
 : remote-directory ( string -- string' )
     [ upload-directory get ] dip "/" glue ;
 
+SLOT: os
+SLOT: cpu
+
 : platform ( builder -- string )
     [ os>> ] [ cpu>> ] bi (platform) ;
 

extra/mason/version/source/source.factor

@@ -35,11 +35,10 @@ IN: mason.version.source
 
 : make-source-release ( version git-id -- path )
     "Creating source release..." print flush
-    unique-directory
     [
         clone-factor prepare-source (make-source-release)
         "Package created: " write absolute-path dup print
-    ] with-directory ;
+    ] with-unique-directory drop ;
 
 : upload-source-release ( package version -- )
     "Uploading source release..." print flush

extra/specialized/specialized.factor

@@ -0,0 +1,55 @@
+! Copyright (C) 2009, 2010 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: words kernel locals accessors compiler.tree.propagation.info
+sequences kernel.private assocs fry parser math quotations
+effects arrays definitions compiler.units namespaces
+compiler.tree.debugger generalizations stack-checker ;
+IN: specialized
+
+: in-compilation-unit? ( -- ? )
+    changed-definitions get >boolean ;
+
+: define-temp-in-unit ( quot effect -- word )
+    in-compilation-unit?
+    [ [ define-temp ] with-nested-compilation-unit ]
+    [ [ define-temp ] with-compilation-unit ]
+    if ;
+
+: final-info-quot ( word -- quot )
+    [ stack-effect in>> length '[ _ ndrop ] ]
+    [ def>> [ final-info ] with-scope >quotation ] bi
+    compose ;
+
+ERROR: bad-outputs word quot ;
+
+: define-outputs ( word quot -- )
+    2dup [ stack-effect ] [ infer ] bi* effect<=
+    [ "outputs" set-word-prop ] [ bad-outputs ] if ;
+
+: record-final-info ( word -- )
+    dup final-info-quot define-outputs ;
+
+:: lookup-specialized ( #call word n -- special-word/f )
+    #call in-d>> n tail* >array [ value-info class>> ] map
+    dup [ object = ] all? [ drop f ] [
+        word "specialized-defs" word-prop [
+            [ declare ] curry word def>> compose
+            word stack-effect define-temp-in-unit
+            dup record-final-info
+            1quotation
+        ] cache
+    ] if ;
+
+: specialized-quot ( word n -- quot )
+    '[ _ _ lookup-specialized ] ;
+
+: make-specialized ( word n -- )
+    [ drop H{ } clone "specialized-defs" set-word-prop ]
+    [ dupd specialized-quot "custom-inlining" set-word-prop ] 2bi ;
+
+SYNTAX: specialized
+    word dup stack-effect in>> length make-specialized ;
+
+PREDICATE: specialized-word < word
+   "specialized-defs" word-prop >boolean ;
+

extra/time/unix/unix.factor

@@ -1,8 +1,12 @@
 ! Copyright (C) 2010 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: calendar kernel math system time unix unix.time ;
+USING: accessors calendar classes.struct kernel math system time
+unix unix.time ;
 IN: time.unix
 
+: timestamp>timezone ( timestamp -- timezone )
+    gmt-offset>> duration>minutes 1 \ timezone <struct-boa> ; inline
+
 M: unix set-time
     [ unix-1970 time- duration>microseconds >integer make-timeval ]
     [ timestamp>timezone ] bi