diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index b7a9f2b6cb..2aa218a2b0 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -7,8 +7,6 @@ + io: - if select() returns an error, fep -- FILE* leaked in process.factor -- runtime primitives like fopen: check for null input - stream server can hang because of exception handler limitations - better i/o scheduler - if two tasks write to a unix stream, the buffer can overflow @@ -44,7 +42,6 @@ + compiler/ffi: -- stack effect comment for FUNCTION: doesn't show return value - float intrinsics - complex float type - complex float intrinsics @@ -72,8 +69,6 @@ + misc: -- aliens are just a special case of displaced aliens -- so we can remove - one built in type - code walker & exceptions - slice: if sequence or seq start is changed, abstraction violation - delegating generic words with a non-standard picker diff --git a/contrib/process.factor b/contrib/process.factor index 818c648f70..b896a96d63 100644 --- a/contrib/process.factor +++ b/contrib/process.factor @@ -5,9 +5,7 @@ FUNCTION: int system ( char* command ) ; compiled FUNCTION: void* popen ( char* command, char* type ) ; compiled -FUNCTION: int fileno ( void* file ) ; compiled - : ( command mode -- stream ) - popen fileno dup ; + popen dup ; : !" parse-string system drop ; parsing diff --git a/library/alien/alien-invoke.factor b/library/alien/alien-invoke.factor index e9e6117bd2..a8f561da77 100644 --- a/library/alien/alien-invoke.factor +++ b/library/alien/alien-invoke.factor @@ -76,9 +76,9 @@ M: alien-invoke linearize* ( node -- ) dup box-return linearize-next ; -: parse-arglist ( lst -- types stack effect ) +: parse-arglist ( return seq -- types stack-effect ) unpair [ - " " % [ "," ?tail drop % " " % ] each "-- " % + " " % [ "," ?tail drop ] map " " join % " -- " % swap % ] "" make ; : (define-c-word) ( type lib func types stack-effect -- ) @@ -87,7 +87,8 @@ M: alien-invoke linearize* ( node -- ) word r> "stack-effect" set-word-prop ; : define-c-word ( type lib func function-args -- ) - [ "()" subseq? not ] subset parse-arglist (define-c-word) ; + [ "()" subseq? not ] subset >r pick r> parse-arglist + (define-c-word) ; M: compound (uncrossref) dup word-def \ alien-invoke swap member? diff --git a/library/alien/aliens.factor b/library/alien/aliens.factor index a96b2940fd..c082650b90 100644 --- a/library/alien/aliens.factor +++ b/library/alien/aliens.factor @@ -17,9 +17,9 @@ sequences ; ! parameter, or a missing abi parameter indicates the cdecl ABI ! should be used, which is common on Unix. -UNION: c-ptr byte-array alien displaced-alien ; +: ( address -- alien ) f ; inline -M: alien hashcode ( obj -- n ) alien-address >fixnum ; +UNION: c-ptr byte-array alien ; M: alien = ( obj obj -- ? ) over alien? [ [ alien-address ] 2apply = ] [ 2drop f ] if ; diff --git a/library/alien/c-types.factor b/library/alien/c-types.factor index deea985b30..78f6c851a6 100644 --- a/library/alien/c-types.factor +++ b/library/alien/c-types.factor @@ -50,7 +50,7 @@ SYMBOL: c-types >r c-size [ rot * ] cons r> append define-compound ; : define-nth ( name vocab -- ) - #! Make a word foo-nth ( n alien -- displaced-alien ). + #! Make a word foo-nth ( n alien -- alien ). >r dup "-nth" append r> create swap dup c-getter (define-nth) ; diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index a8fb83e3f6..ed52185b59 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -160,7 +160,6 @@ call { "dlopen" "alien" } { "dlsym" "alien" } { "dlclose" "alien" } - { "" "alien" } { "" "arrays" } { "" "alien" } { "alien-signed-cell" "alien" } @@ -283,7 +282,8 @@ num-types f builtins set { { 0 { "real" "math" } f } { 1 { "imaginary" "math" } f } } define-builtin "complex" "math" create 4 "math-priority" set-word-prop -"displaced-alien" "alien" create 7 "displaced-alien?" "alien" create { } define-builtin +"alien" "alien" create 7 "alien?" "alien" create +{ { 1 { "underlying-alien" "alien" } f } } define-builtin "array?" "arrays" create t "inline" set-word-prop "array" "arrays" create 8 "array?" "arrays" create @@ -329,9 +329,6 @@ num-types f builtins set "dll" "alien" create 15 "dll?" "alien" create { { 1 { "dll-path" "alien" } f } } define-builtin -"alien?" "alien" create t "inline" set-word-prop -"alien" "alien" create 16 "alien?" "alien" create { } define-builtin - "word?" "words" create t "inline" set-word-prop "word" "words" create 17 "word?" "words" create { diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index 93ab32335f..05ce5c2e9a 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -387,7 +387,7 @@ sequences strings vectors words prettyprint ; \ [ [ integer ] [ byte-array ] ] "infer-effect" set-word-prop \ t "flushable" set-word-prop -\ [ [ integer c-ptr ] [ displaced-alien ] ] "infer-effect" set-word-prop +\ [ [ integer c-ptr ] [ alien ] ] "infer-effect" set-word-prop \ t "flushable" set-word-prop \ alien-signed-cell [ [ c-ptr integer ] [ integer ] ] "infer-effect" set-word-prop diff --git a/native/alien.c b/native/alien.c index 7f08d56518..0218b7dfdc 100644 --- a/native/alien.c +++ b/native/alien.c @@ -21,21 +21,17 @@ void *alien_offset(CELL object) { ALIEN *alien; F_ARRAY *array; - DISPLACED_ALIEN *d; switch(type_of(object)) { + case BYTE_ARRAY_TYPE: + array = untag_byte_array_fast(object); + return array + 1; case ALIEN_TYPE: alien = untag_alien_fast(object); if(alien->expired) general_error(ERROR_EXPIRED,object,true); - return alien->ptr; - case BYTE_ARRAY_TYPE: - array = untag_byte_array_fast(object); - return array + 1; - case DISPLACED_ALIEN_TYPE: - d = untag_displaced_alien_fast(object); - return alien_offset(d->alien) + d->displacement; + return alien_offset(alien->alien) + alien->displacement; case F_TYPE: return NULL; default: @@ -58,29 +54,22 @@ INLINE void *alien_pointer(void) } /* make an alien */ -ALIEN *alien(void *ptr) +ALIEN *make_alien(CELL delegate, CELL displacement) { - ALIEN* alien = allot_object(ALIEN_TYPE,sizeof(ALIEN)); - alien->ptr = ptr; + ALIEN *alien = allot_object(ALIEN_TYPE,sizeof(ALIEN)); + alien->alien = delegate; + alien->displacement = displacement; alien->expired = false; return alien; } /* make an alien and push */ -void box_alien(void *ptr) +void box_alien(CELL ptr) { - if(ptr == NULL) + if(ptr == 0) dpush(F); else - dpush(tag_object(alien(ptr))); -} - -/* make an alien form an address on the stack */ -void primitive_alien(void) -{ - void* ptr = (void*)unbox_signed_cell(); - maybe_gc(sizeof(ALIEN)); - box_alien(ptr); + dpush(tag_object(make_alien(F,ptr))); } /* make an alien pointing at an offset of another alien */ @@ -88,14 +77,10 @@ void primitive_displaced_alien(void) { CELL alien; CELL displacement; - DISPLACED_ALIEN* d; - maybe_gc(sizeof(DISPLACED_ALIEN)); + maybe_gc(sizeof(ALIEN)); alien = dpop(); displacement = unbox_unsigned_cell(); - d = allot_object(DISPLACED_ALIEN_TYPE,sizeof(DISPLACED_ALIEN)); - d->alien = alien; - d->displacement = displacement; - dpush(tag_object(d)); + dpush(tag_object(make_alien(alien,displacement))); } /* address of an object representing a C pointer */ @@ -118,20 +103,15 @@ void primitive_string_to_alien(void) drepl(tag_object(string_to_alien(untag_string(dpeek()),true))); } -/* expire aliens when loading the image */ -void fixup_alien(ALIEN *alien) -{ - alien->expired = true; -} - /* image loading */ -void fixup_displaced_alien(DISPLACED_ALIEN *d) +void fixup_alien(ALIEN *d) { data_fixup(&d->alien); + d->expired = true; } /* GC */ -void collect_displaced_alien(DISPLACED_ALIEN *d) +void collect_alien(ALIEN *d) { copy_handle(&d->alien); } diff --git a/native/alien.h b/native/alien.h index 18dab6cd79..dfb3f341f0 100644 --- a/native/alien.h +++ b/native/alien.h @@ -1,6 +1,7 @@ typedef struct { CELL header; - void* ptr; + CELL alien; + CELL displacement; bool expired; } ALIEN; @@ -9,19 +10,9 @@ INLINE ALIEN* untag_alien_fast(CELL tagged) return (ALIEN*)UNTAG(tagged); } -typedef struct { - CELL header; - CELL alien; - CELL displacement; -} DISPLACED_ALIEN; - -INLINE DISPLACED_ALIEN* untag_displaced_alien_fast(CELL tagged) -{ - return (DISPLACED_ALIEN*)UNTAG(tagged); -} +ALIEN *make_alien(CELL delegate, CELL displacement); void primitive_expired(void); -void primitive_alien(void); void primitive_displaced_alien(void); void primitive_alien_address(void); @@ -30,13 +21,11 @@ void* alien_offset(CELL object); void primitive_alien_to_string(void); void primitive_string_to_alien(void); -void fixup_alien(ALIEN* alien); -void fixup_displaced_alien(DISPLACED_ALIEN* d); -void collect_displaced_alien(DISPLACED_ALIEN* d); +void fixup_alien(ALIEN* d); +void collect_alien(ALIEN* d); -DLLEXPORT void* unbox_alien(void); -ALIEN* alien(void* ptr); -DLLEXPORT void box_alien(void* ptr); +DLLEXPORT void *unbox_alien(void); +DLLEXPORT void box_alien(CELL ptr); void primitive_alien_signed_cell(void); void primitive_set_alien_signed_cell(void); diff --git a/native/gc.c b/native/gc.c index 2d2529a8ec..98d58b15d6 100644 --- a/native/gc.c +++ b/native/gc.c @@ -185,8 +185,8 @@ INLINE void collect_object(CELL scan) case DLL_TYPE: collect_dll((DLL*)scan); break; - case DISPLACED_ALIEN_TYPE: - collect_displaced_alien((DISPLACED_ALIEN*)scan); + case ALIEN_TYPE: + collect_alien((ALIEN*)scan); break; case WRAPPER_TYPE: collect_wrapper((F_WRAPPER*)scan); diff --git a/native/io.c b/native/io.c index c67552c9a4..cfc1e6bd54 100644 --- a/native/io.c +++ b/native/io.c @@ -20,8 +20,8 @@ The native FFI streams in the library don't have this limitation. */ void init_c_io(void) { - userenv[IN_ENV] = tag_object(alien(stdin)); - userenv[OUT_ENV] = tag_object(alien(stdout)); + userenv[IN_ENV] = tag_object(make_alien(F,(CELL)stdin)); + userenv[OUT_ENV] = tag_object(make_alien(F,(CELL)stdout)); } void io_error(void) @@ -35,12 +35,12 @@ void primitive_fopen(void) char *path, *mode; FILE* file; maybe_gc(0); - mode = unbox_c_string(); - path = unbox_c_string(); + mode = pop_c_string(); + path = pop_c_string(); file = fopen(path,mode); if(file == NULL) io_error(); - box_alien(file); + box_alien((CELL)file); } void primitive_fgetc(void) diff --git a/native/memory.c b/native/memory.c index 4996dff35b..2cb9c3c54b 100644 --- a/native/memory.c +++ b/native/memory.c @@ -75,9 +75,6 @@ CELL untagged_object_size(CELL pointer) case ALIEN_TYPE: size = sizeof(ALIEN); break; - case DISPLACED_ALIEN_TYPE: - size = sizeof(DISPLACED_ALIEN); - break; case WRAPPER_TYPE: size = sizeof(F_WRAPPER); break; diff --git a/native/memory.h b/native/memory.h index fa2e7a2a64..7e17294643 100644 --- a/native/memory.h +++ b/native/memory.h @@ -64,8 +64,7 @@ INLINE CELL align8(CELL a) /*** Header types ***/ -#define DISPLACED_ALIEN_TYPE 7 - +#define ALIEN_TYPE 7 #define ARRAY_TYPE 8 /* Canonical F object */ @@ -78,7 +77,6 @@ INLINE CELL align8(CELL a) #define SBUF_TYPE 13 #define WRAPPER_TYPE 14 #define DLL_TYPE 15 -#define ALIEN_TYPE 16 #define WORD_TYPE 17 #define TUPLE_TYPE 18 #define BYTE_ARRAY_TYPE 19 diff --git a/native/misc.c b/native/misc.c index b209445aaf..97d9700ef2 100644 --- a/native/misc.c +++ b/native/misc.c @@ -19,7 +19,7 @@ void primitive_os_env(void) maybe_gc(0); - name = unbox_c_string(); + name = pop_c_string(); value = getenv(name); if(value == NULL) dpush(F); diff --git a/native/primitives.c b/native/primitives.c index 49d60675e8..610e31d892 100644 --- a/native/primitives.c +++ b/native/primitives.c @@ -126,7 +126,6 @@ void* primitives[] = { primitive_dlopen, primitive_dlsym, primitive_dlclose, - primitive_alien, primitive_byte_array, primitive_displaced_alien, primitive_alien_signed_cell, diff --git a/native/relocate.c b/native/relocate.c index 8ecb633794..4d0e9bf472 100644 --- a/native/relocate.c +++ b/native/relocate.c @@ -29,9 +29,6 @@ void relocate_object(CELL relocating) case ALIEN_TYPE: fixup_alien((ALIEN*)relocating); break; - case DISPLACED_ALIEN_TYPE: - fixup_displaced_alien((DISPLACED_ALIEN*)relocating); - break; case WRAPPER_TYPE: fixup_wrapper((F_WRAPPER*)relocating); break; diff --git a/native/string.c b/native/string.c index c403137a12..60c5f1c987 100644 --- a/native/string.c +++ b/native/string.c @@ -166,7 +166,7 @@ void primitive_string_to_memory(void) } /* FFI calls this */ -char* unbox_c_string(void) +char *unbox_c_string(void) { CELL str = dpop(); if(type_of(str) == STRING_TYPE) @@ -175,6 +175,14 @@ char* unbox_c_string(void) return (char*)alien_offset(str); } +/* this function is used when we really want only Factor strings as input, not +aliens. In particular, certian primitives crash if given a null pointer (f), so +we protect against this by using this function instead of unbox_c_string() */ +char *pop_c_string(void) +{ + return to_c_string(untag_string(dpop()),true); +} + /* FFI calls this */ u16* unbox_utf16_string(void) { diff --git a/native/string.h b/native/string.h index 956ff2edc1..d5098b6528 100644 --- a/native/string.h +++ b/native/string.h @@ -45,6 +45,7 @@ F_STRING* from_c_string(const char* c_string); F_STRING* memory_to_string(const BYTE* string, CELL length); void primitive_memory_to_string(void); DLLEXPORT char* unbox_c_string(void); +char *pop_c_string(void); DLLEXPORT u16* unbox_utf16_string(void); /* untagged & unchecked */ diff --git a/native/unix/file.c b/native/unix/file.c index 628ff069ca..dea7f0af57 100644 --- a/native/unix/file.c +++ b/native/unix/file.c @@ -66,6 +66,6 @@ void primitive_cwd(void) void primitive_cd(void) { maybe_gc(0); - chdir(unbox_c_string()); + chdir(pop_c_string()); } diff --git a/native/win32/file.c b/native/win32/file.c index 134841f6d5..c005986282 100644 --- a/native/win32/file.c +++ b/native/win32/file.c @@ -65,5 +65,5 @@ void primitive_cwd(void) void primitive_cd(void) { maybe_gc(0); - SetCurrentDirectory(unbox_c_string()); + SetCurrentDirectory(pop_c_string()); } \ No newline at end of file