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

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

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 [

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 ,
         ] [

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

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 ;

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
 
-        "<value>" "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
+    compress-strings ;
-    H{ } clone classes:next-method-quot-cache set-global ;
 
 : (deploy) ( final-image vocab config -- )
     #! Does the actual work of a deployment in the slave

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 [
     [

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

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" }
+}

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

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
+windows.nt windows threads libc combinators
-command-line shuffle opengl ui.render unicode.case ascii
+combinators.short-circuit continuations command-line shuffle
-math.bitwise locals symbols accessors math.geometry.rect ;
+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 ? )
+: keystroke>gesture ( n -- mods sym )
-    dup wm-keydown-codes at* [
+    wm-keydown-codes at* [ key-modifiers swap ] [ drop f f ] if ;
-        nip >r key-modifiers r> t
+
-    ] [
+: send-key-gesture ( sym action? quot hWnd -- )
-        drop 1string >r key-modifiers r>
+    [ [ key-modifiers ] 3dip call ] dip
-        C+ pick member? >r A+ pick member? r> or [
+    window-focus propagate-gesture ; inline
-            shift? [ >lower ] unless f
+
-        ] [
+: send-key-down ( sym action? hWnd -- )
-            switch-case? [ switch-case ] when t
+    [ [ <key-down> ] ] dip send-key-gesture ;
-        ] if
+
-    ] if ;
+: send-key-up ( sym action? hWnd -- )
+    [ [ <key-up> ] ] 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 <key-down>
+        wParam key-sym over [
-        hWnd window-focus propagate-gesture
+            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 exclude-key-wm-char? [
+        ctrl? alt? xor [
             wParam 1string
-        hWnd window-focus user-input
+            [ f hWnd send-key-down ]
+            [ hWnd window-focus user-input ] bi
+        ] unless
     ] unless ;
 
 :: handle-wm-keyup ( hWnd uMsg wParam lParam -- )
-    wParam keystroke>gesture <key-up>
+    wParam exclude-key-wm-keydown? [
-    hWnd window-focus propagate-gesture ;
+        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 ] }
+        { WM_LBUTTONDOWN   [ 1 t ] }
-        { [ dup WM_LBUTTONUP     = ] [ drop 1 f ] }
+        { WM_LBUTTONUP     [ 1 f ] }
-        { [ dup WM_MBUTTONDOWN   = ] [ drop 2 t ] }
+        { WM_MBUTTONDOWN   [ 2 t ] }
-        { [ dup WM_MBUTTONUP     = ] [ drop 2 f ] }
+        { WM_MBUTTONUP     [ 2 f ] }
-        { [ dup WM_RBUTTONDOWN   = ] [ drop 3 t ] }
+        { WM_RBUTTONDOWN   [ 3 t ] }
-        { [ dup WM_RBUTTONUP     = ] [ drop 3 f ] }
+        { WM_RBUTTONUP     [ 3 f ] }
 
-        { [ dup WM_NCLBUTTONDOWN = ] [ drop 1 t ] }
+        { WM_NCLBUTTONDOWN [ 1 t ] }
-        { [ dup WM_NCLBUTTONUP   = ] [ drop 1 f ] }
+        { WM_NCLBUTTONUP   [ 1 f ] }
-        { [ dup WM_NCMBUTTONDOWN = ] [ drop 2 t ] }
+        { WM_NCMBUTTONDOWN [ 2 t ] }
-        { [ dup WM_NCMBUTTONUP   = ] [ drop 2 f ] }
+        { WM_NCMBUTTONUP   [ 2 f ] }
-        { [ dup WM_NCRBUTTONDOWN = ] [ drop 3 t ] }
+        { WM_NCRBUTTONDOWN [ 3 t ] }
-        { [ dup WM_NCRBUTTONUP   = ] [ drop 3 f ] }
+        { WM_NCRBUTTONUP   [ 3 f ] }
-    } cond ;
+    } case ;
 
 ! If the user clicks in the window border ("non-client area")
 ! Windows sends us an NC[LMR]BUTTONDOWN message; but if the

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." } ;

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*
+        [ "method-class" word-prop ]
-    ] 2cache ;
+        [
+            "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 ;

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-method
-SYMBOL: current-generic
 
-: with-method-definition ( quot -- parsed )
+: with-method-definition ( method quot -- )
-    [
+    [ dup current-method ] dip with-variable ; inline
-        [
-            [ "method-class" word-prop current-class set ]
-            [ "method-generic" word-prop current-generic set ]
-            [ ] tri
-        ] dip call
-    ] with-scope ; inline
 
 : (M:) ( method def -- )
     CREATE-METHOD [ parse-definition ] with-method-definition ;

core/syntax/syntax.factor

@@ -202,13 +202,12 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "call-next-method" [
-        current-class get current-generic get
+        current-method get [
-        2dup [ word? ] both? [
+            literalize parsed
-            [ literalize parsed ] bi@
             \ (call-next-method) parsed
         ] [
             not-in-a-method-error
-        ] if
+        ] if*
     ] define-syntax
     
     "initial:" "syntax" lookup define-symbol

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)