From 7025ebd7ee5f856751af7b205195fd828e808f91 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 20:19:16 -0500
Subject: [PATCH 01/16] docs
---
basis/calendar/calendar-docs.factor | 68 ++++++++++++++++++++++++++++-
basis/calendar/calendar.factor | 1 -
2 files changed, 67 insertions(+), 2 deletions(-)
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index 2c23ae95c1..d3bfa7bcb1 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/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,69 @@ 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"
+ }
+} ;
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index d9284573c4..36b3cf3250 100755
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -395,7 +395,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 ;
From 261fc87dca04101790b2148ef8edd6df1fde9fda Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 21:20:56 -0500
Subject: [PATCH 02/16] wtf instant was MEMO: oops. docs
---
basis/calendar/calendar-docs.factor | 40 +++++++++++++++++++++++++++++
basis/calendar/calendar.factor | 9 +++----
2 files changed, 44 insertions(+), 5 deletions(-)
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index d3bfa7bcb1..8ee104d16e 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -250,6 +250,7 @@ HELP: dt>seconds
"360"
}
} ;
+
HELP: dt>milliseconds
{ $values { "duration" duration } { "x" number } }
{ $description "Calculates the length of a duration in milliseconds." }
@@ -259,3 +260,42 @@ HELP: 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"
+ }
+} ;
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 36b3cf3250..ff002bb16c 100755
--- a/basis/calendar/calendar.factor
+++ b/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
From 683993c94786155e363bd70b3e6ec17b60c2698f Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 31 Aug 2008 21:24:58 -0500
Subject: [PATCH 03/16] obj.view: Add workaround so that 'article-content'
method doesn't call 'execute'
---
extra/obj/view/view.factor | 8 +++++++-
1 file changed, 7 insertions(+), 1 deletion(-)
diff --git a/extra/obj/view/view.factor b/extra/obj/view/view.factor
index 6b3249f057..cf5ca33745 100644
--- a/extra/obj/view/view.factor
+++ b/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 ;
\ No newline at end of file
From 768b97aa6660562e771e6aa7abf7a08d4375e4a9 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 31 Aug 2008 22:07:22 -0500
Subject: [PATCH 04/16] obj.examples.todo: Use the 'obj' system as a todo list
---
extra/obj/examples/todo/todo.factor | 83 +++++++++++++++++++++++++++++
1 file changed, 83 insertions(+)
create mode 100644 extra/obj/examples/todo/todo.factor
diff --git a/extra/obj/examples/todo/todo.factor b/extra/obj/examples/todo/todo.factor
new file mode 100644
index 0000000000..3d545479e9
--- /dev/null
+++ b/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 ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
From 401597a387add5b52111d1dd954d6250ee2b2688 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 31 Aug 2008 23:35:32 -0500
Subject: [PATCH 05/16] Update old accessors from 'ui.gestures'
---
basis/ui/gestures/gestures-docs.factor | 18 +++++++++---------
basis/ui/gestures/gestures.factor | 16 ++++++++--------
2 files changed, 17 insertions(+), 17 deletions(-)
diff --git a/basis/ui/gestures/gestures-docs.factor b/basis/ui/gestures/gestures-docs.factor
index bcf7eb5ca8..0575ff17f0 100644
--- a/basis/ui/gestures/gestures-docs.factor
+++ b/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\" }" } } ;
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 95417ac71f..6b53d25ea1 100755
--- a/basis/ui/gestures/gestures.factor
+++ b/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" ;
From 61e5729cdbbe2ea87d0e842e74aa4fe399b01caa Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 31 Aug 2008 23:53:07 -0500
Subject: [PATCH 06/16] Update old accessors from 'ui.operations'
---
basis/ui/operations/operations-docs.factor | 12 ++++-----
basis/ui/operations/operations.factor | 30 +++++++++++-----------
basis/ui/tools/listener/listener.factor | 2 +-
3 files changed, 22 insertions(+), 22 deletions(-)
diff --git a/basis/ui/operations/operations-docs.factor b/basis/ui/operations/operations-docs.factor
index 5f7ed60f38..ebdf3eee1f 100644
--- a/basis/ui/operations/operations-docs.factor
+++ b/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 } } }
diff --git a/basis/ui/operations/operations.factor b/basis/ui/operations/operations.factor
index 5a47f9e80b..8b4817dcac 100755
--- a/basis/ui/operations/operations.factor
+++ b/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 ;
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 1ae99b800d..2dee1ba4a9 100755
--- a/basis/ui/tools/listener/listener.factor
+++ b/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
From 8fed0d29eb4b03c0942e02a199c5f6df1f770797 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Mon, 1 Sep 2008 02:04:42 -0500
Subject: [PATCH 07/16] Fix dead code elimination with alien nodes
---
basis/compiler/tests/alien.factor | 7 +++++
.../tree/dead-code/simple/simple.factor | 30 +++++++++++--------
2 files changed, 25 insertions(+), 12 deletions(-)
mode change 100644 => 100755 basis/compiler/tests/alien.factor
mode change 100644 => 100755 basis/compiler/tree/dead-code/simple/simple.factor
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
old mode 100644
new mode 100755
index 9d2b43c1df..f2a2255949
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -84,6 +84,13 @@ FUNCTION: tiny ffi_test_17 int x ;
[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test
+: indirect-test-1' ( ptr -- )
+ "int" { } "cdecl" alien-indirect drop ;
+
+{ 1 0 } [ indirect-test-1' ] must-infer-as
+
+[ ] [ "ffi_test_1" f dlsym indirect-test-1' ] unit-test
+
[ -1 indirect-test-1 ] must-fail
: indirect-test-2 ( x y ptr -- result )
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
old mode 100644
new mode 100755
index 3ea9139e5f..9ebf064f79
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -81,11 +81,19 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
drop-values
] ;
-: drop-dead-outputs ( node -- nodes )
+: drop-dead-outputs ( node -- #shuffle )
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
+: some-outputs-dead? ( #call -- ? )
+ out-d>> [ live-value? not ] contains? ;
+
+: maybe-drop-dead-outputs ( node -- nodes )
+ dup some-outputs-dead? [
+ dup drop-dead-outputs 2array
+ ] when ;
+
M: #introduce remove-dead-code* ( #introduce -- nodes )
- dup drop-dead-outputs 2array ;
+ maybe-drop-dead-outputs ;
M: #>r remove-dead-code*
[ filter-live ] change-out-r
@@ -110,17 +118,9 @@ M: #push remove-dead-code*
[ in-d>> #drop remove-dead-code* ]
bi ;
-: some-outputs-dead? ( #call -- ? )
- out-d>> [ live-value? not ] contains? ;
-
M: #call remove-dead-code*
- dup dead-flushable-call? [
- remove-flushable-call
- ] [
- dup some-outputs-dead? [
- dup drop-dead-outputs 2array
- ] when
- ] if ;
+ dup dead-flushable-call?
+ [ remove-flushable-call ] [ maybe-drop-dead-outputs ] if ;
M: #shuffle remove-dead-code*
[ filter-live ] change-in-d
@@ -136,3 +136,9 @@ M: #copy remove-dead-code*
M: #terminate remove-dead-code*
[ filter-live ] change-in-d
[ filter-live ] change-in-r ;
+
+M: #alien-invoke remove-dead-code*
+ maybe-drop-dead-outputs ;
+
+M: #alien-indirect remove-dead-code*
+ maybe-drop-dead-outputs ;
From 9a5f3cd606d1ca10b02dd2cd15ed4843199c1842 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 02:45:20 -0500
Subject: [PATCH 08/16] Don't strip superclass prop
---
basis/tools/deploy/shaker/shaker.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 5e888cd871..36fe015611 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -136,7 +136,6 @@ IN: tools.deploy.shaker
"specializer"
"step-into"
"step-into?"
- "superclass"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"
From 41fa05a639fb23aefbe498b9b215f52f4fc80ecc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 02:52:25 -0500
Subject: [PATCH 09/16] Fix recent visual regression
---
basis/ui/gadgets/buttons/buttons.factor | 11 ++++++++---
1 file changed, 8 insertions(+), 3 deletions(-)
diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor
index b5e8e8a1e1..a079781d69 100755
--- a/basis/ui/gadgets/buttons/buttons.factor
+++ b/basis/ui/gadgets/buttons/buttons.factor
@@ -67,9 +67,12 @@ M: button-paint draw-interior
M: button-paint draw-boundary
button-paint draw-boundary ;
+: align-left ( button -- button )
+ { 0 1/2 } >>align ; inline
+
: roll-button-theme ( button -- button )
f black <solid> dup f <button-paint> >>boundary
- { 0 1/2 } >>align ; inline
+ align-left ; inline
: <roll-button> ( label quot -- button )
<button> roll-button-theme ;
@@ -141,7 +144,8 @@ TUPLE: checkbox < button ;
<checkmark> label-on-right checkbox-theme
[ model>> toggle-model ]
checkbox new-button
- swap >>model ;
+ swap >>model
+ align-left ;
M: checkbox model-changed
swap model-value over (>>selected?) relayout-1 ;
@@ -179,7 +183,8 @@ TUPLE: radio-control < button value ;
[ [ value>> ] keep set-control-value ]
radio-control new-button
swap >>model
- swap >>value ; inline
+ swap >>value
+ align-left ; inline
M: radio-control model-changed
swap model-value
From a50cb4c21be892ef032fb5a45033951f3bd87e76 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 02:53:20 -0500
Subject: [PATCH 10/16] Deploy descriptor for spheres
---
extra/spheres/deploy.factor | 15 +++++++++++++++
1 file changed, 15 insertions(+)
create mode 100644 extra/spheres/deploy.factor
diff --git a/extra/spheres/deploy.factor b/extra/spheres/deploy.factor
new file mode 100644
index 0000000000..0eeef1e3b7
--- /dev/null
+++ b/extra/spheres/deploy.factor
@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+ { deploy-reflection 1 }
+ { deploy-random? t }
+ { deploy-word-defs? f }
+ { deploy-word-props? f }
+ { deploy-name "Spheres" }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-io 1 }
+ { deploy-threads? t }
+ { "stop-after-last-window?" t }
+ { deploy-ui? t }
+ { deploy-c-types? f }
+}
From f47eb29b51d73680b0f3d43e669fcad6dbeed1fb Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 1 Sep 2008 03:27:31 -0500
Subject: [PATCH 11/16] Update old accessors from 'ui.render'
---
basis/ui/render/render-docs.factor | 8 ++++----
basis/ui/render/render.factor | 6 +++---
2 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/basis/ui/render/render-docs.factor b/basis/ui/render/render-docs.factor
index 04b623672d..fc16ed9345 100755
--- a/basis/ui/render/render-docs.factor
+++ b/basis/ui/render/render-docs.factor
@@ -38,16 +38,16 @@ HELP: draw-boundary
{ $contract "Draws the boundary of a gadget by making OpenGL calls. The " { $snippet "boundary" } " slot may be set to objects implementing this generic word." } ;
HELP: solid
-{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $link solid-color } " slot stores a color specifier." } ;
+{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid fill, respectively. The " { $snippet "color" } " slot stores a color specifier." } ;
HELP: gradient
-{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $link gradient-colors } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ;
+{ $class-description "A class implementing the " { $link draw-interior } " generic word to draw a smoothly shaded transition between colors. The " { $snippet "colors" } " slot stores a sequence of color specifiers and the gradient is drawn in the direction given by the " { $snippet "orientation" } " slot of the gadget." } ;
HELP: polygon
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"
{ $list
- { { $link polygon-color } " - a color specifier" }
- { { $link polygon-points } " - a sequence of points" }
+ { { $snippet "color" } " - a color specifier" }
+ { { $snippet "points" } " - a sequence of points" }
}
} ;
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index a4bb353d1b..2147fc2b53 100644
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -95,7 +95,7 @@ C: <solid> solid
! Solid pen
: (solid) ( gadget paint -- loc dim )
- solid-color set-color rect-dim >r origin get dup r> v+ ;
+ color>> set-color rect-dim >r origin get dup r> v+ ;
M: solid draw-interior (solid) gl-fill-rect ;
@@ -109,7 +109,7 @@ C: <gradient> gradient
M: gradient draw-interior
origin get [
over orientation>>
- swap gradient-colors
+ swap colors>>
rot rect-dim
gl-gradient
] with-translation ;
@@ -121,7 +121,7 @@ C: <polygon> polygon
: draw-polygon ( polygon quot -- )
origin get [
- >r dup polygon-color set-color polygon-points r> call
+ >r dup color>> set-color points>> r> call
] with-translation ; inline
M: polygon draw-boundary
From c570085151ec1667d5ac5dc24b171c362bdd9b60 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 1 Sep 2008 03:40:31 -0500
Subject: [PATCH 12/16] Update old accessors from ui.tools.*
---
basis/ui/tools/debugger/debugger.factor | 2 +-
basis/ui/tools/deploy/deploy.factor | 4 ++--
basis/ui/tools/inspector/inspector.factor | 2 +-
basis/ui/tools/interactor/interactor.factor | 2 +-
basis/ui/tools/listener/listener.factor | 8 ++++----
basis/ui/tools/profiler/profiler.factor | 2 +-
basis/ui/tools/search/search.factor | 12 ++++++------
basis/ui/tools/tools.factor | 2 +-
basis/ui/tools/walker/walker.factor | 2 +-
basis/ui/tools/workspace/workspace.factor | 6 +++---
10 files changed, 21 insertions(+), 21 deletions(-)
diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index 5a3ad01d2e..4ba4374bb8 100644
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/basis/ui/tools/debugger/debugger.factor
@@ -29,7 +29,7 @@ TUPLE: debugger < track restarts ;
-rot <restart-list> >>restarts
dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
-M: debugger focusable-child* debugger-restarts ;
+M: debugger focusable-child* restarts>> ;
: debugger-window ( error -- )
#! No restarts for the debugger window
diff --git a/basis/ui/tools/deploy/deploy.factor b/basis/ui/tools/deploy/deploy.factor
index b68e5162a3..285757e390 100755
--- a/basis/ui/tools/deploy/deploy.factor
+++ b/basis/ui/tools/deploy/deploy.factor
@@ -65,13 +65,13 @@ TUPLE: deploy-gadget < pack vocab settings ;
[ deploy-gadget? ] find-parent ;
: find-deploy-vocab ( gadget -- vocab )
- find-deploy-gadget deploy-gadget-vocab ;
+ find-deploy-gadget vocab>> ;
: find-deploy-config ( gadget -- config )
find-deploy-vocab deploy-config ;
: find-deploy-settings ( gadget -- settings )
- find-deploy-gadget deploy-gadget-settings ;
+ find-deploy-gadget settings>> ;
: com-revert ( gadget -- )
dup find-deploy-config
diff --git a/basis/ui/tools/inspector/inspector.factor b/basis/ui/tools/inspector/inspector.factor
index bb0f02ec7e..273d6bc549 100644
--- a/basis/ui/tools/inspector/inspector.factor
+++ b/basis/ui/tools/inspector/inspector.factor
@@ -47,4 +47,4 @@ inspector-gadget "multi-touch" f {
} define-command-map
M: inspector-gadget tool-scroller
- inspector-gadget-pane find-scroller ;
+ pane>> find-scroller ;
diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor
index 20428a39b6..39f10f42ae 100755
--- a/basis/ui/tools/interactor/interactor.factor
+++ b/basis/ui/tools/interactor/interactor.factor
@@ -76,7 +76,7 @@ M: interactor model-changed
] with-output-stream* ;
: add-interactor-history ( str interactor -- )
- over empty? [ 2drop ] [ interactor-history adjoin ] if ;
+ over empty? [ 2drop ] [ history>> adjoin ] if ;
: interactor-continue ( obj interactor -- )
mailbox>> mailbox-put ;
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 2dee1ba4a9..683eff9457 100755
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -110,7 +110,7 @@ M: engine-word word-completion-string
] [ 2drop ] if ;
: insert-word ( word -- )
- get-workspace workspace-listener input>>
+ get-workspace listener>> input>>
[ >r word-completion-string r> user-input ]
[ interactor-use use-if-necessary ]
2bi ;
@@ -131,10 +131,10 @@ TUPLE: stack-display < track ;
1 track-add ;
M: stack-display tool-scroller
- find-workspace workspace-listener tool-scroller ;
+ find-workspace listener>> tool-scroller ;
: ui-listener-hook ( listener -- )
- >r datastack r> listener-gadget-stack set-model ;
+ >r datastack r> stack>> set-model ;
: ui-error-hook ( error listener -- )
find-workspace debugger-popup ;
@@ -168,7 +168,7 @@ M: stack-display tool-scroller
} cleave ;
: init-listener ( listener -- )
- f <model> swap set-listener-gadget-stack ;
+ f <model> swap (>>stack) ;
: <listener-gadget> ( -- gadget )
{ 0 1 } listener-gadget new-track
diff --git a/basis/ui/tools/profiler/profiler.factor b/basis/ui/tools/profiler/profiler.factor
index f440bd8766..462af87574 100755
--- a/basis/ui/tools/profiler/profiler.factor
+++ b/basis/ui/tools/profiler/profiler.factor
@@ -14,7 +14,7 @@ TUPLE: profiler-gadget < track pane ;
dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- )
- >r profiler-gadget-pane r> with-pane ;
+ >r pane>> r> with-pane ;
: com-full-profile ( gadget -- )
[ profile. ] with-profiler-pane ;
diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
index 89f238b574..5237813fe0 100755
--- a/basis/ui/tools/search/search.factor
+++ b/basis/ui/tools/search/search.factor
@@ -14,7 +14,7 @@ IN: ui.tools.search
TUPLE: live-search < track field list ;
: search-value ( live-search -- value )
- live-search-list list-value ;
+ list>> list-value ;
: search-gesture ( gesture live-search -- operation/f )
search-value object-operations
@@ -32,7 +32,7 @@ M: live-search handle-gesture ( gesture live-search -- ? )
[ live-search? ] find-parent ;
: find-search-list ( gadget -- list )
- find-live-search live-search-list ;
+ find-live-search list>> ;
TUPLE: search-field < editor ;
@@ -70,12 +70,12 @@ search-field H{
over field>> set-editor-string
dup field>> end-of-document ;
-M: live-search focusable-child* live-search-field ;
+M: live-search focusable-child* field>> ;
M: live-search pref-dim* drop { 400 200 } ;
: current-word ( workspace -- string )
- workspace-listener listener-gadget-input selected-word ;
+ listener>> input>> selected-word ;
: definition-candidates ( words -- candidates )
[ dup synopsis >lower ] { } map>assoc sort-values ;
@@ -149,10 +149,10 @@ M: live-search pref-dim* drop { 400 200 } ;
f [ string>> ] <live-search> ;
: listener-history ( listener -- seq )
- listener-gadget-input interactor-history <reversed> ;
+ input>> history>> <reversed> ;
: com-history ( workspace -- )
- "" over workspace-listener listener-history <history-search>
+ "" over listener>> listener-history <history-search>
"History search" show-titled-popup ;
workspace "toolbar" f {
diff --git a/basis/ui/tools/tools.factor b/basis/ui/tools/tools.factor
index a437c2dbb6..21fa44b593 100755
--- a/basis/ui/tools/tools.factor
+++ b/basis/ui/tools/tools.factor
@@ -54,7 +54,7 @@ IN: ui.tools
M: workspace model-changed
nip
- dup workspace-listener listener-gadget-output scroll>bottom
+ dup listener>> output>> scroll>bottom
dup resize-workspace
request-focus ;
diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor
index 767be92687..51091c576d 100755
--- a/basis/ui/tools/walker/walker.factor
+++ b/basis/ui/tools/walker/walker.factor
@@ -84,7 +84,7 @@ walker-gadget "toolbar" f {
: walker-for-thread? ( thread gadget -- ? )
{
{ [ dup walker-gadget? not ] [ 2drop f ] }
- { [ dup walker-gadget-closing? ] [ 2drop f ] }
+ { [ dup closing?>> ] [ 2drop f ] }
[ thread>> eq? ]
} cond ;
diff --git a/basis/ui/tools/workspace/workspace.factor b/basis/ui/tools/workspace/workspace.factor
index bc758e9eb8..ab6b3fe1cf 100755
--- a/basis/ui/tools/workspace/workspace.factor
+++ b/basis/ui/tools/workspace/workspace.factor
@@ -29,7 +29,7 @@ M: gadget tool-scroller drop f ;
book>> children>> [ class eq? ] with find ;
: show-tool ( class workspace -- tool )
- [ find-tool swap ] keep workspace-book model>>
+ [ find-tool swap ] keep book>> model>>
set-model ;
: select-tool ( workspace class -- ) swap show-tool drop ;
@@ -81,10 +81,10 @@ SYMBOL: workspace-dim
M: workspace pref-dim* drop workspace-dim get ;
M: workspace focusable-child*
- dup workspace-popup [ ] [ workspace-listener ] ?if ;
+ dup popup>> [ ] [ listener>> ] ?if ;
: workspace-page ( workspace -- gadget )
- workspace-book current-page ;
+ book>> current-page ;
M: workspace tool-scroller ( workspace -- scroller )
workspace-page tool-scroller ;
From b821bcf8a352be42efeda9ff428f92e1242e452b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 04:15:01 -0500
Subject: [PATCH 13/16] Fixing help unit test which was clobbering help lint
---
basis/help/lint/lint.factor | 14 ++++++--------
basis/help/topics/topics-tests.factor | 2 +-
2 files changed, 7 insertions(+), 9 deletions(-)
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 14d3420a68..b12dcaa807 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors sequences parser kernel help help.markup
+USING: fry accessors sequences parser kernel help help.markup
help.topics words strings classes tools.vocabs namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators combinators.short-circuit splitting debugger
@@ -39,7 +39,7 @@ IN: help.lint
$predicate
$class-description
$error-description
- } swap [ elements f like ] curry contains? ;
+ } swap '[ , elements empty? not ] contains? ;
: check-values ( word element -- )
{
@@ -108,12 +108,10 @@ M: help-error error.
articles get keys
vocabs [ dup vocab-docs-path swap ] H{ } map>assoc
H{ } clone [
- [
- [ dup >link where dup ] 2dip
- [ >r >r first r> at r> push-at ] 2curry
- [ 2drop ]
- if
- ] 2curry each
+ '[
+ dup >link where dup
+ [ first , at , push-at ] [ 2drop ] if
+ ] each
] keep ;
: check-about ( vocab -- )
diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor
index 699b2d398a..f53bdee9c7 100644
--- a/basis/help/topics/topics-tests.factor
+++ b/basis/help/topics/topics-tests.factor
@@ -16,7 +16,7 @@ IN: help.topics.tests
SYMBOL: foo
-[ ] [ { "test" "a" } "Test A" { { $subsection foo } } <article> add-article ] unit-test
+[ ] [ "Test A" { { $subsection foo } } <article> { "test" "a" } add-article ] unit-test
! Test article location recording
From 8bf37558d42a1573650b4fa24c5c72b60675f760 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 04:32:16 -0500
Subject: [PATCH 14/16] Clean up Windows I/O a bit, remove classes.tuple.lib
---
basis/io/windows/launcher/launcher.factor | 16 ++-
basis/io/windows/nt/backend/backend.factor | 5 +-
basis/io/windows/nt/sockets/sockets.factor | 155 +++++++++++++--------
extra/classes/tuple/lib/authors.txt | 1 -
extra/classes/tuple/lib/lib-docs.factor | 29 ----
extra/classes/tuple/lib/lib-tests.factor | 8 --
extra/classes/tuple/lib/lib.factor | 18 ---
7 files changed, 112 insertions(+), 120 deletions(-)
delete mode 100644 extra/classes/tuple/lib/authors.txt
delete mode 100644 extra/classes/tuple/lib/lib-docs.factor
delete mode 100644 extra/classes/tuple/lib/lib-tests.factor
delete mode 100755 extra/classes/tuple/lib/lib.factor
diff --git a/basis/io/windows/launcher/launcher.factor b/basis/io/windows/launcher/launcher.factor
index 9442fa9a72..ed9b53675b 100755
--- a/basis/io/windows/launcher/launcher.factor
+++ b/basis/io/windows/launcher/launcher.factor
@@ -6,7 +6,7 @@ windows.types math windows.kernel32
namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators
io.backend accessors concurrency.flags io.files assocs
-io.files.private windows destructors classes.tuple.lib ;
+io.files.private windows destructors ;
IN: io.windows.launcher
TUPLE: CreateProcess-args
@@ -30,7 +30,19 @@ TUPLE: CreateProcess-args
0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- )
- CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
+ {
+ [ lpApplicationName>> ]
+ [ lpCommandLine>> ]
+ [ lpProcessAttributes>> ]
+ [ lpThreadAttributes>> ]
+ [ bInheritHandles>> ]
+ [ dwCreateFlags>> ]
+ [ lpEnvironment>> ]
+ [ lpCurrentDirectory>> ]
+ [ lpStartupInfo>> ]
+ [ lpProcessInformation>> ]
+ } cleave
+ CreateProcess win32-error=0/f ;
: count-trailing-backslashes ( str n -- str n )
>r "\\" ?tail r> swap [
diff --git a/basis/io/windows/nt/backend/backend.factor b/basis/io/windows/nt/backend/backend.factor
index e9df2ddab9..7fbc1dbcf9 100755
--- a/basis/io/windows/nt/backend/backend.factor
+++ b/basis/io/windows/nt/backend/backend.factor
@@ -1,9 +1,8 @@
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.ports io.timeouts
io.windows io.windows.files libc kernel math namespaces
-sequences threads classes.tuple.lib windows windows.errors
-windows.kernel32 strings splitting io.files
-io.buffers qualified ascii system
+sequences threads windows windows.errors windows.kernel32
+strings splitting io.files io.buffers qualified ascii system
accessors locals ;
QUALIFIED: windows.winsock
IN: io.windows.nt.backend
diff --git a/basis/io/windows/nt/sockets/sockets.factor b/basis/io/windows/nt/sockets/sockets.factor
index a31c41942f..41c5e88f5f 100755
--- a/basis/io/windows/nt/sockets/sockets.factor
+++ b/basis/io/windows/nt/sockets/sockets.factor
@@ -1,9 +1,8 @@
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
io.sockets io namespaces io.streams.duplex io.windows
-io.windows.sockets
-io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib system combinators accessors ;
+io.windows.sockets io.windows.nt.backend windows.winsock kernel
+libc math sequences threads system combinators accessors ;
IN: io.windows.nt.sockets
: malloc-int ( object -- object )
@@ -28,71 +27,89 @@ M: winnt WSASocket-flags ( -- DWORD )
] keep *void* ;
TUPLE: ConnectEx-args port
- s* name* namelen* lpSendBuffer* dwSendDataLength*
- lpdwBytesSent* lpOverlapped* ptr* ;
+ s name namelen lpSendBuffer dwSendDataLength
+ lpdwBytesSent lpOverlapped ptr ;
: wait-for-socket ( args -- n )
- [ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ;
+ [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
: <ConnectEx-args> ( sockaddr size -- ConnectEx )
ConnectEx-args new
- swap >>namelen*
- swap >>name*
- f >>lpSendBuffer*
- 0 >>dwSendDataLength*
- f >>lpdwBytesSent*
- (make-overlapped) >>lpOverlapped* ;
+ swap >>namelen
+ swap >>name
+ f >>lpSendBuffer
+ 0 >>dwSendDataLength
+ f >>lpdwBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
: call-ConnectEx ( ConnectEx -- )
- ConnectEx-args >tuple*<
+ {
+ [ s>> ]
+ [ name>> ]
+ [ namelen>> ]
+ [ lpSendBuffer>> ]
+ [ dwSendDataLength>> ]
+ [ lpdwBytesSent>> ]
+ [ lpOverlapped>> ]
+ [ ptr>> ]
+ } cleave
"int"
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
"stdcall" alien-indirect drop
- winsock-error-string [ throw ] when* ;
+ winsock-error-string [ throw ] when* ; inline
M: object establish-connection ( client-out remote -- )
make-sockaddr/size <ConnectEx-args>
swap >>port
- dup port>> handle>> handle>> >>s*
- dup s*>> get-ConnectEx-ptr >>ptr*
+ dup port>> handle>> handle>> >>s
+ dup s>> get-ConnectEx-ptr >>ptr
dup call-ConnectEx
wait-for-socket drop ;
TUPLE: AcceptEx-args port
- sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength*
- dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ;
+ sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
+ dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
: init-accept-buffer ( addr AcceptEx -- )
swap sockaddr-type heap-size 16 +
- [ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi
- dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer*
- drop ;
+ [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
+ dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
+ drop ; inline
: <AcceptEx-args> ( server addr -- AcceptEx )
AcceptEx-args new
2dup init-accept-buffer
- swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket*
- over handle>> handle>> >>sListenSocket*
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
+ over handle>> handle>> >>sListenSocket
swap >>port
- 0 >>dwReceiveDataLength*
- f >>lpdwBytesReceived*
- (make-overlapped) >>lpOverlapped* ;
+ 0 >>dwReceiveDataLength
+ f >>lpdwBytesReceived
+ (make-overlapped) >>lpOverlapped ; inline
: call-AcceptEx ( AcceptEx -- )
- AcceptEx-args >tuple*< AcceptEx drop
- winsock-error-string [ throw ] when* ;
+ {
+ [ sListenSocket>> ]
+ [ sAcceptSocket>> ]
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ [ lpdwBytesReceived>> ]
+ [ lpOverlapped>> ]
+ } cleave AcceptEx drop
+ winsock-error-string [ throw ] when* ; inline
: extract-remote-address ( AcceptEx -- sockaddr )
{
- [ lpOutputBuffer*>> ]
- [ dwReceiveDataLength*>> ]
- [ dwLocalAddressLength*>> ]
- [ dwRemoteAddressLength*>> ]
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
} cleave
f <void*>
0 <int>
f <void*>
- [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
+ [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
M: object (accept) ( server addr -- handle sockaddr )
[
@@ -100,39 +117,49 @@ M: object (accept) ( server addr -- handle sockaddr )
{
[ call-AcceptEx ]
[ wait-for-socket drop ]
- [ sAcceptSocket*>> <win32-socket> ]
+ [ sAcceptSocket>> <win32-socket> ]
[ extract-remote-address ]
} cleave
] with-destructors ;
TUPLE: WSARecvFrom-args port
- s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd*
- lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ;
+ s lpBuffers dwBufferCount lpNumberOfBytesRecvd
+ lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
: make-receive-buffer ( -- WSABUF )
"WSABUF" malloc-object &free
default-buffer-size get over set-WSABUF-len
- default-buffer-size get malloc &free over set-WSABUF-buf ;
+ default-buffer-size get malloc &free over set-WSABUF-buf ; inline
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new
swap >>port
- dup port>> handle>> handle>> >>s*
+ dup port>> handle>> handle>> >>s
dup port>> addr>> sockaddr-type heap-size
- [ malloc &free >>lpFrom* ]
- [ malloc-int &free >>lpFromLen* ] bi
- make-receive-buffer >>lpBuffers*
- 1 >>dwBufferCount*
- 0 malloc-int &free >>lpFlags*
- 0 malloc-int &free >>lpNumberOfBytesRecvd*
- (make-overlapped) >>lpOverlapped* ;
+ [ malloc &free >>lpFrom ]
+ [ malloc-int &free >>lpFromLen ] bi
+ make-receive-buffer >>lpBuffers
+ 1 >>dwBufferCount
+ 0 malloc-int &free >>lpFlags
+ 0 malloc-int &free >>lpNumberOfBytesRecvd
+ (make-overlapped) >>lpOverlapped ; inline
: call-WSARecvFrom ( WSARecvFrom -- )
- WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesRecvd>> ]
+ [ lpFlags>> ]
+ [ lpFrom>> ]
+ [ lpFromLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSARecvFrom socket-error* ; inline
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
- [ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
- [ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
+ [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
+ [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
[
@@ -144,31 +171,41 @@ M: winnt (receive) ( datagram -- packet addrspec )
] with-destructors ;
TUPLE: WSASendTo-args port
- s* lpBuffers* dwBufferCount* lpNumberOfBytesSent*
- dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ;
+ s lpBuffers dwBufferCount lpNumberOfBytesSent
+ dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
: make-send-buffer ( packet -- WSABUF )
"WSABUF" malloc-object &free
[ >r malloc-byte-array &free r> set-WSABUF-buf ]
[ >r length r> set-WSABUF-len ]
[ nip ]
- 2tri ;
+ 2tri ; inline
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new
swap >>port
- dup port>> handle>> handle>> >>s*
+ dup port>> handle>> handle>> >>s
swap make-sockaddr/size
>r malloc-byte-array &free
- r> [ >>lpTo* ] [ >>iToLen* ] bi*
- swap make-send-buffer >>lpBuffers*
- 1 >>dwBufferCount*
- 0 >>dwFlags*
- 0 <uint> >>lpNumberOfBytesSent*
- (make-overlapped) >>lpOverlapped* ;
+ r> [ >>lpTo ] [ >>iToLen ] bi*
+ swap make-send-buffer >>lpBuffers
+ 1 >>dwBufferCount
+ 0 >>dwFlags
+ 0 <uint> >>lpNumberOfBytesSent
+ (make-overlapped) >>lpOverlapped ; inline
: call-WSASendTo ( WSASendTo -- )
- WSASendTo-args >tuple*< WSASendTo socket-error* ;
+ {
+ [ s>> ]
+ [ lpBuffers>> ]
+ [ dwBufferCount>> ]
+ [ lpNumberOfBytesSent>> ]
+ [ dwFlags>> ]
+ [ lpTo>> ]
+ [ iToLen>> ]
+ [ lpOverlapped>> ]
+ [ lpCompletionRoutine>> ]
+ } cleave WSASendTo socket-error* ; inline
M: winnt (send) ( packet addrspec datagram -- )
[
diff --git a/extra/classes/tuple/lib/authors.txt b/extra/classes/tuple/lib/authors.txt
deleted file mode 100644
index 7c1b2f2279..0000000000
--- a/extra/classes/tuple/lib/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/classes/tuple/lib/lib-docs.factor b/extra/classes/tuple/lib/lib-docs.factor
deleted file mode 100644
index 0c4c11e46f..0000000000
--- a/extra/classes/tuple/lib/lib-docs.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-USING: help.syntax help.markup kernel prettyprint sequences ;
-IN: classes.tuple.lib
-
-HELP: >tuple<
-{ $values { "class" "a tuple class" } }
-{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
-{ $example
- "USING: kernel prettyprint classes.tuple.lib ;"
- "IN: scratchpad"
- "TUPLE: foo a b c ;"
- "1 2 3 \\ foo boa \\ foo >tuple< .s"
- "1\n2\n3"
-}
-{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
-{ $see-also >tuple*< } ;
-
-HELP: >tuple*<
-{ $values { "class" "a tuple class" } }
-{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
-{ $example
- "USING: kernel prettyprint classes.tuple.lib ;"
- "IN: scratchpad"
- "TUPLE: foo a bb* ccc dddd* ;"
- "1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
- "2\n4"
-}
-{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
-{ $see-also >tuple< } ;
-
diff --git a/extra/classes/tuple/lib/lib-tests.factor b/extra/classes/tuple/lib/lib-tests.factor
deleted file mode 100644
index 7f7f24ab56..0000000000
--- a/extra/classes/tuple/lib/lib-tests.factor
+++ /dev/null
@@ -1,8 +0,0 @@
-USING: kernel tools.test classes.tuple.lib ;
-IN: classes.tuple.lib.tests
-
-TUPLE: foo a b* c d* e f* ;
-
-[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
-[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test
-
diff --git a/extra/classes/tuple/lib/lib.factor b/extra/classes/tuple/lib/lib.factor
deleted file mode 100755
index a234ce0d41..0000000000
--- a/extra/classes/tuple/lib/lib.factor
+++ /dev/null
@@ -1,18 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel macros sequences slots words classes.tuple
-quotations combinators accessors ;
-IN: classes.tuple.lib
-
-: reader-slots ( seq -- quot )
- [ reader>> 1quotation ] map [ cleave ] curry ;
-
-MACRO: >tuple< ( class -- )
- all-slots rest-slice reader-slots ;
-
-MACRO: >tuple*< ( class -- )
- all-slots
- [ slot-spec-name "*" tail? ] filter
- reader-slots ;
-
-
From 3b24b5267352203ef443d2156ac602217f5e9245 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 1 Sep 2008 04:32:26 -0500
Subject: [PATCH 15/16] Omit default method from usage lists
---
core/generic/generic.factor | 6 +++++-
core/generic/standard/standard.factor | 4 ----
2 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 553ced5800..f2c154b3b2 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -105,6 +105,10 @@ M: method-body crossref?
drop [ <method> dup ] 2keep reveal-method
] if ;
+PREDICATE: default-method < word "default" word-prop ;
+
+M: default-method irrelevant? drop t ;
+
: <default-method> ( generic combination -- method )
[ drop object bootstrap-word swap <method> ] [ make-default-method ] 2bi
[ define ] [ drop t "default" set-word-prop ] [ drop ] 2tri ;
@@ -137,7 +141,7 @@ M: method-body definer
M: method-body forget*
dup "forgotten" word-prop [ drop ] [
[
- dup "default" word-prop [ drop ] [
+ dup default-method? [ drop ] [
[
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 503c72290a..860781e5e2 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -26,10 +26,6 @@ ERROR: no-method object generic ;
: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
-: default-method ( word -- pair )
- "default-method" word-prop
- object bootstrap-word swap 2array ;
-
: push-method ( method specializer atomic assoc -- )
[
[ H{ } clone <predicate-dispatch-engine> ] unless*
From c2d58d0d1c84aeaa2de07ff300e9020435524567 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Mon, 1 Sep 2008 07:14:43 -0500
Subject: [PATCH 16/16] ui.traverse.tests: Minor fix
---
basis/ui/traverse/traverse-tests.factor | 8 +++++---
1 file changed, 5 insertions(+), 3 deletions(-)
diff --git a/basis/ui/traverse/traverse-tests.factor b/basis/ui/traverse/traverse-tests.factor
index 5e6ac4125b..ddb0ebcd12 100755
--- a/basis/ui/traverse/traverse-tests.factor
+++ b/basis/ui/traverse/traverse-tests.factor
@@ -1,9 +1,11 @@
-IN: ui.traverse.tests
-USING: ui.gadgets ui.gadgets.labels namespaces sequences kernel
+
+USING: accessors ui.gadgets ui.gadgets.labels namespaces sequences kernel
math arrays tools.test io ui.gadgets.panes ui.traverse
definitions compiler.units ;
-M: array gadget-children ;
+IN: ui.traverse.tests
+
+M: array children>> ;
GENERIC: (flatten-tree) ( node -- )