diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 475cf72d28..95b29ee50b 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -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\"" } } }
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 0369d55fb3..bce2e16d73 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -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 ;
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index c3f5c64b29..f1d8abdc1e 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -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 ]
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 0e038d0a10..74b4d03cbb 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -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
diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor
index 40bcbe78b1..ad2fa14954 100755
--- a/core/debugger/debugger.factor
+++ b/core/debugger/debugger.factor
@@ -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" ;
diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor
index 4e8fb255dd..ebbce4d7e2 100755
--- a/core/definitions/definitions-tests.factor
+++ b/core/definitions/definitions-tests.factor
@@ -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
[ ] [
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index 9b799d9143..62b85dde3a 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -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" } }
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 3c83b87d49..ad31831e94 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -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
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index 27b0ddb7a2..9fd5481a39 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -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 )
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 313f487c99..c634e02e75 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -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#)
diff --git a/core/io/files/files.factor b/core/io/files/files.factor
index e5c6ca9ce5..a6320a7507 100755
--- a/core/io/files/files.factor
+++ b/core/io/files/files.factor
@@ -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
diff --git a/core/io/io.factor b/core/io/io.factor
index 2d927d088a..ef9eae7902 100755
--- a/core/io/io.factor
+++ b/core/io/io.factor
@@ -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 ;
diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor
index 10a9fda3ea..5153d84c7f 100755
--- a/core/optimizer/specializers/specializers.factor
+++ b/core/optimizer/specializers/specializers.factor
@@ -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 ;
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 50f8f582d3..c955817ab9 100755
--- a/core/parser/parser.factor
+++ b/core/parser/parser.factor
@@ -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 )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 92d22247bd..7e9046573f 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -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 ;
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 79a5553228..d9870b08da 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -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
diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor
index c2e627e7bf..d746404cba 100755
--- a/core/threads/threads-tests.factor
+++ b/core/threads/threads-tests.factor
@@ -14,3 +14,5 @@ yield
[ 3 ] [
[ 3 swap resume-with ] "Test suspend" suspend
] unit-test
+
+[ f ] [ f get-global ] unit-test
diff --git a/core/threads/threads.factor b/core/threads/threads.factor
index b4fd6eee60..d7d7988893 100755
--- a/core/threads/threads.factor
+++ b/core/threads/threads.factor
@@ -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 -- ? )
diff --git a/core/tuples/tuples-docs.factor b/core/tuples/tuples-docs.factor
index c03b9784ee..3af7d27d86 100755
--- a/core/tuples/tuples-docs.factor
+++ b/core/tuples/tuples-docs.factor
@@ -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" } }
diff --git a/core/words/words.factor b/core/words/words.factor
index ce69c1ff2e..73b877fdbb 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -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 ;
diff --git a/extra/bootstrap/tools/tools.factor b/extra/bootstrap/tools/tools.factor
index 0bf7a032ee..670bca4903 100755
--- a/extra/bootstrap/tools/tools.factor
+++ b/extra/bootstrap/tools/tools.factor
@@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
"tools.threads"
"tools.vocabs"
"tools.vocabs.browser"
+ "tools.vocabs.monitor"
"editors"
} [ require ] each
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 654d096b26..9eabfae95c 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -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 ;
diff --git a/extra/help/help-tests.factor b/extra/help/help-tests.factor
new file mode 100644
index 0000000000..e38f2fc15d
--- /dev/null
+++ b/extra/help/help-tests.factor
@@ -0,0 +1,5 @@
+IN: help.tests
+USING: tools.test help kernel ;
+
+[ 3 throw ] must-fail
+[ ] [ :help ] unit-test
diff --git a/extra/help/help.factor b/extra/help/help.factor
index 85f5a35a5c..34e90b2ccf 100755
--- a/extra/help/help.factor
+++ b/extra/help/help.factor
@@ -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
diff --git a/extra/io/unix/unix.factor b/extra/io/unix/unix.factor
index 01e29866eb..1f0492a060 100755
--- a/extra/io/unix/unix.factor
+++ b/extra/io/unix/unix.factor
@@ -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
diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor
index 319acc35f8..1baec5658f 100755
--- a/extra/io/windows/nt/nt.factor
+++ b/extra/io/windows/nt/nt.factor
@@ -13,5 +13,3 @@ USE: io.windows.files
USE: io.backend
T{ windows-nt-io } set-io-backend
-
-"tools.vocabs.monitor" require
diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor
index b4f1b0a61e..bd1e62f22a 100755
--- a/extra/locals/locals-tests.factor
+++ b/extra/locals/locals-tests.factor
@@ -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
diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor
index 9819e65e37..a8f5e139e7 100755
--- a/extra/locals/locals.factor
+++ b/extra/locals/locals.factor
@@ -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
diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor
index 5846515dca..42545500a5 100755
--- a/extra/logging/logging.factor
+++ b/extra/logging/logging.factor
@@ -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
diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor
index 3b0b8fd29f..ab915ae7d5 100755
--- a/extra/memoize/memoize.factor
+++ b/extra/memoize/memoize.factor
@@ -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 ;
diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor
index 5baa205d15..079f484274 100755
--- a/extra/multiline/multiline.factor
+++ b/extra/multiline/multiline.factor
@@ -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 )
diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor
index bc65f72435..d06afdc5ea 100755
--- a/extra/openssl/libcrypto/libcrypto.factor
+++ b/extra/openssl/libcrypto/libcrypto.factor
@@ -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
diff --git a/extra/openssl/libssl/libssl.factor b/extra/openssl/libssl/libssl.factor
old mode 100644
new mode 100755
index d8709cbf53..11dcee31f6
--- a/extra/openssl/libssl/libssl.factor
+++ b/extra/openssl/libssl/libssl.factor
@@ -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 >>
diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor
index 3724b929f0..469f6a91ed 100755
--- a/extra/promises/promises.factor
+++ b/extra/promises/promises.factor
@@ -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
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index edf78de479..44fb15ac7e 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -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 ;
diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor
index 8dca72c29e..e9527e6f9a 100755
--- a/extra/ui/freetype/freetype.factor
+++ b/extra/ui/freetype/freetype.factor
@@ -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
diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor
index 8eb5fe59aa..0c9c23cf76 100755
--- a/extra/ui/windows/windows.factor
+++ b/extra/ui/windows/windows.factor
@@ -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
diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor
index 11be803893..d8e1e8937a 100755
--- a/extra/unicode/data/data.factor
+++ b/extra/unicode/data/data.factor
@@ -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 ;
diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor
index 39879bf91d..e3e8a23ca7 100755
--- a/extra/windows/user32/user32.factor
+++ b/extra/windows/user32/user32.factor
@@ -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
diff --git a/vm/code_gc.c b/vm/code_gc.c
index 5c51fe7e8b..5b0d2ebabb 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -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)
{
diff --git a/vm/data_gc.h b/vm/data_gc.h
index d9c3d8eb1c..8f93ce79a1 100755
--- a/vm/data_gc.h
+++ b/vm/data_gc.h
@@ -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))