linkage errors don't thwart compilation anymore

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

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,
 };