diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 317dac803e..0369d55fb3 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -53,18 +53,11 @@ TUPLE: library path abi dll ; : library ( name -- library ) libraries get at ; -: ( path abi -- library ) f \ library construct-boa ; +: ( 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 -- ) swap libraries get set-at ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index f68bdcf0a2..3a41b80c2a 100755 --- a/core/alien/compiler/compiler.factor +++ b/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 diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 66ede8b054..05850e10ee 100755 --- a/core/bootstrap/primitives.factor +++ b/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 diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index f44e6c1387..b40c5afd33 100755 --- a/core/compiler/compiler.factor +++ b/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 ; diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4bb10b23a2..cd6c8b61f7 100755 --- a/core/cpu/architecture/architecture.factor +++ b/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 -- ) diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 25e2f8222b..3ee93ba4a5 100755 --- a/core/generator/fixup/fixup.factor +++ b/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 ; diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index acb05be720..31486372f2 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/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 diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 9d0f959b68..2173d5d4e1 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -596,3 +596,5 @@ set-primitive-effect \ (os-envs) { } { array } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop + +\ dll-valid? { object } { object } set-primitive-effect diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index c40bc54335..b89f56334b 100755 --- a/core/parser/parser-tests.factor +++ b/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 diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor old mode 100644 new mode 100755 index cc20b4b349..d509803896 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/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 -- ) - >r r> [ - 500000 (reverse-complement) - ] with-stream ; + [ + swap [ + swap [ + 500000 (reverse-complement) + ] with-stream + ] with-disposal + ] with-disposal ; : reverse-complement-in "extra/benchmark/reverse-complement/reverse-complement-in.txt" diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor index 04106285e0..9473e6063f 100755 --- a/extra/cryptlib/streams/streams.factor +++ b/extra/cryptlib/streams/streams.factor @@ -23,10 +23,10 @@ TUPLE: crypt-stream handle eof? ; CRYPT_SESSINFO_ACTIVE 1 set-attribute ; : ( handle -- stream ) - crypt-stream construct-empty - over init-crypt-stream - default-buffer-size over set-delegate - tuck set-crypt-stream-handle + dup init-crypt-stream + default-buffer-size + { set-crypt-stream-handle set-delegate } + crypt-stream construct dup swap ; : check-read ( err -- eof? ) diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index 6beb48e05e..3821ac46b3 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -37,18 +37,15 @@ C: 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 diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor old mode 100644 new mode 100755 index 895efc59dc..0aca30c4db --- a/extra/id3/id3.factor +++ b/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 diff --git a/extra/optimizer/report/report.factor b/extra/optimizer/report/report.factor index 6655d9dcf3..feaace9808 100755 --- a/extra/optimizer/report/report.factor +++ b/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 diff --git a/extra/raptor/raptor.factor b/extra/raptor/raptor.factor old mode 100644 new mode 100755 index d776739d89..1ada2a30c6 --- a/extra/raptor/raptor.factor +++ b/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 -- ) - [ ] [ ] bi - [ listener ] with-stream ; + dup [ + swap [ + [ + listener + ] with-stream + ] with-disposal + ] with-disposal ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index aa3641417b..20130bec2e 100755 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -62,7 +62,7 @@ IN: temporary "Subject: Factor rules" f f - " " + "" "Hi guys" "Bye guys" } diff --git a/extra/tools/disassembler/disassembler.factor b/extra/tools/disassembler/disassembler.factor index 8fe3b9bdf0..147c307a32 100755 --- a/extra/tools/disassembler/disassembler.factor +++ b/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 ; diff --git a/vm/alien.c b/vm/alien.c index 2e14ae9ba7..26d9464700 100755 --- a/vm/alien.c +++ b/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); + } +} diff --git a/vm/alien.h b/vm/alien.h index 3357b0a3c0..babfbc358d 100755 --- a/vm/alien.h +++ b/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); diff --git a/vm/code_heap.c b/vm/code_heap.c index f449445eb9..c2f8ba0f5e 100755 --- a/vm/code_heap.c +++ b/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 */ diff --git a/vm/image.c b/vm/image.c index 3d3c352093..70eceeafdc 100755 --- a/vm/image.c +++ b/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); diff --git a/vm/os-unix.c b/vm/os-unix.c index 92028dfc43..a84b29c2e2 100755 --- a/vm/os-unix.c +++ b/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) diff --git a/vm/os-unix.h b/vm/os-unix.h index 85f760b5aa..a23e8e545c 100755 --- a/vm/os-unix.h +++ b/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); diff --git a/vm/os-windows.c b/vm/os-windows.c index 54baf56212..a60339c578 100755 --- a/vm/os-windows.c +++ b/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) diff --git a/vm/os-windows.h b/vm/os-windows.h index a22252fde8..86492990b5 100755 --- a/vm/os-windows.h +++ b/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); diff --git a/vm/primitives.c b/vm/primitives.c index 5699f90fda..a5cdb4f1ef 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -188,4 +188,5 @@ void *primitives[] = { primitive_resize_byte_array, primitive_resize_bit_array, primitive_resize_float_array, + primitive_dll_validp, };