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

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

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

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

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

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

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

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