From 15a8ff071cb9d5708fd48a1177cb2194d271cdde Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 31 Aug 2008 11:00:26 -0700 Subject: [PATCH 001/194] Load game-input backend at compile time --- extra/game-input/backend/backend.factor | 6 ++++-- extra/game-input/backend/dinput/dinput.factor | 3 ++- extra/game-input/backend/iokit/iokit.factor | 5 +++-- extra/game-input/game-input.factor | 4 +++- 4 files changed, 12 insertions(+), 6 deletions(-) diff --git a/extra/game-input/backend/backend.factor b/extra/game-input/backend/backend.factor index cfba0a52f5..df61179da7 100644 --- a/extra/game-input/backend/backend.factor +++ b/extra/game-input/backend/backend.factor @@ -2,12 +2,14 @@ USING: eval multiline system combinators ; IN: game-input.backend STRING: set-backend-for-macosx -USING: namespaces game-input.backend.iokit game-input ; +USING: namespaces parser game-input.backend.iokit ; +<< "game-input" (use+) >> iokit-game-input-backend game-input-backend set-global ; STRING: set-backend-for-windows -USING: namespaces game-input.backend.dinput game-input ; +USING: namespaces parser game-input.backend.dinput ; +<< "game-input" (use+) >> dinput-game-input-backend game-input-backend set-global ; diff --git a/extra/game-input/backend/dinput/dinput.factor b/extra/game-input/backend/dinput/dinput.factor index 73c9f511a1..116faf60cd 100755 --- a/extra/game-input/backend/dinput/dinput.factor +++ b/extra/game-input/backend/dinput/dinput.factor @@ -1,10 +1,11 @@ -USING: windows.dinput windows.dinput.constants game-input +USING: windows.dinput windows.dinput.constants parser symbols alien.c-types windows.ole32 namespaces assocs kernel arrays vectors windows.kernel32 windows.com windows.dinput shuffle windows.user32 windows.messages sequences combinators math.geometry.rect ui.windows accessors math windows alien alien.strings io.encodings.utf16 continuations byte-arrays locals game-input.backend.dinput.keys-array ; +<< "game-input" (use+) >> IN: game-input.backend.dinput SINGLETON: dinput-game-input-backend diff --git a/extra/game-input/backend/iokit/iokit.factor b/extra/game-input/backend/iokit/iokit.factor index dcdfa6d192..4a7d251425 100755 --- a/extra/game-input/backend/iokit/iokit.factor +++ b/extra/game-input/backend/iokit/iokit.factor @@ -1,9 +1,10 @@ USING: cocoa cocoa.plists core-foundation iokit iokit.hid kernel cocoa.enumeration destructors math.parser cocoa.application -sequences locals combinators.short-circuit game-input threads +sequences locals combinators.short-circuit threads symbols namespaces assocs vectors arrays combinators core-foundation.run-loop accessors sequences.private -alien.c-types math ; +alien.c-types math parser ; +<< "game-input" (use+) >> IN: game-input.backend.iokit SINGLETON: iokit-game-input-backend diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 208c8476fc..18ec04df1f 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -28,7 +28,6 @@ M: f (reset-game-input) ; PRIVATE> : open-game-input ( -- ) - load-game-input-backend game-input-opened? [ (open-game-input) game-input-opened on @@ -76,3 +75,6 @@ M: keyboard-state clone call-next-method dup keys>> clone >>keys ; HOOK: read-keyboard game-input-backend ( -- keyboard-state ) + +load-game-input-backend + From 36828477f76cfeaecde0a08fca9d88e4ab0b3457 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 15:54:00 -0500 Subject: [PATCH 002/194] more docs --- basis/calendar/calendar-docs.factor | 75 ++++++++++++++++++++++++++++- basis/calendar/calendar.factor | 52 +++++++++++--------- 2 files changed, 104 insertions(+), 23 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 734c19f045..4adf635d99 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -8,7 +8,7 @@ HELP: duration { $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers." } ; HELP: timestamp -{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } "." } ; +{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ; { timestamp duration } related-words @@ -128,3 +128,76 @@ HELP: >time< } ; { >date< >time< } related-words + +HELP: instant +{ $values { "duration" duration } } +{ $description "Pushes a " { $snippet "duration" } " of zero seconds." } ; + +HELP: years +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ year years } related-words + +HELP: months +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ month months } related-words + +HELP: days +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ day days } related-words + +HELP: weeks +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ week weeks } related-words + +HELP: hours +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ hour hours } related-words + +HELP: minutes +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ minute minutes } related-words + +HELP: seconds +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ second seconds } related-words + +HELP: milliseconds +{ $values { "x" number } { "duration" duration } } +{ $description } ; +{ millisecond milliseconds } related-words + +HELP: leap-year? +{ $values { "obj" object } { "?" "a boolean" } } +{ $description "Returns " { $link t } " if the object represents a leap year." } +{ $examples + { $example "USING: calendar prettyprint ;" + "2008 leap-year? ." + "t" + } + { $example "USING: calendar prettyprint ;" + "2010 1 1 leap-year? ." + "f" + } +} ; + +HELP: time+ +{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } } +{ $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 <=> ." + "+eq+" + } + { $example "USING: calendar math.order prettyprint ;" + "2010 1 1 3 days time+ days>> ." + "4" + } +} ; + diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index af0ced7ed2..fd99464bd3 100755 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -3,7 +3,7 @@ USING: arrays kernel math math.functions namespaces sequences strings system vocabs.loader calendar.backend threads accessors combinators locals classes.tuple math.order -memoize summary combinators.short-circuit ; +memoize summary combinators.short-circuit alias ; IN: calendar TUPLE: duration @@ -116,15 +116,23 @@ PRIVATE> : >time< ( timestamp -- hour minute second ) [ hour>> ] [ minute>> ] [ second>> ] tri ; -MEMO: instant ( -- dt ) 0 0 0 0 0 0 ; -: years ( n -- dt ) instant clone swap >>year ; -: months ( n -- dt ) instant clone swap >>month ; -: days ( n -- dt ) instant clone swap >>day ; -: weeks ( n -- dt ) 7 * days ; -: hours ( n -- dt ) instant clone swap >>hour ; -: minutes ( n -- dt ) instant clone swap >>minute ; -: seconds ( n -- dt ) instant clone swap >>second ; -: milliseconds ( n -- dt ) 1000 / seconds ; +MEMO: instant ( -- duration ) 0 0 0 0 0 0 ; +: years ( x -- duration ) instant clone swap >>year ; +: months ( x -- duration ) instant clone swap >>month ; +: days ( x -- duration ) instant clone swap >>day ; +: weeks ( x -- duration ) 7 * days ; +: hours ( x -- duration ) instant clone swap >>hour ; +: minutes ( x -- duration ) instant clone swap >>minute ; +: seconds ( x -- duration ) instant clone swap >>second ; +: milliseconds ( x -- duration ) 1000 / seconds ; +ALIAS: year years +ALIAS: month months +ALIAS: day days +ALIAS: week weeks +ALIAS: hour hours +ALIAS: minute minutes +ALIAS: second seconds +ALIAS: millisecond milliseconds GENERIC: leap-year? ( obj -- ? ) @@ -218,7 +226,7 @@ M: number +second ( timestamp n -- timestamp ) PRIVATE> -GENERIC# time+ 1 ( time dt -- time ) +GENERIC# time+ 1 ( time1 time2 -- time3 ) M: timestamp time+ >r clone r> (time+) drop ; @@ -236,8 +244,8 @@ M: duration time+ 2drop ] if ; -: dt>years ( dt -- x ) - #! Uses average month/year length since dt loses calendar +: dt>years ( duration -- x ) + #! Uses average month/year length since duration loses calendar #! data 0 swap { @@ -251,12 +259,12 @@ M: duration time+ M: duration <=> [ dt>years ] compare ; -: dt>months ( dt -- x ) dt>years months-per-year * ; -: dt>days ( dt -- x ) dt>years days-per-year * ; -: dt>hours ( dt -- x ) dt>years hours-per-year * ; -: dt>minutes ( dt -- x ) dt>years minutes-per-year * ; -: dt>seconds ( dt -- x ) dt>years seconds-per-year * ; -: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ; +: dt>months ( duration -- x ) dt>years months-per-year * ; +: dt>days ( duration -- x ) dt>years days-per-year * ; +: dt>hours ( duration -- x ) dt>years hours-per-year * ; +: dt>minutes ( duration -- x ) dt>years minutes-per-year * ; +: dt>seconds ( duration -- x ) dt>years seconds-per-year * ; +: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ; GENERIC: time- ( time1 time2 -- time ) @@ -296,7 +304,7 @@ M: timestamp time- } 2cleave ] if ; -: before ( dt -- -dt ) +: before ( duration -- -duration ) -1 time* ; M: duration time- @@ -324,8 +332,8 @@ MEMO: unix-1970 ( -- timestamp ) : now ( -- timestamp ) gmt >local-time ; -: hence ( dt -- timestamp ) now swap time+ ; -: ago ( dt -- timestamp ) now swap 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 From 610a70c3d280d7cfb81782c09f6d05dba1accd71 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 15:58:12 -0500 Subject: [PATCH 003/194] fix docs --- basis/calendar/calendar-docs.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 4adf635d99..5ff3ef6cc1 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math strings help.markup help.syntax -calendar.backend ; +calendar.backend math.order ; IN: calendar HELP: duration -{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers." } ; +{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two timestamps with the " { $link <=> } " word." } ; HELP: timestamp { $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ; @@ -195,8 +195,8 @@ HELP: time+ "10 months 2 months time+ 1 year <=> ." "+eq+" } - { $example "USING: calendar math.order prettyprint ;" - "2010 1 1 3 days time+ days>> ." + { $example "USING: accessors calendar math.order prettyprint ;" + "2010 1 1 3 days time+ day>> ." "4" } } ; From 31c5e57ab270604053c614209414a78c7d875fd9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 16:17:46 -0500 Subject: [PATCH 004/194] new accessors --- basis/ui/tools/browser/browser.factor | 6 +++--- basis/ui/tools/debugger/debugger.factor | 2 +- basis/ui/tools/search/search.factor | 4 ++-- basis/ui/tools/traceback/traceback.factor | 8 ++++---- basis/ui/tools/walker/walker.factor | 4 ++-- 5 files changed, 12 insertions(+), 12 deletions(-) diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index 8f180714c8..33523701aa 100755 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -39,17 +39,17 @@ M: browser-gadget ungraft* : showing-definition? ( defspec assoc -- ? ) [ key? ] 2keep - [ >r dup word-link? [ link-name ] when r> key? ] 2keep + [ >r dup word-link? [ name>> ] when r> key? ] 2keep >r dup vocab-link? [ vocab ] when r> key? or or ; M: browser-gadget definitions-changed ( assoc browser -- ) history>> - dup model-value rot showing-definition? + dup value>> rot showing-definition? [ notify-connections ] [ drop ] if ; : help-action ( browser-gadget -- link ) - history>> model-value >link ; + history>> value>> >link ; : com-follow ( link -- ) browser-gadget call-tool ; diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index 203406c6cb..5a3ad01d2e 100644 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -11,7 +11,7 @@ USING: accessors arrays ui ui.commands ui.gestures ui.gadgets IN: ui.tools.debugger : ( restarts restart-hook -- gadget ) - [ restart-name ] rot ; + [ name>> ] rot ; TUPLE: debugger < track restarts ; diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor index 407484ba97..89f238b574 100755 --- a/basis/ui/tools/search/search.factor +++ b/basis/ui/tools/search/search.factor @@ -118,7 +118,7 @@ M: live-search pref-dim* drop { 400 200 } ; : ( string files -- gadget ) source-file-candidates - f [ pathname-string ] ; + f [ string>> ] ; : all-source-files ( -- seq ) source-files get keys natural-sort ; @@ -146,7 +146,7 @@ M: live-search pref-dim* drop { 400 200 } ; : ( string seq -- gadget ) history-candidates - f [ input-string ] ; + f [ string>> ] ; : listener-history ( listener -- seq ) listener-gadget-input interactor-history ; diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor index 05cb043e49..06ebb7eb4e 100755 --- a/basis/ui/tools/traceback/traceback.factor +++ b/basis/ui/tools/traceback/traceback.factor @@ -9,15 +9,15 @@ USING: accessors continuations kernel models namespaces IN: ui.tools.traceback : ( model -- gadget ) - [ [ continuation-call callstack. ] when* ] + [ [ call>> callstack. ] when* ] t "Call stack" ; : ( model -- gadget ) - [ [ continuation-data stack. ] when* ] + [ [ data>> stack. ] when* ] t "Data stack" ; : ( model -- gadget ) - [ [ continuation-retain stack. ] when* ] + [ [ return>> stack. ] when* ] t "Retain stack" ; TUPLE: traceback-gadget < track ; @@ -39,7 +39,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ; dup f track-add ; : ( model -- gadget ) - [ [ continuation-name namestack. ] when* ] + [ [ name>> namestack. ] when* ] ; : ( model -- gadget ) diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor index c667e6918d..767be92687 100755 --- a/basis/ui/tools/walker/walker.factor +++ b/basis/ui/tools/walker/walker.factor @@ -41,7 +41,7 @@ M: walker-gadget focusable-child* : walker-state-string ( status thread -- string ) [ "Thread: " % - dup thread-name % + dup name>> % " (" % swap { { +stopped+ "Stopped" } @@ -92,7 +92,7 @@ walker-gadget "toolbar" f { [ swap walker-for-thread? ] curry find-window ; : walker-window ( status continuation thread -- ) - [ ] [ thread-name ] bi open-status-window ; + [ ] [ name>> ] bi open-status-window ; [ dup find-walker-window dup From 39c5b13b50f513cd15703580612c4dfa6cbf8d1c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 16:18:02 -0500 Subject: [PATCH 005/194] new accessors --- basis/ui/freetype/freetype.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor index 7bda548a26..d2dfe56ed4 100755 --- a/basis/ui/freetype/freetype.factor +++ b/basis/ui/freetype/freetype.factor @@ -184,7 +184,7 @@ M: freetype-renderer string-height ( open-font string -- h ) : draw-char ( open-font sprites char loc -- ) GL_MODELVIEW [ 0 0 glTranslated - char-sprite sprite-dlist glCallList + char-sprite dlist>> glCallList ] do-matrix ; : char-widths ( open-font string -- widths ) From ab83333b5161da3fffc8c315cd02b5fbf491680d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 16:19:24 -0500 Subject: [PATCH 006/194] new accessors --- basis/ui/gadgets/editors/editors.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor index 06a8b4886a..8142297318 100755 --- a/basis/ui/gadgets/editors/editors.factor +++ b/basis/ui/gadgets/editors/editors.factor @@ -55,9 +55,9 @@ M: editor ungraft* dup caret>> deactivate-editor-model dup mark>> deactivate-editor-model ; -: editor-caret* ( editor -- loc ) caret>> model-value ; +: editor-caret* ( editor -- loc ) caret>> value>> ; -: editor-mark* ( editor -- loc ) mark>> model-value ; +: editor-mark* ( editor -- loc ) mark>> value>> ; : set-caret ( loc editor -- ) [ model>> validate-loc ] keep @@ -501,7 +501,7 @@ TUPLE: field < wrapper field-model editor ; swap >>field-model ; M: field graft* - [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ] + [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ] [ dup editor>> model>> add-connection ] bi ; From 24bf9e3f9c63e007bca46bc2255e81eb17ce4ebc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 16:21:18 -0500 Subject: [PATCH 007/194] new accessors --- basis/ui/gadgets/gadgets.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor index bcf908571c..15850ae357 100755 --- a/basis/ui/gadgets/gadgets.factor +++ b/basis/ui/gadgets/gadgets.factor @@ -50,7 +50,7 @@ M: gadget model-changed 2drop ; dup model>> dup [ 2dup remove-connection ] when 2drop ; : control-value ( control -- value ) - model>> model-value ; + model>> value>> ; : set-control-value ( value control -- ) model>> set-model ; From f7c27f4127effd2418c699ffae7cf6a44b3d4bc9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 16:22:25 -0500 Subject: [PATCH 008/194] new accessors --- basis/ui/gadgets/incremental/incremental.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor index 77b88959c9..3291a1c42a 100755 --- a/basis/ui/gadgets/incremental/incremental.factor +++ b/basis/ui/gadgets/incremental/incremental.factor @@ -41,7 +41,7 @@ M: incremental pref-dim* swap set-rect-loc ; : prefer-incremental ( gadget -- ) - dup forget-pref-dim dup pref-dim swap set-rect-dim ; + dup forget-pref-dim dup pref-dim >>dim drop ; : add-incremental ( gadget incremental -- ) not-in-layout From d2861cae6e132d91deba91164bbb74169016f18f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 16:24:40 -0500 Subject: [PATCH 009/194] fix accessor. oops --- basis/ui/tools/traceback/traceback.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor index 06ebb7eb4e..92c5e09a88 100755 --- a/basis/ui/tools/traceback/traceback.factor +++ b/basis/ui/tools/traceback/traceback.factor @@ -17,7 +17,7 @@ IN: ui.tools.traceback t "Data stack" ; : ( model -- gadget ) - [ [ return>> stack. ] when* ] + [ [ retain>> stack. ] when* ] t "Retain stack" ; TUPLE: traceback-gadget < track ; From 6474ed69a7aa46d87fffa15a4bc4fb2f2517d1e1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 16:24:53 -0500 Subject: [PATCH 010/194] new accessor --- basis/ui/render/render.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor index c7bfc99024..a4bb353d1b 100644 --- a/basis/ui/render/render.factor +++ b/basis/ui/render/render.factor @@ -138,7 +138,7 @@ M: polygon draw-interior : ( color points -- gadget ) dup max-dim - >r r> over set-rect-dim + >r r> >>dim [ (>>interior) ] keep ; ! Font rendering From aa68ea0ce1f9cd6591a33447d38dc4400fa5f3e8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 17:27:28 -0500 Subject: [PATCH 011/194] fix messup --- basis/calendar/calendar-docs.factor | 7 ------- basis/calendar/calendar.factor | 8 -------- 2 files changed, 15 deletions(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index 5ff3ef6cc1..d687a8a9f4 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -136,27 +136,22 @@ HELP: instant HELP: years { $values { "x" number } { "duration" duration } } { $description } ; -{ year years } related-words HELP: months { $values { "x" number } { "duration" duration } } { $description } ; -{ month months } related-words HELP: days { $values { "x" number } { "duration" duration } } { $description } ; -{ day days } related-words HELP: weeks { $values { "x" number } { "duration" duration } } { $description } ; -{ week weeks } related-words HELP: hours { $values { "x" number } { "duration" duration } } { $description } ; -{ hour hours } related-words HELP: minutes { $values { "x" number } { "duration" duration } } @@ -166,12 +161,10 @@ HELP: minutes HELP: seconds { $values { "x" number } { "duration" duration } } { $description } ; -{ second seconds } related-words HELP: milliseconds { $values { "x" number } { "duration" duration } } { $description } ; -{ millisecond milliseconds } related-words HELP: leap-year? { $values { "obj" object } { "?" "a boolean" } } diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index fd99464bd3..b7e93e56f9 100755 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -125,14 +125,6 @@ MEMO: instant ( -- duration ) 0 0 0 0 0 0 ; : minutes ( x -- duration ) instant clone swap >>minute ; : seconds ( x -- duration ) instant clone swap >>second ; : milliseconds ( x -- duration ) 1000 / seconds ; -ALIAS: year years -ALIAS: month months -ALIAS: day days -ALIAS: week weeks -ALIAS: hour hours -ALIAS: minute minutes -ALIAS: second seconds -ALIAS: millisecond milliseconds GENERIC: leap-year? ( obj -- ? ) From 357f5c36fdf3b19526b24cb2c5a8d554bef97349 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 17:28:27 -0500 Subject: [PATCH 012/194] oops --- basis/calendar/calendar-docs.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor index d687a8a9f4..2c23ae95c1 100644 --- a/basis/calendar/calendar-docs.factor +++ b/basis/calendar/calendar-docs.factor @@ -156,7 +156,6 @@ HELP: hours HELP: minutes { $values { "x" number } { "duration" duration } } { $description } ; -{ minute minutes } related-words HELP: seconds { $values { "x" number } { "duration" duration } } From 89264e77267a8474962566113b21f6dd497a7d4b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 17:29:55 -0500 Subject: [PATCH 013/194] fix using --- basis/calendar/calendar.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index b7e93e56f9..d9284573c4 100755 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -3,7 +3,7 @@ USING: arrays kernel math math.functions namespaces sequences strings system vocabs.loader calendar.backend threads accessors combinators locals classes.tuple math.order -memoize summary combinators.short-circuit alias ; +memoize summary combinators.short-circuit ; IN: calendar TUPLE: duration From 29e5ed2adbc1e5260da76f704bdd36b69a9bb5e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 Aug 2008 19:17:04 -0500 Subject: [PATCH 014/194] Fixing deploy tool --- .../tree/propagation/info/info.factor | 6 +-- .../tree/propagation/inlining/inlining.factor | 16 ++++++-- .../known-words/known-words.factor | 40 +++++++++---------- .../tree/propagation/nodes/nodes.factor | 3 -- .../tree/propagation/simple/simple.factor | 39 ++++++++---------- basis/macros/expander/expander.factor | 4 +- .../known-words/known-words.factor | 10 ++--- .../transforms/transforms.factor | 11 ++--- basis/tools/deploy/shaker/shaker.factor | 38 +++++++++++++----- basis/tools/deploy/test/1/deploy.factor | 16 ++++---- basis/tools/deploy/test/2/deploy.factor | 14 +++---- basis/tools/deploy/test/3/deploy.factor | 18 ++++----- basis/tools/deploy/test/4/deploy.factor | 14 +++---- basis/tools/deploy/test/5/deploy.factor | 14 +++---- 14 files changed, 127 insertions(+), 116 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index f3ecd7ae65..2281c140a4 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -12,8 +12,6 @@ IN: compiler.tree.propagation.info : null-class? ( class -- ? ) null class<= ; -SYMBOL: +interval+ - GENERIC: eql? ( obj1 obj2 -- ? ) M: object eql? eq? ; M: fixnum eql? eq? ; @@ -40,7 +38,7 @@ slots ; : class-interval ( class -- interval ) dup real class<= - [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ; + [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ; : interval>literal ( class interval -- literal literal? ) #! If interval has zero length and the class is sufficiently @@ -84,7 +82,7 @@ slots ; init-value-info ; foldable : ( class -- info ) - dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or + dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or ; foldable : ( interval -- info ) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index 09f50b21ea..4f93769b7f 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays sequences math math.order -math.partial-dispatch generic generic.standard classes.algebra -classes.union sets quotations assocs combinators words -namespaces +math.partial-dispatch generic generic.standard generic.math +classes.algebra classes.union sets quotations assocs combinators +words namespaces compiler.tree compiler.tree.builder compiler.tree.normalization @@ -145,3 +145,13 @@ SYMBOL: history : always-inline-word? ( word -- ? ) { curry compose } memq? ; + +: do-inlining ( #call word -- ? ) + { + { [ dup always-inline-word? ] [ inline-word ] } + { [ dup standard-generic? ] [ inline-standard-method ] } + { [ dup math-generic? ] [ inline-math-method ] } + { [ dup math-partial? ] [ inline-math-partial ] } + { [ dup method-body? ] [ inline-method-body ] } + [ 2drop f ] + } cond ; diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 23323e107d..c07c5a5cb5 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -17,11 +17,11 @@ IN: compiler.tree.propagation.known-words \ fixnum most-negative-fixnum most-positive-fixnum [a,b] -+interval+ set-word-prop +"interval" set-word-prop \ array-capacity 0 max-array-capacity [a,b] -+interval+ set-word-prop +"interval" set-word-prop { + - * / } [ { number number } "input-classes" set-word-prop ] each @@ -66,17 +66,17 @@ most-negative-fixnum most-positive-fixnum [a,b] over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline { bitnot fixnum-bitnot bignum-bitnot } [ - [ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop + [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop ] each -\ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop +\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; : fits? ( interval class -- ? ) - +interval+ word-prop interval-subset? ; + "interval" word-prop interval-subset? ; : binary-op-class ( info1 info2 -- newclass ) [ class>> ] bi@ @@ -120,7 +120,7 @@ most-negative-fixnum most-positive-fixnum [a,b] [ binary-op-class ] [ , binary-op-interval ] 2bi @ - ] +outputs+ set-word-prop ; + ] "outputs" set-word-prop ; \ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op \ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op @@ -158,7 +158,7 @@ most-negative-fixnum most-positive-fixnum [a,b] in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ; : define-comparison-constraints ( word op -- ) - '[ , comparison-constraints ] +constraints+ set-word-prop ; + '[ , comparison-constraints ] "constraints" set-word-prop ; comparison-ops [ dup '[ , define-comparison-constraints ] each-derived-op ] each @@ -178,13 +178,13 @@ generic-comparison-ops [ comparison-ops [ dup '[ - [ , fold-comparison ] +outputs+ set-word-prop + [ , fold-comparison ] "outputs" set-word-prop ] each-derived-op ] each generic-comparison-ops [ dup specific-comparison - '[ , fold-comparison ] +outputs+ set-word-prop + '[ , fold-comparison ] "outputs" set-word-prop ] each : maybe-or-never ( ? -- info ) @@ -196,7 +196,7 @@ generic-comparison-ops [ { number= bignum= float= } [ [ info-intervals-intersect? maybe-or-never - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] each : info-classes-intersect? ( info1 info2 -- ? ) @@ -206,13 +206,13 @@ generic-comparison-ops [ over value-info literal>> fixnum? [ [ value-info literal>> is-equal-to ] dip t--> ] [ 3drop f ] if -] +constraints+ set-word-prop +] "constraints" set-word-prop \ eq? [ [ info-intervals-intersect? ] [ info-classes-intersect? ] 2bi or maybe-or-never -] +outputs+ set-word-prop +] "outputs" set-word-prop { { >fixnum fixnum } @@ -226,7 +226,7 @@ generic-comparison-ops [ interval-intersect ] 2bi - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] assoc-each { @@ -250,36 +250,36 @@ generic-comparison-ops [ } } cond [ fixnum fits? fixnum integer ? ] keep - [ 2nip ] curry +outputs+ set-word-prop + [ 2nip ] curry "outputs" set-word-prop ] each { } [ [ literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if [ clear ] dip - ] +outputs+ set-word-prop + ] "outputs" set-word-prop ] each \ new [ literal>> dup tuple-class? [ drop tuple ] unless -] +outputs+ set-word-prop +] "outputs" set-word-prop ! the output of clone has the same type as the input { clone (clone) } [ [ clone f >>literal f >>literal? ] - +outputs+ set-word-prop + "outputs" set-word-prop ] each \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if -] +outputs+ set-word-prop +] "outputs" set-word-prop \ instance? [ [ value-info ] dip over literal>> class? [ [ literal>> ] dip predicate-constraints ] [ 3drop f ] if -] +constraints+ set-word-prop +] "constraints" set-word-prop \ instance? [ ! We need to force the caller word to recompile when the class @@ -292,4 +292,4 @@ generic-comparison-ops [ [ predicate-output-infos ] bi ] [ 2drop object-info ] if -] +outputs+ set-word-prop +] "outputs" set-word-prop diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor index 358944d1b7..9e4d99e462 100644 --- a/basis/compiler/tree/propagation/nodes/nodes.factor +++ b/basis/compiler/tree/propagation/nodes/nodes.factor @@ -6,9 +6,6 @@ compiler.tree.propagation.copy compiler.tree.propagation.info ; IN: compiler.tree.propagation.nodes -SYMBOL: +constraints+ -SYMBOL: +outputs+ - GENERIC: propagate-before ( node -- ) GENERIC: propagate-after ( node -- ) diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index d664ae5ccf..809a85a51f 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -3,8 +3,7 @@ USING: fry accessors kernel sequences sequences.private assocs words namespaces classes.algebra combinators classes classes.tuple classes.tuple.private continuations arrays -math math.partial-dispatch math.private slots generic definitions -generic.standard generic.math +math math.private slots generic definitions stack-checker.state compiler.tree compiler.tree.propagation.info @@ -52,7 +51,7 @@ M: #declare propagate-before with-datastack first assume ; : compute-constraints ( #call word -- ) - dup +constraints+ word-prop [ nip custom-constraints ] [ + dup "constraints" word-prop [ nip custom-constraints ] [ dup predicate? [ [ [ in-d>> first ] [ out-d>> first ] bi ] [ "predicating" word-prop ] bi* @@ -61,19 +60,22 @@ M: #declare propagate-before ] if* ; : call-outputs-quot ( #call word -- infos ) - [ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi* + [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi* with-datastack ; : foldable-call? ( #call word -- ? ) "foldable" word-prop [ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ; -: fold-call ( #call word -- infos ) +: (fold-call) ( #call word -- info ) [ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi* '[ , , with-datastack [ ] map nip ] [ drop [ object-info ] replicate ] recover ; +: fold-call ( #call word -- ) + [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ; + : predicate-output-infos ( info class -- info ) [ class>> ] dip { { [ 2dup class<= ] [ t ] } @@ -95,30 +97,23 @@ M: #declare propagate-before : output-value-infos ( #call word -- infos ) { - { [ 2dup foldable-call? ] [ fold-call ] } { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup predicate? ] [ propagate-predicate ] } - { [ dup +outputs+ word-prop ] [ call-outputs-quot ] } + { [ dup "outputs" word-prop ] [ call-outputs-quot ] } [ default-output-value-infos ] } cond ; -: do-inlining ( #call word -- ? ) - { - { [ dup always-inline-word? ] [ inline-word ] } - { [ dup standard-generic? ] [ inline-standard-method ] } - { [ dup math-generic? ] [ inline-math-method ] } - { [ dup math-partial? ] [ inline-math-partial ] } - { [ dup method-body? ] [ inline-method-body ] } - [ 2drop f ] - } cond ; - M: #call propagate-before - dup word>> 2dup do-inlining [ 2drop ] [ - [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] - [ compute-constraints ] - 2bi - ] if ; + dup word>> { + { [ 2dup foldable-call? ] [ fold-call ] } + { [ 2dup do-inlining ] [ 2drop ] } + [ + [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ] + [ compute-constraints ] + 2bi + ] + } cond ; M: #call annotate-node dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ; diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor index f538412937..0a1703de58 100644 --- a/basis/macros/expander/expander.factor +++ b/basis/macros/expander/expander.factor @@ -32,8 +32,8 @@ M: wrapper expand-macros* wrapped>> literal ; stack get pop >quotation end (expand-macros) ; : expand-macro? ( word -- quot ? ) - dup [ "macro" word-prop ] [ +transform-quot+ word-prop ] bi or dup [ - swap [ stack-effect in>> length ] [ +transform-n+ word-prop ] bi or + dup [ "macro" word-prop ] [ "transform-quot" word-prop ] bi or dup [ + swap [ stack-effect in>> length ] [ "transform-n" word-prop ] bi or stack get length <= ] [ 2drop f f ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index c01236fba9..5cbd5f40af 100755 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -173,15 +173,13 @@ do-primitive alien-invoke alien-indirect alien-callback { call execute dispatch load-locals get-local drop-locals } [ t "no-compile" set-word-prop ] each -SYMBOL: +primitive+ - : non-inline-word ( word -- ) dup called-dependency depends-on { { [ dup "shuffle" word-prop ] [ infer-shuffle-word ] } { [ dup "special" word-prop ] [ infer-special ] } - { [ dup +primitive+ word-prop ] [ infer-primitive ] } - { [ dup +transform-quot+ word-prop ] [ apply-transform ] } + { [ dup "primitive" word-prop ] [ infer-primitive ] } + { [ dup "transform-quot" word-prop ] [ apply-transform ] } { [ dup "macro" word-prop ] [ apply-macro ] } { [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] } @@ -190,7 +188,7 @@ SYMBOL: +primitive+ } cond ; : define-primitive ( word inputs outputs -- ) - [ 2drop t +primitive+ set-word-prop ] + [ 2drop t "primitive" set-word-prop ] [ drop "input-classes" set-word-prop ] [ nip "default-output-classes" set-word-prop ] 3tri ; @@ -600,8 +598,6 @@ SYMBOL: +primitive+ \ (set-os-envs) { array } { } define-primitive -\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop - \ dll-valid? { object } { object } define-primitive \ modify-code-heap { array object } { } define-primitive diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 200b5d9c43..1bdfdb6f42 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -8,9 +8,6 @@ stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors ; IN: stack-checker.transforms -SYMBOL: +transform-quot+ -SYMBOL: +transform-n+ - : give-up-transform ( word -- ) dup recursive-label [ call-recursive-word ] @@ -48,8 +45,8 @@ SYMBOL: +transform-n+ : apply-transform ( word -- ) [ inlined-dependency depends-on ] [ [ ] - [ +transform-quot+ word-prop ] - [ +transform-n+ word-prop ] + [ "transform-quot" word-prop ] + [ "transform-n" word-prop ] tri (apply-transform) ] bi ; @@ -64,8 +61,8 @@ SYMBOL: +transform-n+ ] bi ; : define-transform ( word quot n -- ) - [ drop +transform-quot+ set-word-prop ] - [ nip +transform-n+ set-word-prop ] + [ drop "transform-quot" set-word-prop ] + [ nip "transform-n" set-word-prop ] 3bi ; ! Combinators diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index eaa0342c25..5e888cd871 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -85,8 +85,11 @@ IN: tools.deploy.shaker [ strip-dictionary? [ { + "cannot-infer" "coercer" + "combination" "compiled-effect" + "compiled-generic-uses" "compiled-uses" "constraints" "declared-effect" @@ -94,38 +97,52 @@ IN: tools.deploy.shaker "default-method" "default-output-classes" "derived-from" - "identities" + "engines" "if-intrinsics" "infer" "inferred-effect" + "inline" + "inlined-block" "input-classes" "interval" "intrinsics" + "lambda" "loc" + "local-reader" + "local-reader?" + "local-writer" + "local-writer?" + "local?" + "macro" "members" - "methods" + "memo-quot" "method-class" "method-generic" - "combination" - "cannot-infer" + "methods" "no-compile" "optimizer-hooks" - "output-classes" + "outputs" "participants" "predicate" "predicate-definition" "predicating" - "tuple-dispatch-generic" - "slots" + "reader" + "reading" + "recursive" + "shuffle" "slot-names" + "slots" + "special" "specializer" "step-into" "step-into?" "superclass" - "reading" - "writing" + "transform-n" + "transform-quot" + "tuple-dispatch-generic" "type" - "engines" + "writer" + "writing" } % ] when @@ -211,6 +228,7 @@ IN: tools.deploy.shaker classes:update-map command-line:main-vocab-hook compiled-crossref + compiled-generic-crossref compiler.units:recompile-hook compiler.units:update-tuples-hook definitions:crossref diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor index 490c21a067..098e99719e 100755 --- a/basis/tools/deploy/test/1/deploy.factor +++ b/basis/tools/deploy/test/1/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.1" } - { deploy-threads? t } - { deploy-compiler? t } - { deploy-math? t } { deploy-c-types? f } + { deploy-name "tools.deploy.test.1" } { deploy-io 2 } - { deploy-reflection 1 } - { deploy-ui? f } + { deploy-random? f } + { deploy-math? t } + { deploy-compiler? t } + { deploy-reflection 2 } { "stop-after-last-window?" t } + { deploy-threads? t } + { deploy-ui? f } { deploy-word-props? f } + { deploy-word-defs? f } } diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor index aeec8e94f7..c6f46eede6 100755 --- a/basis/tools/deploy/test/2/deploy.factor +++ b/basis/tools/deploy/test/2/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-compiler? t } - { deploy-reflection 2 } + { deploy-io 2 } { deploy-ui? f } - { deploy-word-props? f } { deploy-threads? t } { deploy-c-types? f } - { deploy-random? f } - { "stop-after-last-window?" t } { deploy-name "tools.deploy.test.2" } - { deploy-io 2 } + { deploy-compiler? t } + { deploy-word-props? f } + { deploy-reflection 2 } { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor index dde8291658..5f45b87e0d 100755 --- a/basis/tools/deploy/test/3/deploy.factor +++ b/basis/tools/deploy/test/3/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-word-defs? f } - { deploy-random? f } - { deploy-name "tools.deploy.test.3" } - { deploy-threads? t } - { deploy-compiler? t } - { deploy-math? t } - { deploy-c-types? f } { deploy-io 3 } - { deploy-reflection 1 } { deploy-ui? f } - { "stop-after-last-window?" t } + { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.3" } + { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor index 65ead56e2b..ea899e64c0 100644 --- a/basis/tools/deploy/test/4/deploy.factor +++ b/basis/tools/deploy/test/4/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } { deploy-io 2 } - { deploy-c-types? f } - { deploy-random? f } { deploy-ui? f } - { deploy-name "tools.deploy.test.4" } - { deploy-word-defs? f } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.4" } { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor index bb4580b7ae..797116e09b 100644 --- a/basis/tools/deploy/test/5/deploy.factor +++ b/basis/tools/deploy/test/5/deploy.factor @@ -1,15 +1,15 @@ USING: tools.deploy.config ; H{ - { deploy-math? t } - { deploy-reflection 1 } { deploy-io 3 } - { deploy-c-types? f } - { deploy-random? f } { deploy-ui? f } - { deploy-name "tools.deploy.test.5" } - { deploy-word-defs? f } - { "stop-after-last-window?" t } { deploy-threads? t } + { deploy-c-types? f } + { deploy-name "tools.deploy.test.5" } { deploy-compiler? t } { deploy-word-props? f } + { deploy-reflection 2 } + { deploy-word-defs? f } + { "stop-after-last-window?" t } + { deploy-random? f } + { deploy-math? t } } From facc5edeec38a201bebcedf1a053e9e7904ab762 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 Aug 2008 19:23:04 -0500 Subject: [PATCH 015/194] Fix handler --- basis/ui/gadgets/handler/handler.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/gadgets/handler/handler.factor b/basis/ui/gadgets/handler/handler.factor index 1ad5063013..1c12142593 100644 --- a/basis/ui/gadgets/handler/handler.factor +++ b/basis/ui/gadgets/handler/handler.factor @@ -8,4 +8,4 @@ TUPLE: handler < wrapper table ; : ( child -- handler ) handler new-wrapper ; M: handler handle-gesture ( gesture gadget -- ? ) - over table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file + tuck table>> at dup [ call f ] [ 2drop t ] if ; \ No newline at end of file From da295345a2f5d3d135307fd71ac768e530e60536 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 Aug 2008 19:28:26 -0500 Subject: [PATCH 016/194] Fix tests --- basis/help/topics/topics-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor index c52d5e347f..699b2d398a 100644 --- a/basis/help/topics/topics-tests.factor +++ b/basis/help/topics/topics-tests.factor @@ -1,6 +1,6 @@ -USING: definitions help help.topics help.crossref help.markup -help.syntax kernel sequences tools.test words parser namespaces -assocs source-files eval ; +USING: accessors definitions help help.topics help.crossref +help.markup help.syntax kernel sequences tools.test words parser +namespaces assocs source-files eval ; IN: help.topics.tests \ article-name must-infer From 88aa1def3564819a46ed36378041e658776ad15e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 31 Aug 2008 20:13:06 -0500 Subject: [PATCH 017/194] More a UI dependency to basis --- {extra => basis}/math/points/points.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {extra => basis}/math/points/points.factor (100%) diff --git a/extra/math/points/points.factor b/basis/math/points/points.factor similarity index 100% rename from extra/math/points/points.factor rename to basis/math/points/points.factor From 7025ebd7ee5f856751af7b205195fd828e808f91 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 31 Aug 2008 20:19:16 -0500 Subject: [PATCH 018/194] 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 Date: Sun, 31 Aug 2008 21:20:56 -0500 Subject: [PATCH 019/194] 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 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 ; +: instant ( -- duration ) 0 0 0 0 0 0 ; : 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 Date: Sun, 31 Aug 2008 21:24:58 -0500 Subject: [PATCH 020/194] 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 Date: Sun, 31 Aug 2008 22:07:22 -0500 Subject: [PATCH 021/194] 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 Date: Sun, 31 Aug 2008 23:35:32 -0500 Subject: [PATCH 022/194] 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 Date: Sun, 31 Aug 2008 23:53:07 -0500 Subject: [PATCH 023/194] 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" Date: Mon, 1 Sep 2008 02:04:42 -0500 Subject: [PATCH 024/194] 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 Date: Mon, 1 Sep 2008 02:45:20 -0500 Subject: [PATCH 025/194] 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 Date: Mon, 1 Sep 2008 02:52:25 -0500 Subject: [PATCH 026/194] 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 dup f >>boundary - { 0 1/2 } >>align ; inline + align-left ; inline : ( label quot -- button )