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

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

db4
Eduardo Cavazos 2008-03-16 15:58:14 -06:00
parent 3d2ee2a35c 8a8a94206d
commit 4e0c0dab49
41 changed files with 197 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/alien/alien-docs.factor
View File

@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
HELP: load-library
{ $values { "name" "a string" } { "dll" "a DLL handle" } }
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
HELP: add-library
{ $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }

2
core/alien/alien.factor
View File

@ -57,7 +57,7 @@ TUPLE: library path abi dll ;
over dup [ dlopen ] when \ library construct-boa ;
: load-library ( name -- dll )
library library-dll ;
library dup [ library-dll ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;

4
core/alien/c-types/c-types.factor
View File

@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- )
r> add*
] when ;
: malloc-file-contents ( path -- alien )
binary file-contents malloc-byte-array ;
: malloc-file-contents ( path -- alien len )
binary file-contents dup malloc-byte-array swap length ;
[
[ alien-cell ]

1
core/bootstrap/stage1.factor
View File

@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
"listener" vocab
[ restarts. vocab-main execute ]
[ die ] if*
1 exit
] recover
] [
"Cannot find " write write "." print

2
core/debugger/debugger.factor
View File

@ -214,7 +214,7 @@ M: check-closed summary
drop "Attempt to perform I/O on closed stream" ;
M: check-method summary
drop "Invalid parameters for define-method" ;
drop "Invalid parameters for create-method" ;
M: check-tuple summary
drop "Invalid class for define-constructor" ;

6
core/definitions/definitions-tests.factor
View File

@ -1,10 +1,10 @@
IN: definitions.tests
USING: tools.test generic kernel definitions sequences
compiler.units ;
compiler.units words ;
TUPLE: combination-1 ;
M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
M: combination-1 perform-combination 2drop [ ] ;
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
@ -13,7 +13,7 @@ SYMBOL: generic-1
[
generic-1 T{ combination-1 } define-generic
[ ] object \ generic-1 define-method
object \ generic-1 create-method [ ] define
] with-compilation-unit
[ ] [

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

@ -34,7 +34,7 @@ $nl
{ $subsection define-generic }
{ $subsection define-simple-generic }
"Methods can be added to existing generic words:"
{ $subsection define-method }
{ $subsection create-method }
"Method definitions can be looked up:"
{ $subsection method }
{ $subsection methods }
@ -123,7 +123,7 @@ HELP: method
{ $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
{ $description "Looks up a method definition." } ;
{ method define-method POSTPONE: M: } related-words
{ method create-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
@ -140,16 +140,17 @@ HELP: order
HELP: check-method
{ $values { "class" class } { "generic" generic } }
{ $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
HELP: with-methods
{ $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
{ $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
$low-level-note ;
HELP: define-method
{ $values { "quot" quotation } { "class" class } { "generic" generic } }
{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
HELP: create-method
{ $values { "class" class } { "generic" generic } { "method" method-body } }
{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
{ $notes "To define a method, pass the output value to " { $link define } "." } ;
HELP: implementors
{ $values { "class" class } { "seq" "a sequence of generic words" } }

54
core/generic/generic.factor
View File

@ -17,10 +17,6 @@ M: object perform-combination
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
GENERIC: method-prologue ( class combination -- quot )
M: object method-prologue 2drop [ ] ;
GENERIC: make-default-method ( generic combination -- method )
PREDICATE: word generic "combination" word-prop >boolean ;
@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
: check-method ( class generic -- class generic )
over class? over generic? and [
\ check-method construct-boa throw
] unless ;
] unless ; inline
: with-methods ( word quot -- )
: with-methods ( generic quot -- )
swap [ "methods" word-prop swap call ] keep make-generic ;
inline
: method-word-name ( class word -- string )
word-name "/" rot word-name 3append ;
: make-method-def ( quot class generic -- quot )
"combination" word-prop method-prologue swap append ;
PREDICATE: word method-body "method-def" word-prop >boolean ;
PREDICATE: word method-body
"method-generic" word-prop >boolean ;
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
: method-word-props ( quot class generic -- assoc )
: method-word-props ( class generic -- assoc )
[
"method-generic" set
"method-class" set
"method-def" set
] H{ } make-assoc ;
: <method> ( quot class generic -- method )
: <method> ( class generic -- method )
check-method
[ make-method-def ] 3keep
[ method-word-props ] 2keep
method-word-name f <word>
tuck set-word-props
dup rot define ;
[ set-word-props ] keep ;
: redefine-method ( quot class generic -- )
[ method swap "method-def" set-word-prop ] 3keep
[ make-method-def ] 2keep
method swap define ;
: reveal-method ( method class generic -- )
[ set-at ] with-methods ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
2dup method [
redefine-method
: create-method ( class generic -- method )
2dup method dup [
2nip
] [
[ <method> ] 2keep
[ set-at ] with-methods
drop [ <method> dup ] 2keep reveal-method
] if ;
: <default-method> ( generic combination -- method )
object bootstrap-word pick <method>
[ -rot make-default-method define ] keep ;
: define-default-method ( generic combination -- )
dupd make-default-method object bootstrap-word pick <method>
"default-method" set-word-prop ;
dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
M: method-spec where
@ -108,11 +98,10 @@ M: method-spec set-where
first2 method set-where ;
M: method-spec definer
drop \ M: \ ; ;
first2 method definer ;
M: method-spec definition
first2 method dup
[ "method-def" word-prop ] when ;
first2 method definition ;
: forget-method ( class generic -- )
check-method
@ -125,9 +114,6 @@ M: method-spec forget*
M: method-body definer
drop \ M: \ ; ;
M: method-body definition
"method-def" word-prop ;
M: method-body forget*
dup "method-class" word-prop
swap "method-generic" word-prop

2
core/generic/math/math.factor
View File

@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
: applicable-method ( generic class -- quot )
over method
[ word-def ]
[ 1quotation ]
[ default-math-method ] ?if ;
: object-method ( generic -- quot )

4
core/generic/standard/standard.factor
View File

@ -8,10 +8,6 @@ IN: generic.standard
TUPLE: standard-combination # ;
M: standard-combination method-prologue
standard-combination-# object
<array> swap add* [ declare ] curry ;
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)

5
core/io/files/files.factor
View File

@ -216,10 +216,7 @@ M: pathname <=> [ pathname-string ] compare ;
>r <file-reader> r> with-stream ; inline
: file-contents ( path encoding -- str )
dupd [ file-info file-info-size read ] with-file-reader ;
! : file-contents ( path encoding -- str )
! dupd [ file-length read ] with-file-reader ;
<file-reader> contents ;
: with-file-writer ( path encoding quot -- )
>r <file-writer> r> with-stream ; inline

8
core/io/io.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables generic kernel math namespaces sequences strings
continuations assocs io.styles sbufs ;
USING: hashtables generic kernel math namespaces sequences
continuations assocs io.styles ;
IN: io
GENERIC: stream-readln ( stream -- str )
@ -88,4 +88,6 @@ SYMBOL: stderr
[ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
: contents ( stream -- str )
2048 <sbuf> [ stream-copy ] keep >string ;
[
[ 65536 read dup ] [ ] [ drop ] unfold concat f like
] with-stream ;

36
core/optimizer/specializers/specializers.factor
View File

@ -24,20 +24,40 @@ IN: optimizer.specializers
\ dispatch ,
] [ ] make ;
: specializer-methods ( quot word -- default alist )
: specializer-cases ( quot word -- default alist )
dup [ array? ] all? [ 1array ] unless [
[ make-specializer ] keep
[ declare ] curry pick append
] { } map>assoc ;
: method-declaration ( method -- quot )
dup "method-generic" word-prop dispatch# object <array>
swap "method-class" word-prop add* ;
: specialize-method ( quot method -- quot' )
method-declaration [ declare ] curry swap append ;
: specialize-quot ( quot specializer -- quot' )
dup { number } = [
drop tag-specializer
] [
specializer-cases alist>quot
] if ;
: standard-method? ( method -- ? )
dup method-body? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
: specialized-def ( word -- quot )
dup word-def swap "specializer" word-prop [
dup { number } = [
drop tag-specializer
] [
specializer-methods alist>quot
] if
] when* ;
dup word-def swap {
{ [ dup standard-method? ] [ specialize-method ] }
{
[ dup "specializer" word-prop ]
[ "specializer" word-prop specialize-quot ]
}
{ [ t ] [ drop ] }
} cond ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;

20
core/parser/parser.factor
View File

@ -215,9 +215,6 @@ SYMBOL: in
: set-in ( name -- )
check-vocab-string dup in set create-vocab (use+) ;
: create-in ( string -- word )
in get create dup set-word dup save-location ;
TUPLE: unexpected want got ;
: unexpected ( want got -- * )
@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
: parse-tokens ( end -- seq )
100 <vector> swap (parse-tokens) >array ;
: create-in ( string -- word )
in get create dup set-word dup save-location ;
: CREATE ( -- word ) scan create-in ;
: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
: create-class-in ( word -- word )
in get create
dup save-class-location
@ -284,6 +288,12 @@ M: no-word summary
] ?if
] when ;
: create-method-in ( class generic -- method )
create-method f set-word dup save-location ;
: CREATE-METHOD ( -- method )
scan-word scan-word create-method-in ;
TUPLE: staging-violation word ;
: staging-violation ( word -- * )
@ -355,7 +365,9 @@ TUPLE: bad-number ;
: parse-definition ( -- quot )
\ ; parse-until >quotation ;
: (:) CREATE dup reset-generic parse-definition ;
: (:) CREATE-WORD parse-definition ;
: (M:) CREATE-METHOD parse-definition ;
GENERIC: expected>string ( obj -- str )

3
core/slots/slots.factor
View File

@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
C: <slot-spec> slot-spec
: define-typecheck ( class generic quot -- )
over define-simple-generic -rot define-method ;
over define-simple-generic
>r create-method r> define ;
: define-slot-word ( class slot word quot -- )
rot >fixnum add* define-typecheck ;

19
core/syntax/syntax.factor
View File

@ -97,7 +97,7 @@ IN: bootstrap.syntax
"parsing" [ word t "parsing" set-word-prop ] define-syntax
"SYMBOL:" [
CREATE dup reset-generic define-symbol
CREATE-WORD define-symbol
] define-syntax
"DEFER:" [
@ -111,31 +111,26 @@ IN: bootstrap.syntax
] define-syntax
"GENERIC:" [
CREATE dup reset-word
define-simple-generic
CREATE-GENERIC define-simple-generic
] define-syntax
"GENERIC#" [
CREATE dup reset-word
CREATE-GENERIC
scan-word <standard-combination> define-generic
] define-syntax
"MATH:" [
CREATE dup reset-word
CREATE-GENERIC
T{ math-combination } define-generic
] define-syntax
"HOOK:" [
CREATE dup reset-word scan-word
CREATE-GENERIC scan-word
<hook-combination> define-generic
] define-syntax
"M:" [
f set-word
location >r
scan-word bootstrap-word scan-word
[ parse-definition -rot define-method ] 2keep
2array r> remember-definition
(M:) define
] define-syntax
"UNION:" [
@ -163,7 +158,7 @@ IN: bootstrap.syntax
] define-syntax
"C:" [
CREATE dup reset-generic
CREATE-WORD
scan-word dup check-tuple
[ construct-boa ] curry define-inline
] define-syntax

2
core/threads/threads-tests.factor
View File

@ -14,3 +14,5 @@ yield
[ 3 ] [
[ 3 swap resume-with ] "Test suspend" suspend
] unit-test
[ f ] [ f get-global ] unit-test

2
core/threads/threads.factor
View File

@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
: threads 41 getenv ;
threads global [ H{ } assoc-like ] change-at
: thread ( id -- thread ) threads at ;
: thread-registered? ( thread -- ? )

20
core/tuples/tuples-docs.factor
View File

@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots"
$nl
"A shortcut for defining BOA constructors:"
{ $subsection POSTPONE: C: }
"Examples of constructors:"
{ $code
"TUPLE: color red green blue alpha ;"
""
"C: <rgba> rgba"
": <rgba> color construct-boa ; ! identical to above"
""
": <rgb>"
" { set-color-red set-color-green set-color-blue }"
" color construct ;"
": <rgb> f <rgba> ; ! identical to above"
""
": <color> construct-empty ;"
": <color> { } color construct ; ! identical to above"
": <color> f f f f <rgba> ; ! identical to above"
}
"After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
ARTICLE: "tuple-delegation" "Delegation"
@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples"
"Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
{ $subsection POSTPONE: TUPLE: }
"An example:"
{ $code "TUPLE: person name address phone ;" }
"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
{ $code "TUPLE: person name address phone ;" "C: <person> person" }
"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
{ $table
{ "Reader" "Writer" }
{ { $snippet "person-name" } { $snippet "set-person-name" } }

2
core/words/words.factor
View File

@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
: crossref? ( word -- ? )
{
{ [ dup "forgotten" word-prop ] [ f ] }
{ [ dup "method-def" word-prop ] [ t ] }
{ [ dup "method-generic" word-prop ] [ t ] }
{ [ dup word-vocabulary ] [ t ] }
{ [ t ] [ f ] }
} cond nip ;

1
extra/bootstrap/tools/tools.factor
View File

@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
"tools.vocabs.monitor"
"editors"
} [ require ] each

2
extra/delegate/delegate.factor
View File

@ -7,7 +7,7 @@ IN: delegate
swap { } like "protocol-words" set-word-prop ;
: PROTOCOL:
CREATE dup reset-generic dup define-symbol
CREATE-WORD dup define-symbol
parse-definition swap define-protocol ; parsing
PREDICATE: word protocol "protocol-words" word-prop ;

5
extra/help/help-tests.factor Normal file
View File

@ -0,0 +1,5 @@
IN: help.tests
USING: tools.test help kernel ;
[ 3 throw ] must-fail
[ ] [ :help ] unit-test

2
extra/help/help.factor
View File

@ -136,7 +136,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
":edit - jump to source location (parse errors only)" print
":get ( var -- value ) accesses variables at time of the error" print
":vars - list all variables at error time";
":vars - list all variables at error time" print ;
: :help ( -- )
error get delegates [ error-help ] map [ ] subset

2
extra/io/unix/unix.factor
View File

@ -3,5 +3,3 @@ io.unix.launcher io.unix.mmap io.backend
combinators namespaces system vocabs.loader sequences ;
"io.unix." os append require
"tools.vocabs.monitor" require

2
extra/io/windows/nt/nt.factor
View File

@ -13,5 +13,3 @@ USE: io.windows.files
USE: io.backend
T{ windows-nt-io } set-io-backend
"tools.vocabs.monitor" require

19
extra/locals/locals-tests.factor
View File

@ -1,5 +1,6 @@
USING: locals math sequences tools.test hashtables words kernel
namespaces arrays strings prettyprint ;
namespaces arrays strings prettyprint io.streams.string parser
;
IN: locals.tests
:: foo ( a b -- a a ) a a ;
@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
[ "[| a! | ]" ] [
[| a! | ] unparse
] unit-test
DEFER: xyzzy
[ ] [
"IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
[ 10 ] [ 10 xyzzy ] unit-test
[ ] [
"IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
<string-reader> "lambda-generic-test" parse-stream drop
] unit-test
[ 5 ] [ 10 xyzzy ] unit-test

20
extra/locals/locals.factor
View File

@ -249,13 +249,14 @@ M: wlet local-rewrite*
word [ over "declared-effect" set-word-prop ] when*
effect-in make-locals ;
: ((::)) ( word -- word quot )
: parse-locals-definition ( word -- word quot )
scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
2dup "lambda" set-word-prop
lambda-rewrite first ;
: (::) ( -- word quot )
CREATE dup reset-generic ((::)) ;
: (::) CREATE-WORD parse-locals-definition ;
: (M::) CREATE-METHOD parse-locals-definition ;
PRIVATE>
@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
: :: (::) define ; parsing
! This will be cleaned up when method tuples and method words
! are unified
: create-method ( class generic -- method )
2dup method dup
[ 2nip ]
[ drop 2dup [ ] -rot define-method create-method ] if ;
: CREATE-METHOD ( -- class generic body )
scan-word bootstrap-word scan-word 2dup
create-method f set-word dup save-location ;
: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
: M:: (M::) define ; parsing
: MACRO:: (::) define-macro ; parsing

3
extra/logging/logging.factor
View File

@ -127,8 +127,7 @@ PRIVATE>
: LOG:
#! Syntax: name level
CREATE
dup reset-generic
CREATE-WORD
dup scan-word
[ >r >r 1array stack>message r> r> log-message ] 2curry
define ; parsing

2
extra/memoize/memoize.factor
View File

@ -40,7 +40,7 @@ IN: memoize
over make-memoizer define ;
: MEMO:
CREATE dup reset-generic parse-definition define-memoized ; parsing
CREATE-WORD parse-definition define-memoized ; parsing
PREDICATE: word memoized "memoize" word-prop ;

2
extra/multiline/multiline.factor
View File

@ -18,7 +18,7 @@ IN: multiline
lexer get next-line ;
: STRING:
CREATE dup reset-generic
CREATE-WORD
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )

2
extra/openssl/libcrypto/libcrypto.factor
View File

@ -11,7 +11,7 @@ IN: openssl.libcrypto
<<
"libcrypto" {
{ [ win32? ] [ "libeay32.dll" "stdcall" ] }
{ [ win32? ] [ "libeay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
{ [ unix? ] [ "libcrypto.so" "cdecl" ] }
} cond add-library

2
extra/openssl/libssl/libssl.factor Normal file → Executable file
View File

@ -10,7 +10,7 @@ USING: alien alien.syntax combinators kernel system ;
IN: openssl.libssl
<< "libssl" {
{ [ win32? ] [ "ssleay32.dll" "stdcall" ] }
{ [ win32? ] [ "ssleay32.dll" "cdecl" ] }
{ [ macosx? ] [ "libssl.dylib" "cdecl" ] }
{ [ unix? ] [ "libssl.so" "cdecl" ] }
} cond add-library >>

2
extra/promises/promises.factor
View File

@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ;
] [ ] make ;
: LAZY:
CREATE dup reset-generic
CREATE-WORD
dup parse-definition
make-lazy-quot define ; parsing

7
extra/tools/deploy/shaker/shaker.factor
View File

@ -133,9 +133,10 @@ IN: tools.deploy.shaker
strip-io? [ io.backend:io-backend , ] when
[
io.backend:io-backend
io.backend:io-backend ,
"default-buffer-size" "io.nonblocking" lookup ,
] { "alarms" "io" "tools" } strip-vocab-globals %
] { } make
{ "alarms" "io" "tools" } strip-vocab-globals %
strip-dictionary? [
{ } { "cpu" } strip-vocab-globals %
@ -193,7 +194,7 @@ IN: tools.deploy.shaker
global swap
'[ drop , member? not ] assoc-subset
[ drop string? not ] assoc-subset ! strip CLI args
dup keys .
dup keys unparse show
21 setenv
] [ drop ] if ;

5
extra/ui/freetype/freetype.factor
View File

@ -73,10 +73,7 @@ M: freetype-renderer free-fonts ( world -- )
] keep *void* ;
: open-face ( font style -- face )
ttf-name ttf-path
dup malloc-file-contents
swap file-info file-info-size
(open-face) ;
ttf-name ttf-path malloc-file-contents (open-face) ;
SYMBOL: dpi

27
extra/ui/windows/windows.factor
View File

@ -376,6 +376,22 @@ SYMBOL: trace-messages?
: peek-message? ( msg -- ? ) f 0 0 PM_REMOVE PeekMessage zero? ;
! ! ! !
: set-world-dim ( dim world -- )
swap >r world-handle win-hWnd HWND_TOP 20 20 r> first2 0
SetWindowPos drop ;
USE: random
USE: arrays
: twiddle
100 500 random +
100 500 random +
2array
"x" get-global find-world
set-world-dim
yield ;
! ! ! !
: event-loop ( msg -- )
{
{ [ windows get empty? ] [ drop ] }
@ -436,17 +452,16 @@ SYMBOL: trace-messages?
: init-win32-ui ( -- )
V{ } clone nc-buttons set-global
"MSG" <c-object> msg-obj set-global
"MSG" malloc-object msg-obj set-global
"Factor-window" malloc-u16-string class-name-ptr set-global
register-wndclassex drop
GetDoubleClickTime double-click-timeout set-global ;
: cleanup-win32-ui ( -- )
class-name-ptr get-global [
dup f UnregisterClass drop
free
] when*
f class-name-ptr set-global ;
class-name-ptr get-global [ dup f UnregisterClass drop free ] when*
msg-obj get-global [ free ] when*
f class-name-ptr set-global
f msg-obj set-global ;
: setup-pixel-format ( hdc -- )
16 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep

2
extra/unicode/data/data.factor
View File

@ -5,7 +5,7 @@ IN: unicode.data
<<
: VALUE:
CREATE dup reset-generic { f } clone [ first ] curry define ; parsing
CREATE-WORD { f } clone [ first ] curry define ; parsing
: set-value ( value word -- )
word-def first set-first ;

8
extra/windows/user32/user32.factor
View File

@ -1283,7 +1283,13 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ;
! FUNCTION: SetWindowLongA
! FUNCTION: SetWindowLongW
! FUNCTION: SetWindowPlacement
! FUNCTION: SetWindowPos
FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ;
: HWND_BOTTOM ALIEN: 1 ;
: HWND_NOTOPMOST ALIEN: -2 ;
: HWND_TOP ALIEN: 0 ;
: HWND_TOPMOST ALIEN: -1 ;
! FUNCTION: SetWindowRgn
! FUNCTION: SetWindowsHookA
! FUNCTION: SetWindowsHookExA

2
vm/code_gc.c
View File

@ -375,6 +375,8 @@ void forward_object_xts(void)
F_WORD *word = untag_object(obj);
word->code = forward_xt(word->code);
if(word->profiling)
word->profiling = forward_xt(word->profiling);
}
else if(type_of(obj) == QUOTATION_TYPE)
{

9
vm/data_gc.h
View File

@ -263,13 +263,18 @@ DEFPUSHPOP(root_,extra_roots)
#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0)
#define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop())
INLINE bool in_data_heap_p(CELL ptr)
{
return (ptr >= data_heap->segment->start
&& ptr <= data_heap->segment->end);
}
/* We ignore strings which point outside the data heap, but we might be given
a char* which points inside the data heap, in which case it is a root, for
example if we call unbox_char_string() the result is placed in a byte array */
INLINE bool root_push_alien(const void *ptr)
{
if((CELL)ptr > data_heap->segment->start
&& (CELL)ptr < data_heap->segment->end)
if(in_data_heap_p((CELL)ptr))
{
F_BYTE_ARRAY *objptr = ((F_BYTE_ARRAY *)ptr) - 1;
if(objptr->header == tag_header(BYTE_ARRAY_TYPE))