alien.libraries, compiler.cfg.builder.alien: if `dlopen` fails during `<library>`, call `dlerror` and store the error message in the library object; put the dlerror message in the linkage-error when a word from the library is compiled
							parent
							
								
									b6e0f0180b
								
							
						
					
					
						commit
						5703e8d7a1
					
				|  | @ -2,39 +2,37 @@ | |||
| ! See http://factorcode.org/license.txt for BSD license. | ||||
| USING: accessors alien alien.strings assocs io.backend | ||||
| kernel namespaces destructors sequences strings | ||||
| system io.pathnames fry ; | ||||
| system io.pathnames fry combinators vocabs.loader ; | ||||
| IN: alien.libraries | ||||
| 
 | ||||
| ERROR: unknown-dlsym-platform ; | ||||
| << { | ||||
|     { [ os windows? ] [ "alien.libraries.windows" ] } | ||||
|     { [ os unix? ] [ "alien.libraries.unix" ] } | ||||
|     [ unknown-dlsym-platform ] | ||||
| } cond use-vocab >> | ||||
| 
 | ||||
| : dlopen ( path -- dll ) native-string>alien (dlopen) ; | ||||
| 
 | ||||
| : dlsym ( name dll -- alien ) [ string>symbol ] dip (dlsym) ; | ||||
| 
 | ||||
| : dlsym-raw ( name dll -- alien ) [ string>symbol ] dip (dlsym-raw) ; | ||||
| 
 | ||||
| : dlerror ( -- message/f ) (dlerror) ; | ||||
| HOOK: dlerror os ( -- message/f ) | ||||
| 
 | ||||
| SYMBOL: libraries | ||||
| 
 | ||||
| libraries [ H{ } clone ] initialize | ||||
| 
 | ||||
| TUPLE: library { path string } { abi abi initial: cdecl } dll ; | ||||
| TUPLE: library { path string } { abi abi initial: cdecl } dll dlerror ; | ||||
| 
 | ||||
| ERROR: no-library name ; | ||||
| 
 | ||||
| : library ( name -- library ) libraries get at ; | ||||
| 
 | ||||
| : <library> ( path abi -- library ) | ||||
|     over dup [ dlopen ] when \ library boa ; | ||||
|     over dup | ||||
|     [ dlopen dup dll-valid? [ f ] [ dlerror ] if ] [ f ] if | ||||
|     \ library boa ; | ||||
| 
 | ||||
| : library-dll ( library -- dll ) | ||||
|     dup [ dll>> ] when ; | ||||
| 
 | ||||
| : load-library ( name -- dll ) | ||||
|     library dup [ dll>> ] when ; | ||||
|     library library-dll ; | ||||
| 
 | ||||
| M: dll dispose dlclose ; | ||||
| 
 | ||||
|  | @ -70,17 +68,9 @@ deploy-libraries [ V{ } clone ] initialize | |||
|     [ deploy-libraries get 2dup member? [ 2drop ] [ push ] if ] | ||||
|     [ no-library ] if ; | ||||
| 
 | ||||
| <PRIVATE | ||||
| 
 | ||||
| HOOK: >deployed-library-path os ( path -- path' ) | ||||
| 
 | ||||
| M: windows >deployed-library-path | ||||
|     file-name ; | ||||
| 
 | ||||
| M: unix >deployed-library-path | ||||
|     file-name "$ORIGIN" prepend-path ; | ||||
| 
 | ||||
| M: macosx >deployed-library-path | ||||
|     file-name "@executable_path/../Frameworks" prepend-path ; | ||||
| 
 | ||||
| PRIVATE> | ||||
| << { | ||||
|     { [ os windows? ] [ "alien.libraries.windows" ] } | ||||
|     { [ os unix? ] [ "alien.libraries.unix" ] } | ||||
| } cond require >> | ||||
|  |  | |||
|  | @ -1,5 +1,15 @@ | |||
| USING: alien.c-types alien.syntax io.encodings.utf8 ; | ||||
| USING: alien.c-types alien.libraries alien.syntax io.encodings.utf8 | ||||
| io.pathnames system ; | ||||
| IN: alien.libraries.unix | ||||
| 
 | ||||
| FUNCTION-ALIAS: (dlerror) | ||||
|     c-string[utf8] dlerror ( ) ; | ||||
|     c-string dlerror ( ) ; | ||||
| 
 | ||||
| M: unix dlerror (dlerror) ; | ||||
| 
 | ||||
| M: unix >deployed-library-path | ||||
|     file-name "$ORIGIN" prepend-path ; | ||||
| 
 | ||||
| M: macosx >deployed-library-path | ||||
|     file-name "@executable_path/../Frameworks" prepend-path ; | ||||
| 
 | ||||
|  |  | |||
|  | @ -1,5 +1,8 @@ | |||
| USING: windows.errors ; | ||||
| USING: alien.libraries io.pathnames system windows.errors ; | ||||
| IN: alien.libraries.windows | ||||
| 
 | ||||
| : (dlerror) ( -- message ) | ||||
| M: windows >deployed-library-path | ||||
|     file-name ; | ||||
| 
 | ||||
| M: windows dlerror ( -- message ) | ||||
|     win32-error-string ; | ||||
|  |  | |||
|  | @ -67,11 +67,17 @@ M: string dlsym-valid? dlsym ; | |||
| 
 | ||||
| M: array dlsym-valid? '[ _ dlsym ] any? ; | ||||
| 
 | ||||
| : check-dlsym ( symbols dll -- ) | ||||
|     dup dll-valid? [ | ||||
|         dupd dlsym-valid? | ||||
|         [ drop ] [ dlerror cfg get word>> no-such-symbol ] if | ||||
|     ] [ dll-path "" cfg get word>> no-such-library drop ] if ; | ||||
| : check-dlsym ( symbols library -- ) | ||||
|     { | ||||
|         { [ dup library-dll dll-valid? not ] [ | ||||
|             [ library-dll dll-path ] [ dlerror>> ] bi | ||||
|             cfg get word>> no-such-library drop  | ||||
|         ] } | ||||
|         { [ 2dup library-dll dlsym-valid? not ] [ | ||||
|             drop dlerror cfg get word>> no-such-symbol | ||||
|         ] } | ||||
|         [ 2drop ] | ||||
|     } cond ; | ||||
| 
 | ||||
| : decorated-symbol ( params -- symbols ) | ||||
|     [ function>> ] [ parameters>> [ stack-size ] map-sum number>string ] bi | ||||
|  | @ -85,7 +91,7 @@ M: array dlsym-valid? '[ _ dlsym ] any? ; | |||
| 
 | ||||
| : caller-linkage ( params -- symbols dll ) | ||||
|     [ dup abi>> callee-cleanup? [ decorated-symbol ] [ function>> ] if ] | ||||
|     [ library>> load-library ] | ||||
|     [ library>> library ] | ||||
|     bi 2dup check-dlsym ; | ||||
| 
 | ||||
| : caller-return ( params -- ) | ||||
|  |  | |||
		Loading…
	
		Reference in New Issue