From ca200b72d055799a723292f817dddea4b0453a36 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Sat, 22 Nov 2008 02:15:25 -0600 Subject: [PATCH 1/7] Fixing some problems with Windows keyboard handling --- basis/ui/windows/windows.factor | 94 +++++++++++++++++++-------------- 1 file changed, 55 insertions(+), 39 deletions(-) mode change 100644 => 100755 basis/ui/windows/windows.factor diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor old mode 100644 new mode 100755 index fc22f30e0a..512930d06d --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -6,9 +6,10 @@ ui.gadgets ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel math math.vectors namespaces make sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types -windows.nt windows threads libc combinators continuations -command-line shuffle opengl ui.render unicode.case ascii -math.bitwise locals symbols accessors math.geometry.rect ; +windows.nt windows threads libc combinators +combinators.short-circuit continuations command-line shuffle +opengl ui.render ascii math.bitwise locals symbols accessors +math.geometry.rect math.order ascii ; IN: ui.windows SINGLETON: windows-ui-backend @@ -144,11 +145,6 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; : alt? ( -- ? ) left-alt? right-alt? or ; : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ; -: switch-case ( seq -- seq ) - dup first CHAR: a >= [ >upper ] [ >lower ] if ; - -: switch-case? ( -- ? ) shift? caps-lock? xor not ; - : key-modifiers ( -- seq ) [ shift? [ S+ , ] when @@ -179,33 +175,53 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; : exclude-key-wm-char? ( n -- bool ) exclude-keys-wm-char key? ; -: keystroke>gesture ( n -- mods sym ? ) - dup wm-keydown-codes at* [ - nip >r key-modifiers r> t - ] [ - drop 1string >r key-modifiers r> - C+ pick member? >r A+ pick member? r> or [ - shift? [ >lower ] unless f - ] [ - switch-case? [ switch-case ] when t - ] if - ] if ; +: keystroke>gesture ( n -- mods sym ) + wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ; + +: send-key-gesture ( sym action? quot hWnd -- ) + [ [ key-modifiers ] 3dip call ] dip + window-focus propagate-gesture ; inline + +: send-key-down ( sym action? hWnd -- ) + [ [ ] ] dip send-key-gesture ; + +: send-key-up ( sym action? hWnd -- ) + [ [ ] ] dip send-key-gesture ; + +: key-sym ( wParam -- string/f action? ) + { + { + [ dup LETTER? ] + [ shift? caps-lock? xor [ CHAR: a + CHAR: A - ] unless 1string f ] + } + { [ dup digit? ] [ 1string f ] } + [ wm-keydown-codes at t ] + } cond ; :: handle-wm-keydown ( hWnd uMsg wParam lParam -- ) wParam exclude-key-wm-keydown? [ - wParam keystroke>gesture - hWnd window-focus propagate-gesture + wParam key-sym over [ + dup ctrl? alt? xor or [ + hWnd send-key-down + ] [ 2drop ] if + ] [ 2drop ] if ] unless ; :: handle-wm-char ( hWnd uMsg wParam lParam -- ) - wParam exclude-key-wm-char? ctrl? alt? xor or [ - wParam 1string - hWnd window-focus user-input + wParam exclude-key-wm-char? [ + ctrl? alt? xor [ + wParam 1string + [ f hWnd send-key-down ] + [ hWnd window-focus user-input ] bi + ] unless ] unless ; :: handle-wm-keyup ( hWnd uMsg wParam lParam -- ) - wParam keystroke>gesture - hWnd window-focus propagate-gesture ; + wParam exclude-key-wm-keydown? [ + wParam key-sym over [ + hWnd send-key-up + ] [ 2drop ] if + ] unless ; :: set-window-active ( hwnd uMsg wParam lParam ? -- n ) ? hwnd window (>>active?) @@ -241,20 +257,20 @@ M: windows-ui-backend (close-window) : message>button ( uMsg -- button down? ) { - { [ dup WM_LBUTTONDOWN = ] [ drop 1 t ] } - { [ dup WM_LBUTTONUP = ] [ drop 1 f ] } - { [ dup WM_MBUTTONDOWN = ] [ drop 2 t ] } - { [ dup WM_MBUTTONUP = ] [ drop 2 f ] } - { [ dup WM_RBUTTONDOWN = ] [ drop 3 t ] } - { [ dup WM_RBUTTONUP = ] [ drop 3 f ] } + { WM_LBUTTONDOWN [ 1 t ] } + { WM_LBUTTONUP [ 1 f ] } + { WM_MBUTTONDOWN [ 2 t ] } + { WM_MBUTTONUP [ 2 f ] } + { WM_RBUTTONDOWN [ 3 t ] } + { WM_RBUTTONUP [ 3 f ] } - { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] } - { [ dup WM_NCLBUTTONUP = ] [ drop 1 f ] } - { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] } - { [ dup WM_NCMBUTTONUP = ] [ drop 2 f ] } - { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] } - { [ dup WM_NCRBUTTONUP = ] [ drop 3 f ] } - } cond ; + { WM_NCLBUTTONDOWN [ 1 t ] } + { WM_NCLBUTTONUP [ 1 f ] } + { WM_NCMBUTTONDOWN [ 2 t ] } + { WM_NCMBUTTONUP [ 2 f ] } + { WM_NCRBUTTONDOWN [ 3 t ] } + { WM_NCRBUTTONUP [ 3 f ] } + } case ; ! If the user clicks in the window border ("non-client area") ! Windows sends us an NC[LMR]BUTTONDOWN message; but if the From f1b95c0038216d0fc107071762222830196265c5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 19:57:06 -0600 Subject: [PATCH 2/7] Fix .c command in FEP --- vm/debug.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/vm/debug.c b/vm/debug.c index 8c6ec203ad..db8e60c781 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -167,7 +167,9 @@ void print_stack_frame(F_STACK_FRAME *frame) print_obj(frame_scan(frame)); print_string("\n"); print_cell_hex((CELL)frame_executing(frame)); + print_string(" "); print_cell_hex((CELL)frame->xt); + print_string("\n"); } void print_callstack(void) From 3e7afcac29f2e2d461f72565de8c62b88ba9e55b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 19:57:25 -0600 Subject: [PATCH 3/7] (call-next-method) now takes a method instead of a class and a generic --- basis/stack-checker/transforms/transforms.factor | 8 ++++++-- core/generic/generic-docs.factor | 2 +- core/generic/generic.factor | 12 ++++++++---- core/generic/parser/parser.factor | 13 +++---------- core/syntax/syntax.factor | 7 +++---- 5 files changed, 21 insertions(+), 21 deletions(-) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index e4f8c50eeb..6e11eb1189 100644 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -90,8 +90,12 @@ IN: stack-checker.transforms \ spread [ spread>quot ] 1 define-transform \ (call-next-method) [ - [ [ inlined-dependency depends-on ] bi@ ] [ next-method-quot ] 2bi -] 2 define-transform + [ + [ "method-class" word-prop ] + [ "method-generic" word-prop ] bi + [ inlined-dependency depends-on ] bi@ + ] [ next-method-quot ] bi +] 1 define-transform ! Constructors \ boa [ diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index b5f22ec120..35029a3fb0 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -162,6 +162,6 @@ HELP: forget-methods { sort-classes order } related-words HELP: (call-next-method) -{ $values { "class" class } { "generic" generic } } +{ $values { "method" method-body } } { $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." } { $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index e2818a51b2..8d7ed4cb60 100644 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -49,12 +49,16 @@ GENERIC: effective-method ( generic -- method ) GENERIC: next-method-quot* ( class generic combination -- quot ) -: next-method-quot ( class generic -- quot ) +: next-method-quot ( method -- quot ) next-method-quot-cache get [ - dup "combination" word-prop next-method-quot* - ] 2cache ; + [ "method-class" word-prop ] + [ + "method-generic" word-prop + dup "combination" word-prop + ] bi next-method-quot* + ] cache ; -: (call-next-method) ( class generic -- ) +: (call-next-method) ( method -- ) next-method-quot call ; TUPLE: check-method class generic ; diff --git a/core/generic/parser/parser.factor b/core/generic/parser/parser.factor index 7380399b5c..c6420164d2 100644 --- a/core/generic/parser/parser.factor +++ b/core/generic/parser/parser.factor @@ -13,17 +13,10 @@ ERROR: not-in-a-method-error ; : CREATE-METHOD ( -- method ) scan-word bootstrap-word scan-word create-method-in ; -SYMBOL: current-class -SYMBOL: current-generic +SYMBOL: current-method -: with-method-definition ( quot -- parsed ) - [ - [ - [ "method-class" word-prop current-class set ] - [ "method-generic" word-prop current-generic set ] - [ ] tri - ] dip call - ] with-scope ; inline +: with-method-definition ( method quot -- ) + [ dup current-method ] dip with-variable ; inline : (M:) ( method def -- ) CREATE-METHOD [ parse-definition ] with-method-definition ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 105bdc325f..7ab2eefcb9 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -202,13 +202,12 @@ IN: bootstrap.syntax ] define-syntax "call-next-method" [ - current-class get current-generic get - 2dup [ word? ] both? [ - [ literalize parsed ] bi@ + current-method get [ + literalize parsed \ (call-next-method) parsed ] [ not-in-a-method-error - ] if + ] if* ] define-syntax "initial:" "syntax" lookup define-symbol From 2f3b05b108281e37f3cb67c3ca406078d37d9e59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 19:57:47 -0600 Subject: [PATCH 4/7] Test call-next-method from an uncomipiled method in a compiled deployment --- basis/tools/deploy/test/7/7.factor | 18 ++++++++++++++++++ basis/tools/deploy/test/7/deploy.factor | 15 +++++++++++++++ 2 files changed, 33 insertions(+) create mode 100644 basis/tools/deploy/test/7/7.factor create mode 100644 basis/tools/deploy/test/7/deploy.factor diff --git a/basis/tools/deploy/test/7/7.factor b/basis/tools/deploy/test/7/7.factor new file mode 100644 index 0000000000..a16e3c82c5 --- /dev/null +++ b/basis/tools/deploy/test/7/7.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math namespaces ; +IN: tools.deploy.test.7 + +SYMBOL: my-var + +GENERIC: my-generic ( x -- b ) + +M: integer my-generic sq ; + +M: fixnum my-generic call-next-method my-var get call ; + +: test-7 ( -- ) + [ 1 + ] my-var set-global + 12 my-generic 145 assert= ; + +MAIN: test-7 diff --git a/basis/tools/deploy/test/7/deploy.factor b/basis/tools/deploy/test/7/deploy.factor new file mode 100644 index 0000000000..bc374f1088 --- /dev/null +++ b/basis/tools/deploy/test/7/deploy.factor @@ -0,0 +1,15 @@ +USING: tools.deploy.config ; +H{ + { deploy-threads? t } + { deploy-word-props? f } + { deploy-ui? f } + { deploy-io 2 } + { deploy-math? t } + { "stop-after-last-window?" t } + { deploy-compiler? t } + { deploy-unicode? f } + { deploy-c-types? f } + { deploy-reflection 1 } + { deploy-word-defs? f } + { deploy-name "tools.deploy.test.7" } +} From f5513877ec1e5b841aa9cb27171e0ed9af05b49d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 19:58:05 -0600 Subject: [PATCH 5/7] Don't load listener into deployment image --- basis/bootstrap/stage2.factor | 2 +- basis/tools/deploy/backend/backend.factor | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index d25394e978..6dd3918e0d 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -67,7 +67,7 @@ SYMBOL: bootstrap-time os wince? [ "windows.ce" require ] when os winnt? [ "windows.nt" require ] when - "deploy-vocab" get [ + "staging" get "deploy-vocab" get or [ "stage2: deployment mode" print ] [ "listener" require diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor index 9431cb2c19..18713c7b0c 100644 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -55,6 +55,8 @@ DEFER: ?make-staging-image : staging-command-line ( profile -- flags ) [ + "-staging" , + dup empty? [ "-i=" my-boot-image-name append , ] [ From 323f95d3f4c9e48b7b8c8f92fffc22612a105663 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 19:58:23 -0600 Subject: [PATCH 6/7] Pre-compute next-methods when deploying --- basis/tools/deploy/deploy-tests.factor | 5 +++ basis/tools/deploy/shaker/next-methods.factor | 4 ++ basis/tools/deploy/shaker/shaker.factor | 39 ++++++++++--------- .../tools/deploy/shaker/strip-debugger.factor | 8 +++- 4 files changed, 35 insertions(+), 21 deletions(-) create mode 100644 basis/tools/deploy/shaker/next-methods.factor diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index 226cf654b1..e0ac391fdf 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -106,3 +106,8 @@ M: quit-responder call-responder* "tools.deploy.test.6" shake-and-bake run-temp-image ] unit-test + +[ ] [ + "tools.deploy.test.7" shake-and-bake + run-temp-image +] unit-test diff --git a/basis/tools/deploy/shaker/next-methods.factor b/basis/tools/deploy/shaker/next-methods.factor new file mode 100644 index 0000000000..2bff407525 --- /dev/null +++ b/basis/tools/deploy/shaker/next-methods.factor @@ -0,0 +1,4 @@ +USING: words ; +IN: generic + +: next-method-quot ( method -- quot ) "next-method-quot" word-prop ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index f5778e410f..9cc5a66f70 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -5,7 +5,7 @@ namespaces make assocs kernel parser lexer strings.parser tools.deploy.config vocabs sequences words words.private memory kernel.private continuations io prettyprint vocabs.loader debugger system strings sets vectors quotations byte-arrays -sorting compiler.units definitions ; +sorting compiler.units definitions generic generic.standard ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes QUALIFIED: command-line @@ -14,7 +14,6 @@ QUALIFIED: continuations QUALIFIED: definitions QUALIFIED: init QUALIFIED: layouts -QUALIFIED: listener QUALIFIED: prettyprint.config QUALIFIED: source-files QUALIFIED: vocabs @@ -95,20 +94,13 @@ IN: tools.deploy.shaker : stripped-word-props ( -- seq ) [ - strip-dictionary? deploy-compiler? get and [ - { - "combination" - "members" - "methods" - } % - ] when - strip-dictionary? [ { "alias" "boa-check" "cannot-infer" "coercer" + "combination" "compiled-effect" "compiled-generic-uses" "compiled-uses" @@ -138,7 +130,9 @@ IN: tools.deploy.shaker "local-writer?" "local?" "macro" + "members" "memo-quot" + "methods" "mixin" "method-class" "method-generic" @@ -201,17 +195,13 @@ IN: tools.deploy.shaker : stripped-globals ( -- seq ) [ - "callbacks" "alien.compiler" lookup , - "inspector-hook" "inspector" lookup , { - bootstrap.stage2:bootstrap-time continuations:error continuations:error-continuation continuations:error-thread continuations:restarts - listener:error-hook init:init-hooks source-files:source-files input-stream @@ -234,6 +224,10 @@ IN: tools.deploy.shaker "tools" "io.launcher" "random" + "compiler" + "stack-checker" + "bootstrap" + "listener" } strip-vocab-globals % strip-dictionary? [ @@ -244,6 +238,7 @@ IN: tools.deploy.shaker { gensym name>char-hook + classes:next-method-quot-cache classes:class-and-cache classes:class-not-cache classes:class-or-cache @@ -304,10 +299,7 @@ IN: tools.deploy.shaker "ui-error-hook" "ui.gadgets.worlds" lookup , ] when - "" "stack-checker.state" lookup [ , ] when* - "windows-messages" "windows.messages" lookup [ , ] when* - ] { } make ; : strip-globals ( stripped-globals -- ) @@ -368,11 +360,21 @@ SYMBOL: deploy-vocab t "quiet" set-global f output-stream set-global ; +: compute-next-methods ( -- ) + [ standard-generic? ] instances [ + "methods" word-prop [ + nip + dup next-method-quot "next-method-quot" set-word-prop + ] assoc-each + ] each + "resource:basis/tools/deploy/shaker/next-methods.factor" run-file ; + : strip ( -- ) init-stripper strip-libc strip-cocoa strip-debugger + compute-next-methods strip-init-hooks strip-c-io f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore @@ -382,8 +384,7 @@ SYMBOL: deploy-vocab r> strip-words compress-byte-arrays compress-quotations - compress-strings - H{ } clone classes:next-method-quot-cache set-global ; + compress-strings ; : (deploy) ( final-image vocab config -- ) #! Does the actual work of a deployment in the slave diff --git a/basis/tools/deploy/shaker/strip-debugger.factor b/basis/tools/deploy/shaker/strip-debugger.factor index bdcc6c237e..db7eb63bbf 100644 --- a/basis/tools/deploy/shaker/strip-debugger.factor +++ b/basis/tools/deploy/shaker/strip-debugger.factor @@ -1,9 +1,13 @@ USING: compiler.units words vocabs kernel threads.private ; IN: debugger -: print-error ( error -- ) die drop ; +: consume ( error -- ) + #! We don't want DCE to drop the error before the die call! + drop ; -: error. ( error -- ) die drop ; +: print-error ( error -- ) die consume ; + +: error. ( error -- ) die consume ; "threads" vocab [ [ From 359fac1266be936af588bbd6144f28b13efb9e5d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 22 Nov 2008 19:58:32 -0600 Subject: [PATCH 7/7] Update for call-next-method changes --- basis/tools/walker/walker.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 9775bdff81..1d26567952 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -83,7 +83,7 @@ M: object add-breakpoint ; : (step-into-continuation) ( -- ) continuation callstack >>call break ; -: (step-into-call-next-method) ( class generic -- ) +: (step-into-call-next-method) ( method -- ) next-method-quot (step-into-quot) ; ! Messages sent to walker thread