Merge git://factorcode.org/git/factor

core/alien/alien.factor

@@ -53,18 +53,11 @@ TUPLE: library path abi dll ;
 
 : library ( name -- library ) libraries get at ;
 
-: <library> ( path abi -- library ) f \ library construct-boa ;
+: <library> ( path abi -- library )
+    over dup [ dlopen ] when \ library construct-boa ;
 
 : load-library ( name -- dll )
-    library dup [
-        dup library-dll [ ] [
-            dup library-path dup [
-                dlopen dup rot set-library-dll
-            ] [
-                2drop f
-            ] if
-        ] ?if
-    ] when ;
+    library library-dll ;
 
 : add-library ( name path abi -- )
     <library> swap libraries get set-at ;

core/alien/compiler/compiler.factor

@@ -213,30 +213,37 @@ TUPLE: no-such-library name ;
 M: no-such-library summary
     drop "Library not found" ;
 
+M: no-such-library compiler-error-type
+    drop +linkage+ ;
+
 : no-such-library ( name -- )
-    \ no-such-library +linkage+ (inference-error) ;
+    \ no-such-library construct-boa
+    compiling-word get compiler-error ;
 
-: (alien-invoke-dlsym) ( node -- symbol dll )
-    dup alien-invoke-function
-    swap alien-invoke-library [
-        load-library
-    ] [
-        2drop no-such-library
-    ] recover ;
-
-TUPLE: no-such-symbol ;
+TUPLE: no-such-symbol name ;
 
 M: no-such-symbol summary
     drop "Symbol not found" ;
 
-: no-such-symbol ( -- )
-    \ no-such-symbol +linkage+ (inference-error) ;
+M: no-such-symbol compiler-error-type
+    drop +linkage+ ;
 
-: alien-invoke-dlsym ( node -- symbol dll )
-    dup (alien-invoke-dlsym) 2dup dlsym [
-        >r over stdcall-mangle r> 2dup dlsym
-        [ no-such-symbol ] unless
-    ] unless rot drop ;
+: no-such-symbol ( name -- )
+    \ no-such-symbol construct-boa
+    compiling-word get compiler-error ;
+
+: check-dlsym ( symbols dll -- )
+    dup dll-valid? [
+        dupd [ dlsym ] curry contains?
+        [ drop ] [ no-such-symbol ] if
+    ] [
+        dll-path no-such-library drop
+    ] if ;
+
+: alien-invoke-dlsym ( node -- symbols dll )
+    dup alien-invoke-function dup pick stdcall-mangle 2array
+    swap alien-invoke-library library dup [ library-dll ] when
+    2dup check-dlsym ;
 
 \ alien-invoke [
     ! Four literals
@@ -247,8 +254,6 @@ M: no-such-symbol summary
     pop-literal nip over set-alien-invoke-function
     pop-literal nip over set-alien-invoke-library
     pop-literal nip over set-alien-invoke-return
-    ! If symbol doesn't resolve, no stack effect, no compile
-    dup alien-invoke-dlsym 2drop
     ! Quotation which coerces parameters to required types
     dup make-prep-quot recursive-state get infer-quot
     ! Add node to IR

core/bootstrap/primitives.factor

@@ -646,6 +646,7 @@ builtins get num-tags get tail f union-class define-class
     { "resize-byte-array" "byte-arrays" }
     { "resize-bit-array" "bit-arrays" }
     { "resize-float-array" "float-arrays" }
+    { "dll-valid?" "alien" }
 }
 dup length [ >r first2 r> make-primitive ] 2each
 

core/compiler/compiler.factor

@@ -24,7 +24,6 @@ IN: compiler
 
 : finish-compile ( word effect dependencies -- )
     >r dupd save-effect r>
-    f pick compiler-error
     over compiled-unxref
     over crossref? [ compiled-xref ] [ 2drop ] if ;
 
@@ -38,6 +37,7 @@ IN: compiler
     swap compiler-error ;
 
 : (compile) ( word -- )
+    f over compiler-error
     [ dup compile-succeeded finish-compile ]
     [ dupd compile-failed f save-effect ]
     recover ;

core/cpu/architecture/architecture.factor

@@ -128,7 +128,7 @@ HOOK: %prepare-var-args compiler-backend ( -- )
 
 M: object %prepare-var-args ;
 
-HOOK: %alien-invoke compiler-backend ( library function -- )
+HOOK: %alien-invoke compiler-backend ( function library -- )
 
 HOOK: %cleanup compiler-backend ( alien-node -- )
 

core/generator/fixup/fixup.factor

@@ -111,7 +111,8 @@ SYMBOL: literal-table
 : add-literal ( obj -- n ) literal-table get push-new* ;
 
 : string>symbol ( str -- alien )
-    wince? [ string>u16-alien ] [ string>char-alien ] if ;
+    [ wince? [ string>u16-alien ] [ string>char-alien ] if ]
+    over string? [ call ] [ map ] if ;
 
 : add-dlsym-literals ( symbol dll -- )
     >r string>symbol r> 2array literal-table get push-all ;

core/hashtables/hashtables-tests.factor

@@ -157,8 +157,12 @@ H{ } "x" set
 ] unit-test
 
 [ { "one" "two" 3 } ] [
-    H{ { 1 "one" } { 2 "two" } }
-    { 1 2 3 } clone [ substitute ] keep
+    { 1 2 3 } clone dup
+    H{ { 1 "one" } { 2 "two" } } substitute-here
+] unit-test
+
+[ { "one" "two" 3 } ] [
+    { 1 2 3 } H{ { 1 "one" } { 2 "two" } } substitute
 ] unit-test
 
 [ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test

core/inference/known-words/known-words.factor

@@ -596,3 +596,5 @@ set-primitive-effect
 \ (os-envs) { } { array } <effect> set-primitive-effect
 
 \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop
+
+\ dll-valid? { object } { object } <effect> set-primitive-effect

core/parser/parser-tests.factor

@@ -5,18 +5,6 @@ sorting tuples compiler.units ;
 IN: temporary
 
 [
-    [ 1 CHAR: a ]
-    [ 0 "abcd" next-char ] unit-test
-
-    [ 8 CHAR: \s ]
-    [ 1 "\\u000020hello" next-escape ] unit-test
-
-    [ 2 CHAR: \n ]
-    [ 1 "\\nhello" next-escape ] unit-test
-
-    [ 8 CHAR: \s ]
-    [ 0 "\\u000020hello" next-char ] unit-test
-
     [ 1 [ 2 [ 3 ] 4 ] 5 ]
     [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ]
     unit-test

extra/benchmark/reverse-complement/reverse-complement.factor

@@ -32,9 +32,13 @@ HINTS: do-line vector string ;
     readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
 
 : reverse-complement ( infile outfile -- )
-    <file-writer> >r <file-reader> r> <duplex-stream> [
-        500000 <vector> (reverse-complement)
-    ] with-stream ;
+    <file-writer> [
+        swap <file-reader> [
+            swap <duplex-stream> [
+                500000 <vector> (reverse-complement)
+            ] with-stream
+        ] with-disposal
+    ] with-disposal ;
 
 : reverse-complement-in
     "extra/benchmark/reverse-complement/reverse-complement-in.txt"

extra/cryptlib/streams/streams.factor

@@ -23,10 +23,10 @@ TUPLE: crypt-stream handle eof? ;
     CRYPT_SESSINFO_ACTIVE 1 set-attribute ;
 
 : <crypt-stream> ( handle -- stream )
-    crypt-stream construct-empty
-    over init-crypt-stream
-    default-buffer-size <buffer> over set-delegate
-    tuck set-crypt-stream-handle 
+    dup init-crypt-stream
+    default-buffer-size <buffer>
+    { set-crypt-stream-handle set-delegate }
+    crypt-stream construct
     dup <line-reader> swap <plain-writer> <duplex-stream> ;
 
 : check-read ( err -- eof? )

extra/fjsc/fjsc.factor

@@ -37,18 +37,15 @@ C: <ast-hashtable> ast-hashtable
 
 : identifier-middle? ( ch -- bool )
   [ blank? not ] keep
-  [ CHAR: } = not ] keep
-  [ CHAR: ] = not ] keep
-  [ CHAR: ;" = not ] keep
-  [ CHAR: " = not ] keep
+  [ "}];\"" member? not ] keep
   digit? not
-  and and and and and ;
+  and and ;
 
 MEMO: 'identifier-ends' ( -- parser )
   [
     [ blank? not ] keep
     [ CHAR: " = not ] keep
-    [ CHAR: ;" = not ] keep
+    [ CHAR: ; = not ] keep
     [ LETTER? not ] keep
     [ letter? not ] keep
     identifier-middle? not

extra/id3/id3.factor

@@ -3,7 +3,7 @@
 !
 
 USING: arrays combinators io io.binary io.files io.paths
-io.utf16 kernel math math.parser namespaces sequences
+io.encodings.utf16 kernel math math.parser namespaces sequences
 splitting strings assocs unicode.categories ;
 
 IN: id3

extra/optimizer/report/report.factor

@@ -1,13 +1,13 @@
 IN: optimizer.report
 USING: assocs words sequences arrays compiler tools.time
 io.styles io prettyprint vocabs kernel sorting generator
-optimizer ;
+optimizer math ;
 
 : count-optimization-passes ( nodes n -- n )
     >r optimize-1
     [ r> 1+ count-optimization-passes ] [ drop r> ] if ;
 
-: word-table
+: results
     [ [ second ] swap compose compare ] curry sort 20 tail*
     print
     standard-table-style

extra/raptor/raptor.factor

@@ -45,8 +45,13 @@ USING: io io.files io.streams.lines io.streams.plain io.streams.duplex
        listener ;
 
 : tty-listener ( tty -- )
-  [ <file-reader> ] [ <file-writer> ] bi <duplex-stream>
-  [ listener ] with-stream ;
+  dup <file-reader> [
+    swap <file-writer> [
+      <duplex-stream> [
+        listener
+      ] with-stream
+    ] with-disposal
+  ] with-disposal ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 

extra/smtp/smtp-tests.factor

@@ -62,7 +62,7 @@ IN: temporary
         "Subject: Factor rules"
         f
         f
-        " "
+        ""
         "Hi guys"
         "Bye guys"
     }

extra/tools/disassembler/disassembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files io words alien kernel math.parser alien.syntax
 io.launcher system assocs arrays sequences namespaces qualified
-system math windows.kernel32 generator.fixup ;
+system math generator.fixup ;
 IN: tools.disassembler
 
 : in-file "gdb-in.txt" resource-path ;

vm/alien.c

@@ -182,7 +182,7 @@ DEFINE_PRIMITIVE(dlopen)
 	F_DLL* dll = allot_object(DLL_TYPE,sizeof(F_DLL));
 	UNREGISTER_ROOT(path);
 	dll->path = path;
-	ffi_dlopen(dll,true);
+	ffi_dlopen(dll);
 	dpush(tag_object(dll));
 }
 
@@ -202,7 +202,7 @@ DEFINE_PRIMITIVE(dlsym)
 	{
 		d = untag_dll(dll);
 		if(d->dll == NULL)
-			general_error(ERROR_EXPIRED,dll,F,NULL);
+			dpush(F);
 	}
 
 	box_alien(ffi_dlsym(d,sym));
@@ -213,3 +213,15 @@ DEFINE_PRIMITIVE(dlclose)
 {
 	ffi_dlclose(untag_dll(dpop()));
 }
+
+DEFINE_PRIMITIVE(dll_validp)
+{
+	CELL dll = dpop();
+	if(dll == F)
+		dpush(T);
+	else
+	{
+		F_DLL *d = untag_dll(dll);
+		dpush(d->dll == NULL ? F : T);
+	}
+}

vm/alien.h

@@ -46,3 +46,4 @@ DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
 DECLARE_PRIMITIVE(dlopen);
 DECLARE_PRIMITIVE(dlsym);
 DECLARE_PRIMITIVE(dlclose);
+DECLARE_PRIMITIVE(dll_validp);

vm/code_heap.c

@@ -18,22 +18,37 @@ INLINE CELL get_literal(CELL literals_start, CELL num)
 void *get_rel_symbol(F_REL *rel, CELL literals_start)
 {
 	CELL arg = REL_ARGUMENT(rel);
-	F_SYMBOL *symbol = alien_offset(get_literal(literals_start,arg));
+	CELL symbol = get_literal(literals_start,arg);
 	CELL library = get_literal(literals_start,arg + 1);
+
 	F_DLL *dll = (library == F ? NULL : untag_dll(library));
 
 	if(dll != NULL && !dll->dll)
 		return undefined_symbol;
 
-	if(!symbol)
-		return undefined_symbol;
+	if(type_of(symbol) == BYTE_ARRAY_TYPE)
+	{
+		F_CHAR *name = alien_offset(symbol);
+		void *sym = ffi_dlsym(dll,name);
 
-	void *sym = ffi_dlsym(dll,symbol);
+		if(sym)
+			return sym;
+	}
+	else if(type_of(symbol) == ARRAY_TYPE)
+	{
+		CELL i;
+		F_ARRAY *names = untag_object(symbol);
+		for(i = 0; i < array_capacity(names); i++)
+		{
+			F_CHAR *name = alien_offset(array_nth(names,i));
+			void *sym = ffi_dlsym(dll,name);
 
-	if(sym)
-		return sym;
-	else
-		return undefined_symbol;
+			if(sym)
+				return sym;
+		}
+	}
+
+	return undefined_symbol;
 }
 
 /* Compute an address to store at a relocation */

vm/image.c

@@ -224,7 +224,7 @@ void relocate_object(CELL relocating)
 		fixup_quotation((F_QUOTATION *)relocating);
 		break;
 	case DLL_TYPE:
-		ffi_dlopen((F_DLL *)relocating,false);
+		ffi_dlopen((F_DLL *)relocating);
 		break;
 	case ALIEN_TYPE:
 		fixup_alien((F_ALIEN *)relocating);

vm/os-unix.c

@@ -20,25 +20,9 @@ void init_ffi(void)
 	null_dll = dlopen(NULL_DLL,RTLD_LAZY);
 }
 
-void ffi_dlopen(F_DLL *dll, bool error)
+void ffi_dlopen(F_DLL *dll)
 {
-	void *dllptr = dlopen(alien_offset(dll->path), RTLD_LAZY);
-
-	if(dllptr == NULL)
-	{
-		if(error)
-		{
-			general_error(ERROR_FFI,F,
-				tag_object(from_char_string(dlerror())),
-				NULL);
-		}
-		else
-			dll->dll = NULL;
-
-		return;
-	}
-
-	dll->dll = dllptr;
+	dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
 }
 
 void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)

vm/os-unix.h

@@ -27,7 +27,7 @@ typedef char F_SYMBOL;
 #define FPRINTF(stream,format,arg) fprintf(stream,format,arg)
 
 void init_ffi(void);
-void ffi_dlopen(F_DLL *dll, bool error);
+void ffi_dlopen(F_DLL *dll);
 void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
 void ffi_dlclose(F_DLL *dll);
 

vm/os-windows.c

@@ -43,20 +43,9 @@ void init_ffi(void)
 		fatal_error("GetModuleHandle(\"" FACTOR_DLL_NAME "\") failed", 0);
 }
 
-void ffi_dlopen (F_DLL *dll, bool error)
+void ffi_dlopen(F_DLL *dll)
 {
-	HMODULE module = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
-
-	if (!module)
-	{
-		dll->dll = NULL;
-		if(error)
-			general_error(ERROR_FFI,F,tag_object(get_error_message()),NULL);
-		else
-			return;
-	}
-
-	dll->dll = module;
+	dll->dll = LoadLibraryEx(alien_offset(dll->path), NULL, 0);
 }
 
 void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)

vm/os-windows.h

@@ -33,7 +33,7 @@ DLLEXPORT F_CHAR *error_message(DWORD id);
 void windows_error(void);
 
 void init_ffi(void);
-void ffi_dlopen(F_DLL *dll, bool error);
+void ffi_dlopen(F_DLL *dll);
 void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol);
 void ffi_dlclose(F_DLL *dll);
 

vm/primitives.c

@@ -188,4 +188,5 @@ void *primitives[] = {
 	primitive_resize_byte_array,
 	primitive_resize_bit_array,
 	primitive_resize_float_array,
+	primitive_dll_validp,
 };