diff --git a/basis/columns/columns.factor b/basis/columns/columns.factor index 5ac8531f58..8f45dab872 100644 --- a/basis/columns/columns.factor +++ b/basis/columns/columns.factor @@ -9,7 +9,7 @@ TUPLE: column seq col ; C: column M: column virtual-seq seq>> ; -M: column virtual@ dup col>> -rot seq>> nth bounds-check ; +M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ; M: column length seq>> length ; INSTANCE: column virtual-sequence diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 8b2106685a..4b98e9a410 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -19,9 +19,9 @@ FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ; FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ; FUNCTION: SInt32 CFRunLoopRunInMode ( - CFStringRef mode, - CFTimeInterval seconds, - Boolean returnAfterSourceHandled + CFStringRef mode, + CFTimeInterval seconds, + Boolean returnAfterSourceHandled ) ; FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource ( @@ -31,27 +31,27 @@ FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource ( ) ; FUNCTION: void CFRunLoopAddSource ( - CFRunLoopRef rl, - CFRunLoopSourceRef source, - CFStringRef mode + CFRunLoopRef rl, + CFRunLoopSourceRef source, + CFStringRef mode ) ; FUNCTION: void CFRunLoopRemoveSource ( - CFRunLoopRef rl, - CFRunLoopSourceRef source, - CFStringRef mode + CFRunLoopRef rl, + CFRunLoopSourceRef source, + CFStringRef mode ) ; FUNCTION: void CFRunLoopAddTimer ( - CFRunLoopRef rl, - CFRunLoopTimerRef timer, - CFStringRef mode + CFRunLoopRef rl, + CFRunLoopTimerRef timer, + CFStringRef mode ) ; FUNCTION: void CFRunLoopRemoveTimer ( - CFRunLoopRef rl, - CFRunLoopTimerRef timer, - CFStringRef mode + CFRunLoopRef rl, + CFRunLoopTimerRef timer, + CFStringRef mode ) ; : CFRunLoopDefaultMode ( -- alien ) diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 2e6180c897..c3a969a325 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -23,11 +23,11 @@ TYPEDEF: int CFStringEncoding : kCFStringEncodingUTF32LE HEX: 1c000100 ; FUNCTION: CFStringRef CFStringCreateWithBytes ( - CFAllocatorRef alloc, - UInt8* bytes, - CFIndex numBytes, - CFStringEncoding encoding, - Boolean isExternalRepresentation + CFAllocatorRef alloc, + UInt8* bytes, + CFIndex numBytes, + CFStringEncoding encoding, + Boolean isExternalRepresentation ) ; FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ; @@ -35,16 +35,16 @@ FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ; FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ; FUNCTION: Boolean CFStringGetCString ( - CFStringRef theString, - char* buffer, - CFIndex bufferSize, - CFStringEncoding encoding + CFStringRef theString, + char* buffer, + CFIndex bufferSize, + CFStringEncoding encoding ) ; FUNCTION: CFStringRef CFStringCreateWithCString ( - CFAllocatorRef alloc, - char* cStr, - CFStringEncoding encoding + CFAllocatorRef alloc, + char* cStr, + CFStringEncoding encoding ) ; : ( string -- alien ) diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index ea246cfa28..a3e5c7ceb7 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -60,8 +60,8 @@ GENERIC: add-atom ( a disjoint-set -- ) M: disjoint-set add-atom [ dupd parents>> set-at ] - [ 0 -rot ranks>> set-at ] - [ 1 -rot counts>> set-at ] + [ [ 0 ] 2dip ranks>> set-at ] + [ [ 1 ] 2dip counts>> set-at ] 2tri ; : add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ; diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor index 6993bcb65b..29f865cf3c 100644 --- a/basis/documents/documents.factor +++ b/basis/documents/documents.factor @@ -153,18 +153,18 @@ GENERIC: next-elt ( loc document elt -- newloc ) TUPLE: char-elt ; : (prev-char) ( loc document quot -- loc ) - -rot { - { [ over { 0 0 } = ] [ drop ] } - { [ over second zero? ] [ [ first 1- ] dip line-end ] } - [ pick call ] - } cond nip ; inline + { + { [ pick { 0 0 } = ] [ 2drop ] } + { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] } + [ call ] + } cond ; inline : (next-char) ( loc document quot -- loc ) - -rot { - { [ 2dup doc-end = ] [ drop ] } - { [ 2dup line-end? ] [ drop first 1+ 0 2array ] } - [ pick call ] - } cond nip ; inline + { + { [ 2over doc-end = ] [ 2drop ] } + { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] } + [ call ] + } cond ; inline M: char-elt prev-elt drop [ drop -1 +col ] (prev-char) ; diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor index 8616325a81..c7e9fb985e 100644 --- a/basis/formatting/formatting-tests.factor +++ b/basis/formatting/formatting-tests.factor @@ -85,13 +85,13 @@ IN: formatting.tests [ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test [ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test - [ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test [ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test - +[ t ] [ "10/09/08" testtime "%m/%d/%y" strftime = ] unit-test [ t ] [ "Thu" testtime "%a" strftime = ] unit-test [ t ] [ "Thursday" testtime "%A" strftime = ] unit-test - [ t ] [ "Oct" testtime "%b" strftime = ] unit-test [ t ] [ "October" testtime "%B" strftime = ] unit-test +[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test +[ t ] [ "PM" testtime "%p" strftime = ] unit-test diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index 7dd8458488..3f12c36bbd 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license USING: accessors arrays ascii calendar combinators fry kernel -io io.encodings.ascii io.files io.streams.string +generalizations io io.encodings.ascii io.files io.streams.string macros math math.functions math.parser peg.ebnf quotations sequences splitting strings unicode.case vectors ; @@ -32,10 +32,7 @@ IN: formatting [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ; : max-digits ( n digits -- n' ) - 10 swap ^ [ * round ] keep / ; - -: max-width ( string length -- string' ) - short head ; + 10 swap ^ [ * round ] keep / ; inline : >exp ( x -- exp base ) [ @@ -69,7 +66,7 @@ pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]] -width_ = "." ([0-9])* => [[ second >digits '[ _ max-width ] ]] +width_ = "." ([0-9])* => [[ second >digits '[ _ short head ] ]] width = (width_)? => [[ [ ] or ]] digits_ = "." ([0-9])* => [[ second >digits ]] @@ -113,23 +110,25 @@ MACRO: printf ( format-string -- ) string 2 CHAR: 0 pad-left ; inline + +: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline : >time ( timestamp -- string ) [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array - [ number>string zero-pad ] map ":" join ; inline + [ pad-00 ] map ":" join ; inline : >date ( timestamp -- string ) [ month>> ] [ day>> ] [ year>> ] tri 3array - [ number>string zero-pad ] map "/" join ; inline + [ pad-00 ] map "/" join ; inline : >datetime ( timestamp -- string ) { [ day-of-week day-abbreviation3 ] [ month>> month-abbreviation ] - [ day>> number>string zero-pad ] + [ day>> pad-00 ] [ >time ] [ year>> number>string ] - } cleave 3array [ 2array ] dip append " " join ; inline + } cleave 5 narray " " join ; inline : (week-of-year) ( timestamp day -- n ) [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when @@ -147,20 +146,20 @@ fmt-A = "A" => [[ [ dup day-of-week day-name ] ]] fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]] fmt-B = "B" => [[ [ dup month>> month-name ] ]] fmt-c = "c" => [[ [ dup >datetime ] ]] -fmt-d = "d" => [[ [ dup day>> number>string zero-pad ] ]] -fmt-H = "H" => [[ [ dup hour>> number>string zero-pad ] ]] -fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when number>string zero-pad ] ]] -fmt-j = "j" => [[ [ dup day-of-year number>string ] ]] -fmt-m = "m" => [[ [ dup month>> number>string zero-pad ] ]] -fmt-M = "M" => [[ [ dup minute>> number>string zero-pad ] ]] +fmt-d = "d" => [[ [ dup day>> pad-00 ] ]] +fmt-H = "H" => [[ [ dup hour>> pad-00 ] ]] +fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when pad-00 ] ]] +fmt-j = "j" => [[ [ dup day-of-year pad-000 ] ]] +fmt-m = "m" => [[ [ dup month>> pad-00 ] ]] +fmt-M = "M" => [[ [ dup minute>> pad-00 ] ]] fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]] -fmt-S = "S" => [[ [ dup second>> round number>string zero-pad ] ]] -fmt-U = "U" => [[ [ dup week-of-year-sunday ] ]] +fmt-S = "S" => [[ [ dup second>> floor pad-00 ] ]] +fmt-U = "U" => [[ [ dup week-of-year-sunday pad-00 ] ]] fmt-w = "w" => [[ [ dup day-of-week number>string ] ]] -fmt-W = "W" => [[ [ dup week-of-year-monday ] ]] +fmt-W = "W" => [[ [ dup week-of-year-monday pad-00 ] ]] fmt-x = "x" => [[ [ dup >date ] ]] fmt-X = "X" => [[ [ dup >time ] ]] -fmt-y = "y" => [[ [ dup year>> 100 mod number>string ] ]] +fmt-y = "y" => [[ [ dup year>> 100 mod pad-00 ] ]] fmt-Y = "Y" => [[ [ dup year>> number>string ] ]] fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]] unknown = (.)* => [[ "Unknown directive" throw ]] diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 0d435a1eaf..4ea90e086b 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -100,14 +100,12 @@ $nl { $code "10 [ \"Factor rocks!\" print ] times" } "Now we can look at a new data type, the array:" { $code "{ 1 2 3 }" } -"An array looks like a quotation except it cannot be evaluated; it simply stores data." +"An array differs from a quotation in that it cannot be evaluated; it simply stores data." $nl "You can perform an operation on each element of an array:" { $example "{ 1 2 3 } [ \"The number is \" write . ] each" - "The number is 1" - "The number is 2" - "The number is 3" + "The number is 1\nThe number is 2\nThe number is 3" } "You can transform each element, collecting the results in a new array:" { $example "{ 5 12 0 -12 -5 } [ sq ] map ." "{ 25 144 0 144 25 }" } diff --git a/basis/help/help-tests.factor b/basis/help/help-tests.factor index e38f2fc15d..e091278359 100644 --- a/basis/help/help-tests.factor +++ b/basis/help/help-tests.factor @@ -3,3 +3,4 @@ USING: tools.test help kernel ; [ 3 throw ] must-fail [ ] [ :help ] unit-test +[ ] [ f print-topic ] unit-test \ No newline at end of file diff --git a/basis/help/help.factor b/basis/help/help.factor index cd80a73dad..272bdc1db3 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -112,6 +112,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; ] with-style nl ; : print-topic ( topic -- ) + >link last-element off dup $title article-content print-content nl ; diff --git a/basis/http/server/cgi/cgi.factor b/basis/http/server/cgi/cgi.factor index e618249ff4..59cd62f338 100644 --- a/basis/http/server/cgi/cgi.factor +++ b/basis/http/server/cgi/cgi.factor @@ -58,6 +58,8 @@ IN: http.server.cgi ] with-stream ] >>body ; +SLOT: special + : enable-cgi ( responder -- responder ) [ serve-cgi ] "application/x-cgi-script" pick special>> set-at ; diff --git a/basis/inspector/inspector.factor b/basis/inspector/inspector.factor index b47426f5bb..9c61d092e5 100644 --- a/basis/inspector/inspector.factor +++ b/basis/inspector/inspector.factor @@ -3,7 +3,7 @@ USING: accessors arrays generic hashtables io kernel assocs math namespaces prettyprint sequences strings io.styles vectors words quotations mirrors splitting math.parser classes vocabs refs -sets sorting summary debugger continuations ; +sets sorting summary debugger continuations fry ; IN: inspector : value-editor ( path -- ) @@ -53,7 +53,7 @@ SYMBOL: +editable+ [ drop ] [ dup enum? [ +sequence+ on ] when standard-table-style [ - swap [ -rot describe-row ] curry each-index + swap '[ [ _ ] 2dip describe-row ] each-index ] tabular-output ] if-empty ; @@ -64,7 +64,7 @@ M: tuple error. describe ; : namestack. ( seq -- ) [ [ global eq? not ] filter [ keys ] gather ] keep - [ dupd assoc-stack ] curry H{ } map>assoc describe ; + '[ dup _ assoc-stack ] H{ } map>assoc describe ; : .vars ( -- ) namestack namestack. ; diff --git a/basis/io/backend/unix/unix-tests.factor b/basis/io/backend/unix/unix-tests.factor index 5417b9b178..2e94d7a2df 100644 --- a/basis/io/backend/unix/unix-tests.factor +++ b/basis/io/backend/unix/unix-tests.factor @@ -1,7 +1,7 @@ USING: io.files io.files.temp io.directories io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences prettyprint system io.encodings.binary io.encodings.ascii -io.streams.duplex destructors make ; +io.streams.duplex destructors make io.launcher ; IN: io.backend.unix.tests ! Unix domain stream sockets @@ -138,3 +138,13 @@ datagram-client delete-file input-stream get send ] with-file-reader ] must-fail + +! closing stdin caused some problems +[ ] [ + [ + vm , + "-i=" image append , + "-run=none" , + "-e=USING: destructors namespaces io calendar threads ; input-stream get dispose 1 seconds sleep" , + ] { } make try-process +] unit-test diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index ee4a1ed91f..60313b3306 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -3,8 +3,9 @@ USING: accessors alien.c-types alien.syntax combinators csv io.backend io.encodings.utf8 io.files io.files.info io.streams.string io.files.unix kernel math.order namespaces sequences sorting -system unix unix.statfs.linux unix.statvfs.linux -specialized-arrays.direct.uint arrays io.files.info.unix ; +system unix unix.statfs.linux unix.statvfs.linux io.files.links +specialized-arrays.direct.uint arrays io.files.info.unix assocs +io.pathnames ; IN: io.files.info.unix.linux TUPLE: linux-file-system-info < unix-file-system-info @@ -70,6 +71,16 @@ M: linux file-systems } cleave ] map ; +: (find-mount-point) ( path mtab-paths -- mtab-entry ) + [ follow-links ] dip 2dup at* [ + 2nip + ] [ + drop [ parent-directory ] dip (find-mount-point) + ] if ; + +: find-mount-point ( path -- mtab-entry ) + parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ; + ERROR: file-system-not-found ; M: linux file-system-info ( path -- ) @@ -80,9 +91,7 @@ M: linux file-system-info ( path -- ) [ file-system-statvfs statvfs>file-system-info ] bi file-system-calculations ] keep - - parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort - [ mount-point>> head? ] with find nip [ file-system-not-found ] unless* + find-mount-point { [ file-system-name>> >>device-name drop ] [ mount-point>> >>mount-point drop ] diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index aecf42d9a2..cf826a59d3 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -102,10 +102,7 @@ M: windows link-info ( path -- info ) [ GetDiskFreeSpaceEx win32-error=0/f ] 3keep ; : calculate-file-system-info ( file-system-info -- file-system-info' ) - { - [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] - [ ] - } cleave ; + [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ] keep ; TUPLE: win32-file-system-info < file-system-info max-component flags device-serial ; diff --git a/basis/io/files/links/links-docs.factor b/basis/io/files/links/links-docs.factor index 0e9a375da3..8419399c92 100644 --- a/basis/io/files/links/links-docs.factor +++ b/basis/io/files/links/links-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io.files.info ; +USING: help.markup help.syntax io.files.info math ; IN: io.files.links HELP: make-link @@ -13,11 +13,40 @@ HELP: copy-link { $values { "target" "a path to an existing symlink" } { "symlink" "a path to a new symbolic link" } } { $description "Copies a symbolic link without following the link." } ; -{ make-link read-link copy-link } related-words +HELP: follow-link +{ $values + { "path" "a pathname string" } + { "path'" "a pathname string" } +} +{ $description "Returns an absolute path from " { $link read-link } "." } ; + +HELP: follow-links +{ $values + { "path" "a pathname string" } + { "path'" "a pathname string" } +} +{ $description "Follows a chain of symlinks up to " { $link symlink-depth } "." } ; + +{ read-link follow-link follow-links } related-words + +HELP: symlink-depth +{ $values + { "value" integer } +} +{ $description "The number of redirections " { $link follow-links } " will follow." } ; + +HELP: too-many-symlinks +{ $values + { "path" "a pathname string" } { "n" integer } +} +{ $description "An error thrown when the number of redirections in a chain of symlinks surpasses the value in the " { $link symlink-depth } " variable." } ; ARTICLE: "io.files.links" "Symbolic links" -"Reading and creating links:" +"Reading links:" { $subsection read-link } +{ $subsection follow-link } +{ $subsection follow-links } +"Creating links:" { $subsection make-link } "Copying links:" { $subsection copy-link } diff --git a/basis/io/files/links/links.factor b/basis/io/files/links/links.factor index 02e1a1b078..1212d579db 100644 --- a/basis/io/files/links/links.factor +++ b/basis/io/files/links/links.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel vocabs.loader ; +USING: accessors io.backend io.files.info io.files.types +io.pathnames kernel math namespaces system vocabs.loader ; IN: io.files.links HOOK: make-link os ( target symlink -- ) @@ -10,4 +11,25 @@ HOOK: read-link os ( symlink -- path ) : copy-link ( target symlink -- ) [ read-link ] dip make-link ; -os unix? [ "io.files.links.unix" require ] when \ No newline at end of file +os unix? [ "io.files.links.unix" require ] when + +: follow-link ( path -- path' ) + [ parent-directory ] [ read-link ] bi append-path ; + +SYMBOL: symlink-depth +10 symlink-depth set-global + +ERROR: too-many-symlinks path n ; + +> +symbolic-link+ = + [ [ 1- ] [ follow-link ] bi* (follow-links) ] + [ nip ] if ; inline recursive + +PRIVATE> + +: follow-links ( path -- path' ) + [ symlink-depth get ] dip normalize-path (follow-links) ; diff --git a/basis/io/files/links/unix/unix-tests.factor b/basis/io/files/links/unix/unix-tests.factor new file mode 100644 index 0000000000..b1d2c5b8fa --- /dev/null +++ b/basis/io/files/links/unix/unix-tests.factor @@ -0,0 +1,32 @@ +USING: io.directories io.files.links tools.test sequences +io.files.unique tools.files fry math kernel math.parser +io.pathnames namespaces ; +IN: io.files.links.unix.tests + +: make-test-links ( n path -- ) + [ '[ [ 1+ ] keep [ number>string _ prepend ] bi@ make-link ] each ] + [ [ number>string ] dip prepend touch-file ] 2bi ; inline + +[ t ] [ + [ + 5 "lol" make-test-links + "lol1" follow-links + current-directory get "lol5" append-path = + ] with-unique-directory +] unit-test + +[ + [ + 100 "laf" make-test-links "laf1" follow-links + ] with-unique-directory +] [ too-many-symlinks? ] must-fail-with + +[ t ] [ + 110 symlink-depth [ + [ + 100 "laf" make-test-links + "laf1" follow-links + current-directory get "laf100" append-path = + ] with-unique-directory + ] with-variable +] unit-test diff --git a/basis/io/files/links/unix/unix.factor b/basis/io/files/links/unix/unix.factor index 69b31c6874..2f38c39e02 100644 --- a/basis/io/files/links/unix/unix.factor +++ b/basis/io/files/links/unix/unix.factor @@ -7,4 +7,4 @@ M: unix make-link ( path1 path2 -- ) normalize-path symlink io-error ; M: unix read-link ( path -- path' ) - normalize-path read-symbolic-link ; + normalize-path read-symbolic-link ; diff --git a/basis/logging/logging.factor b/basis/logging/logging.factor index fb6b328990..6769932c88 100644 --- a/basis/logging/logging.factor +++ b/basis/logging/logging.factor @@ -61,7 +61,7 @@ PRIVATE> [ dup ] 2dip 2curry annotate ; : call-logging-quot ( quot word level -- quot' ) - "called" -rot [ log-message ] 3curry prepose ; + [ "called" ] 2dip [ log-message ] 3curry prepose ; : add-logging ( word level -- ) [ call-logging-quot ] (define-logging) ; diff --git a/basis/logging/parser/parser-docs.factor b/basis/logging/parser/parser-docs.factor index 76c7ab6c90..7ab1ad3883 100644 --- a/basis/logging/parser/parser-docs.factor +++ b/basis/logging/parser/parser-docs.factor @@ -13,7 +13,7 @@ HELP: parse-log } ; ARTICLE: "logging.parser" "Log file parser" -"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs." +"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $vocab-link "logging.insomniac" } " to analyze logs." $nl "There is only one primary entry point:" { $subsection parse-log } ; diff --git a/basis/logging/server/server.factor b/basis/logging/server/server.factor index 68f8d74571..618dba544c 100644 --- a/basis/logging/server/server.factor +++ b/basis/logging/server/server.factor @@ -28,7 +28,7 @@ SYMBOL: log-files : multiline-header ( -- string ) 20 CHAR: - ; foldable -: (write-message) ( msg name>> level multi? -- ) +: (write-message) ( msg word-name level multi? -- ) [ "[" write multiline-header write "] " write ] [ @@ -36,18 +36,19 @@ SYMBOL: log-files ] if write bl write ": " write print ; -: write-message ( msg name>> level -- ) - rot harvest { - { [ dup empty? ] [ 3drop ] } - { [ dup length 1 = ] [ first -rot f (write-message) ] } +: write-message ( msg word-name level -- ) + [ harvest ] 2dip { + { [ pick empty? ] [ 3drop ] } + { [ pick length 1 = ] [ [ first ] 2dip f (write-message) ] } [ - [ first -rot f (write-message) ] 3keep - rest -rot [ t (write-message) ] 2curry each + [ [ first ] 2dip f (write-message) ] + [ [ rest ] 2dip [ t (write-message) ] 2curry each ] + 3bi ] } cond ; : (log-message) ( msg -- ) - #! msg: { msg name>> level service } + #! msg: { msg word-name level service } first4 log-stream [ write-message flush ] with-output-stream* ; : try-dispose ( stream -- ) diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 81294d29f7..15914e7b05 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -50,11 +50,11 @@ M: ratio <= scale <= ; M: ratio > scale > ; M: ratio >= scale >= ; -M: ratio + 2dup scale + -rot ratio+d / ; -M: ratio - 2dup scale - -rot ratio+d / ; -M: ratio * 2>fraction * [ * ] dip / ; +M: ratio + [ scale + ] [ ratio+d ] 2bi / ; +M: ratio - [ scale - ] [ ratio+d ] 2bi / ; +M: ratio * 2>fraction [ * ] 2bi@ / ; M: ratio / scale / ; M: ratio /i scale /i ; M: ratio /f scale /f ; -M: ratio mod [ /i ] 2keep rot * - ; +M: ratio mod 2dup /i * - ; M: ratio /mod [ /i ] 2keep mod ; diff --git a/basis/mirrors/mirrors.factor b/basis/mirrors/mirrors.factor index d3d6dbdb04..25486d127d 100644 --- a/basis/mirrors/mirrors.factor +++ b/basis/mirrors/mirrors.factor @@ -32,7 +32,7 @@ M: mirror set-at ( val key mirror -- ) swap set-slot ; M: mirror delete-at ( key mirror -- ) - f -rot set-at ; + [ f ] 2dip set-at ; M: mirror clear-assoc ( mirror -- ) [ object>> ] [ object-slots ] bi [ diff --git a/basis/models/compose/compose-tests.factor b/basis/models/compose/compose-tests.factor index 16a5ab339c..0644bb6841 100644 --- a/basis/models/compose/compose-tests.factor +++ b/basis/models/compose/compose-tests.factor @@ -1,5 +1,5 @@ USING: arrays generic kernel math models namespaces sequences assocs -tools.test models.compose accessors ; +tools.test models.compose accessors locals ; IN: models.compose.tests ! Test compose @@ -22,3 +22,25 @@ IN: models.compose.tests [ { 4 5 } ] [ "c" get value>> ] unit-test [ ] [ "c" get deactivate-model ] unit-test + +TUPLE: an-observer { i integer } ; + +M: an-observer model-changed nip [ 1+ ] change-i drop ; + +[ 1 0 ] [ + [let* | m1 [ 1 ] + m2 [ 2 ] + c [ { m1 m2 } ] + o1 [ an-observer new ] + o2 [ an-observer new ] | + + o1 m1 add-connection + o2 m2 add-connection + + c activate-model + + "OH HAI" m1 set-model + o1 i>> + o2 i>> + ] +] unit-test \ No newline at end of file diff --git a/basis/models/compose/compose.factor b/basis/models/compose/compose.factor index a2c3385248..386a06781d 100644 --- a/basis/models/compose/compose.factor +++ b/basis/models/compose/compose.factor @@ -18,7 +18,8 @@ TUPLE: compose < model ; M: compose model-changed nip - [ [ value>> ] composed-value ] keep set-model ; + dup [ value>> ] composed-value >>value + notify-connections ; M: compose model-activated dup model-changed ; diff --git a/basis/opengl/capabilities/capabilities.factor b/basis/opengl/capabilities/capabilities.factor index 3972fea7b3..09d49b33c2 100755 --- a/basis/opengl/capabilities/capabilities.factor +++ b/basis/opengl/capabilities/capabilities.factor @@ -1,14 +1,11 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel namespaces make sequences splitting opengl.gl -continuations math.parser math arrays sets math.order ; +continuations math.parser math arrays sets math.order fry ; IN: opengl.capabilities : (require-gl) ( thing require-quot make-error-quot -- ) - -rot dupd call - [ 2drop ] - [ swap " " make throw ] - if ; inline + [ dupd call [ drop ] ] dip '[ _ " " make throw ] if ; inline : gl-extensions ( -- seq ) GL_EXTENSIONS glGetString " " split ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index 10f9c57a83..f5868ee7a1 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -6,7 +6,7 @@ USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences splitting words byte-arrays assocs colors accessors -generalizations locals specialized-arrays.float +generalizations locals fry specialized-arrays.float specialized-arrays.uint ; IN: opengl @@ -154,19 +154,21 @@ MACRO: all-enabled-client-state ( seq quot -- ) : delete-gl-buffer ( id -- ) [ glDeleteBuffers ] (delete-gl-object) ; -: with-gl-buffer ( binding id quot -- ) - -rot dupd glBindBuffer - [ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline +:: with-gl-buffer ( binding id quot -- ) + binding id glBindBuffer + quot [ binding 0 glBindBuffer ] [ ] cleanup ; inline : with-array-element-buffers ( array-buffer element-buffer quot -- ) - -rot GL_ELEMENT_ARRAY_BUFFER swap [ - swap GL_ARRAY_BUFFER -rot with-gl-buffer + [ GL_ELEMENT_ARRAY_BUFFER ] 2dip '[ + GL_ARRAY_BUFFER swap _ with-gl-buffer ] with-gl-buffer ; inline : ( target data hint -- id ) - pick gen-gl-buffer [ [ - [ dup byte-length swap ] dip glBufferData - ] with-gl-buffer ] keep ; + pick gen-gl-buffer [ + [ + [ [ byte-length ] keep ] dip glBufferData + ] with-gl-buffer + ] keep ; : buffer-offset ( int -- alien ) ; inline diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index 7434ca6a7a..a9fb366812 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -51,8 +51,7 @@ PRIVATE> dup zero? [ 2drop epsilon ] [ - 2dup exactly-n - -rot 1- at-most-n 2choice + [ exactly-n ] [ 1- at-most-n ] 2bi 2choice ] if ; : at-least-n ( parser n -- parser' ) diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 3fc6fec8ed..206a054d35 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -373,7 +373,7 @@ TUPLE: range-parser min max ; pick empty? [ 3drop f ] [ - pick first -rot between? [ + [ dup first ] 2dip between? [ unclip-slice ] [ drop f diff --git a/basis/sequences/deep/deep.factor b/basis/sequences/deep/deep.factor index 244040d60a..d942b3f4c4 100644 --- a/basis/sequences/deep/deep.factor +++ b/basis/sequences/deep/deep.factor @@ -14,11 +14,11 @@ M: object branch? drop f ; : deep-each ( obj quot: ( elt -- ) -- ) [ call ] 2keep over branch? - [ [ deep-each ] curry each ] [ 2drop ] if ; inline recursive + [ '[ _ deep-each ] each ] [ 2drop ] if ; inline recursive : deep-map ( obj quot: ( elt -- elt' ) -- newobj ) [ call ] keep over branch? - [ [ deep-map ] curry map ] [ drop ] if ; inline recursive + [ '[ _ deep-map ] map ] [ drop ] if ; inline recursive : deep-filter ( obj quot: ( elt -- ? ) -- seq ) over [ pusher [ deep-each ] dip ] dip @@ -27,7 +27,7 @@ M: object branch? drop f ; : (deep-find) ( obj quot: ( elt -- ? ) -- elt ? ) [ call ] 2keep rot [ drop t ] [ over branch? [ - f -rot [ [ nip ] dip (deep-find) ] curry find drop >boolean + [ f ] 2dip '[ nip _ (deep-find) ] find drop >boolean ] [ 2drop f f ] if ] if ; inline recursive @@ -36,7 +36,7 @@ M: object branch? drop f ; : deep-contains? ( obj quot -- ? ) (deep-find) nip ; inline : deep-all? ( obj quot -- ? ) - [ not ] compose deep-contains? not ; inline + '[ @ not ] deep-contains? not ; inline : deep-member? ( obj seq -- ? ) swap '[ @@ -50,7 +50,7 @@ M: object branch? drop f ; : deep-change-each ( obj quot: ( elt -- elt' ) -- ) over branch? [ - [ [ call ] keep over [ deep-change-each ] dip ] curry change-each + '[ _ [ call ] keep over [ deep-change-each ] dip ] change-each ] [ 2drop ] if ; inline recursive : flatten ( obj -- seq ) diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index d2bf583b5a..6f77e66cd2 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -1,6 +1,7 @@ IN: struct-arrays.tests USING: struct-arrays tools.test kernel math sequences -alien.syntax alien.c-types destructors libc accessors ; +alien.syntax alien.c-types destructors libc accessors +destructors ; C-STRUCT: test-struct { "int" "x" } @@ -27,3 +28,12 @@ C-STRUCT: test-struct 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce ] with-destructors ] unit-test + +[ ] [ ALIEN: 123 10 "test-struct" drop ] unit-test + +[ ] [ + [ + 10 "test-struct" malloc-struct-array + underlying>> &free drop + ] with-destructors +] unit-test \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays.factor b/basis/struct-arrays/struct-arrays.factor index 33a469d0c8..ba0524009f 100755 --- a/basis/struct-arrays/struct-arrays.factor +++ b/basis/struct-arrays/struct-arrays.factor @@ -32,9 +32,9 @@ ERROR: bad-byte-array-length byte-array ; ] keep struct-array boa ; inline : ( alien length c-type -- struct-array ) - struct-array boa ; inline + heap-size struct-array boa ; inline : malloc-struct-array ( length c-type -- struct-array ) - heap-size [ calloc ] 2keep ; + [ heap-size calloc ] 2keep ; INSTANCE: struct-array sequence diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor index 1dcc6fe4c1..91b4d603af 100644 --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -13,7 +13,7 @@ IN: tools.deploy.macosx vm parent-directory parent-directory ; : copy-bundle-dir ( bundle-name dir -- ) - bundle-dir over append-path -rot + [ bundle-dir prepend-path swap ] keep "Contents" prepend-path append-path copy-tree ; : app-plist ( executable bundle-name -- assoc ) diff --git a/basis/tools/profiler/profiler-docs.factor b/basis/tools/profiler/profiler-docs.factor index 69edf1a7e0..da9171cedf 100644 --- a/basis/tools/profiler/profiler-docs.factor +++ b/basis/tools/profiler/profiler-docs.factor @@ -2,14 +2,18 @@ USING: tools.profiler.private tools.time help.markup help.syntax quotations io strings words definitions ; IN: tools.profiler -ARTICLE: "profiling" "Profiling code" -"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler. The profiler is completely accurate with words and methods which are compiled with the non-optimizing compiler. Some optimizations performed by the optimizing compiler can inhibit accurate call counting, however:" +ARTICLE: "profiler-limitations" "Profiler limitations" +"Certain optimizations performed by the compiler can inhibit accurate call counting:" { $list - "The optimizing compiler open-codes certain primitives with inline machine code, and in some cases optimizes them out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations." - { "Calls to " { $link POSTPONE: inline } " words are not counted.." } + "Calls to open-coded intrinsics are not counted. Certain words are open-coded as inline machine code, and in some cases optimized out altogether; this includes stack shuffling operations, conditionals, and many object allocation operations." + { "Calls to " { $link POSTPONE: inline } " words are not counted." } { "Calls to methods which were inlined as a result of type inference are not counted." } "Tail-recursive loops will only count the initial invocation of the word, not every tail call." -} +} ; + +ARTICLE: "profiling" "Profiling code" +"The " { $vocab-link "tools.profiler" } " vocabulary implements a simple call counting profiler." +$nl "Quotations can be passed to a combinator which calls them with the profiler enabled:" { $subsection profile } "After a quotation has been profiled, call counts can be presented in various ways:" @@ -17,7 +21,9 @@ ARTICLE: "profiling" "Profiling code" { $subsection vocab-profile. } { $subsection usage-profile. } { $subsection vocabs-profile. } -{ $subsection method-profile. } ; +{ $subsection method-profile. } +{ $subsection "profiler-limitations" } +{ $see-also "ui-profiler" } ; ABOUT: "profiling" diff --git a/basis/ui/gadgets/borders/borders.factor b/basis/ui/gadgets/borders/borders.factor index 94816788e1..1f66cca178 100644 --- a/basis/ui/gadgets/borders/borders.factor +++ b/basis/ui/gadgets/borders/borders.factor @@ -16,6 +16,9 @@ TUPLE: border < gadget swap border new-border swap dup 2array >>size ; +: ( child gap -- border ) + { 1 1 } >>fill ; + M: border pref-dim* [ size>> 2 v*n ] keep gadget-child pref-dim v+ ; diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 72d5900c28..67386c1807 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -107,7 +107,7 @@ M: editor ungraft* editor-font* "" string-height ; : y>line ( y editor -- line# ) - line-height / >fixnum ; + line-height /i ; :: point>loc ( point editor -- loc ) point second editor y>line { diff --git a/basis/ui/gadgets/menus/menus.factor b/basis/ui/gadgets/menus/menus.factor index 2aef0b8417..c482f31896 100644 --- a/basis/ui/gadgets/menus/menus.factor +++ b/basis/ui/gadgets/menus/menus.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: locals accessors arrays ui.commands ui.gadgets +USING: locals accessors arrays ui.commands ui.operations ui.gadgets ui.gadgets.buttons ui.gadgets.worlds ui.gestures generic hashtables kernel math models namespaces opengl sequences math.vectors ui.gadgets.theme ui.gadgets.packs @@ -54,3 +54,9 @@ M: menu-glass layout* gadget-child prefer ; : show-commands-menu ( target commands -- ) [ dup [ ] ] dip show-menu ; + +: ( target hook -- menu ) + over object-operations ; + +: show-operations-menu ( gadget target -- ) + [ ] show-menu ; \ No newline at end of file diff --git a/basis/ui/gadgets/presentations/presentations-docs.factor b/basis/ui/gadgets/presentations/presentations-docs.factor index c651e849a2..005fa1e7fe 100644 --- a/basis/ui/gadgets/presentations/presentations-docs.factor +++ b/basis/ui/gadgets/presentations/presentations-docs.factor @@ -35,8 +35,6 @@ HELP: {