diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 293c3fe09b..a480b2799a 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/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 ; diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 13917fd6bf..606d1a0edf 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/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 diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0721e61a2a..9791919392 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/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 diff --git a/basis/stack-checker/row-polymorphism/row-polymorphism.factor b/basis/stack-checker/row-polymorphism/row-polymorphism.factor index ad4f92ced4..38b25bf3f8 100644 --- a/basis/stack-checker/row-polymorphism/row-polymorphism.factor +++ b/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" ] bi@ terminated? get ; inline + terminated? get [ [ 0 ] [ meta-d length inner-d - ] if [ "x" ] bi@ ] keep + ; inline : with-effect-here ( quot -- effect ) meta-d length input-count get diff --git a/basis/unix/ffi/ffi.factor b/basis/unix/ffi/ffi.factor index 640c7df5b6..6c6399b8bd 100644 --- a/basis/unix/ffi/ffi.factor +++ b/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 ) ; diff --git a/basis/unix/time/time.factor b/basis/unix/time/time.factor index bd3a02fcab..ad5a2d6d56 100644 --- a/basis/unix/time/time.factor +++ b/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 ; inline - STRUCT: tm { sec int } { min int } diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index ec638e6f31..c25634624f 100644 --- a/basis/unix/types/types.factor +++ b/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 - diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index cd0eb7ada3..edd4f75464 100644 --- a/basis/unix/users/users.factor +++ b/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> diff --git a/core/arrays/arrays-docs.factor b/core/arrays/arrays-docs.factor index b9d579fbac..1220112bd7 100644 --- a/core/arrays/arrays-docs.factor +++ b/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." } ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 07f6e9ef9a..14ed5b9717 100644 --- a/core/bootstrap/primitives.factor +++ b/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 )) } { "" "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-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 )) } { "" "classes.tuple.private" "primitive_tuple_boa" (( slots... layout -- tuple )) } { "" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) } { "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) } diff --git a/core/byte-arrays/byte-arrays-docs.factor b/core/byte-arrays/byte-arrays-docs.factor index f6507ac963..f804802fa7 100644 --- a/core/byte-arrays/byte-arrays-docs.factor +++ b/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" } ; diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index 6fb6909da8..d53282114b 100644 --- a/core/strings/strings-docs.factor +++ b/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" } ; diff --git a/extra/game/debug/tests/tests.factor b/extra/game/debug/tests/tests.factor index 817379bf57..2a70f55d8a 100644 --- a/extra/game/debug/tests/tests.factor +++ b/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 ; diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index 8251fe21b6..9eb50ab941 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/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* ; diff --git a/extra/mason/updates/updates.factor b/extra/mason/updates/updates.factor index 57a8c748d2..79b36662bc 100644 --- a/extra/mason/updates/updates.factor +++ b/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 diff --git a/extra/mason/version/files/files.factor b/extra/mason/version/files/files.factor index ba09c6274c..6e762e5af2 100644 --- a/extra/mason/version/files/files.factor +++ b/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) ; diff --git a/extra/mason/version/source/source.factor b/extra/mason/version/source/source.factor index cc41ee3e6b..13bd0cffd9 100644 --- a/extra/mason/version/source/source.factor +++ b/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 diff --git a/extra/specialized/specialized.factor b/extra/specialized/specialized.factor new file mode 100644 index 0000000000..035a587c2f --- /dev/null +++ b/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 ; + diff --git a/extra/time/unix/unix.factor b/extra/time/unix/unix.factor index ba1bc6e3fb..d4bd45aeae 100644 --- a/extra/time/unix/unix.factor +++ b/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 ; inline + M: unix set-time [ unix-1970 time- duration>microseconds >integer make-timeval ] [ timestamp>timezone ] bi