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

basis/calendar/calendar-docs.factor

@@ -184,7 +184,7 @@ HELP: time+
 { $description "Adds two durations to produce a duration or adds a timestamp and a duration to produce a timestamp. The calculation takes timezones into account." }
 { $examples
     { $example "USING: calendar math.order prettyprint ;"
-               "10 months 2 months time+ 1 year <=> ."
+               "10 months 2 months time+ 1 years <=> ."
                "+eq+"
     }
     { $example "USING: accessors calendar math.order prettyprint ;"
@@ -193,3 +193,109 @@ HELP: time+
     }
 } ;
 
+HELP: dt>years
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in years." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 months dt>years ."
+               "1/2"
+    }
+} ;
+
+HELP: dt>months
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in months." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "30 days dt>months ."
+               "16000/16233"
+    }
+} ;
+
+HELP: dt>days
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in days." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 hours dt>days ."
+               "1/4"
+    }
+} ;
+
+HELP: dt>hours
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in hours." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "3/4 days dt>hours ."
+               "18"
+    }
+} ;
+HELP: dt>minutes
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in minutes." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 hours dt>minutes ."
+               "360"
+    }
+} ;
+HELP: dt>seconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in seconds." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 minutes dt>seconds ."
+               "360"
+    }
+} ;
+
+HELP: dt>milliseconds
+{ $values { "duration" duration } { "x" number } }
+{ $description "Calculates the length of a duration in milliseconds." }
+{ $examples
+    { $example "USING: calendar prettyprint ;"
+               "6 seconds dt>milliseconds ."
+               "6000"
+    }
+} ;
+
+{ dt>years dt>months dt>days dt>hours dt>minutes dt>seconds dt>milliseconds } related-words
+
+
+HELP: time-
+{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } }
+{ $description "Subtracts two durations to produce a duration or subtracts a duration from a timestamp to produce a timestamp. The calculation takes timezones into account." }
+{ $examples
+    { $example "USING: calendar math.order prettyprint ;"
+               "10 months 2 months time- 8 months <=> ."
+               "+eq+"
+    }
+    { $example "USING: accessors calendar math.order prettyprint ;"
+               "2010 1 1 <date> 3 days time- day>> ."
+               "29"
+    }
+} ;
+
+{ time+ time- } related-words
+
+HELP: convert-timezone
+{ $values { "timestamp" timestamp } { "duration" duration } { "timestamp" timestamp } }
+{ $description "Converts the " { $snippet "timestamp" } "'s " { $snippet "gmt-offset" } " to the GMT offset represented by the " { $snippet "duration" } "." }
+{ $examples
+    { $example "USING: accessors calendar prettyprint ;"
+               "gmt noon instant -5 >>hour convert-timezone gmt-offset>> hour>> ."
+               "-5"
+    }
+} ;
+
+HELP: >local-time
+{ $values { "timestamp" timestamp } { "timestamp" timestamp } }
+{ $description "Converts the " { $snippet "timestamp" } " to the timezone of your computer." }
+{ $examples
+    { $example "USING: accessors calendar kernel prettyprint ;"
+               "now gmt >local-time [ gmt-offset>> ] bi@ = ."
+               "t"
+    }
+} ;

basis/calendar/calendar.factor

@@ -60,6 +60,8 @@ PRIVATE>
 : month-abbreviation ( n -- string )
     check-month 1- month-abbreviations nth ;
 
+: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
+
 : day-names ( -- array )
     {
         "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday"
@@ -116,7 +118,7 @@ PRIVATE>
 : >time< ( timestamp -- hour minute second )
     [ hour>> ] [ minute>> ] [ second>> ] tri ;
 
-MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
+: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
 : years ( x -- duration ) instant clone swap >>year ;
 : months ( x -- duration ) instant clone swap >>month ;
 : days ( x -- duration ) instant clone swap >>day ;
@@ -258,7 +260,7 @@ M: duration <=> [ dt>years ] compare ;
 : dt>seconds ( duration -- x ) dt>years seconds-per-year * ;
 : dt>milliseconds ( duration -- x ) dt>seconds 1000 * ;
 
-GENERIC: time- ( time1 time2 -- time )
+GENERIC: time- ( time1 time2 -- time3 )
 
 : convert-timezone ( timestamp duration -- timestamp )
     over gmt-offset>> over = [ drop ] [
@@ -323,12 +325,9 @@ MEMO: unix-1970 ( -- timestamp )
     unix-1970 millis milliseconds time+ ;
 
 : now ( -- timestamp ) gmt >local-time ;
-
 : hence ( duration -- timestamp ) now swap time+ ;
 : ago ( duration -- timestamp ) now swap time- ;
 
-: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
-
 : zeller-congruence ( year month day -- n )
     #! Zeller Congruence
     #! http://web.textfiles.com/computers/formulas.txt
@@ -395,7 +394,6 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
 : time-since-midnight ( timestamp -- duration )
     dup midnight time- ;
 
-
 M: timestamp sleep-until timestamp>millis sleep-until ;
 
 M: duration sleep hence sleep-until ;

basis/ui/gestures/gestures-docs.factor

@@ -30,13 +30,13 @@ HELP: motion
 { $examples { $code "T{ motion }" } } ;
 
 HELP: drag
-{ $class-description "Mouse drag gesture. The " { $link drag-# } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
+{ $class-description "Mouse drag gesture. The " { $snippet "#" } " slot is either set to a mouse button number, or " { $link f } " indicating no specific button is expected." } ;
 
 HELP: button-up
 { $class-description "Mouse button up gesture. Instances have two slots:"
     { $list
-        { { $link button-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
-        { { $link button-up-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
+        { { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+        { { $snippet "#" } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
     }
 }
 { $examples { $code "T{ button-up f f 1 }" "T{ button-up }" } } ;
@@ -44,8 +44,8 @@ HELP: button-up
 HELP: button-down
 { $class-description "Mouse button down gesture. Instances have two slots:"
     { $list
-        { { $link button-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
-        { { $link button-down-# } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
+        { { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+        { { $snippet "#" } " - a mouse button number, or " { $link f } " indicating no specific button is expected" }
     }
 }
 { $examples { $code "T{ button-down f f 1 }" "T{ button-down }" } } ;
@@ -109,8 +109,8 @@ HELP: S+
 HELP: key-down
 { $class-description "Key down gesture. Instances have two slots:"
     { $list
-        { { $link key-down-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
-    { { $link key-down-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
+        { { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+    { { $snippet "sym" } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
     }
 }
 { $examples { $code "T{ key-down f { C+ } \"a\" }" "T{ key-down f f \"TAB\" }" } } ;
@@ -118,8 +118,8 @@ HELP: key-down
 HELP: key-up
 { $class-description "Key up gesture. Instances have two slots:"
     { $list
-        { { $link key-up-mods } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
-    { { $link key-up-sym } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
+        { { $snippet "mods" } " - a sequence of modifiers; see " { $link "keyboard-gestures" } }
+    { { $snippet "sym" } " - a string denoting the key pressed; see " { $link "keyboard-gestures" } }
     }
 }
 { $examples { $code "T{ key-up f { C+ } \"a\" }" "T{ key-up f f \"TAB\" }" } } ;

basis/ui/gestures/gestures.factor

@@ -226,14 +226,14 @@ SYMBOL: drag-timer
 : send-button-down ( gesture loc world -- )
     move-hand
     start-drag-timer
-    dup button-down-#
+    dup #>>
     dup update-click# hand-buttons get-global push
     update-clicked
     button-gesture ;
 
 : send-button-up ( gesture loc world -- )
     move-hand
-    dup button-up-# hand-buttons get-global delete
+    dup #>> hand-buttons get-global delete
     stop-drag-timer
     button-gesture ;
 
@@ -261,21 +261,21 @@ GENERIC: gesture>string ( gesture -- string/f )
     [ name>> ] map concat >string ;
 
 M: key-down gesture>string
-    dup key-down-mods modifiers>string
-    swap key-down-sym append ;
+    dup mods>> modifiers>string
+    swap sym>> append ;
 
 M: button-up gesture>string
     [
-        dup button-up-mods modifiers>string %
+        dup mods>> modifiers>string %
         "Click Button" %
-        button-up-# [ " " % # ] when*
+        #>> [ " " % # ] when*
     ] "" make ;
 
 M: button-down gesture>string
     [
-        dup button-down-mods modifiers>string %
+        dup mods>> modifiers>string %
         "Press Button" %
-        button-down-# [ " " % # ] when*
+        #>> [ " " % # ] when*
     ] "" make ;
 
 M: left-action gesture>string drop "Swipe left" ;

basis/ui/operations/operations-docs.factor

@@ -22,11 +22,11 @@ HELP: operation
 $nl
 "Operations have the following slots:"
 { $list
-    { { $link operation-predicate } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
-    { { $link operation-command } " - a " { $link word } }
-    { { $link operation-translator } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
-    { { $link operation-hook } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
-    { { $link operation-listener? } " - a boolean" }
+    { { $snippet "predicate" } " - a quotation with stack effect " { $snippet "( obj -- ? )" } }
+    { { $snippet "command" } " - a " { $link word } }
+    { { $snippet "translator" } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
+    { { $snippet "hook" } " - a quotation with stack effect " { $snippet "( obj -- newobj )" } ", or " { $link f } }
+    { { $snippet "listener?" } " - a boolean" }
 } } ;
 
 HELP: operation-gesture
@@ -38,7 +38,7 @@ HELP: operations
 
 HELP: object-operations
 { $values { "obj" object } { "operations" "a sequence of " { $link operation } " instances" } }
-{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $link operation-predicate } " quotation in turn." } ;
+{ $description "Outputs a sequence of operations applicable to the given object, by testing each defined operation's " { $snippet "predicate" } " quotation in turn." } ;
 
 HELP: primary-operation
 { $values { "obj" object } { "operation" "an " { $link operation  } " or " { $link f } } }

basis/ui/operations/operations.factor

@@ -19,34 +19,34 @@ TUPLE: operation predicate command translator hook listener? ;
         swap >>predicate ;
 
 PREDICATE: listener-operation < operation
-    dup operation-command listener-command?
-    swap operation-listener? or ;
+    dup command>> listener-command?
+    swap listener?>> or ;
 
 M: operation command-name
-    operation-command command-name ;
+    command>> command-name ;
 
 M: operation command-description
-    operation-command command-description ;
+    command>> command-description ;
 
-M: operation command-word operation-command command-word ;
+M: operation command-word command>> command-word ;
 
 : operation-gesture ( operation -- gesture )
-    operation-command +keyboard+ word-prop ;
+    command>> +keyboard+ word-prop ;
 
 SYMBOL: operations
 
 : object-operations ( obj -- operations )
-    operations get [ operation-predicate call ] with filter ;
+    operations get [ predicate>> call ] with filter ;
 
 : find-operation ( obj quot -- command )
     >r object-operations r> find-last nip ; inline
 
 : primary-operation ( obj -- operation )
-    [ operation-command +primary+ word-prop ] find-operation ;
+    [ command>> +primary+ word-prop ] find-operation ;
 
 : secondary-operation ( obj -- operation )
     dup
-    [ operation-command +secondary+ word-prop ] find-operation
+    [ command>> +secondary+ word-prop ] find-operation
     [ ] [ primary-operation ] ?if ;
 
 : default-flags ( -- assoc )
@@ -59,9 +59,9 @@ SYMBOL: operations
 
 : modify-operation ( hook translator operation -- operation )
     clone
-    tuck set-operation-translator
-    tuck set-operation-hook
-    t over set-operation-listener? ;
+    tuck (>>translator)
+    tuck (>>hook)
+    t over (>>listener?) ;
 
 : modify-operations ( operations hook translator -- operations )
     rot [ >r 2dup r> modify-operation ] map 2nip ;
@@ -76,9 +76,9 @@ SYMBOL: operations
 : operation-quot ( target command -- quot )
     [
         swap literalize ,
-        dup operation-translator %
-        operation-command ,
+        dup translator>> %
+        command>> ,
     ] [ ] make ;
 
 M: operation invoke-command ( target command -- )
-    [ operation-hook call ] keep operation-quot call ;
+    [ hook>> call ] keep operation-quot call ;

basis/ui/tools/listener/listener.factor

@@ -64,7 +64,7 @@ M: listener-command invoke-command ( target command -- )
     command-quot call-listener ;
 
 M: listener-operation invoke-command ( target command -- )
-    [ operation-hook call ] keep operation-quot call-listener ;
+    [ hook>> call ] keep operation-quot call-listener ;
 
 : eval-listener ( string -- )
     get-workspace

extra/obj/examples/todo/todo.factor

@@ -0,0 +1,83 @@
+
+USING: kernel sequences sets combinators.cleave
+       obj obj.view obj.util obj.print ;
+
+IN: obj.examples.todo
+
+SYM: person types adjoin
+SYM: todo   types adjoin
+
+SYM: owners properties adjoin
+SYM: eta    properties adjoin
+SYM: notes  properties adjoin
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYM: slava { type person } define-object
+SYM: doug  { type person } define-object
+SYM: ed    { type person } define-object
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+SYM: compiler-bugs
+  {
+    type todo
+    owners { slava }
+    notes  {
+             "Investitage FEP on Terrorist"
+             "Problem with cutler in VirtualBox?"
+           }
+  }
+define-object
+
+SYM: remove-old-accessors-from-core
+  {
+    type todo
+    owners { slava }
+  }
+define-object
+
+SYM: move-db-and-web-framework-to-basis
+  {
+   type todo
+   owners { slava }
+  }
+define-object
+
+SYM: remove-old-accessors-from-basis
+  {
+    type todo
+    owners { doug ed }
+  }
+define-object
+
+SYM: blas-on-bsd
+  {
+    type todo
+    owners { slava doug }
+  }
+define-object
+
+SYM: multi-methods-backend
+  {
+    type todo
+    owners { slava }
+  }
+define-object
+
+SYM: update-core-for-multi-methods { type todo owners { slava } } define-object
+SYM: update-basis-for-multi-methods { type todo } define-object
+SYM: update-extra-for-multi-methods { type todo } define-object
+
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: todo-list ( -- )
+  objects [ type -> todo = ] filter
+    [ { [ self -> ] [ owners -> ] [ eta -> ] } 1arr ]
+  map
+  { "ITEM" "OWNERS" "ETA" } prefix
+  print-table ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+

extra/obj/view/view.factor

@@ -40,7 +40,13 @@ PREDICATE: obj-list < word \ objects = ;
 
 M: obj-list article-title ( objects -- title ) drop "Objects" ;
 
+! M: obj-list article-content ( objects -- title )
+!    execute
+!    [ [ type -> ] [ ] bi 2array ] map
+!    { $tab , } bake ;
+
 M: obj-list article-content ( objects -- title )
-   execute
+   drop
+   objects
    [ [ type -> ] [ ] bi 2array ] map
    { $tab , } bake ;