steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Doug Coleman 2008-11-22 20:02:52 -06:00
parent bcd75e97d3 ec0d4717ca
commit 3a8f1b4966
16 changed files with 150 additions and 83 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/stage2.factor
View File

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

8
basis/stack-checker/transforms/transforms.factor
View File

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

2
basis/tools/deploy/backend/backend.factor
View File

@ -55,6 +55,8 @@ DEFER: ?make-staging-image
: staging-command-line ( profile -- flags )
[
"-staging" ,
dup empty? [
"-i=" my-boot-image-name append ,
] [

5
basis/tools/deploy/deploy-tests.factor
View File

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

4
basis/tools/deploy/shaker/next-methods.factor Normal file
View File

@ -0,0 +1,4 @@
USING: words ;
IN: generic
: next-method-quot ( method -- quot ) "next-method-quot" word-prop ;

39
basis/tools/deploy/shaker/shaker.factor
View File

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

8
basis/tools/deploy/shaker/strip-debugger.factor
View File

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

18
basis/tools/deploy/test/7/7.factor Normal file
View File

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

15
basis/tools/deploy/test/7/deploy.factor Normal file
View File

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

2
basis/tools/walker/walker.factor
View File

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

92
basis/ui/windows/windows.factor Normal file → Executable file
View File

@ -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 -- )
[ [ <key-down> ] ] dip send-key-gesture ;
: 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>
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 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>
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

2
core/generic/generic-docs.factor
View File

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

12
core/generic/generic.factor
View File

@ -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 ;

13
core/generic/parser/parser.factor
View File

@ -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 ;

7
core/syntax/syntax.factor
View File

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

2
vm/debug.c
View File

@ -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)